72524a0 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Proper tail calls and ArithTy ITChar support

72524a0Jan Bessai13 years ago

java/src/main/java/org/idris/rts/Closure.java+10−9

compare with master

unifiedsplit

@@ -3,19 +3,20 @@ package org.idris.rts;

3import java.util.concurrent.Callable;

5public abstract class Closure implements Callable<Object>, Runnable {

6− protected final Object [] context;

6+ @Override

7−

7+ public abstract Object call();

8− protected Closure(final Object ... context) {

9− this.context = context;

9+ public static Object unwrapTailCall(Object o) {

10+ while (o instanceof Closure) {

11+ o = ((Closure)o).call();

12+ }

13+ return o;

10 }

14 }

11−

15+

12 @Override

16 @Override

13 public void run() {

17 public void run() {

14− call();

18+ unwrapTailCall(call());

15 }

19 }

16−

17− @Override

18− public abstract Object call();

20 public Thread fork() {

21 public Thread fork() {

21 Thread childProcess = new Thread(this);

22 Thread childProcess = new Thread(this);

java/src/main/java/org/idris/rts/TailCallClosure.javadeleted−26

@@ -1,26 +0,0 @@

1−package org.idris.rts;

2−

3−public class TailCallClosure extends Closure {

4− private final Closure function;

5−

6− public TailCallClosure(Closure function) {

7− super();

8− this.function = function;

9− }

10−

11− public final Object call() {

12− Closure function = this.function;

13− Object result = null;

14− while (function != null) {

15− result = function.call();

16− function = null;

17− if (result instanceof TailCallClosure) {

18− function = ((TailCallClosure)result).function;

19− } else {

20− return result;

21− }

22− }

23− return result;

24− }

25−}

26−

src/IRTS/CodegenJava.hs+11−15

@@ -1,7 +1,7 @@

1{-# LANGUAGE PatternGuards #-}

2module IRTS.CodegenJava (codegenJava) where

4−import Core.TT

4+import Core.TT hiding (mkApp)

5import IRTS.BCImp

6import IRTS.CodegenCommon

7import IRTS.Java.ASTBuilding

@@ -313,12 +313,7 @@ mkExp :: SExp -> BlockResultTransformation -> CodeGeneration [BlockStmt]

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

314

315-- Applications

316−mkExp (SApp True name args) cont =

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

317− ((\ name args -> call name args) <$> mangleFull name <*> mapM (Nothing <>@!) args) >>= cont []

318− --mkTailCallClosure name args >>= cont []

319−mkExp (SApp False name args) cont =

320− ((\ name args -> call name args) <$> mangleFull name <*> mapM (Nothing <>@!) args) >>= cont []

321− --((\ closure -> (closure ~> "call") []) <$> mkTailCallClosure name args) >>= cont []

322

317

323-- Bindings

318-- Bindings

324mkExp (SLet var newExp inExp) cont = mkLet var newExp inExp cont

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

@@ -373,16 +368,18 @@ varPos (Glob name) = do

373-----------------------------------------------------------------------

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

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

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

375

370

376−mkTailCallClosure :: Name -> [LVar] -> CodeGeneration Exp

371+mkApp :: Bool -> Name -> [LVar] -> CodeGeneration Exp

377−mkTailCallClosure name args =

372+mkApp False name args =

378− (\ methClosure ->

373+ (\ methodName params ->

379− InstanceCreation [] (toClassType idrisTailCallClosureType) [methClosure] Nothing

374+ (idrisClosureType ~> "unwrapTailCall") [call methodName params]

380 )

375 )

376+ <$> mangleFull name

377+ <*> mapM (Nothing <>@!) args

381− <$> mkMethodCallClosure name args

378+mkApp True name args = mkMethodCallClosure name args

382

379

383mkMethodCallClosure :: Name -> [LVar] -> CodeGeneration Exp

380mkMethodCallClosure :: Name -> [LVar] -> CodeGeneration Exp

384mkMethodCallClosure name args =

381mkMethodCallClosure name args =

385− (\ name args -> closure [localContext] (call name args))

382+ (\ name args -> closure (call name args))

386 <$> mangleFull name

383 <$> mangleFull name

387 <*> mapM (Nothing <>@!) args

384 <*> mapM (Nothing <>@!) args

388

385

@@ -531,7 +528,6 @@ mkConstant c@(B16V x) = mkConstantArray (constType c) B16 x

531mkConstant c@(B32V x) = mkConstantArray (constType c) B32 x

528mkConstant c@(B32V x) = mkConstantArray (constType c) B32 x

532mkConstant c@(B64V x) = mkConstantArray (constType c) B64 x

529mkConstant c@(B64V x) = mkConstantArray (constType c) B64 x

533mkConstant c@(AType x) = ClassLit (Just $ box (constType c))

530mkConstant c@(AType x) = ClassLit (Just $ box (constType c))

534−mkConstant c@(ChType ) = ClassLit (Just $ box integerType)

535mkConstant c@(StrType ) = ClassLit (Just $ stringType)

531mkConstant c@(StrType ) = ClassLit (Just $ stringType)

536mkConstant c@(PtrType ) = ClassLit (Just $ objectType)

532mkConstant c@(PtrType ) = ClassLit (Just $ objectType)

537mkConstant c@(VoidType ) = ClassLit (Just $ voidType)

533mkConstant c@(VoidType ) = ClassLit (Just $ voidType)

@@ -596,7 +592,7 @@ mkPrimitiveFunction op args =

596

592

597mkThread :: LVar -> CodeGeneration Exp

593mkThread :: LVar -> CodeGeneration Exp

598mkThread arg =

594mkThread arg =

599− (\ closure -> (closure ~> "fork") []) <$> mkTailCallClosure (MN 0 "EVAL") [arg]

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

600

596

601-----------------------------------------------------------------------

597-----------------------------------------------------------------------

602-- Exceptions

598-- Exceptions

src/IRTS/Java/ASTBuilding.hs+3−3

@@ -113,12 +113,12 @@ extendWithNull :: [Exp] -> Int -> [Exp]

113extendWithNull exps additionalZeros =

114 exps ++ (replicate additionalZeros (Lit $ Null))

115

116−closure :: [Exp] -> Exp -> Exp

116+closure :: Exp -> Exp

117−closure params body =

117+closure body =

118 InstanceCreation

119 []

120 (toClassType idrisClosureType)

121− params

121+ []

122 (Just $ ClassBody

123 [ simpleMethod

124 [Public, Final] (Just objectType) "call" []

src/IRTS/Java/JTypes.hs+3−1

@@ -142,6 +142,7 @@ intTyToJType :: IntTy -> J.Type

142intTyToJType (ITFixed nt) = nativeTyToJType nt

143intTyToJType (ITNative) = integerType

144intTyToJType (ITBig) = bigIntegerType

145+intTyToJType (ITChar) = charType

145intTyToJType (ITVec nt _) = array $ nativeTyToJType nt

146intTyToJType (ITVec nt _) = array $ nativeTyToJType nt

146

147

147arithTyToJType :: ArithTy -> J.Type

148arithTyToJType :: ArithTy -> J.Type

@@ -183,7 +184,7 @@ constType :: Const -> J.Type

183constType (I _) = arithTyToJType (ATInt ITNative)

184constType (I _) = arithTyToJType (ATInt ITNative)

184constType (BI _) = arithTyToJType (ATInt ITBig )

185constType (BI _) = arithTyToJType (ATInt ITBig )

185constType (Fl _) = arithTyToJType (ATFloat )

186constType (Fl _) = arithTyToJType (ATFloat )

186−constType (Ch _) = charType

187+constType (Ch _) = arithTyToJType (ATInt ITChar )

187constType (Str _) = stringType

188constType (Str _) = stringType

188constType (B8 _) = arithTyToJType (ATInt $ ITFixed IT8 )

189constType (B8 _) = arithTyToJType (ATInt $ ITFixed IT8 )

189constType (B16 _) = arithTyToJType (ATInt $ ITFixed IT16)

190constType (B16 _) = arithTyToJType (ATInt $ ITFixed IT16)

@@ -223,6 +224,7 @@ opName x

223 suffixFor (ITFixed nt) = show nt

224 suffixFor (ITFixed nt) = show nt

224 suffixFor (ITNative) = show IT32

225 suffixFor (ITNative) = show IT32

225 suffixFor (ITBig) = show ITBig

226 suffixFor (ITBig) = show ITBig

227+ suffixFor (ITChar) = show ITChar

226 suffixFor (ITVec nt _) = "ITVec" ++ (show $ nativeTyWidth nt)

228 suffixFor (ITVec nt _) = "ITVec" ++ (show $ nativeTyWidth nt)

227

229

228sourceTypes :: PrimFn -> [J.Type]

230sourceTypes :: PrimFn -> [J.Type]