2572b10 · Idris-dev · git.iko.soy

lib/IO.idr+7−2

compare with master

unifiedsplit

@@ -21,10 +21,15 @@ io_return x = prim__IO x

21run__IO : IO () -> IO ()

22run__IO v = io_bind v (\v' => io_return v')

23

24+data IntTy = ITNative | IT8 | IT16 | IT32 | IT64

25

26

26interpFTy : FTy -> Type

27interpFTy : FTy -> Type

27−interpFTy FInt = Int

28+interpFTy (FInt ITNative) = Int

29+interpFTy (FInt IT8) = Bits8

30+interpFTy (FInt IT16) = Bits16

31+interpFTy (FInt IT32) = Bits32

32+interpFTy (FInt IT64) = Bits64

28interpFTy FFloat = Float

33interpFTy FFloat = Float

29interpFTy FChar = Char

34interpFTy FChar = Char

30interpFTy FString = String

35interpFTy FString = String

lib/Prelude.idr+3−3

@@ -298,7 +298,7 @@ fwrite (FHandle h) s = do_fwrite h s

298

299partial

300do_feof : Ptr -> IO Int

301−do_feof h = mkForeign (FFun "fileEOF" [FPtr] FInt) h

301+do_feof h = mkForeign (FFun "fileEOF" [FPtr] (FInt ITNative)) h

302

303feof : File -> IO Bool

304feof (FHandle h) = do eof <- do_feof h

@@ -306,7 +306,7 @@ feof (FHandle h) = do eof <- do_feof h

306

307partial

308do_ferror : Ptr -> IO Int

309−do_ferror h = mkForeign (FFun "fileError" [FPtr] FInt) h

309+do_ferror h = mkForeign (FFun "fileError" [FPtr] (FInt ITNative)) h

310

311ferror : File -> IO Bool

312ferror (FHandle h) = do err <- do_ferror h

@@ -314,7 +314,7 @@ ferror (FHandle h) = do err <- do_ferror h

314

315partial

316nullPtr : Ptr -> IO Bool

317−nullPtr p = do ok <- mkForeign (FFun "isNull" [FPtr] FInt) p

317+nullPtr p = do ok <- mkForeign (FFun "isNull" [FPtr] (FInt ITNative)) p

318 return (ok /= 0);

319

320partial

lib/System.idr+4−4

@@ -10,10 +10,10 @@ getArgs = do n <- numArgs

10 ga' [] 0 n

11 where

12 numArgs : IO Int

13− numArgs = mkForeign (FFun "idris_numArgs" [FPtr] FInt) prim__vm

13+ numArgs = mkForeign (FFun "idris_numArgs" [FPtr] (FInt ITNative)) prim__vm

14

15 getArg : Int -> IO String

16− getArg x = mkForeign (FFun "idris_getArg" [FPtr, FInt] (FAny String)) prim__vm x

16+ getArg x = mkForeign (FFun "idris_getArg" [FPtr, FInt ITNative] (FAny String)) prim__vm x

17

18 ga' : List String -> Int -> Int -> IO (List String)

19 ga' acc i n = if (i == n) then (return $ reverse acc) else

@@ -24,8 +24,8 @@ getEnv : String -> IO String

24getEnv x = mkForeign (FFun "getenv" [FString] FString) x

25

26exit : Int -> IO ()

27−exit code = mkForeign (FFun "exit" [FInt] FUnit) code

27+exit code = mkForeign (FFun "exit" [FInt ITNative] FUnit) code

28

29usleep : Int -> IO ()

30−usleep i = mkForeign (FFun "usleep" [FInt] FUnit) i

30+usleep i = mkForeign (FFun "usleep" [FInt ITNative] FUnit) i

31

lib/System/Concurrency/Raw.idr+1−1

@@ -15,7 +15,7 @@ sendToThread {a} dest val

15

16checkMsgs : IO Bool

17checkMsgs = do msgs <- mkForeign (FFun "idris_checkMessage"

18− [FPtr] FInt) prim__vm

18+ [FPtr] (FInt ITNative)) prim__vm

19 return (intToBool msgs)

20

21-- Check inbox for messages. If there are none, blocks until a message

rts/idris_bitstring.c+28

@@ -60,6 +60,34 @@ VAL idris_castB32Int(VM *vm, VAL a) {

60 return MKINT((i_int)a->info.bits32);

61}

62

63+VAL idris_b8const(VM *vm, uint8_t a) {

64+ VAL cl = allocate(vm, sizeof(Closure), 0);

65+ SETTY(cl, BITS8);

66+ cl->info.bits8 = a;

67+ return cl;

68+}

69+

70+VAL idris_b16const(VM *vm, uint16_t a) {

71+ VAL cl = allocate(vm, sizeof(Closure), 0);

72+ SETTY(cl, BITS16);

73+ cl->info.bits16 = a;

74+ return cl;

75+}

76+

77+VAL idris_b32const(VM *vm, uint32_t a) {

78+ VAL cl = allocate(vm, sizeof(Closure), 0);

79+ SETTY(cl, BITS32);

80+ cl->info.bits32 = a;

81+ return cl;

82+}

83+

84+VAL idris_b64const(VM *vm, uint64_t a) {

85+ VAL cl = allocate(vm, sizeof(Closure), 0);

86+ SETTY(cl, BITS64);

87+ cl->info.bits64 = a;

88+ return cl;

89+}

90+

63VAL idris_b8Plus(VM *vm, VAL a, VAL b) {

91VAL idris_b8Plus(VM *vm, VAL a, VAL b) {

64 VAL cl = allocate(vm, sizeof(Closure), 0);

92 VAL cl = allocate(vm, sizeof(Closure), 0);

65 SETTY(cl, BITS8);

93 SETTY(cl, BITS8);

rts/idris_bitstring.h+4

@@ -11,6 +11,10 @@ VAL idris_b16(VM *vm, VAL a);

11VAL idris_b32(VM *vm, VAL a);

12VAL idris_b64(VM *vm, VAL a);

13VAL idris_castB32Int(VM *vm, VAL a);

14+VAL idris_b8const(VM *vm, uint8_t a);

15+VAL idris_b16const(VM *vm, uint16_t a);

16+VAL idris_b32const(VM *vm, uint32_t a);

17+VAL idris_b64const(VM *vm, uint64_t a);

14

18

15VAL idris_b8Plus(VM *vm, VAL a, VAL b);

19VAL idris_b8Plus(VM *vm, VAL a, VAL b);

16VAL idris_b8Minus(VM *vm, VAL a, VAL b);

20VAL idris_b8Minus(VM *vm, VAL a, VAL b);

src/IRTS/CodegenC.hs+10−2

@@ -106,6 +106,10 @@ bcc i (ASSIGNCONST l c)

106 mkConst (Fl f) = "MKFLOAT(vm, " ++ show f ++ ")"

107 mkConst (Ch c) = "MKINT(" ++ show (fromEnum c) ++ ")"

108 mkConst (Str s) = "MKSTR(vm, " ++ show s ++ ")"

109+ mkConst (B8 x) = "idris_b8const(vm, " ++ show x ++ ")"

110+ mkConst (B16 x) = "idris_b16const(vm, " ++ show x ++ ")"

111+ mkConst (B32 x) = "idris_b32const(vm, " ++ show x ++ ")"

112+ mkConst (B64 x) = "idris_b64const(vm, " ++ show x ++ ")"

109 mkConst _ = "MKINT(42424242)"

113 mkConst _ = "MKINT(42424242)"

110bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"

114bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"

111bcc i (MKCON l tag args)

115bcc i (MKCON l tag args)

@@ -223,7 +227,10 @@ bcc i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed

223bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); assert(0); exit(-1);"

227bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); assert(0); exit(-1);"

224-- bcc i _ = indent i ++ "// not done yet\n"

228-- bcc i _ = indent i ++ "// not done yet\n"

225

229

230+

231+

226−c_irts FInt l x = l ++ "MKINT((i_int)(" ++ x ++ "))"

232+c_irts (FInt ITNative) l x = l ++ "MKINT((i_int)(" ++ x ++ "))"

233+c_irts (FInt ty) l x = l ++ "idris_b" ++ show (intTyWidth ty) ++ "const(vm, " ++ x ++ ")"

227c_irts FChar l x = l ++ "MKINT((i_int)(" ++ x ++ "))"

234c_irts FChar l x = l ++ "MKINT((i_int)(" ++ x ++ "))"

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

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

229c_irts FUnit l x = x

236c_irts FUnit l x = x

@@ -231,7 +238,8 @@ c_irts FPtr l x = l ++ "MKPTR(vm, " ++ x ++ ")"

231c_irts FDouble l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"

238c_irts FDouble l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"

232c_irts FAny l x = l ++ x

239c_irts FAny l x = l ++ x

233

240

234−irts_c FInt x = "GETINT(" ++ x ++ ")"

241+irts_c (FInt ITNative) x = "GETINT(" ++ x ++ ")"

242+irts_c (FInt ty) x = "(" ++ x ++ "->info.bits" ++ show (intTyWidth ty) ++ ")"

235irts_c FChar x = "GETINT(" ++ x ++ ")"

243irts_c FChar x = "GETINT(" ++ x ++ ")"

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

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

237irts_c FUnit x = x

245irts_c FUnit x = x

src/IRTS/CodegenJava.hs+8−8

@@ -976,7 +976,7 @@ mkStringAtIndex var indexExp =

976 <$> mkVarAccess (Just stringType) var

977

978mkForeignType :: FType -> Maybe ClassType

979−mkForeignType FInt = return integerType

979+mkForeignType (FInt ty) = return (intTyToClass ty)

980mkForeignType FChar = return integerType

981mkForeignType FString = return stringType

982mkForeignType FPtr = return objectType

@@ -985,14 +985,14 @@ mkForeignType FAny = return objectType

985mkForeignType FUnit = Nothing

986

987mkForeignVarAccess :: FType -> LVar -> CodeGeneration Exp

988−mkForeignVarAccess FInt var =

988+mkForeignVarAccess (FInt ty) var =

989− (\ var -> MethodInv $ PrimaryMethodCall (var)

989+ (\ var -> MethodInv $ PrimaryMethodCall var

990 []

991− (Ident "intValue")

991+ (Ident (intTyToMethod ty))

992 []

993 )

994 <$> mkVarAccess (Just integerType) var

995−mkForeignVarAccess FChar var = Cast (PrimType CharT) <$> mkForeignVarAccess FInt var

995+mkForeignVarAccess FChar var = Cast (PrimType CharT) <$> mkForeignVarAccess (FInt IT32) var

996mkForeignVarAccess FDouble var =

997 (\ var -> MethodInv $ PrimaryMethodCall (var)

998 []

@@ -1003,12 +1003,12 @@ mkForeignVarAccess FDouble var =

1003mkForeignVarAccess otherType var = mkVarAccess (mkForeignType otherType) var

1004

1005mkFromForeignType :: FType -> Exp -> Exp

1006−mkFromForeignType FInt from =

1006+mkFromForeignType (FInt ty) from =

1007− MethodInv $ TypeMethodCall (J.Name [Ident "Integer"])

1007+ MethodInv $ TypeMethodCall (J.Name [intTyToIdent ty])

1008 []

1009 (Ident "valueOf")

1010 [from]

1011−mkFromForeignType FChar from = mkFromForeignType FInt from

1011+mkFromForeignType FChar from = mkFromForeignType (FInt IT32) from

1012mkFromForeignType FDouble from =

1013 MethodInv $ TypeMethodCall (J.Name [Ident "Double"])

1014 []

src/IRTS/Compiler.hs+7−1

@@ -284,15 +284,21 @@ getFTypes tm = case unApply tm of

284 _ -> Nothing

285

286mkIty' (P _ (UN ty) _) = mkIty ty

287+mkIty' (App (P _ (UN "FInt") _) (P _ (UN intTy) _)) = mkIntIty intTy

287mkIty' _ = FAny

288mkIty' _ = FAny

288

289

289−mkIty "FInt" = FInt

290mkIty "FFloat" = FDouble

291mkIty "FChar" = FChar

292mkIty "FString" = FString

293mkIty "FPtr" = FPtr

294mkIty "FUnit" = FUnit

295

296+mkIntIty "ITNative" = FInt ITNative

297+mkIntIty "IT8" = FInt IT8

298+mkIntIty "IT16" = FInt IT16

299+mkIntIty "IT32" = FInt IT32

300+mkIntIty "IT64" = FInt IT64

301+

296zname = NS (UN "O") ["Nat","Prelude"]

302zname = NS (UN "O") ["Nat","Prelude"]

297sname = NS (UN "S") ["Nat","Prelude"]

303sname = NS (UN "S") ["Nat","Prelude"]

298

304

src/IRTS/LParser.hs+1−1

@@ -164,7 +164,7 @@ pLExp' = try (do lchar '%'; pCast)

164

165pLang = do reserved "C"; return LANG_C

166

167−pType = do reserved "Int"; return FInt

167+pType = do reserved "Int"; return (FInt ITNative)

168 <|> do reserved "Float"; return FDouble

169 <|> do reserved "String"; return FString

170 <|> do reserved "Unit"; return FUnit

src/IRTS/Lang.hs+1−1

@@ -80,7 +80,7 @@ data PrimFn = LPlus IntTy | LMinus IntTy | LTimes IntTy

80data FLang = LANG_C

81 deriving (Show, Eq)

82

84 deriving (Show, Eq)

85

86data LAlt = LConCase Int Name [Name] LExp