50e3329 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Merge pull request #823 from raichoo/javascript

50e3329Edwin Brady13 years ago

src/IRTS/CodegenJavaScript.hs+206−393

compare with master

unifiedsplit

@@ -24,8 +24,10 @@ idrNamespace = "__IDR__"

24idrRTNamespace = "__IDRRT__"

25idrLTNamespace = "__IDRLT__"

27+

27data JSTarget = Node | JavaScript deriving Eq

28data JSTarget = Node | JavaScript deriving Eq

30+

29data JSType = JSIntTy

31data JSType = JSIntTy

30 | JSStringTy

32 | JSStringTy

31 | JSIntegerTy

33 | JSIntegerTy

@@ -35,16 +37,19 @@ data JSType = JSIntTy

35 | JSForgotTy

37 | JSForgotTy

36 deriving Eq

38 deriving Eq

40+

38data JSInteger = JSBigZero

41data JSInteger = JSBigZero

39 | JSBigOne

42 | JSBigOne

40 | JSBigInt Integer

43 | JSBigInt Integer

41 deriving Eq

44 deriving Eq

46+

43data JSNum = JSInt Int

47data JSNum = JSInt Int

44 | JSFloat Double

48 | JSFloat Double

45 | JSInteger JSInteger

49 | JSInteger JSInteger

46 deriving Eq

50 deriving Eq

52+

48data JS = JSRaw String

53data JS = JSRaw String

49 | JSIdent String

54 | JSIdent String

50 | JSFunction [String] JS

55 | JSFunction [String] JS

@@ -62,7 +67,6 @@ data JS = JSRaw String

62 | JSTrue

67 | JSTrue

63 | JSFalse

68 | JSFalse

64 | JSArray [JS]

69 | JSArray [JS]

65− | JSObject [(String, JS)]

66 | JSString String

70 | JSString String

67 | JSChar String

71 | JSChar String

68 | JSNum JSNum

72 | JSNum JSNum

@@ -71,8 +75,10 @@ data JS = JSRaw String

71 | JSIndex JS JS

75 | JSIndex JS JS

72 | JSCond [(JS, JS)]

76 | JSCond [(JS, JS)]

73 | JSTernary JS JS JS

77 | JSTernary JS JS JS

78+ | JSParens JS

74 deriving Eq

79 deriving Eq

81+

76compileJS :: JS -> String

82compileJS :: JS -> String

77compileJS (JSRaw code) =

83compileJS (JSRaw code) =

78 code

84 code

@@ -114,7 +120,7 @@ compileJS (JSNew name args) =

114 "new " ++ name ++ "(" ++ intercalate "," (map compileJS args) ++ ")"

120 "new " ++ name ++ "(" ++ intercalate "," (map compileJS args) ++ ")"

115

121

116compileJS (JSError exc) =

122compileJS (JSError exc) =

117− "(function(){throw '" ++ exc ++ "';})()"

123+ "throw new Error(\"" ++ exc ++ "\")"

118

124

119compileJS (JSOp op lhs rhs) =

125compileJS (JSOp op lhs rhs) =

120 compileJS lhs ++ " " ++ op ++ " " ++ compileJS rhs

126 compileJS lhs ++ " " ++ op ++ " " ++ compileJS rhs

@@ -145,12 +151,6 @@ compileJS JSFalse =

145compileJS (JSArray elems) =

151compileJS (JSArray elems) =

146 "[" ++ intercalate "," (map compileJS elems) ++ "]"

152 "[" ++ intercalate "," (map compileJS elems) ++ "]"

147

153

148−compileJS (JSObject fields) =

149− "{" ++ intercalate ",\n" (map compileField fields) ++ "}"

150− where

151− compileField :: (String, JS) -> String

152− compileField (name, val) = '\'' : name ++ "' : " ++ compileJS val

153−

154compileJS (JSString str) =

155 show str

156

@@ -174,19 +174,15 @@ compileJS (JSIndex lhs rhs) =

174 compileJS lhs ++ "[" ++ compileJS rhs ++ "]"

175

176compileJS (JSCond branches) =

177− intercalate " else " $ map createIfBlock (eliminateDeadBranches branches)

177+ intercalate " else " $ map createIfBlock branches

178 where

179− eliminateDeadBranches (e@(JSTrue, _):_) = [e]

180− eliminateDeadBranches (x:xs) = x : eliminateDeadBranches xs

181− eliminateDeadBranches [] = []

182−

183 createIfBlock (JSTrue, e) =

179 createIfBlock (JSTrue, e) =

184 "{\n"

180 "{\n"

185− ++ "return " ++ compileJS e

181+ ++ compileJS e

186 ++ ";\n}"

182 ++ ";\n}"

187 createIfBlock (cond, e) =

183 createIfBlock (cond, e) =

188 "if (" ++ compileJS cond ++") {\n"

184 "if (" ++ compileJS cond ++") {\n"

189− ++ "return " ++ compileJS e

185+ ++ compileJS e

190 ++ ";\n}"

186 ++ ";\n}"

191

187

192compileJS (JSTernary cond true false) =

188compileJS (JSTernary cond true false) =

@@ -195,48 +191,64 @@ compileJS (JSTernary cond true false) =

195 f = compileJS false in

191 f = compileJS false in

196 "(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")"

192 "(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")"

197

193

194+compileJS (JSParens js) =

195+ "(" ++ compileJS js ++ ")"

196+

197+

198jsTailcall :: JS -> JS

199jsTailcall call =

200 jsCall (idrRTNamespace ++ "tailcall") [

201 JSFunction [] (JSReturn call)

202 ]

203

204+

204jsCall :: String -> [JS] -> JS

205jsCall :: String -> [JS] -> JS

205jsCall fun = JSApp (JSIdent fun)

206jsCall fun = JSApp (JSIdent fun)

206

207

208+

207jsMeth :: JS -> String -> [JS] -> JS

209jsMeth :: JS -> String -> [JS] -> JS

208jsMeth obj meth =

210jsMeth obj meth =

209 JSApp (JSProj obj meth)

211 JSApp (JSProj obj meth)

210

212

213+

211jsInstanceOf :: JS -> JS -> JS

214jsInstanceOf :: JS -> JS -> JS

212jsInstanceOf = JSOp "instanceof"

215jsInstanceOf = JSOp "instanceof"

213

216

217+

214jsEq :: JS -> JS -> JS

218jsEq :: JS -> JS -> JS

215jsEq = JSOp "=="

219jsEq = JSOp "=="

216

220

221+

217jsAnd :: JS -> JS -> JS

222jsAnd :: JS -> JS -> JS

218jsAnd = JSOp "&&"

223jsAnd = JSOp "&&"

219

224

225+

220jsType :: JS

226jsType :: JS

221jsType = JSIdent $ idrRTNamespace ++ "Type"

227jsType = JSIdent $ idrRTNamespace ++ "Type"

222

228

229+

223jsCon :: JS

230jsCon :: JS

224jsCon = JSIdent $ idrRTNamespace ++ "Con"

231jsCon = JSIdent $ idrRTNamespace ++ "Con"

225

232

233+

226jsTag :: JS -> JS

234jsTag :: JS -> JS

227jsTag obj = JSProj obj "tag"

235jsTag obj = JSProj obj "tag"

228

236

237+

229jsTypeTag :: JS -> JS

238jsTypeTag :: JS -> JS

230jsTypeTag obj = JSProj obj "type"

239jsTypeTag obj = JSProj obj "type"

231

240

241+

232jsBigInt :: JS -> JS

242jsBigInt :: JS -> JS

233jsBigInt (JSString "0") = JSNum $ JSInteger JSBigZero

243jsBigInt (JSString "0") = JSNum $ JSInteger JSBigZero

234jsBigInt (JSString "1") = JSNum $ JSInteger JSBigOne

244jsBigInt (JSString "1") = JSNum $ JSInteger JSBigOne

235jsBigInt val = JSApp (JSIdent $ idrRTNamespace ++ "bigInt") [val]

245jsBigInt val = JSApp (JSIdent $ idrRTNamespace ++ "bigInt") [val]

236

246

247+

237jsVar :: Int -> String

248jsVar :: Int -> String

238jsVar = ("__var_" ++) . show

249jsVar = ("__var_" ++) . show

239

250

251+

240jsLet :: String -> JS -> JS -> JS

252jsLet :: String -> JS -> JS -> JS

241jsLet name value body =

253jsLet name value body =

242 JSApp (

254 JSApp (

@@ -246,6 +258,33 @@ jsLet name value body =

246 ) [value]

258 ) [value]

247

259

248

260

261+jsError :: String -> JS

262+jsError err = JSApp (JSFunction [] (JSError err)) []

263+

264+

265+transformJS :: (JS -> JS) -> JS -> JS

266+transformJS tr js =

267+ transformHelper js

268+ where

269+ transformHelper :: JS -> JS

270+ transformHelper js

271+ | JSFunction args body <- js = JSFunction args $ tr body

272+ | JSSeq seq <- js = JSSeq $ map tr seq

273+ | JSReturn ret <- js = JSReturn $ tr ret

274+ | JSApp lhs rhs <- js = JSApp (tr lhs) $ map tr rhs

275+ | JSNew con args <- js = JSNew con $ map tr args

276+ | JSOp op lhs rhs <- js = JSOp op (tr lhs) (tr rhs)

277+ | JSProj obj field <- js = JSProj (tr obj) field

278+ | JSArray vals <- js = JSArray $ map tr vals

279+ | JSAssign lhs rhs <- js = JSAssign (tr lhs) (tr rhs)

280+ | JSAlloc var val <- js = JSAlloc var $ fmap tr val

281+ | JSIndex lhs rhs <- js = JSIndex (tr lhs) (tr rhs)

282+ | JSCond conds <- js = JSCond $ map (tr *** tr) conds

283+ | JSTernary c t f <- js = JSTernary (tr c) (tr t) (tr f)

284+ | JSParens val <- js = JSParens $ tr val

285+ | otherwise = js

286+

287+

249jsSubst :: JS -> JS -> JS -> JS

288jsSubst :: JS -> JS -> JS -> JS

250jsSubst var new old

289jsSubst var new old

251 | var == old = new

290 | var == old = new

@@ -284,37 +323,7 @@ jsSubst (JSIdent var) new (JSApp (JSFunction [arg] body) vals)

284 body

323 body

285 )) $ map (jsSubst (JSIdent var) new) vals

324 )) $ map (jsSubst (JSIdent var) new) vals

286

325

287−jsSubst var new (JSApp lhs rhs) =

326+jsSubst var new js = transformJS (jsSubst var new) js

288− JSApp (jsSubst var new lhs) (map (jsSubst var new) rhs)

289−

290−jsSubst var new (JSFunction [] body) =

291− JSFunction [] (jsSubst var new body)

292−

293−jsSubst var new (JSReturn ret) =

294− JSReturn $ jsSubst var new ret

295−

296−jsSubst var new (JSProj obj field) =

297− JSProj (jsSubst var new obj) field

298−

299−jsSubst var new (JSSeq body) =

300− JSSeq $ map (jsSubst var new) body

301−

302−jsSubst var new (JSOp op lhs rhs) =

303− JSOp op (jsSubst var new lhs) (jsSubst var new rhs)

304−

305−jsSubst var new (JSIndex obj field) =

306− JSIndex (jsSubst var new obj) (jsSubst var new field)

307−

308−jsSubst var new (JSCond conds) =

309− JSCond (map ((jsSubst var new) *** (jsSubst var new)) conds)

310−

311−jsSubst var new (JSAssign lhs rhs) =

312− JSAssign (jsSubst var new lhs) (jsSubst var new rhs)

313−

314−jsSubst var new (JSAlloc val (Just js)) =

315− JSAlloc val (Just (jsSubst var new js))

316−

317−jsSubst _ _ js = js

318

327

319

328

320removeAllocations :: JS -> JS

329removeAllocations :: JS -> JS

@@ -330,43 +339,7 @@ removeAllocations (JSSeq body) =

330 map (jsSubst (JSIdent name) val) (removeHelper js)

339 map (jsSubst (JSIdent name) val) (removeHelper js)

331 removeHelper (j:js) = j : removeHelper js

340 removeHelper (j:js) = j : removeHelper js

332

341

333−removeAllocations (JSFunction args body) =

342+removeAllocations js = transformJS removeAllocations js

334− JSFunction args $ removeAllocations body

335−

336−removeAllocations (JSReturn ret) =

337− JSReturn $ removeAllocations ret

338−

339−removeAllocations (JSApp fun args) =

340− JSApp (removeAllocations fun) (map removeAllocations args)

341−

342−removeAllocations (JSNew con args) =

343− JSNew con $ map removeAllocations args

344−

345−removeAllocations (JSOp op lhs rhs) =

346− JSOp op (removeAllocations lhs) (removeAllocations rhs)

347−

348−removeAllocations (JSProj obj field) =

349− JSProj (removeAllocations obj) field

350−

351−removeAllocations (JSArray vals) =

352− JSArray $ map removeAllocations vals

353−

354−removeAllocations (JSAssign lhs rhs) =

355− JSAssign (removeAllocations lhs) (removeAllocations rhs)

356−

357−removeAllocations (JSAlloc name (Just val)) =

358− JSAlloc name $ Just (removeAllocations val)

359−

360−removeAllocations (JSIndex val idx) =

361− JSIndex (removeAllocations val) (removeAllocations idx)

362−

363−removeAllocations (JSCond conds) =

364− JSCond $ map (removeAllocations *** removeAllocations) conds

365−

366−removeAllocations (JSTernary c t f) =

367− JSTernary (removeAllocations c) (removeAllocations t) (removeAllocations f)

368−

369−removeAllocations js = js

370

343

371

344

372isJSConstant :: JS -> Bool

345isJSConstant :: JS -> Bool

@@ -379,20 +352,23 @@ isJSConstant js

379 | JSApp (JSIdent "__IDRRT__bigInt") _ <- js = True

352 | JSApp (JSIdent "__IDRRT__bigInt") _ <- js = True

380 | otherwise = False

353 | otherwise = False

381

354

355+

382inlineJS :: JS -> JS

356inlineJS :: JS -> JS

357+inlineJS (JSReturn (JSApp (JSFunction [] err@(JSError _)) [])) = err

383inlineJS (JSReturn (JSApp (JSFunction ["cse"] body) [val@(JSVar _)])) =

358inlineJS (JSReturn (JSApp (JSFunction ["cse"] body) [val@(JSVar _)])) =

384 inlineJS $ jsSubst (JSIdent "cse") val body

359 inlineJS $ jsSubst (JSIdent "cse") val body

385

360

361+

386inlineJS (JSReturn (JSApp (JSFunction [arg] cond@(JSCond _)) [val])) =

362inlineJS (JSReturn (JSApp (JSFunction [arg] cond@(JSCond _)) [val])) =

387− JSSeq [ JSAlloc arg (Just (inlineJS val))

363+ inlineJS $ JSSeq [ JSAlloc arg (Just val)

388− , inlineJS cond

364+ , cond

389− ]

365+ ]

390

366

391inlineJS (JSApp (JSProj (JSFunction args (JSReturn body)) "apply") [

367inlineJS (JSApp (JSProj (JSFunction args (JSReturn body)) "apply") [

392 JSThis,JSProj var "vars"

368 JSThis,JSProj var "vars"

393 ])

369 ])

394 | var /= JSIdent "cse" =

370 | var /= JSIdent "cse" =

395− inlineApply args body 0

371+ inlineJS $ inlineApply args body 0

396 where

372 where

397 inlineApply [] body _ = inlineJS body

373 inlineApply [] body _ = inlineJS body

398 inlineApply (a:as) body n =

374 inlineApply (a:as) body n =

@@ -411,94 +387,62 @@ inlineJS (JSApp (JSIdent "__IDRRT__tailcall") [

411inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])

387inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])

412 | JSNew con [tag, vals] <- ret

388 | JSNew con [tag, vals] <- ret

413 , opt <- inlineJS val =

389 , opt <- inlineJS val =

414− JSNew con [tag, jsSubst (JSIdent arg) opt vals]

390+ inlineJS $ JSNew con [tag, inlineJS $ jsSubst (JSIdent arg) opt vals]

415

391

416 | JSNew con [JSFunction [] (JSReturn (JSApp fun vars))] <- ret

392 | JSNew con [JSFunction [] (JSReturn (JSApp fun vars))] <- ret

417 , opt <- inlineJS val =

393 , opt <- inlineJS val =

418− JSNew con [JSFunction [] (

394+ inlineJS $ JSNew con [JSFunction [] (

419 JSReturn (

395 JSReturn (

420 JSApp (

396 JSApp (

421− jsSubst (JSIdent arg) opt fun

397+ inlineJS $ jsSubst (JSIdent arg) opt fun

422 ) (

398 ) (

423− map (jsSubst (JSIdent arg) opt) vars

399+ map (inlineJS . jsSubst (JSIdent arg) opt) vars

424 )

400 )

425 )

401 )

426 )]

402 )]

427

403

428 | JSApp (JSProj obj field) args <- ret

404 | JSApp (JSProj obj field) args <- ret

429 , opt <- inlineJS val =

405 , opt <- inlineJS val =

430− JSApp (

406+ inlineJS $ JSApp (

431− JSProj (jsSubst (JSIdent arg) opt obj) field

407+ inlineJS $ JSProj (jsSubst (JSIdent arg) opt obj) field

432 ) (

408 ) (

433− map (jsSubst (JSIdent arg) opt) args

409+ map (inlineJS . jsSubst (JSIdent arg) opt) args

434 )

410 )

435

411

436 | JSIndex (JSProj obj field) idx <- ret

412 | JSIndex (JSProj obj field) idx <- ret

437 , opt <- inlineJS val =

413 , opt <- inlineJS val =

438− JSIndex (JSProj (

414+ inlineJS $ JSIndex (JSProj (

439− jsSubst (JSIdent arg) opt obj

415+ inlineJS $ jsSubst (JSIdent arg) opt obj

440 ) field

416 ) field

441− ) (jsSubst (JSIdent arg) opt idx)

417+ ) (inlineJS $ jsSubst (JSIdent arg) opt idx)

442

418

443 | JSOp op lhs rhs <- ret

419 | JSOp op lhs rhs <- ret

444 , opt <- inlineJS val =

420 , opt <- inlineJS val =

445− JSOp op (jsSubst (JSIdent arg) opt lhs) $

421+ inlineJS $ JSOp op (inlineJS $ jsSubst (JSIdent arg) opt lhs) $

446− (jsSubst (JSIdent arg) opt rhs)

422+ (inlineJS $ jsSubst (JSIdent arg) opt rhs)

447

423

448 | JSApp (JSIdent fun) args <- ret

424 | JSApp (JSIdent fun) args <- ret

449 , opt <- inlineJS val =

425 , opt <- inlineJS val =

450− JSApp (JSIdent fun) $ map (jsSubst (JSIdent arg) opt) args

426+ inlineJS $ JSApp (JSIdent fun) $ map (inlineJS . jsSubst (JSIdent arg) opt) args

451−

452−inlineJS (JSApp fun args) =

453− JSApp (inlineJS fun) (map inlineJS args)

454−

455−inlineJS (JSNew con args) =

456− JSNew con $ map inlineJS args

457−

458−inlineJS (JSArray fields) =

459− JSArray (map inlineJS fields)

460

427

461−inlineJS (JSAssign lhs rhs) =

428+inlineJS js = transformJS inlineJS js

462− JSAssign (inlineJS lhs) (inlineJS rhs)

463

429

464−inlineJS (JSSeq seq) =

465− JSSeq (map inlineJS seq)

466−

467−inlineJS (JSFunction args body) =

468− JSFunction args (inlineJS body)

469−

470−inlineJS (JSProj (JSFunction args body) field) =

471− JSProj (JSFunction args (inlineJS body)) field

472−

473−inlineJS (JSReturn js) =

474− JSReturn $ inlineJS js

475−

476−inlineJS (JSAlloc name (Just js)) =

477− JSAlloc name (Just $ inlineJS js)

478−

479−inlineJS (JSCond cases) =

480− JSCond (map (second inlineJS) cases)

481−

482−inlineJS (JSObject fields) =

483− JSObject (map (second inlineJS) fields)

484−

485−inlineJS (JSOp op lhs rhs) =

486− JSOp op (inlineJS lhs) (inlineJS rhs)

487−

488−inlineJS js = js

489

430

490reduceJS :: [JS] -> [JS]

431reduceJS :: [JS] -> [JS]

491reduceJS js = reduceLoop [] ([], js)

432reduceJS js = reduceLoop [] ([], js)

492

433

434+

493funName :: JS -> String

435funName :: JS -> String

494funName (JSAlloc fun _) = fun

436funName (JSAlloc fun _) = fun

495

437

438+

496elimDeadLoop :: [JS] -> [JS]

439elimDeadLoop :: [JS] -> [JS]

497elimDeadLoop js

440elimDeadLoop js

498 | ret <- deadEvalApplyCases js

441 | ret <- deadEvalApplyCases js

499 , ret /= js = elimDeadLoop ret

442 , ret /= js = elimDeadLoop ret

500 | otherwise = js

443 | otherwise = js

501

444

445+

502deadEvalApplyCases :: [JS] -> [JS]

446deadEvalApplyCases :: [JS] -> [JS]

503deadEvalApplyCases js =

447deadEvalApplyCases js =

504 let tags = sort $ nub $ concatMap (getTags) js in

448 let tags = sort $ nub $ concatMap (getTags) js in

@@ -533,7 +477,11 @@ deadEvalApplyCases js =

533

477

534 getTags (JSTernary c t f) = getTags c ++ getTags t ++ getTags f

478 getTags (JSTernary c t f) = getTags c ++ getTags t ++ getTags f

535

479

480+ getTags (JSParens js) = getTags js

481+

536 getTags js = []

482 getTags js = []

483+

484+

537 removeHelper :: [Int] -> JS -> JS

485 removeHelper :: [Int] -> JS -> JS

538 removeHelper tags (JSAlloc fun (Just (

486 removeHelper tags (JSAlloc fun (Just (

539 JSApp (JSFunction [] (JSSeq seq)) []))

487 JSApp (JSFunction [] (JSSeq seq)) []))

@@ -544,6 +492,7 @@ deadEvalApplyCases js =

544

492

545 removeHelper _ js = js

493 removeHelper _ js = js

546

494

495+

547 remover :: [Int] -> [JS] -> [JS]

496 remover :: [Int] -> [JS] -> [JS]

548 remover tags (

497 remover tags (

549 j@(JSAssign ((JSIndex (JSIdent "t") (JSNum (JSInt tag)))) _):js

498 j@(JSAssign ((JSIndex (JSIdent "t") (JSNum (JSInt tag)))) _):js

@@ -587,8 +536,11 @@ initConstructors js =

587

536

588 getTags (JSTernary c t f) = getTags c ++ getTags t ++ getTags f

537 getTags (JSTernary c t f) = getTags c ++ getTags t ++ getTags f

589

538

539+ getTags (JSParens js) = getTags js

540+

590 getTags js = []

541 getTags js = []

591

542

543+

592 replaceConstructors :: [Int] -> [JS] -> [JS]

544 replaceConstructors :: [Int] -> [JS] -> [JS]

593 replaceConstructors tags js = map (replaceHelper tags) js

545 replaceConstructors tags js = map (replaceHelper tags) js

594 where

546 where

@@ -596,47 +548,8 @@ initConstructors js =

596 replaceHelper tags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []])

548 replaceHelper tags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []])

597 | tag `elem` tags = JSIdent ("__IDRCTR__" ++ show tag)

549 | tag `elem` tags = JSIdent ("__IDRCTR__" ++ show tag)

598

550

599− replaceHelper tags (JSNew con args) =

551+ replaceHelper tags js = transformJS (replaceHelper tags) js

600− JSNew con $ map (replaceHelper tags) args

601−

602− replaceHelper tags (JSFunction fun body) =

603− JSFunction fun (replaceHelper tags body)

604−

605− replaceHelper tags (JSReturn ret) =

606− JSReturn (replaceHelper tags ret)

607−

608− replaceHelper tags (JSApp lhs rhs) =

609− JSApp (replaceHelper tags lhs) (map (replaceHelper tags) rhs)

610−

611− replaceHelper tags (JSSeq seq) =

612− JSSeq $ map (replaceHelper tags) seq

613−

614− replaceHelper tags (JSOp op lhs rhs) =

615− JSOp op (replaceHelper tags lhs) (replaceHelper tags rhs)

616−

617− replaceHelper tags (JSProj obj field) =

618− JSProj (replaceHelper tags obj) field

619−

620− replaceHelper tags (JSArray vals) =

621− JSArray $ map (replaceHelper tags) vals

622

552

623− replaceHelper tags (JSAssign lhs rhs) =

624− JSAssign (replaceHelper tags lhs) (replaceHelper tags rhs)

625−

626− replaceHelper tags (JSAlloc var (Just val)) =

627− JSAlloc var $ Just (replaceHelper tags val)

628−

629− replaceHelper tags (JSCond conds) =

630− JSCond (map ((replaceHelper tags) *** (replaceHelper tags)) conds)

631−

632− replaceHelper tags (JSTernary c t f) =

633− JSTernary (replaceHelper tags c) (

634− replaceHelper tags t

635− ) (

636− replaceHelper tags f

637− )

638−

639− replaceHelper tags js = js

640

553

641 createConstant :: Int -> JS

554 createConstant :: Int -> JS

642 createConstant tag =

555 createConstant tag =

@@ -644,6 +557,7 @@ initConstructors js =

644 JSNew (idrRTNamespace ++ "Con") [JSNum (JSInt tag), JSArray []]

557 JSNew (idrRTNamespace ++ "Con") [JSNum (JSInt tag), JSArray []]

645 ))

558 ))

646

559

560+

647removeIDs :: [JS] -> [JS]

561removeIDs :: [JS] -> [JS]

648removeIDs js =

562removeIDs js =

649 case partition isID js of

563 case partition isID js of

@@ -655,10 +569,12 @@ removeIDs js =

655

569

656 isID _ = False

570 isID _ = False

657

571

572+

658 idFor :: JS -> (String, Int)

573 idFor :: JS -> (String, Int)

659 idFor (JSAlloc fun (Just (JSFunction _ (JSSeq body))))

574 idFor (JSAlloc fun (Just (JSFunction _ (JSSeq body))))

660 | JSReturn (JSVar (Loc pos)) <- last body = (fun, pos)

575 | JSReturn (JSVar (Loc pos)) <- last body = (fun, pos)

661

576

577+

662 removeIDCall :: [(String, Int)] -> JS -> JS

578 removeIDCall :: [(String, Int)] -> JS -> JS

663 removeIDCall ids (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (

579 removeIDCall ids (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (

664 JSReturn (JSApp (JSIdent fun) args)

580 JSReturn (JSApp (JSIdent fun) args)

@@ -676,37 +592,8 @@ removeIDs js =

676 | Just pos <- lookup fun ids

592 | Just pos <- lookup fun ids

677 , pos < length args = args !! pos

593 , pos < length args = args !! pos

678

594

679− removeIDCall ids (JSAlloc fun (Just body)) =

680− JSAlloc fun (Just $ removeIDCall ids body)

681−

682− removeIDCall ids (JSReturn js) =

683− JSReturn $ removeIDCall ids js

684−

685− removeIDCall ids (JSSeq js) =

686− JSSeq $ map (removeIDCall ids) js

595+ removeIDCall ids js = transformJS (removeIDCall ids) js

687−

688− removeIDCall ids (JSNew con args) =

689− JSNew con $ map (removeIDCall ids) args

690−

691− removeIDCall ids (JSFunction args body) =

692− JSFunction args $ removeIDCall ids body

693

596

694− removeIDCall ids (JSApp fun args) =

695− JSApp (removeIDCall ids fun) $ map (removeIDCall ids) args

696−

697− removeIDCall ids (JSProj obj field) =

698− JSProj (removeIDCall ids obj) field

699−

700− removeIDCall ids (JSCond conds) =

701− JSCond $ map (removeIDCall ids *** removeIDCall ids) conds

702−

703− removeIDCall ids (JSAssign lhs rhs) =

704− JSAssign (removeIDCall ids lhs) (removeIDCall ids rhs)

705−

706− removeIDCall ids (JSArray fields) =

707− JSArray $ map (removeIDCall ids) fields

708−

709− removeIDCall _ js = js

710

597

711inlineFunctions :: [JS] -> [JS]

598inlineFunctions :: [JS] -> [JS]

712inlineFunctions js =

599inlineFunctions js =

@@ -791,42 +678,39 @@ inlineFunctions js =

791 , countInvokations name f

678 , countInvokations name f

792 ]

679 ]

793

680

681+ countInvokations name (JSParens js) =

682+ countInvokations name js

683+

794 countInvokations _ _ = 0

684 countInvokations _ _ = 0

795

685

796

686

797reduceConstant :: JS -> JS

687reduceConstant :: JS -> JS

688+reduceConstant

798−reduceConstant (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (

689+ (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (

799− JSReturn (JSApp (JSIdent "__IDR__mEVAL0") [JSNum num])

690+ JSReturn (JSApp (JSIdent "__IDR__mEVAL0") [val])

800− )]) = JSNum num

691+ )])

801−

692+ | JSNum num <- val = val

802−reduceConstant (JSReturn ret) =

693+ | JSOp op lhs rhs <- val =

803− JSReturn (reduceConstant ret)

694+ JSParens $ JSOp op (reduceConstant lhs) (reduceConstant rhs)

804−

695+

805−reduceConstant (JSApp fun args) =

696+ | JSApp (JSProj lhs op) [rhs] <- val

806− JSApp (reduceConstant fun) (map reduceConstant args)

697+ , op `elem` [ "subtract"

807−

698+ , "add"

808−reduceConstant (JSArray fields) =

699+ , "multiply"

809− JSArray (map reduceConstant fields)

700+ , "divide"

810−

701+ , "mod"

811−reduceConstant (JSAlloc name (Just val)) =

702+ , "equals"

812− JSAlloc name $ Just (reduceConstant val)

703+ , "lesser"

813−

704+ , "lesserOrEquals"

705+ , "greater"

706+ , "greaterOrEquals"

707+ ] = val

708+

814−reduceConstant (JSNew con args) =

709+reduceConstant (JSApp ident [(JSParens js)]) =

815− JSNew con (map reduceConstant args)

710+ JSApp ident [reduceConstant js]

711+

712+reduceConstant js = transformJS reduceConstant js

816

713

817−reduceConstant (JSProj obj field) =

818− JSProj (reduceConstant obj) field

819−

820−reduceConstant (JSCond conds) =

821− JSCond $ map (reduceConstant *** reduceConstant) conds

822−

823−reduceConstant (JSSeq seq) =

824− JSSeq $ map reduceConstant seq

825−

826−reduceConstant (JSFunction args body) =

827− JSFunction args (reduceConstant body)

828−

829−reduceConstant js = js

830

714

831reduceConstants :: JS -> JS

715reduceConstants :: JS -> JS

832reduceConstants js

716reduceConstants js

@@ -848,6 +732,7 @@ elimDuplicateEvals (JSAlloc fun (Just (JSFunction args (JSSeq seq)))) =

848

732

849elimDuplicateEvals js = js

733elimDuplicateEvals js = js

850

734

735+

851optimizeEvalTailcalls :: (String, String) -> JS -> JS

736optimizeEvalTailcalls :: (String, String) -> JS -> JS

852optimizeEvalTailcalls (fun, tc) js =

737optimizeEvalTailcalls (fun, tc) js =

853 optHelper js

738 optHelper js

@@ -858,106 +743,28 @@ optimizeEvalTailcalls (fun, tc) js =

858 ])

743 ])

859 | n == fun = JSApp (JSIdent tc) $ map optHelper args

744 | n == fun = JSApp (JSIdent tc) $ map optHelper args

860

745

861− optHelper (JSFunction args body) =

862− JSFunction args $ optHelper body

863−

864− optHelper (JSSeq seq) =

865− JSSeq $ map optHelper seq

866−

867− optHelper (JSReturn ret) =

868− JSReturn $ optHelper ret

869−

870− optHelper (JSApp lhs rhs) =

871− JSApp (optHelper lhs) (map optHelper rhs)

872−

873− optHelper (JSNew con args) =

874− JSNew con $ map optHelper args

875−

876− optHelper (JSOp op lhs rhs) =

877− JSOp op (optHelper lhs) (optHelper rhs)

878−

879− optHelper (JSProj obj field) =

880− JSProj (optHelper obj) field

881−

882− optHelper (JSArray vals) =

883− JSArray $ map optHelper vals

884−

885− optHelper (JSAssign lhs rhs) =

886− JSAssign (optHelper lhs) (optHelper rhs)

887−

888− optHelper (JSAlloc var (Just val)) =

889− JSAlloc var (Just $ optHelper val)

890−

891− optHelper (JSIndex lhs rhs) =

892− JSIndex (optHelper lhs) (optHelper rhs)

893−

894− optHelper (JSCond conds) =

895− JSCond $ map (optHelper *** optHelper) conds

896−

897− optHelper (JSTernary c t f) =

898− JSTernary (

899− optHelper c

900− ) (

901− optHelper t

746+ optHelper js = transformJS optHelper js

902− ) (

903− optHelper f

904− )

905−

906− optHelper js = js

907

747

908

748

909removeInstanceChecks :: JS -> JS

749removeInstanceChecks :: JS -> JS

910removeInstanceChecks (JSCond conds) =

750removeInstanceChecks (JSCond conds) =

751+ JSCond $ eliminateDeadBranches $ map (

911− JSCond $ map (removeHelper *** removeInstanceChecks) conds

752+ removeHelper *** removeInstanceChecks

753+ ) conds

912 where

754 where

913 removeHelper (

755 removeHelper (

914 JSOp "&&" (JSOp "instanceof" _ (JSIdent "__IDRRT__Con")) check

756 JSOp "&&" (JSOp "instanceof" _ (JSIdent "__IDRRT__Con")) check

915 ) = removeHelper check

757 ) = removeHelper check

916 removeHelper js = js

758 removeHelper js = js

917

759

918−removeInstanceChecks (JSFunction args body) =

919− JSFunction args $ removeInstanceChecks body

920−

921−removeInstanceChecks (JSSeq seq) =

922− JSSeq $ map removeInstanceChecks seq

923−

924−removeInstanceChecks (JSReturn ret) =

925− JSReturn $ removeInstanceChecks ret

926−

927−removeInstanceChecks (JSApp lhs rhs) =

928− JSApp (removeInstanceChecks lhs) $ map removeInstanceChecks rhs

929

760

930−removeInstanceChecks (JSNew con args) =

761+ eliminateDeadBranches (e@(JSTrue, _):_) = [e]

931− JSNew con $ map removeInstanceChecks args

762+ eliminateDeadBranches [(_, js)] = [(JSTrue, js)]

932−

763+ eliminateDeadBranches (x:xs) = x : eliminateDeadBranches xs

933−removeInstanceChecks (JSOp op lhs rhs) =

764+ eliminateDeadBranches [] = []

934− JSOp op (removeInstanceChecks lhs) (removeInstanceChecks rhs)

935−

936−removeInstanceChecks (JSProj obj field) =

937− JSProj (removeInstanceChecks obj) field

938−

939−removeInstanceChecks (JSArray vals) =

940− JSArray $ map removeInstanceChecks vals

941−

942−removeInstanceChecks (JSAssign lhs rhs) =

943− JSAssign (removeInstanceChecks lhs) (removeInstanceChecks rhs)

944−

945−removeInstanceChecks (JSAlloc var (Just val)) =

946− JSAlloc var (Just $ removeInstanceChecks val)

947−

948−removeInstanceChecks (JSIndex lhs rhs) =

949− JSIndex (removeInstanceChecks lhs) (removeInstanceChecks rhs)

950

765

951−removeInstanceChecks (JSTernary c t f) =

952− JSTernary (

953− removeInstanceChecks c

954− ) (

955− removeInstanceChecks t

956− ) (

957− removeInstanceChecks f

766+removeInstanceChecks js = transformJS removeInstanceChecks js

958− )

959

767

960−removeInstanceChecks js = js

961

768

962reduceLoop :: [String] -> ([JS], [JS]) -> [JS]

769reduceLoop :: [String] -> ([JS], [JS]) -> [JS]

963reduceLoop reduced (cons, program) =

770reduceLoop reduced (cons, program) =

@@ -974,13 +781,15 @@ reduceLoop reduced (cons, program) =

974 reducable $ last body

781 reducable $ last body

975 | otherwise = False

782 | otherwise = False

976 where reducable :: JS -> Bool

783 where reducable :: JS -> Bool

784+ reducable js

977− reducable (JSReturn js) = reducable js

785+ | JSReturn ret <- js = reducable ret

978− reducable (JSNew _ args) = and $ map reducable args

786+ | JSNew _ args <- js = and $ map reducable args

979− reducable (JSArray fields) = and $ map reducable fields

787+ | JSArray fields <- js = and $ map reducable fields

980− reducable (JSNum _) = True

788+ | JSNum _ <- js = True

981− reducable JSNull = True

789+ | JSNull <- js = True

982− reducable (JSIdent _) = True

790+ | JSIdent _ <- js = True

983− reducable _ = False

791+ | otherwise = False

792+

984

793

985 reduce :: JS -> JS

794 reduce :: JS -> JS

986 reduce (JSAlloc fun (Just (JSFunction _ (JSSeq body))))

795 reduce (JSAlloc fun (Just (JSFunction _ (JSSeq body))))

@@ -988,6 +797,7 @@ reduceLoop reduced (cons, program) =

988

797

989 reduce js = js

798 reduce js = js

990

799

800+

991 reduceCall :: [String] -> JS -> JS

801 reduceCall :: [String] -> JS -> JS

992 reduceCall funs (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (

802 reduceCall funs (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (

993 JSReturn (JSApp id@(JSIdent ret) _)

803 JSReturn (JSApp id@(JSIdent ret) _)

@@ -997,43 +807,8 @@ reduceLoop reduced (cons, program) =

997 reduceCall funs js@(JSApp id@(JSIdent fun) _)

807 reduceCall funs js@(JSApp id@(JSIdent fun) _)

998 | fun `elem` funs = id

808 | fun `elem` funs = id

999

809

1000− reduceCall funs (JSAlloc fun (Just body)) =

1001− JSAlloc fun (Just $ reduceCall funs body)

1002−

1003− reduceCall funs (JSReturn js) =

810+ reduceCall funs js = transformJS (reduceCall funs) js

1004− JSReturn $ reduceCall funs js

1005

811

1006− reduceCall funs (JSSeq js) =

1007− JSSeq $ map (reduceCall funs) js

1008−

1009− reduceCall funs (JSNew con args) =

1010− JSNew con $ map (reduceCall funs) args

1011−

1012− reduceCall funs (JSFunction args body) =

1013− JSFunction args $ reduceCall funs body

1014−

1015− reduceCall funs (JSApp fun args) =

1016− JSApp (reduceCall funs fun) $ map (reduceCall funs) args

1017−

1018− reduceCall funs (JSProj obj field) =

1019− JSProj (reduceCall funs obj) field

1020−

1021− reduceCall funs (JSIndex obj idx) =

1022− JSIndex (reduceCall funs obj) (reduceCall funs idx)

1023−

1024− reduceCall funs (JSOp op rhs lhs) =

1025− JSOp op (reduceCall funs rhs) (reduceCall funs lhs)

1026−

1027− reduceCall funs (JSCond conds) =

1028− JSCond $ map (reduceCall funs *** reduceCall funs) conds

1029−

1030− reduceCall funs (JSAssign lhs rhs) =

1031− JSAssign (reduceCall funs lhs) (reduceCall funs rhs)

1032−

1033− reduceCall funs (JSArray fields) =

1034− JSArray $ map (reduceCall funs) fields

1035−

1036− reduceCall _ js = js

1037

812

1038optimizeJS :: JS -> JS

813optimizeJS :: JS -> JS

1039optimizeJS = inlineLoop

814optimizeJS = inlineLoop

@@ -1043,6 +818,7 @@ optimizeJS = inlineLoop

1043 , opt /= js = inlineLoop opt

818 , opt /= js = inlineLoop opt

1044 | otherwise = js

819 | otherwise = js

1045

820

821+

1046codegenJavaScript

822codegenJavaScript

1047 :: JSTarget

823 :: JSTarget

1048 -> [(Name, SDecl)]

824 -> [(Name, SDecl)]

@@ -1074,25 +850,29 @@ codegenJavaScript target definitions filename outputType = do

1074 def :: [(String, SDecl)]

850 def :: [(String, SDecl)]

1075 def = map (first translateNamespace) definitions

851 def = map (first translateNamespace) definitions

1076

852

853+

1077 functions :: [String]

854 functions :: [String]

1078− functions =

855+ functions = translate >>> optimize >>> compile $ def

1079− let translated =

856+ where

1080− concatMap translateDeclaration def ++ [mainLoop, invokeLoop]

857+ translate p = concatMap translateDeclaration p ++ [mainLoop, invokeLoop]

1081−

858+ optimize p = foldl' (flip ($)) p opt

859+ compile = map compileJS

860+

861+ opt =

1082− optimized = map optimizeJS translated

862+ [ map optimizeJS

1083− idsRemoved = removeIDs optimized

863+ , removeIDs

1084− reduced = reduceJS idsRemoved

864+ , reduceJS

1085− constRemoved = map reduceConstants reduced

865+ , map reduceConstants

1086− constrInit = initConstructors constRemoved

866+ , initConstructors

1087− removeAlloc = map removeAllocations constrInit

867+ , map removeAllocations

1088− deadElim = elimDeadLoop removeAlloc

868+ , elimDeadLoop

1089− inlined = inlineFunctions deadElim

869+ , inlineFunctions

1090− elimDup = map elimDuplicateEvals inlined

870+ , map elimDuplicateEvals

1091− evalTC = map (optimizeEvalTailcalls ("__IDR__mEVAL0", "__IDRRT__EVALTC")) elimDup

871+ , map (optimizeEvalTailcalls ("__IDR__mEVAL0", "__IDRRT__EVALTC"))

1092− applyTC = map (optimizeEvalTailcalls ("__IDR__mAPPLY0", "__IDRRT__APPLYTC")) evalTC

872+ , map (optimizeEvalTailcalls ("__IDR__mAPPLY0", "__IDRRT__APPLYTC"))

1093− remChecks = map removeInstanceChecks applyTC

873+ , map removeInstanceChecks

1094− js = remChecks in

874+ ]

1095− map compileJS js

875+

1096

876

1097 mainLoop :: JS

877 mainLoop :: JS

1098 mainLoop =

878 mainLoop =

@@ -1109,12 +889,15 @@ codegenJavaScript target definitions filename outputType = do

1109 mainFun :: JS

889 mainFun :: JS

1110 mainFun = jsTailcall $ jsCall runMain []

890 mainFun = jsTailcall $ jsCall runMain []

1111

891

892+

1112 runMain :: String

893 runMain :: String

1113 runMain = idrNamespace ++ translateName (sMN 0 "runMain")

894 runMain = idrNamespace ++ translateName (sMN 0 "runMain")

1114

895

896+

1115 invokeLoop :: JS

897 invokeLoop :: JS

1116 invokeLoop = jsCall "main" []

898 invokeLoop = jsCall "main" []

1117

899

900+

1118translateIdentifier :: String -> String

901translateIdentifier :: String -> String

1119translateIdentifier =

902translateIdentifier =

1120 replaceReserved . concatMap replaceBadChars

903 replaceReserved . concatMap replaceBadChars

@@ -1128,6 +911,8 @@ translateIdentifier =

1128 replaceReserved s

911 replaceReserved s

1129 | s `elem` reserved = '_' : s

912 | s `elem` reserved = '_' : s

1130 | otherwise = s

913 | otherwise = s

914+

915+

1131 reserved = [ "break"

916 reserved = [ "break"

1132 , "case"

917 , "case"

1133 , "catch"

918 , "catch"

@@ -1173,6 +958,7 @@ translateIdentifier =

1173 , "yield"

958 , "yield"

1174 ]

959 ]

1175

960

961+

1176translateNamespace :: Name -> String

962translateNamespace :: Name -> String

1177translateNamespace (UN _) = idrNamespace

963translateNamespace (UN _) = idrNamespace

1178translateNamespace (NS _ ns) = idrNamespace ++ concatMap (translateIdentifier . str) ns

964translateNamespace (NS _ ns) = idrNamespace ++ concatMap (translateIdentifier . str) ns

@@ -1180,6 +966,7 @@ translateNamespace (MN _ _) = idrNamespace

1180translateNamespace (SN name) = idrNamespace ++ translateSpecialName name

966translateNamespace (SN name) = idrNamespace ++ translateSpecialName name

1181translateNamespace NErased = idrNamespace

967translateNamespace NErased = idrNamespace

1182

968

969+

1183translateName :: Name -> String

970translateName :: Name -> String

1184translateName (UN name) = 'u' : translateIdentifier (str name)

971translateName (UN name) = 'u' : translateIdentifier (str name)

1185translateName (NS name _) = 'n' : translateName name

972translateName (NS name _) = 'n' : translateName name

@@ -1187,6 +974,7 @@ translateName (MN i name) = 'm' : translateIdentifier (str name) ++ show i

1187translateName (SN name) = 's' : translateSpecialName name

974translateName (SN name) = 's' : translateSpecialName name

1188translateName NErased = "e"

975translateName NErased = "e"

1189

976

977+

1190translateSpecialName :: SpecialName -> String

978translateSpecialName :: SpecialName -> String

1191translateSpecialName name

979translateSpecialName name

1192 | WhereN i m n <- name =

980 | WhereN i m n <- name =

@@ -1200,6 +988,7 @@ translateSpecialName name

1200 | CaseN n <- name =

988 | CaseN n <- name =

1201 'c' : translateName n

989 'c' : translateName n

1202

990

991+

1203translateConstant :: Const -> JS

992translateConstant :: Const -> JS

1204translateConstant (I i) = JSNum (JSInt i)

993translateConstant (I i) = JSNum (JSInt i)

1205translateConstant (Fl f) = JSNum (JSFloat f)

994translateConstant (Fl f) = JSNum (JSFloat f)

@@ -1217,7 +1006,8 @@ translateConstant PtrType = JSType JSPtrTy

1217translateConstant Forgot = JSType JSForgotTy

1006translateConstant Forgot = JSType JSForgotTy

1218translateConstant (BI i) = jsBigInt $ JSString (show i)

1007translateConstant (BI i) = jsBigInt $ JSString (show i)

1219translateConstant c =

1008translateConstant c =

1220− JSError $ "Unimplemented Constant: " ++ show c

1009+ jsError $ "Unimplemented Constant: " ++ show c

1010+

1221

1011

1222translateDeclaration :: (String, SDecl) -> [JS]

1012translateDeclaration :: (String, SDecl) -> [JS]

1223translateDeclaration (path, SFun name params stackSize body)

1013translateDeclaration (path, SFun name params stackSize body)

@@ -1267,17 +1057,22 @@ translateDeclaration (path, SFun name params stackSize body)

1267 hasProp table var =

1057 hasProp table var =

1268 JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")

1058 JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")

1269

1059

1060+

1270 caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS

1061 caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS

1271 caseFun aux var cse =

1062 caseFun aux var cse =

1272− jsFunAux aux (translateCase (Just (translateVariableName var)) cse)

1063+ let (JSReturn c) = translateCase (Just (translateVariableName var)) cse in

1064+ jsFunAux aux c

1065+

1273

1066

1274 getTag :: SAlt -> Maybe Int

1067 getTag :: SAlt -> Maybe Int

1275 getTag (SConCase _ tag _ _ _) = Just tag

1068 getTag (SConCase _ tag _ _ _) = Just tag

1276 getTag _ = Nothing

1069 getTag _ = Nothing

1277

1070

1071+

1278 lookupTableName :: String

1072 lookupTableName :: String

1279 lookupTableName = idrLTNamespace ++ translateName name

1073 lookupTableName = idrLTNamespace ++ translateName name

1280

1074

1075+

1281 lookupTable :: [(LVar, String)] -> LVar -> [SAlt] -> JS

1076 lookupTable :: [(LVar, String)] -> LVar -> [SAlt] -> JS

1282 lookupTable aux var cases =

1077 lookupTable aux var cases =

1283 JSAlloc lookupTableName $ Just (

1078 JSAlloc lookupTableName $ Just (

@@ -1296,16 +1091,20 @@ translateDeclaration (path, SFun name params stackSize body)

1296 JSAssign (JSIndex (JSIdent "t") (JSNum $ JSInt tag)) fun

1091 JSAssign (JSIndex (JSIdent "t") (JSNum $ JSInt tag)) fun

1297 ) entries

1092 ) entries

1298

1093

1094+

1299 lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (Int, JS)

1095 lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (Int, JS)

1300 lookupEntry aux var alt = do

1096 lookupEntry aux var alt = do

1301 tag <- getTag alt

1097 tag <- getTag alt

1302 return (tag, caseFun aux var alt)

1098 return (tag, caseFun aux var alt)

1303

1099

1100+

1304 jsDecl :: JS -> JS

1101 jsDecl :: JS -> JS

1305 jsDecl = JSAlloc (path ++ translateName name) . Just

1102 jsDecl = JSAlloc (path ++ translateName name) . Just

1306

1103

1104+

1307 jsFun body = jsFunAux [] body

1105 jsFun body = jsFunAux [] body

1308

1106

1107+

1309 jsFunAux :: [(LVar, String)] -> JS -> JS

1108 jsFunAux :: [(LVar, String)] -> JS -> JS

1310 jsFunAux aux body =

1109 jsFunAux aux body =

1311 JSFunction (p ++ map snd aux) (

1110 JSFunction (p ++ map snd aux) (

@@ -1318,17 +1117,21 @@ translateDeclaration (path, SFun name params stackSize body)

1318 assignVar :: Int -> String -> JS

1117 assignVar :: Int -> String -> JS

1319 assignVar n s = JSAlloc (jsVar n) (Just $ JSIdent s)

1118 assignVar n s = JSAlloc (jsVar n) (Just $ JSIdent s)

1320

1119

1120+

1321 assignAux :: (LVar, String) -> JS

1121 assignAux :: (LVar, String) -> JS

1322 assignAux (Loc var, val) =

1122 assignAux (Loc var, val) =

1323 JSAlloc (jsVar var) (Just $ JSIdent val)

1123 JSAlloc (jsVar var) (Just $ JSIdent val)

1324

1124

1125+

1325 p :: [String]

1126 p :: [String]

1326 p = map translateName params

1127 p = map translateName params

1327

1128

1129+

1328translateVariableName :: LVar -> String

1130translateVariableName :: LVar -> String

1329translateVariableName (Loc i) =

1131translateVariableName (Loc i) =

1330 jsVar i

1132 jsVar i

1331

1133

1134+

1332translateExpression :: SExp -> JS

1135translateExpression :: SExp -> JS

1333translateExpression (SLet name value body) =

1136translateExpression (SLet name value body) =

1334 jsLet (translateVariableName name) (

1137 jsLet (translateVariableName name) (

@@ -1504,11 +1307,12 @@ translateExpression (SOp op vars)

1504 translateBinaryOp :: String -> LVar -> LVar -> JS

1307 translateBinaryOp :: String -> LVar -> LVar -> JS

1505 translateBinaryOp f lhs rhs = JSOp f (JSVar lhs) (JSVar rhs)

1308 translateBinaryOp f lhs rhs = JSOp f (JSVar lhs) (JSVar rhs)

1506

1309

1310+

1507 invokeMeth :: LVar -> String -> [LVar] -> JS

1311 invokeMeth :: LVar -> String -> [LVar] -> JS

1508 invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args)

1312 invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args)

1509

1313

1510translateExpression (SError msg) =

1314translateExpression (SError msg) =

1511− JSError msg

1315+ jsError msg

1512

1316

1513translateExpression (SForeign _ _ "putStr" [(FString, var)]) =

1317translateExpression (SForeign _ _ "putStr" [(FString, var)]) =

1514 jsCall (idrRTNamespace ++ "print") [JSVar var]

1318 jsCall (idrRTNamespace ++ "print") [JSVar var]

@@ -1534,6 +1338,7 @@ translateExpression patterncase

1534 JSCond $ map (expandCase param . translateCaseCond param) cases

1338 JSCond $ map (expandCase param . translateCaseCond param) cases

1535 )) [JSVar var]

1339 )) [JSVar var]

1536

1340

1341+

1537 expandCase :: String -> (Cond, JS) -> (JS, JS)

1342 expandCase :: String -> (Cond, JS) -> (JS, JS)

1538 expandCase _ (RawCond cond, branch) = (cond, branch)

1343 expandCase _ (RawCond cond, branch) = (cond, branch)

1539 expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)

1344 expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)

@@ -1562,14 +1367,16 @@ translateExpression (SProj var i) =

1562translateExpression SNothing = JSNull

1367translateExpression SNothing = JSNull

1563

1368

1564translateExpression e =

1369translateExpression e =

1565− JSError $ "Not yet implemented: " ++ filter (/= '\'') (show e)

1370+ jsError $ "Not yet implemented: " ++ filter (/= '\'') (show e)

1371+

1566

1372

1567data FFI = FFICode Char | FFIArg Int | FFIError String

1373data FFI = FFICode Char | FFIArg Int | FFIError String

1568

1374

1375+

1569ffi :: String -> [String] -> JS

1376ffi :: String -> [String] -> JS

1570ffi code args = let parsed = ffiParse code in

1377ffi code args = let parsed = ffiParse code in

1571 case ffiError parsed of

1378 case ffiError parsed of

1572− Just err -> JSError err

1379+ Just err -> jsError err

1573 Nothing -> JSRaw $ renderFFI parsed args

1380 Nothing -> JSRaw $ renderFFI parsed args

1574 where

1381 where

1575 ffiParse :: String -> [FFI]

1382 ffiParse :: String -> [FFI]

@@ -1583,11 +1390,13 @@ ffi code args = let parsed = ffiParse code in

1583 [FFIError "Invalid positional argument"]

1390 [FFIError "Invalid positional argument"]

1584 ffiParse (s:ss) = FFICode s : ffiParse ss

1391 ffiParse (s:ss) = FFICode s : ffiParse ss

1585

1392

1393+

1586 ffiError :: [FFI] -> Maybe String

1394 ffiError :: [FFI] -> Maybe String

1587 ffiError [] = Nothing

1395 ffiError [] = Nothing

1588 ffiError ((FFIError s):xs) = Just s

1396 ffiError ((FFIError s):xs) = Just s

1589 ffiError (x:xs) = ffiError xs

1397 ffiError (x:xs) = ffiError xs

1590

1398

1399+

1591 renderFFI :: [FFI] -> [String] -> String

1400 renderFFI :: [FFI] -> [String] -> String

1592 renderFFI [] _ = ""

1401 renderFFI [] _ = ""

1593 renderFFI ((FFICode c) : fs) args = c : renderFFI fs args

1402 renderFFI ((FFICode c) : fs) args = c : renderFFI fs args

@@ -1595,14 +1404,17 @@ ffi code args = let parsed = ffiParse code in

1595 | i < length args && i >= 0 = args !! i ++ renderFFI fs args

1404 | i < length args && i >= 0 = args !! i ++ renderFFI fs args

1596 | otherwise = "Argument index out of bounds"

1405 | otherwise = "Argument index out of bounds"

1597

1406

1407+

1598data CaseType = ConCase Int

1408data CaseType = ConCase Int

1599 | TypeCase JSType

1409 | TypeCase JSType

1600 | DefaultCase

1410 | DefaultCase

1601 deriving Eq

1411 deriving Eq

1602

1412

1413+

1603data Cond = CaseCond CaseType

1414data Cond = CaseCond CaseType

1604 | RawCond JS

1415 | RawCond JS

1605

1416

1417+

1606translateCaseCond :: String -> SAlt -> (Cond, JS)

1418translateCaseCond :: String -> SAlt -> (Cond, JS)

1607translateCaseCond _ cse@(SDefaultCase _) =

1419translateCaseCond _ cse@(SDefaultCase _) =

1608 (CaseCond DefaultCase, translateCase Nothing cse)

1420 (CaseCond DefaultCase, translateCase Nothing cse)

@@ -1630,11 +1442,12 @@ translateCaseCond var cse@(SConstCase cst _) =

1630translateCaseCond var cse@(SConCase _ tag _ _ _) =

1442translateCaseCond var cse@(SConCase _ tag _ _ _) =

1631 (CaseCond $ ConCase tag, translateCase (Just var) cse)

1443 (CaseCond $ ConCase tag, translateCase (Just var) cse)

1632

1444

1445+

1633translateCase :: Maybe String -> SAlt -> JS

1446translateCase :: Maybe String -> SAlt -> JS

1634−translateCase _ (SDefaultCase e) = translateExpression e

1447+translateCase _ (SDefaultCase e) = JSReturn $ translateExpression e

1635−translateCase _ (SConstCase _ e) = translateExpression e

1448+translateCase _ (SConstCase _ e) = JSReturn $ translateExpression e

1636translateCase (Just var) (SConCase a _ _ vars e) =

1449translateCase (Just var) (SConCase a _ _ vars e) =

1637 let params = map jsVar [a .. (a + length vars)] in

1450 let params = map jsVar [a .. (a + length vars)] in

1638− jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [

1451+ JSReturn $ jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [

1639 JSThis, JSProj (JSIdent var) "vars"

1452 JSThis, JSProj (JSIdent var) "vars"

1640 ]

1453 ]