Skip to content

Commit

Permalink
Revert "Merge pull request #294 from bitlisp/unified-int-primitives"
Browse files Browse the repository at this point in the history 
This reverts commit 8fed722, reversing
changes made to 943b653.
  • Loading branch information
@edwinb
edwinb committed May 9, 2013
1 parent 977c987 commit 05895a5
Show file tree
Hide file tree
Showing 14 changed files with 785 additions and 450 deletions.
4 changes: 2 additions & 2 deletions effects/Effect/Memory.idr
View file
Original file line number Diff line number Diff line change
Expand Up @@ -48,7 +48,7 @@ do_malloc size with (fromInteger (cast size) == size)
private
do_memset : Ptr -> Nat -> Bits8 -> Nat -> IO ()
do_memset ptr offset c size
= mkForeign (FFun "idris_memset" [FPtr, FInt, FChar, FInt] FUnit)
= mkForeign (FFun "idris_memset" [FPtr, FInt, FAny Bits8, FInt] FUnit)
ptr (cast offset) c (cast size)

private
Expand All @@ -73,7 +73,7 @@ private
do_poke : Ptr -> Nat -> Vect Bits8 size -> IO ()
do_poke _ _ [] = return ()
do_poke ptr offset (b::bs)
= do mkForeign (FFun "idris_poke" [FPtr, FInt, FChar] FUnit) ptr (cast offset) b
= do mkForeign (FFun "idris_poke" [FPtr, FInt, FAny Bits8] FUnit) ptr (cast offset) b
do_poke ptr (S offset) bs

instance Handler RawMemory (IOExcept String) where
Expand Down
22 changes: 3 additions & 19 deletions lib/IO.idr
View file
Original file line number Diff line number Diff line change
Expand Up @@ -21,28 +21,12 @@ io_return x = prim__IO x
run__IO : IO () -> IO ()
run__IO v = io_bind v (\v' => io_return v')

data IntTy = ITNative | IT8 | IT16 | IT32 | IT64
data FTy = FIntT IntTy | FFloat | FString | FPtr | FAny Type | FUnit

FInt : FTy
FInt = FIntT ITNative

FChar : FTy
FChar = FIntT IT8

FShort : FTy
FShort = FIntT IT16

FLong : FTy
FLong = FIntT IT64
data FTy = FInt | FFloat | FChar | FString | FPtr | FAny Type | FUnit

interpFTy : FTy -> Type
interpFTy (FIntT ITNative) = Int
interpFTy (FIntT IT8) = Bits8
interpFTy (FIntT IT16) = Bits16
interpFTy (FIntT IT32) = Bits32
interpFTy (FIntT IT64) = Bits64
interpFTy FInt = Int
interpFTy FFloat = Float
interpFTy FChar = Char
interpFTy FString = String
interpFTy FPtr = Ptr
interpFTy (FAny t) = t
Expand Down
6 changes: 3 additions & 3 deletions lib/Prelude.idr
View file
Original file line number Diff line number Diff line change
Expand Up @@ -251,11 +251,11 @@ getLine = return (prim__readString prim__stdin)

partial
putChar : Char -> IO ()
putChar c = mkForeign (FFun "putchar" [FInt] FUnit) (cast c)
putChar c = mkForeign (FFun "putchar" [FChar] FUnit) c

partial
getChar : IO Char
getChar = fmap cast $ mkForeign (FFun "getchar" [] FInt)
getChar = mkForeign (FFun "getchar" [] FChar)

---- some basic file handling

Expand Down Expand Up @@ -323,7 +323,7 @@ ferror (FHandle h) = do err <- do_ferror h

partial
nullPtr : Ptr -> IO Bool
nullPtr p = do ok <- mkForeign (FFun "isNull" [FPtr] FInt) p
nullPtr p = do ok <- mkForeign (FFun "isNull" [FPtr] FInt) p
return (ok /= 0);

partial
Expand Down
28 changes: 0 additions & 28 deletions rts/idris_bitstring.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -60,34 +60,6 @@ VAL idris_castB32Int(VM *vm, VAL a) {
return MKINT((i_int)a->info.bits32);
}

VAL idris_b8const(VM *vm, uint8_t a) {
VAL cl = allocate(vm, sizeof(Closure), 0);
SETTY(cl, BITS8);
cl->info.bits8 = a;
return cl;
}

VAL idris_b16const(VM *vm, uint16_t a) {
VAL cl = allocate(vm, sizeof(Closure), 0);
SETTY(cl, BITS16);
cl->info.bits16 = a;
return cl;
}

VAL idris_b32const(VM *vm, uint32_t a) {
VAL cl = allocate(vm, sizeof(Closure), 0);
SETTY(cl, BITS32);
cl->info.bits32 = a;
return cl;
}

VAL idris_b64const(VM *vm, uint64_t a) {
VAL cl = allocate(vm, sizeof(Closure), 0);
SETTY(cl, BITS64);
cl->info.bits64 = a;
return cl;
}

VAL idris_b8Plus(VM *vm, VAL a, VAL b) {
VAL cl = allocate(vm, sizeof(Closure), 0);
SETTY(cl, BITS8);
Expand Down
4 changes: 0 additions & 4 deletions rts/idris_bitstring.h
View file
Original file line number Diff line number Diff line change
Expand Up @@ -11,10 +11,6 @@ VAL idris_b16(VM *vm, VAL a);
VAL idris_b32(VM *vm, VAL a);
VAL idris_b64(VM *vm, VAL a);
VAL idris_castB32Int(VM *vm, VAL a);
VAL idris_b8const(VM *vm, uint8_t a);
VAL idris_b16const(VM *vm, uint16_t a);
VAL idris_b32const(VM *vm, uint32_t a);
VAL idris_b64const(VM *vm, uint64_t a);

VAL idris_b8Plus(VM *vm, VAL a, VAL b);
VAL idris_b8Minus(VM *vm, VAL a, VAL b);
Expand Down
1 change: 0 additions & 1 deletion rts/idris_rts.h
View file
Original file line number Diff line number Diff line change
Expand Up @@ -125,7 +125,6 @@ typedef intptr_t i_int;
#define ISINT(x) ((((i_int)x)&1) == 1)

#define INTOP(op,x,y) MKINT((i_int)((((i_int)x)>>1) op (((i_int)y)>>1)))
#define UINTOP(op,x,y) MKINT((i_int)((((uintptr_t)x)>>1) op (((uintptr_t)y)>>1)))
#define FLOATOP(op,x,y) MKFLOAT(vm, ((GETFLOAT(x)) op (GETFLOAT(y))))
#define FLOATBOP(op,x,y) MKINT((i_int)(((GETFLOAT(x)) op (GETFLOAT(y)))))
#define ADD(x,y) (void*)(((i_int)x)+(((i_int)y)-1))
Expand Down
48 changes: 14 additions & 34 deletions src/Core/Execute.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3,9 +3,6 @@ module Core.Execute (execute) where

import Idris.AbsSyntax
import Idris.AbsSyntaxTree
import IRTS.Lang( IntTy(..)
, intTyToConst
, FType(..))

import Core.TT
import Core.Evaluate
Expand Down Expand Up @@ -428,16 +425,18 @@ chooseAlt _ [] = Nothing



idrisType :: FType -> ExecVal
data FTy = FInt | FFloat | FChar | FString | FPtr | FUnit deriving (Show, Read)

idrisType :: FTy -> ExecVal
idrisType FUnit = EP Ref unitTy EErased
idrisType ft = EConstant (idr ft)
where idr (FInt ty) = intTyToConst ty
idr FDouble = FlType
where idr FInt = IType
idr FFloat = FlType
idr FChar = ChType
idr FString = StrType
idr FPtr = PtrType

data Foreign = FFun String [FType] FType deriving Show
data Foreign = FFun String [FTy] FTy deriving Show


call :: Foreign -> [ExecVal] -> Exec (Maybe ExecVal)
Expand All @@ -447,19 +446,11 @@ call (FFun name argTypes retType) args =
Nothing -> return Nothing
Just f -> do res <- call' f args retType
return . Just . ioWrap $ res
where call' :: ForeignFun -> [ExecVal] -> FType -> Exec ExecVal
call' (Fun _ h) args (FInt ITNative) = do res <- execIO $ callFFI h retCInt (prepArgs args)
return (EConstant (I (fromIntegral res)))
call' (Fun _ h) args (FInt IT8) = do res <- execIO $ callFFI h retCChar (prepArgs args)
return (EConstant (B8 (fromIntegral res)))
call' (Fun _ h) args (FInt IT16) = do res <- execIO $ callFFI h retCWchar (prepArgs args)
return (EConstant (B16 (fromIntegral res)))
call' (Fun _ h) args (FInt IT32) = do res <- execIO $ callFFI h retCInt (prepArgs args)
return (EConstant (B32 (fromIntegral res)))
call' (Fun _ h) args (FInt IT64) = do res <- execIO $ callFFI h retCLong (prepArgs args)
return (EConstant (B64 (fromIntegral res)))
call' (Fun _ h) args FDouble = do res <- execIO $ callFFI h retCDouble (prepArgs args)
return (EConstant (Fl (realToFrac res)))
where call' :: ForeignFun -> [ExecVal] -> FTy -> Exec ExecVal
call' (Fun _ h) args FInt = do res <- execIO $ callFFI h retCInt (prepArgs args)
return (EConstant (I (fromIntegral res)))
call' (Fun _ h) args FFloat = do res <- execIO $ callFFI h retCDouble (prepArgs args)
return (EConstant (Fl (realToFrac res)))
call' (Fun _ h) args FChar = do res <- execIO $ callFFI h retCChar (prepArgs args)
return (EConstant (Ch (castCCharToChar res)))
call' (Fun _ h) args FString = do res <- execIO $ callFFI h retCString (prepArgs args)
Expand All @@ -476,10 +467,6 @@ call (FFun name argTypes retType) args =

prepArgs = map prepArg
prepArg (EConstant (I i)) = argCInt (fromIntegral i)
prepArg (EConstant (B8 i)) = argCChar (fromIntegral i)
prepArg (EConstant (B16 i)) = argCWchar (fromIntegral i)
prepArg (EConstant (B32 i)) = argCInt (fromIntegral i)
prepArg (EConstant (B64 i)) = argCLong (fromIntegral i)
prepArg (EConstant (Fl f)) = argCDouble (realToFrac f)
prepArg (EConstant (Ch c)) = argCChar (castCharToCChar c) -- FIXME - castCharToCChar only safe for first 256 chars
prepArg (EConstant (Str s)) = argString s
Expand All @@ -497,18 +484,11 @@ foreignFromTT t = case (unApplyV t) of
return $ FFun name argFTy retFTy
_ -> trace "failed to construct ffun" Nothing

getFTy :: ExecVal -> Maybe FType
getFTy (EApp (EP _ (UN "FInt") _) (EP _ (UN intTy) _)) =
case intTy of
"ITNative" -> Just $ FInt ITNative
"IT8" -> Just $ FInt IT8
"IT16" -> Just $ FInt IT16
"IT32" -> Just $ FInt IT32
"IT64" -> Just $ FInt IT64
_ -> Nothing
getFTy :: ExecVal -> Maybe FTy
getFTy (EP _ (UN t) _) =
case t of
"FFloat" -> Just FDouble
"FInt" -> Just FInt
"FFloat" -> Just FFloat
"FChar" -> Just FChar
"FString" -> Just FString
"FPtr" -> Just FPtr
Expand Down
Loading

0 comments on commit 05895a5

Please sign in to comment.