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

git.iko.soy/Idris-dev

Parameterized integer FFI

commit2572b10089bc6b1d0c9fd42a3c165c456883523a authorBenjamin Saunders <besaunde@sfu.ca> dateMon 29 Apr 2013, 12:46 (13 years ago) parent321b8fd

11 files changed+74−23

compare with master

unifiedsplit

lib/IO.idr+7−2 lib/Prelude.idr+3−3 lib/System.idr+4−4 lib/System/Concurrency/Raw.idr+1−1 rts/idris_bitstring.c+28 rts/idris_bitstring.h+4 src/IRTS/CodegenC.hs+10−2 src/IRTS/CodegenJava.hs+8−8 src/IRTS/Compiler.hs+7−1 src/IRTS/LParser.hs+1−1 src/IRTS/Lang.hs+1−1

lib/IO.idr+7−2

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

2121run__IO : IO () -> IO ()

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

2323

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

2526

2627interpFTy : 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

2833interpFTy FFloat = Float

2934interpFTy FChar = Char

3035interpFTy FString = String

lib/Prelude.idr+3−3

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

298298

299299partial

300300do_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

302302

303303feof : File -> IO Bool

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

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

306306

307307partial

308308do_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

310310

311311ferror : File -> IO Bool

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

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

314314

315315partial

316316nullPtr : 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

318318 return (ok /= 0);

319319

320320partial

lib/System.idr+4−4

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

1010 ga' [] 0 n

1111 where

1212 numArgs : IO Int

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

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

1414

1515 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

1717

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

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

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

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

2525

2626exit : Int -> IO ()

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

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

2828

2929usleep : Int -> IO ()

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

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

3131

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

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

1515

1616checkMsgs : IO Bool

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

18− [FPtr] FInt) prim__vm

18+ [FPtr] (FInt ITNative)) prim__vm

1919 return (intToBool msgs)

2020

2121-- 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) {

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

6161}

6262

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+

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

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

6593 SETTY(cl, BITS8);

rts/idris_bitstring.h+4

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

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

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

1313VAL 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);

1418

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

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

src/IRTS/CodegenC.hs+10−2

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

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

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

108108 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 ++ ")"

109113 mkConst _ = "MKINT(42424242)"

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

111115bcc 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

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

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

225229

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

230+

231+

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 ++ ")"

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

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

229236c_irts FUnit l x = x

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

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

232239c_irts FAny l x = l ++ x

233240

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) ++ ")"

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

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

237245irts_c FUnit x = x

src/IRTS/CodegenJava.hs+8−8

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

976976 <$> mkVarAccess (Just stringType) var

977977

978978mkForeignType :: FType -> Maybe ClassType

979−mkForeignType FInt = return integerType

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

980980mkForeignType FChar = return integerType

981981mkForeignType FString = return stringType

982982mkForeignType FPtr = return objectType

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

985985mkForeignType FUnit = Nothing

986986

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

988−mkForeignVarAccess FInt var =

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

988+mkForeignVarAccess (FInt ty) var =

989+ (\ var -> MethodInv $ PrimaryMethodCall var

990990 []

991− (Ident "intValue")

991+ (Ident (intTyToMethod ty))

992992 []

993993 )

994994 <$> 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

996996mkForeignVarAccess FDouble var =

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

998998 []

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

10031003mkForeignVarAccess otherType var = mkVarAccess (mkForeignType otherType) var

10041004

10051005mkFromForeignType :: FType -> Exp -> Exp

1006−mkFromForeignType FInt from =

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

1006+mkFromForeignType (FInt ty) from =

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

10081008 []

10091009 (Ident "valueOf")

10101010 [from]

1011−mkFromForeignType FChar from = mkFromForeignType FInt from

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

10121012mkFromForeignType FDouble from =

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

10141014 []

src/IRTS/Compiler.hs+7−1

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

284284 _ -> Nothing

285285

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

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

287288mkIty' _ = FAny

288289

289−mkIty "FInt" = FInt

290290mkIty "FFloat" = FDouble

291291mkIty "FChar" = FChar

292292mkIty "FString" = FString

293293mkIty "FPtr" = FPtr

294294mkIty "FUnit" = FUnit

295295

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+

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

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

298304

src/IRTS/LParser.hs+1−1

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

164164

165165pLang = do reserved "C"; return LANG_C

166166

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

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

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

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

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

src/IRTS/Lang.hs+1−1

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

8080data FLang = LANG_C

8181 deriving (Show, Eq)

8282

8484 deriving (Show, Eq)

8585

8686data LAlt = LConCase Int Name [Name] LExp