3b25e9e · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

SSA style stack management and FChar is finally gone.

3b25e9eJan Bessai13 years ago

java/src/main/java/org/idris/rts/ForeignWrapper.javadeleted−14

compare with master

unifiedsplit

@@ -1,14 +0,0 @@

1−/*

2− */

3−package org.idris.rts;

4−

5−public abstract class ForeignWrapper {

6− protected abstract Object wrappedInvoke() throws Exception;

7− public Object invoke() {

8− try {

9− return wrappedInvoke();

10− } catch (Exception ex) {

11− throw new RuntimeException(ex);

12− }

13− }

14−}

src/IRTS/CodegenJava.hs+288−173

@@ -15,6 +15,7 @@ import Util.System

15import Control.Applicative hiding (Const)

16import Control.Arrow

17import Control.Monad

18+import Control.Monad.Error

18import qualified Control.Monad.Trans as T

19import qualified Control.Monad.Trans as T

19import Control.Monad.Trans.State

20import Control.Monad.Trans.State

20import Data.Int

21import Data.Int

@@ -34,10 +35,8 @@ import System.FilePath

34import System.IO

35import System.IO

35import System.Process

36import System.Process

37−data CodeGenerationEnv = CodeGenerationEnv { globalVariablePositions :: [(Name, Int)] }

38+-----------------------------------------------------------------------

38−

39+-- Main function

39−type CodeGeneration = StateT (CodeGenerationEnv) (Either String)

40−type BlockResultTransformation = [BlockStmt] -> Exp -> CodeGeneration [BlockStmt]

42codegenJava :: [(Name, SExp)] -> -- initialization of globals

41codegenJava :: [(Name, SExp)] -> -- initialization of globals

43 [(Name, SDecl)] ->

42 [(Name, SDecl)] ->

@@ -54,7 +53,7 @@ codegenJava globalInit defs out hdrs libs exec = do

54 let outjava = srcdir </> clsName <.> "java"

53 let outjava = srcdir </> clsName <.> "java"

55 let jout = either error

54 let jout = either error

56 (prettyPrint)-- flatIndent . prettyPrint)

55 (prettyPrint)-- flatIndent . prettyPrint)

57− (evalStateT (mkCompilationUnit globalInit defs hdrs out) (mkCodeGenEnv globalInit))

56+ (evalStateT (mkCompilationUnit globalInit defs hdrs out) mkCodeGenEnv)

58 writeFile outjava jout

57 writeFile outjava jout

59 if (exec == Raw)

58 if (exec == Raw)

60 then copyFile outjava (takeDirectory out </> clsName <.> "java")

59 then copyFile outjava (takeDirectory out </> clsName <.> "java")

@@ -135,15 +134,133 @@ mkPomDependencies deps =

135-----------------------------------------------------------------------

134-----------------------------------------------------------------------

136-- Code generation environment

135-- Code generation environment

137

136

138−mkCodeGenEnv :: [(Name, SExp)] -> CodeGenerationEnv

137+data CodeGenerationEnv

138+ = CodeGenerationEnv

139+ { globalVariables :: [(Name, ArrayIndex)]

140+ , localVariables :: [[(Int, Ident)]]

141+ , localVarCounter :: Int

142+ }

143+

144+type CodeGeneration = StateT (CodeGenerationEnv) (Either String)

145+

139−mkCodeGenEnv globalInit =

146+mkCodeGenEnv :: CodeGenerationEnv

140− CodeGenerationEnv $ zipWith (\ (name, _) pos -> (name, pos)) globalInit [0..]

147+mkCodeGenEnv = CodeGenerationEnv [] [] 0

148+

149+varPos :: LVar -> CodeGeneration (Either ArrayIndex Ident)

150+varPos (Loc i) = do

151+ vars <- (concat . localVariables) <$> get

152+ case lookup i vars of

153+ (Just varName) -> return (Right varName)

154+ Nothing -> throwError $ "Invalid local variable id: " ++ show i

155+varPos (Glob name) = do

156+ vars <- globalVariables <$> get

157+ case lookup name vars of

158+ (Just varIdx) -> return (Left varIdx)

159+ Nothing -> throwError $ "Invalid global variable id: " ++ show name

160+

161+pushScope :: CodeGeneration ()

162+pushScope =

163+ modify (\ env -> env { localVariables = []:(localVariables env) })

164+

165+popScope :: CodeGeneration ()

166+popScope = do

167+ env <- get

168+ let lVars = tail $ localVariables env

169+ let vC = if null lVars then 0 else localVarCounter env

170+ put $ env { localVariables = tail (localVariables env)

171+ , localVarCounter = vC }

172+

173+setVariable :: LVar -> CodeGeneration (Either ArrayIndex Ident)

174+setVariable (Loc i) = do

175+ env <- get

176+ let lVars = localVariables env

177+ let getter = localVar $ localVarCounter env

178+ let lVars' = ((i, getter) : head lVars) : tail lVars

179+ put $ env { localVariables = lVars'

180+ , localVarCounter = 1 + localVarCounter env}

181+ return (Right getter)

182+setVariable (Glob n) = do

183+ env <- get

184+ let gVars = globalVariables env

185+ let getter = globalContext @! length gVars

186+ let gVars' = (n, getter):gVars

187+ put (env { globalVariables = gVars' })

188+ return (Left getter)

189+

190+pushParams :: [Ident] -> CodeGeneration ()

191+pushParams paramNames =

192+ let varMap = zipWith (flip (,)) paramNames [0..] in

193+ modify (\ env -> env { localVariables = varMap:(localVariables env)

194+ , localVarCounter = (length varMap) + (localVarCounter env) })

141

195

142flatIndent :: String -> String

196flatIndent :: String -> String

143flatIndent (' ' : ' ' : xs) = flatIndent xs

197flatIndent (' ' : ' ' : xs) = flatIndent xs

144flatIndent (x:xs) = x:flatIndent xs

198flatIndent (x:xs) = x:flatIndent xs

145flatIndent [] = []

199flatIndent [] = []

146

200

201+-----------------------------------------------------------------------

202+-- Maintaining control structures over code blocks

203+

204+data BlockPostprocessor

205+ = BlockPostprocessor

206+ { ppInnerBlock :: [BlockStmt] -> Exp -> CodeGeneration [BlockStmt]

207+ , ppOuterBlock :: [BlockStmt] -> CodeGeneration [BlockStmt]

208+ }

209+

210+ppExp :: BlockPostprocessor -> Exp -> CodeGeneration [BlockStmt]

211+ppExp pp exp = ((ppInnerBlock pp) [] exp) >>= ppOuterBlock pp

212+

213+addReturn :: BlockPostprocessor

214+addReturn =

215+ BlockPostprocessor

216+ { ppInnerBlock = (\ block exp -> return $ block ++ [jReturn exp])

217+ , ppOuterBlock = return

218+ }

219+

220+ignoreResult :: BlockPostprocessor

221+ignoreResult =

222+ BlockPostprocessor

223+ { ppInnerBlock = (\ block exp -> return block)

224+ , ppOuterBlock = return

225+ }

226+

227+ignoreOuter :: BlockPostprocessor -> BlockPostprocessor

228+ignoreOuter pp = pp { ppOuterBlock = return }

229+

230+throwRuntimeException :: BlockPostprocessor -> BlockPostprocessor

231+throwRuntimeException pp =

232+ pp

233+ { ppInnerBlock =

234+ (\ blk exp -> return $

235+ blk ++ [ BlockStmt $ Throw

236+ ( InstanceCreation

237+ []

238+ (toClassType runtimeExceptionType)

239+ [exp]

240+ Nothing

241+ )

242+ ]

243+ )

244+ }

245+

246+

247+rethrowAsRuntimeException :: BlockPostprocessor -> BlockPostprocessor

248+rethrowAsRuntimeException pp =

249+ pp

250+ { ppOuterBlock =

251+ (\ blk -> do

252+ ex <- ppInnerBlock (throwRuntimeException pp) [] (ExpName $ J.Name [Ident "ex"])

253+ ppOuterBlock pp

254+ $ [ BlockStmt $ Try

255+ (Block blk)

256+ [Catch (FormalParam [] exceptionType False (VarId (Ident "ex"))) $

257+ Block ex

258+ ]

259+ Nothing

260+ ]

261+ )

262+ }

263+

147-----------------------------------------------------------------------

264-----------------------------------------------------------------------

148-- File structure

265-- File structure

149

266

@@ -206,20 +323,21 @@ mkClassBody globalInit defs =

206

323

207mkGlobalContext :: [(Name, SExp)] -> CodeGeneration [Decl]

324mkGlobalContext :: [(Name, SExp)] -> CodeGeneration [Decl]

208mkGlobalContext [] = return []

325mkGlobalContext [] = return []

209−mkGlobalContext initExps =

326+mkGlobalContext initExps = do

327+ pushScope

328+ varInit <-

329+ mapM (\ (name, exp) -> do

330+ pos <- setVariable (Glob name)

331+ mkUpdate ignoreResult (Glob name) exp

332+ ) initExps

333+ popScope

210− (\ exps -> [ MemberDecl $ FieldDecl [Private, Static, Final]

334+ return [ MemberDecl $ FieldDecl [Private, Static, Final]

211 (array objectType)

335 (array objectType)

212 [ VarDecl (VarId $ globalContextID). Just . InitExp

336 [ VarDecl (VarId $ globalContextID). Just . InitExp

213 $ ArrayCreate objectType [jInt $ length initExps] 0

337 $ ArrayCreate objectType [jInt $ length initExps] 0

214 ]

338 ]

215− , InitDecl True (Block $ concat exps)

339+ , InitDecl True (Block $ concat varInit)

216− ]

340+ ]

217− )

218− <$> mapM

219− (\ (name, exp) ->

220− mkUpdate (Glob name) exp (\ b e -> return $ addToBlock b e)

221− )

222− initExps

223

341

224addMainMethod :: [Decl] -> [Decl]

342addMainMethod :: [Decl] -> [Decl]

225addMainMethod decls

343addMainMethod decls

@@ -280,23 +398,16 @@ mkDecl ((NS n (ns:nss)), decl) =

280 MemberDecl $ MemberClassDecl $ ClassDecl [Public, Static] name [] Nothing [] body)

398 MemberDecl $ MemberClassDecl $ ClassDecl [Public, Static] name [] Nothing [] body)

281 <$> mangle (UN ns)

399 <$> mangle (UN ns)

282 <*> mkClassBody [] [(NS n nss, decl)]

400 <*> mkClassBody [] [(NS n nss, decl)]

283−mkDecl (_, SFun name params stackSize body) =

401+mkDecl (_, SFun name params stackSize body) = do

284− (\ (Ident name) params paramNames methodBody ->

402+ (Ident methodName) <- mangle name

285− simpleMethod

403+ methodParams <- mapM mkFormalParam params

286− [Public, Static]

404+ paramNames <- mapM mangle params

287− (Just objectType)

405+ pushParams paramNames

288− name

406+ methodBody <- mkExp addReturn body

289− params

407+ popScope

290− ( Block $ ( declareFinalObjectArray

408+ return $

291− localContextID

409+ simpleMethod [Public, Static] (Just objectType) methodName methodParams

292− (Just (arrayInitExps $ extendWithNull paramNames stackSize))

293− ) : methodBody

410+ (Block methodBody)

294− )

295− )

296− <$> mangle name

297− <*> mapM mkFormalParam params

298− <*> mapM (\ p -> (ExpName) <$> mangleFull p) params

299− <*> mkExp body (\ block res -> return $ block ++ [jReturn res])

300

411

301mkFormalParam :: Name -> CodeGeneration FormalParam

412mkFormalParam :: Name -> CodeGeneration FormalParam

302mkFormalParam name =

413mkFormalParam name =

@@ -308,63 +419,66 @@ mkFormalParam name =

308

419

309-- | Compile a simple expression and use the given continuation to postprocess

420-- | Compile a simple expression and use the given continuation to postprocess

310-- the resulting value.

421-- the resulting value.

311−mkExp :: SExp -> BlockResultTransformation -> CodeGeneration [BlockStmt]

422+mkExp :: BlockPostprocessor -> SExp -> CodeGeneration [BlockStmt]

312-- Variables

423-- Variables

313−mkExp (SV var) cont = Nothing <>@! var >>= cont []

424+mkExp pp (SV var) =

425+ (Nothing <>@! var) >>= ppExp pp

314

426

315-- Applications

427-- Applications

316−mkExp (SApp pushTail name args) cont = mkApp pushTail name args >>= cont []

428+mkExp pp (SApp pushTail name args) =

429+ mkApp pushTail name args >>= ppExp pp

317

430

318-- Bindings

431-- Bindings

319−mkExp (SLet var newExp inExp) cont = mkLet var newExp inExp cont

432+mkExp pp (SLet var newExp inExp) =

433+ mkLet pp var newExp inExp

320−mkExp (SUpdate var newExp) cont = mkUpdate var newExp cont

434+mkExp pp (SUpdate var newExp) =

435+ mkUpdate pp var newExp

321

436

322-- Objects

437-- Objects

438+mkExp pp (SCon conId _ args) =

323−mkExp (SCon conId _ args) cont = (mkIdrisObject conId args) >>= cont []

439+ mkIdrisObject conId args >>= ppExp pp

324

440

325-- Case expressions

441-- Case expressions

326−mkExp (SCase var alts) cont = mkCase True var alts cont

442+mkExp pp (SCase var alts) = mkCase pp True var alts

327−mkExp (SChkCase var alts) cont = mkCase False var alts cont

443+mkExp pp (SChkCase var alts) = mkCase pp False var alts

328

444

329-- Projections

445-- Projections

446+mkExp pp (SProj var i) =

330−mkExp (SProj var i) cont = (mkProjection var i) >>= cont []

447+ mkProjection var i >>= ppExp pp

331

448

332-- Constants

449-- Constants

333−mkExp (SConst c) cont = cont [] $ mkConstant c

450+mkExp pp (SConst c) =

451+ ppExp pp $ mkConstant c

334

452

335-- Foreign function calls

453-- Foreign function calls

336−mkExp (SForeign lang resTy text params) cont =

454+mkExp pp (SForeign lang resTy text params) =

337− (mkForeign lang resTy text params) >>= cont []

455+ mkForeign pp lang resTy text params

338

456

339-- Primitive functions

457-- Primitive functions

340−mkExp (SOp LFork [arg]) cont = (mkThread arg) >>= cont []

458+mkExp pp (SOp LFork [arg]) =

459+ (mkThread arg) >>= ppExp pp

341−mkExp (SOp LPar [arg]) cont = (Nothing <>@! arg) >>= cont []

460+mkExp pp (SOp LPar [arg]) =

461+ (Nothing <>@! arg) >>= ppExp pp

342−mkExp (SOp LNoOp args) cont = (Nothing <>@! (last args)) >>= cont []

462+mkExp pp (SOp LNoOp args) =

463+ (Nothing <>@! (last args)) >>= ppExp pp

464+mkExp pp (SOp op args) =

343−mkExp (SOp op args) cont = (mkPrimitiveFunction op args) >>= cont []

465+ (mkPrimitiveFunction op args) >>= ppExp pp

344

466

345-- Empty expressions

467-- Empty expressions

346−mkExp (SNothing) cont = cont [] $ Lit Null

468+mkExp pp (SNothing) = ppExp pp $ Lit Null

347

469

348-- Errors

470-- Errors

349−mkExp (SError err) cont = mkException err

471+mkExp pp (SError err) = ppExp (throwRuntimeException pp) (jString err)

350

472

351-----------------------------------------------------------------------

473-----------------------------------------------------------------------

352-- Variable access

474-- Variable access

353

475

354(<>@!) :: Maybe J.Type -> LVar -> CodeGeneration Exp

476(<>@!) :: Maybe J.Type -> LVar -> CodeGeneration Exp

355(<>@!) Nothing var =

477(<>@!) Nothing var =

356− (ArrayAccess . ((contextArray var) @!)) <$> varPos var

478+ either ArrayAccess (\ n -> ExpName $ J.Name [n]) <$> varPos var

357(<>@!) (Just castTo) var =

479(<>@!) (Just castTo) var =

358 (castTo <>) <$> (Nothing <>@! var)

480 (castTo <>) <$> (Nothing <>@! var)

359

481

360−varPos :: LVar -> CodeGeneration Int

361−varPos (Loc i) = return i

362−varPos (Glob name) = do

363− positions <- globalVariablePositions <$> get

364− case lookup name positions of

365− (Just pos) -> return pos

366− Nothing -> T.lift . Left $ "Invalid global variable id: " ++ show name

367−

368-----------------------------------------------------------------------

482-----------------------------------------------------------------------

369-- Application (wrap method calls in tail call closures)

483-- Application (wrap method calls in tail call closures)

370

484

@@ -386,17 +500,29 @@ mkMethodCallClosure name args =

386-----------------------------------------------------------------------

500-----------------------------------------------------------------------

387-- Updates (change context array) and Let bindings (Update, execute)

501-- Updates (change context array) and Let bindings (Update, execute)

388

502

389−mkUpdate :: LVar -> SExp -> BlockResultTransformation -> CodeGeneration [BlockStmt]

503+mkUpdate :: BlockPostprocessor -> LVar -> SExp -> CodeGeneration [BlockStmt]

390−mkUpdate var exp cont = do

504+mkUpdate pp var exp =

391− pos <- varPos var

505+ mkExp

392− mkExp exp (\ blk rhs -> cont blk $ ((contextArray var) @! pos) @:= rhs )

506+ ( pp

393−

507+ { ppInnerBlock =

508+ (\ blk rhs -> do

509+ pos <- setVariable var

510+ vExp <- Nothing <>@! var

511+ ppInnerBlock pp (blk ++ [pos @:= rhs]) vExp

512+ )

513+ }

514+ ) exp

515+

394−mkLet :: LVar -> SExp -> SExp -> BlockResultTransformation -> CodeGeneration [BlockStmt]

516+mkLet :: BlockPostprocessor -> LVar -> SExp -> SExp -> CodeGeneration [BlockStmt]

395−mkLet var@(Loc pos) newExp inExp cont = do

517+mkLet pp var@(Loc pos) newExp inExp =

396− inBlk <- mkExp inExp cont

518+ mkUpdate (pp { ppInnerBlock =

397− upd <- mkUpdate var newExp (\ blk exp -> return $ addToBlock blk exp)

519+ (\ blk _ -> do

520+ inBlk <- mkExp pp inExp

398− return $ upd ++ inBlk

521+ return (blk ++ inBlk)

522+ )

523+ }

524+ ) var newExp

399−mkLet (Glob _) _ _ _ = T.lift $ Left "Cannot let bind to global variable"

525+mkLet _ (Glob _) _ _ = T.lift $ Left "Cannot let bind to global variable"

400

526

401-----------------------------------------------------------------------

527-----------------------------------------------------------------------

402-- Object creation

528-- Object creation

@@ -411,30 +537,36 @@ mkIdrisObject conId args =

411-----------------------------------------------------------------------

537-----------------------------------------------------------------------

412-- Case expressions

538-- Case expressions

413

539

414−mkCase :: Bool -> LVar -> [SAlt] -> BlockResultTransformation -> CodeGeneration [BlockStmt]

540+mkCase :: BlockPostprocessor -> Bool -> LVar -> [SAlt] -> CodeGeneration [BlockStmt]

415−

416−mkCase checked var cases cont

541+mkCase pp checked var cases

542+ | isDefaultOnlyCase cases = mkDefaultMatch pp cases

417 | isConstCase cases = do

543 | isConstCase cases = do

418− defaultStmts <- mkDefaultMatch cases cont

419− ifte <- mkConstMatch var defaultStmts cases cont

544+ ifte <- mkConstMatch (ignoreOuter pp) (\ pp -> mkDefaultMatch pp cases) var cases

420− return [BlockStmt ifte]

545+ ppOuterBlock pp [BlockStmt ifte]

421−mkCase checked var cases cont =

546+ | otherwise = do

422− (\ switchExp blocks defaultStmts ->

423− [BlockStmt $ Switch switchExp (blocks ++ [SwitchBlock Default defaultStmts])]

424− )

425− <$> mkGetConstructorId checked var

547+ switchExp <- mkGetConstructorId checked var

426− <*> mkConsMatch var cases cont

548+ matchBlocks <- mkConsMatch (ignoreOuter pp) (\ pp -> mkDefaultMatch pp cases) var cases

427− <*> mkDefaultMatch cases cont

549+ ppOuterBlock pp [BlockStmt $ Switch switchExp matchBlocks]

428

550

429isConstCase :: [SAlt] -> Bool

551isConstCase :: [SAlt] -> Bool

430isConstCase ((SConstCase _ _):_) = True

552isConstCase ((SConstCase _ _):_) = True

431isConstCase ((SDefaultCase _):cases) = isConstCase cases

553isConstCase ((SDefaultCase _):cases) = isConstCase cases

432isConstCase _ = False

554isConstCase _ = False

433

555

434−mkDefaultMatch :: [SAlt] -> BlockResultTransformation -> CodeGeneration [BlockStmt]

556+isDefaultOnlyCase :: [SAlt] -> Bool

557+isDefaultOnlyCase [SDefaultCase _] = True

558+isDefaultOnlyCase [] = True

559+isDefaultOnlyCase _ = False

560+

561+mkDefaultMatch :: BlockPostprocessor -> [SAlt] -> CodeGeneration [BlockStmt]

435−mkDefaultMatch (x@(SDefaultCase branchExpression):_) cont = mkExp branchExpression cont

562+mkDefaultMatch pp (x@(SDefaultCase branchExpression):_) =

563+ do pushScope

564+ stmt <- mkExp pp branchExpression

565+ popScope

566+ return stmt

436−mkDefaultMatch (x:xs) cont = mkDefaultMatch xs cont

567+mkDefaultMatch pp (x:xs) = mkDefaultMatch pp xs

437−mkDefaultMatch [] cont = mkException "Non-exhaustive pattern"

568+mkDefaultMatch pp [] =

569+ ppExp (throwRuntimeException pp) (jString "Non-exhaustive pattern")

438

570

439mkMatchConstExp :: LVar -> Const -> CodeGeneration Exp

571mkMatchConstExp :: LVar -> Const -> CodeGeneration Exp

440mkMatchConstExp var c

572mkMatchConstExp var c

@@ -454,14 +586,23 @@ mkMatchConstExp var c

454 cty = constType c

586 cty = constType c

455 jc = mkConstant c

587 jc = mkConstant c

456

588

589+mkConstMatch :: BlockPostprocessor ->

590+ (BlockPostprocessor -> CodeGeneration [BlockStmt]) ->

591+ LVar ->

592+ [SAlt] ->

457−mkConstMatch :: LVar -> [BlockStmt] -> [SAlt] -> BlockResultTransformation -> CodeGeneration Stmt

593+ CodeGeneration Stmt

458−mkConstMatch var defaultStmts ((SConstCase constant branchExpression):cases) cont =

594+mkConstMatch pp getDefaultStmts var ((SConstCase constant branchExpression):cases) = do

459− (\ exp block others -> IfThenElse exp (StmtBlock $ Block block) others)

460− <$> mkMatchConstExp var constant

595+ matchExp <- mkMatchConstExp var constant

596+ pushScope

461− <*> mkExp branchExpression cont

597+ branchBlock <- mkExp pp branchExpression

462− <*> mkConstMatch var defaultStmts cases cont

598+ popScope

599+ otherBranches <- mkConstMatch pp getDefaultStmts var cases

600+ return

601+ $ IfThenElse matchExp (StmtBlock $ Block branchBlock) otherBranches

463−mkConstMatch var defaultStmts (c:cases) cont = mkConstMatch var defaultStmts cases cont

602+mkConstMatch pp getDefaultStmts var (c:cases) = mkConstMatch pp getDefaultStmts var cases

603+mkConstMatch pp getDefaultStmts _ [] = do

604+ defaultBlock <- getDefaultStmts pp

464−mkConstMatch var defaultStmts [] cont = return $ StmtBlock (Block defaultStmts)

605+ return $ StmtBlock (Block defaultBlock)

465

606

466mkGetConstructorId :: Bool -> LVar -> CodeGeneration Exp

607mkGetConstructorId :: Bool -> LVar -> CodeGeneration Exp

467mkGetConstructorId True var =

608mkGetConstructorId True var =

@@ -474,26 +615,34 @@ mkGetConstructorId False var =

474 <$> (Nothing <>@! var)

615 <$> (Nothing <>@! var)

475 <*> mkGetConstructorId True var

616 <*> mkGetConstructorId True var

476

617

618+mkConsMatch :: BlockPostprocessor ->

619+ (BlockPostprocessor -> CodeGeneration [BlockStmt]) ->

620+ LVar ->

621+ [SAlt] ->

477−mkConsMatch :: LVar -> [SAlt] -> BlockResultTransformation -> CodeGeneration [SwitchBlock]

622+ CodeGeneration [SwitchBlock]

478−mkConsMatch var ((SConCase parentStackPos consIndex _ params branchExpression):cases) cont =

623+mkConsMatch pp getDefaultStmts var ((SConCase parentStackPos consIndex _ params branchExpression):cases) = do

624+ pushScope

625+ caseBranch <- mkCaseBinding pp var parentStackPos params branchExpression

626+ popScope

627+ otherBranches <- mkConsMatch pp getDefaultStmts var cases

628+ return $

479− (\ block others -> (SwitchBlock (SwitchCase $ jInt consIndex) block):others)

629+ (SwitchBlock (SwitchCase $ jInt consIndex) caseBranch):otherBranches

480− <$> mkCaseBinding var parentStackPos params branchExpression cont

481− <*> mkConsMatch var cases cont

482−mkConsMatch var (_:cases) cont = mkConsMatch var cases cont

630+mkConsMatch pp getDefaultStmts var (c:cases) = mkConsMatch pp getDefaultStmts var cases

483−mkConsMatch _ [] _ = return []

631+mkConsMatch pp getDefaultStmts _ [] = do

484−

632+ defaultBlock <- getDefaultStmts pp

633+ return $

634+ [SwitchBlock Default defaultBlock]

635+

485−mkCaseBinding :: LVar -> Int -> [Name] -> SExp -> BlockResultTransformation -> CodeGeneration [BlockStmt]

636+mkCaseBinding :: BlockPostprocessor -> LVar -> Int -> [Name] -> SExp -> CodeGeneration [BlockStmt]

486−mkCaseBinding var stackStart [] branchExpression cont = mkExp branchExpression cont

487−mkCaseBinding var stackStart (params) branchExpression cont = do

637+mkCaseBinding pp var stackStart params branchExpression =

488− deconstruction <- mkCaseBindingDeconstruction var stackStart params

638+ mkExp pp (toLetIn var stackStart params branchExpression)

489− branchBlk <- mkExp branchExpression cont

639+ where

490− return $ deconstruction ++ branchBlk

640+ toLetIn :: LVar -> Int -> [Name] -> SExp -> SExp

491−

492−mkCaseBindingDeconstruction :: LVar -> Int -> [Name] -> CodeGeneration [BlockStmt]

493−mkCaseBindingDeconstruction var stackStart members =

641+ toLetIn var stackStart members start =

494− mapM (\ pos -> BlockStmt . ExpStmt .

642+ foldr

495− ((contextArray var @! (stackStart + pos)) @:=) <$> mkProjection var pos

643+ (\ pos inExp -> SLet (Loc (stackStart + pos)) (SProj var pos) inExp)

644+ start

496− ) ([0..(length members - 1)])

645+ [0.. (length members - 1)]

497

646

498-----------------------------------------------------------------------

647-----------------------------------------------------------------------

499-- Projection (retrieve the n-th field of an object)

648-- Projection (retrieve the n-th field of an object)

@@ -536,51 +685,31 @@ mkConstant c@(Forgot ) = ClassLit (Just $ objectType)

536-----------------------------------------------------------------------

685-----------------------------------------------------------------------

537-- Foreign function calls

686-- Foreign function calls

538

687

539−mkForeignWrappedMethod :: FCallType -> FType -> String -> [(FType, LVar)] -> CodeGeneration Decl

688+mkForeign :: BlockPostprocessor -> FLang -> FType -> String -> [(FType, LVar)] -> CodeGeneration [BlockStmt]

689+mkForeign pp (LANG_C) resTy text params = mkForeign pp (LANG_JAVA FStatic) resTy text params

540−mkForeignWrappedMethod callType resTy text params

690+mkForeign pp (LANG_JAVA callType) resTy text params

541− | callType <- FStatic =

691+ | callType <- FStatic = do

542− (\ method args ->

692+ method <- liftParsed (parser name text)

693+ args <- foreignVarAccess params

543− wrapperMethod $ wrapReturn resTy (call method args)

694+ wrapReturn resTy (call method args)

544− )

545− <$> liftParsed (parser name text)

546− <*> foreignVarAccess params

547− | callType <- FObject =

695+ | callType <- FObject = do

548− (\ method (tgt:args) ->

696+ method <- liftParsed (parser ident text)

697+ (tgt:args) <- foreignVarAccess params

549− wrapperMethod $ wrapReturn resTy ((tgt ~> (show $ pretty method)) args)

698+ wrapReturn resTy ((tgt ~> (show $ pretty method)) args)

550− )

551− <$> liftParsed (parser ident text)

552− <*> foreignVarAccess params

553− | callType <- FConstructor =

699+ | callType <- FConstructor = do

554− (\ clsTy args ->

700+ clsTy <- liftParsed (parser classType text)

701+ args <- foreignVarAccess params

555− wrapperMethod $ wrapReturn resTy (InstanceCreation [] clsTy args Nothing)

702+ wrapReturn resTy (InstanceCreation [] clsTy args Nothing)

556− )

557− <$> liftParsed (parser classType text)

558− <*> foreignVarAccess params

559 where

703 where

560− wrapperMethod =

561− MemberDecl . MethodDecl

562− [Protected, Final] [] (Just objectType) (Ident $ "wrappedInvoke") [] [toRefType exceptionType]

563− . MethodBody . Just . Block

564−

565−

566− wrapReturn FUnit exp = [ BlockStmt $ ExpStmt exp, jReturn (Lit Null) ]

567− wrapReturn _ exp = [ jReturn exp ]

568−

569 foreignVarAccess args =

704 foreignVarAccess args =

570 mapM (\ (fty, var) -> (foreignType fty <>@! var)) args

705 mapM (\ (fty, var) -> (foreignType fty <>@! var)) args

571

706

572−mkForeign :: FLang -> FType -> String -> [(FType, LVar)] -> CodeGeneration Exp

707+ pp' = rethrowAsRuntimeException pp

573−mkForeign (LANG_JAVA callType) resTy text params =

708+

574− (\ wrappedMethod ->

709+ wrapReturn FUnit exp =

575− ((InstanceCreation

710+ ((ppInnerBlock pp') [BlockStmt $ ExpStmt exp] (Lit Null)) >>= ppOuterBlock pp'

576− []

711+ wrapReturn _ exp =

577− (toClassType foreignWrapperType)

712+ ((ppInnerBlock pp') [] exp) >>= ppOuterBlock pp'

578− []

579− (Just $ ClassBody [wrappedMethod])

580− ) ~> "invoke") []

581− )

582− <$> mkForeignWrappedMethod callType resTy text params

583−mkForeign (LANG_C) resTy text params = mkForeign (LANG_JAVA FStatic) resTy text params

584

713

585-----------------------------------------------------------------------

714-----------------------------------------------------------------------

586-- Primitive functions

715-- Primitive functions

@@ -594,18 +723,4 @@ mkThread :: LVar -> CodeGeneration Exp

594mkThread arg =

723mkThread arg =

595 (\ closure -> (closure ~> "fork") []) <$> mkMethodCallClosure (MN 0 "EVAL") [arg]

724 (\ closure -> (closure ~> "fork") []) <$> mkMethodCallClosure (MN 0 "EVAL") [arg]

596

725

597−-----------------------------------------------------------------------

598−-- Exceptions

599−

600−mkException :: String -> CodeGeneration [BlockStmt]

601−mkException err =

602− return $

603− [ BlockStmt $ Throw

604− ( InstanceCreation

605− []

606− (toClassType runtimeExceptionType)

607− [Lit $ String err]

608− Nothing

609− )

610− ]

611

726

src/IRTS/Java/ASTBuilding.hs+8−2

@@ -55,12 +55,18 @@ instance Callable J.Name where

55(<>) :: Type -> Exp -> Exp

56(<>) = Cast

58+localVar :: Int -> Ident

59+localVar i = Ident $ "loc" ++ show i

60+

58(@!) :: Exp -> Int -> ArrayIndex

61(@!) :: Exp -> Int -> ArrayIndex

59(@!) target pos =

62(@!) target pos =

60 ArrayIndex target (Lit $ Int (toInteger pos))

63 ArrayIndex target (Lit $ Int (toInteger pos))

62−(@:=) :: ArrayIndex -> Exp -> Exp

65+(@:=) :: Either ArrayIndex Ident -> Exp -> BlockStmt

66+(@:=) (Right lhs) rhs =

67+ LocalVars [Final] objectType [VarDecl (VarId lhs) (Just $ InitExp rhs)]

68+(@:=) (Left lhs) rhs =

63−(@:=) lhs rhs = Assign (ArrayLhs lhs) EqualA rhs

69+ BlockStmt . ExpStmt $ Assign (ArrayLhs lhs) EqualA rhs

65(~&&~) :: Exp -> Exp -> Exp

71(~&&~) :: Exp -> Exp -> Exp

66(~&&~) e1 e2 = BinOp e1 CAnd e2

72(~&&~) e1 e2 = BinOp e1 CAnd e2

src/IRTS/Java/JTypes.hs−1

@@ -203,7 +203,6 @@ foreignType :: FType -> Maybe J.Type

203foreignType (FArith at) = Just $ arithTyToJType at

204foreignType (FFunction ) = Just $ callableType

205foreignType (FFunctionIO ) = Just $ callableType

206−foreignType (FChar ) = Just $ charType

207foreignType (FString ) = Just $ stringType

206foreignType (FString ) = Just $ stringType

208foreignType (FUnit ) = Nothing

207foreignType (FUnit ) = Nothing

209foreignType (FPtr ) = Just $ objectType

208foreignType (FPtr ) = Just $ objectType