d4ffc21 · Idris-dev · git.iko.soy

libs/prelude/IO.idr+8

compare with master

unifiedsplit

@@ -32,6 +32,7 @@ data FTy = FIntT IntTy

32 | FFloat

33 | FString

34 | FPtr

35+ | FManagedPtr

35 | FAny Type

36 | FAny Type

36 | FUnit

37 | FUnit

37

38

@@ -85,6 +86,7 @@ interpFTy (FAny t) = t

85interpFTy FFloat = Float

86interpFTy FFloat = Float

86interpFTy FString = String

87interpFTy FString = String

87interpFTy FPtr = Ptr

88interpFTy FPtr = Ptr

89+interpFTy FManagedPtr = ManagedPtr

88interpFTy (FIntT IT8x16) = Bits8x16

90interpFTy (FIntT IT8x16) = Bits8x16

89interpFTy (FIntT IT16x8) = Bits16x8

91interpFTy (FIntT IT16x8) = Bits16x8

90interpFTy (FIntT IT32x4) = Bits32x4

92interpFTy (FIntT IT32x4) = Bits32x4

@@ -106,6 +108,9 @@ mkForeignPrim : Foreign x -> x

106mkLazyForeignPrim : Foreign x -> x

108mkLazyForeignPrim : Foreign x -> x

107-- mkForeign and mkLazyForeign compiled as primitives

109-- mkForeign and mkLazyForeign compiled as primitives

108

110

111+registerPtr : Ptr -> Int -> ManagedPtr

112+registerPtr = prim__registerPtr

113+

109abstract

114abstract

110io_bind : IO a -> (a -> IO b) -> IO b

115io_bind : IO a -> (a -> IO b) -> IO b

111io_bind (MkIO fn) k

116io_bind (MkIO fn) k

@@ -149,3 +154,6 @@ unsafePerformIO (MkIO f) = unsafePerformPrimIO

149 (prim_io_bind (f TheWorld) (\ b => prim_io_return b))

154 (prim_io_bind (f TheWorld) (\ b => prim_io_return b))

150

155

151

156

157+forceGC : IO ()

158+forceGC = mkForeign (FFun "idris_forceGC" [FPtr] FUnit) prim__vm

159+

rts/idris_gc.c+3

@@ -36,6 +36,9 @@ VAL copy(VM* vm, VAL x) {

36 case PTR:

37 cl = MKPTRc(vm, x->info.ptr);

38 break;

39+ case MANAGEDPTR:

40+ cl = MKMPTRc(vm, x->info.mptr->data, x->info.mptr->size);

41+ break;

39 case BITS8:

42 case BITS8:

40 cl = idris_b8CopyForGC(vm, x);

43 cl = idris_b8CopyForGC(vm, x);

41 break;

44 break;

rts/idris_rts.c+25

@@ -178,6 +178,17 @@ VAL MKPTR(VM* vm, void* ptr) {

178 return cl;

179}

180

181+VAL MKMPTR(VM* vm, void* ptr, int size) {

182+ Closure* cl = allocate(vm, sizeof(Closure) +

183+ sizeof(ManagedPtr) + size, 0);

184+ SETTY(cl, MANAGEDPTR);

185+ cl->info.mptr = (ManagedPtr*)((char*)cl + sizeof(Closure));

186+ cl->info.mptr->data = (char*)cl + sizeof(Closure) + sizeof(ManagedPtr);

187+ memcpy(cl->info.mptr->data, ptr, size);

188+ cl->info.mptr->size = size;

189+ return cl;

190+}

191+

181VAL MKFLOATc(VM* vm, double val) {

192VAL MKFLOATc(VM* vm, double val) {

182 Closure* cl = allocate(vm, sizeof(Closure), 1);

193 Closure* cl = allocate(vm, sizeof(Closure), 1);

183 SETTY(cl, FLOAT);

194 SETTY(cl, FLOAT);

@@ -202,6 +213,17 @@ VAL MKPTRc(VM* vm, void* ptr) {

202 return cl;

213 return cl;

203}

214}

204

215

216+VAL MKMPTRc(VM* vm, void* ptr, int size) {

217+ Closure* cl = allocate(vm, sizeof(Closure) +

218+ sizeof(ManagedPtr) + size, 1);

219+ SETTY(cl, MANAGEDPTR);

220+ cl->info.mptr = (ManagedPtr*)((char*)cl + sizeof(Closure));

221+ cl->info.mptr->data = (char*)cl + sizeof(Closure) + sizeof(ManagedPtr);

222+ memcpy(cl->info.mptr->data, ptr, size);

223+ cl->info.mptr->size = size;

224+ return cl;

225+}

226+

205VAL MKB8(VM* vm, uint8_t bits8) {

227VAL MKB8(VM* vm, uint8_t bits8) {

206 Closure* cl = allocate(vm, sizeof(Closure), 1);

228 Closure* cl = allocate(vm, sizeof(Closure), 1);

207 SETTY(cl, BITS8);

229 SETTY(cl, BITS8);

@@ -795,6 +817,9 @@ VAL copyTo(VM* vm, VAL x) {

795 case PTR:

817 case PTR:

796 cl = MKPTRc(vm, x->info.ptr);

818 cl = MKPTRc(vm, x->info.ptr);

797 break;

819 break;

820+ case MANAGEDPTR:

821+ cl = MKMPTRc(vm, x->info.mptr->data, x->info.mptr->size);

822+ break;

798 case BITS8:

823 case BITS8:

799 cl = idris_b8CopyForGC(vm, x);

824 cl = idris_b8CopyForGC(vm, x);

800 break;

825 break;

rts/idris_rts.h+10−1

@@ -17,7 +17,7 @@

17typedef enum {

18 CON, INT, BIGINT, FLOAT, STRING, STROFFSET,

19 BITS8, BITS16, BITS32, BITS64, UNIT, PTR, FWD,

20− BUFFER

20+ MANAGEDPTR, BUFFER

21} ClosureType;

22

23typedef struct Closure *VAL;

@@ -40,6 +40,11 @@ typedef struct {

40 unsigned char store[];

41} Buffer;

42

43+// A foreign pointer, managed by the idris GC

44+typedef struct {

45+ size_t size;

46+ void* data;

47+} ManagedPtr;

43

48

44typedef struct Closure {

49typedef struct Closure {

45// Use top 16 bits of ty for saying which heap value is in

50// Use top 16 bits of ty for saying which heap value is in

@@ -57,6 +62,7 @@ typedef struct Closure {

57 uint32_t bits32;

62 uint32_t bits32;

58 uint64_t bits64;

63 uint64_t bits64;

59 Buffer* buf;

64 Buffer* buf;

65+ ManagedPtr* mptr;

60 } info;

66 } info;

61} Closure;

67} Closure;

62

68

@@ -112,6 +118,7 @@ typedef void(*func)(VM*, VAL*);

112

118

113#define GETSTR(x) (ISSTR(x) ? (((VAL)(x))->info.str) : GETSTROFF(x))

119#define GETSTR(x) (ISSTR(x) ? (((VAL)(x))->info.str) : GETSTROFF(x))

114#define GETPTR(x) (((VAL)(x))->info.ptr)

120#define GETPTR(x) (((VAL)(x))->info.ptr)

121+#define GETMPTR(x) (((VAL)(x))->info.mptr->data)

115#define GETFLOAT(x) (((VAL)(x))->info.f)

122#define GETFLOAT(x) (((VAL)(x))->info.f)

116

123

117#define TAG(x) (ISINT(x) || x == NULL ? (-1) : ( (x)->ty == CON ? (x)->info.c.tag_arity >> 8 : (-1)) )

124#define TAG(x) (ISINT(x) || x == NULL ? (-1) : ( (x)->ty == CON ? (x)->info.c.tag_arity >> 8 : (-1)) )

@@ -163,6 +170,7 @@ typedef intptr_t i_int;

163VAL MKFLOAT(VM* vm, double val);

170VAL MKFLOAT(VM* vm, double val);

164VAL MKSTR(VM* vm, const char* str);

171VAL MKSTR(VM* vm, const char* str);

165VAL MKPTR(VM* vm, void* ptr);

172VAL MKPTR(VM* vm, void* ptr);

173+VAL MKMPTR(VM* vm, void* ptr, int size);

166VAL MKB8(VM* vm, uint8_t b);

174VAL MKB8(VM* vm, uint8_t b);

167VAL MKB16(VM* vm, uint16_t b);

175VAL MKB16(VM* vm, uint16_t b);

168VAL MKB32(VM* vm, uint32_t b);

176VAL MKB32(VM* vm, uint32_t b);

@@ -173,6 +181,7 @@ VAL MKFLOATc(VM* vm, double val);

173VAL MKSTROFFc(VM* vm, StrOffset* off);

181VAL MKSTROFFc(VM* vm, StrOffset* off);

174VAL MKSTRc(VM* vm, char* str);

182VAL MKSTRc(VM* vm, char* str);

175VAL MKPTRc(VM* vm, void* ptr);

183VAL MKPTRc(VM* vm, void* ptr);

184+VAL MKMPTRc(VM* vm, void* ptr, int size);

176VAL MKBUFFERc(VM* vm, Buffer* buf);

185VAL MKBUFFERc(VM* vm, Buffer* buf);

177

186

178char* GETSTROFF(VAL stroff);

187char* GETSTROFF(VAL stroff);

rts/idris_stdfgn.c+4

@@ -1,5 +1,6 @@

1#include "idris_stdfgn.h"

2#include "idris_rts.h"

3+#include "idris_gc.h"

3#include <sys/select.h>

4#include <sys/select.h>

4#include <fcntl.h>

5#include <fcntl.h>

5#include <stdio.h>

6#include <stdio.h>

@@ -80,3 +81,6 @@ int idris_time() {

80 return (int)t;

81 return (int)t;

81}

82}

82

83

84+void idris_forceGC(void* vm) {

85+ idris_gc((VM*)vm);

86+}

rts/idris_stdfgn.h+2

@@ -23,4 +23,6 @@ char* getEnvPair(int i);

23

24int idris_time();

25

26+void idris_forceGC();

27+

26#endif

28#endif

src/IRTS/CodegenC.hs+4

@@ -262,6 +262,7 @@ c_irts (FArith (ATInt (ITFixed ity))) l x

262c_irts FString l x = l ++ "MKSTR(vm, " ++ x ++ ")"

263c_irts FUnit l x = x

264c_irts FPtr l x = l ++ "MKPTR(vm, " ++ x ++ ")"

265+c_irts FManagedPtr l x = l ++ "MKMPTR(vm, " ++ x ++ ")"

265c_irts (FArith ATFloat) l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"

266c_irts (FArith ATFloat) l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"

266c_irts FAny l x = l ++ x

267c_irts FAny l x = l ++ x

267

268

@@ -272,6 +273,7 @@ irts_c (FArith (ATInt (ITFixed ity))) x

272irts_c FString x = "GETSTR(" ++ x ++ ")"

273irts_c FString x = "GETSTR(" ++ x ++ ")"

273irts_c FUnit x = x

274irts_c FUnit x = x

274irts_c FPtr x = "GETPTR(" ++ x ++ ")"

275irts_c FPtr x = "GETPTR(" ++ x ++ ")"

276+irts_c FManagedPtr x = "GETMPTR(" ++ x ++ ")"

275irts_c (FArith ATFloat) x = "GETFLOAT(" ++ x ++ ")"

277irts_c (FArith ATFloat) x = "GETFLOAT(" ++ x ++ ")"

276irts_c FAny x = x

278irts_c FAny x = x

277

279

@@ -470,6 +472,8 @@ doOp v LFork [x] = v ++ "MKPTR(vm, vmThread(vm, " ++ cname (sMN 0 "EVAL") ++ ",

470doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"

472doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"

471doOp v LVMPtr [] = v ++ "MKPTR(vm, vm)"

473doOp v LVMPtr [] = v ++ "MKPTR(vm, vm)"

472doOp v LNullPtr [] = v ++ "MKPTR(vm, NULL)"

474doOp v LNullPtr [] = v ++ "MKPTR(vm, NULL)"

475+doOp v LRegisterPtr [p, i] = v ++ "MKMPTR(vm, GETPTR(" ++ creg p ++

476+ "), GETINT(" ++ creg i ++ "))"

473doOp v (LChInt ITNative) args = v ++ creg (last args)

477doOp v (LChInt ITNative) args = v ++ creg (last args)

474doOp v (LChInt ITChar) args = doOp v (LChInt ITNative) args

478doOp v (LChInt ITChar) args = doOp v (LChInt ITNative) args

475doOp v (LIntCh ITNative) args = v ++ creg (last args)

479doOp v (LIntCh ITNative) args = v ++ creg (last args)

src/IRTS/Compiler.hs+1

@@ -349,6 +349,7 @@ mkIty "FBits32" = mkIntIty "IT32"

349mkIty "FBits64" = mkIntIty "IT64"

350mkIty "FString" = FString

351mkIty "FPtr" = FPtr

352+mkIty "FManagedPtr" = FManagedPtr

352mkIty "FUnit" = FUnit

353mkIty "FUnit" = FUnit

353mkIty "FFunction" = FFunction

354mkIty "FFunction" = FFunction

354mkIty "FFunctionIO" = FFunctionIO

355mkIty "FFunctionIO" = FFunctionIO

src/IRTS/Lang.hs+2

@@ -66,6 +66,7 @@ data PrimFn = LPlus ArithTy | LMinus ArithTy | LTimes ArithTy

66 -- core or another machine. 'id' is a valid implementation

67 | LVMPtr

68 | LNullPtr

69+ | LRegisterPtr

69 | LNoOp

70 | LNoOp

70 deriving (Show, Eq)

71 deriving (Show, Eq)

71

72

@@ -83,6 +84,7 @@ data FType = FArith ArithTy

83 | FString

84 | FString

84 | FUnit

85 | FUnit

85 | FPtr

86 | FPtr

87+ | FManagedPtr

86 | FAny

88 | FAny

87 deriving (Show, Eq)

89 deriving (Show, Eq)

88

90

src/Idris/Core/TT.hs+3−1

@@ -475,7 +475,7 @@ data Const = I Int | BI Integer | Fl Double | Ch Char | Str String

475 | B8V (Vector Word8) | B16V (Vector Word16)

476 | B32V (Vector Word32) | B64V (Vector Word64)

477 | AType ArithTy | StrType

478− | PtrType | BufferType | VoidType | Forgot

479 deriving (Eq, Ord)

480{-!

481deriving instance Binary Const

@@ -495,6 +495,7 @@ instance Pretty Const OutputAnnotation where

495 pretty StrType = text "String"

496 pretty BufferType = text "prim__UnsafeBuffer"

497 pretty PtrType = text "Ptr"

498+ pretty ManagedPtrType = text "Ptr"

498 pretty VoidType = text "Void"

499 pretty VoidType = text "Void"

499 pretty Forgot = text "Forgot"

500 pretty Forgot = text "Forgot"

500 pretty (B8 w) = text . show $ w

501 pretty (B8 w) = text . show $ w

@@ -1041,6 +1042,7 @@ instance Show Const where

1041 show StrType = "String"

1042 show StrType = "String"

1042 show BufferType = "prim__UnsafeBuffer"

1043 show BufferType = "prim__UnsafeBuffer"

1043 show PtrType = "Ptr"

1044 show PtrType = "Ptr"

1045+ show ManagedPtrType = "ManagedPtr"

1044 show VoidType = "Void"

1046 show VoidType = "Void"

1045

1047

1046showEnv :: (Eq n, Show n) => EnvTT n -> TT n -> String

1048showEnv :: (Eq n, Show n) => EnvTT n -> TT n -> String

src/Idris/IBC.hs+2

@@ -617,6 +617,7 @@ instance Binary Const where

617 B32V x1 -> putWord8 23 >> put x1

618 B64V x1 -> putWord8 24 >> put x1

619 BufferType -> putWord8 25

620+ ManagedPtrType -> putWord8 26

620 get

621 get

621 = do i <- getWord8

622 = do i <- getWord8

622 case i of

623 case i of

@@ -658,6 +659,7 @@ instance Binary Const where

658 23 -> fmap B32V get

659 23 -> fmap B32V get

659 24 -> fmap B64V get

660 24 -> fmap B64V get

660 25 -> return BufferType

661 25 -> return BufferType

662+ 26 -> return ManagedPtrType

661

663

662 _ -> error "Corrupted binary data for Const"

664 _ -> error "Corrupted binary data for Const"

663

665

src/Idris/ParseExpr.hs+2

@@ -1003,6 +1003,7 @@ Constant ::=

1003 | 'Float'

1004 | 'String'

1005 | 'Ptr'

1006+ | 'ManagedPtr'

1006 | 'prim__UnsafeBuffer'

1007 | 'prim__UnsafeBuffer'

1007 | 'Bits8'

1008 | 'Bits8'

1008 | 'Bits16'

1009 | 'Bits16'

@@ -1027,6 +1028,7 @@ constant = do reserved "Integer"; return (AType (ATInt ITBig))

1027 <|> do reserved "Float"; return (AType ATFloat)

1028 <|> do reserved "Float"; return (AType ATFloat)

1028 <|> do reserved "String"; return StrType

1029 <|> do reserved "String"; return StrType

1029 <|> do reserved "Ptr"; return PtrType

1030 <|> do reserved "Ptr"; return PtrType

1031+ <|> do reserved "ManagedPtr"; return ManagedPtrType

1030 <|> do reserved "prim__UnsafeBuffer"; return BufferType

1032 <|> do reserved "prim__UnsafeBuffer"; return BufferType

1031 <|> do reserved "Bits8"; return (AType (ATInt (ITFixed IT8)))

1033 <|> do reserved "Bits8"; return (AType (ATInt (ITFixed IT8)))

1032 <|> do reserved "Bits16"; return (AType (ATInt (ITFixed IT16)))

1034 <|> do reserved "Bits16"; return (AType (ATInt (ITFixed IT16)))

src/Idris/Primitives.hs+3−1

@@ -172,7 +172,9 @@ primitives =

172 (0, LStdIn) partial,

173 Prim (sUN "prim__null") (ty [] PtrType) 0 (p_cantreduce)

174 (0, LNullPtr) total,

175−

175+ -- Managed pointer registration

176+ Prim (sUN "prim__registerPtr") (ty [PtrType, AType (ATInt ITNative)] ManagedPtrType) 2 (p_cantreduce)

177+ (2, LRegisterPtr) total,

176 -- Buffers

178 -- Buffers

177 Prim (sUN "prim__allocate") (ty [AType (ATInt (ITFixed IT64))] BufferType) 1 (p_cantreduce)

179 Prim (sUN "prim__allocate") (ty [AType (ATInt (ITFixed IT64))] BufferType) 1 (p_cantreduce)

178 (1, LAllocate) total,

180 (1, LAllocate) total,