ref: 8363022e68ba1fe71213a89ba4881d8e65533738
parent: bcb571d56500ce09f9994d7ae777e830c9a6e629
author: Lennart Augustsson <lennart@augustsson.net>
date: Sun Apr 7 07:00:54 EDT 2024
Lots of Ptr improvements.
--- a/lib/Foreign/ForeignPtr.hs
+++ b/lib/Foreign/ForeignPtr.hs
@@ -23,10 +23,8 @@
instance Eq (ForeignPtr a) where
p == q = unsafeForeignPtrToPtr p == unsafeForeignPtrToPtr q
-{-instance Ord (ForeignPtr a) where
compare p q = compare (unsafeForeignPtrToPtr p) (unsafeForeignPtrToPtr q)
--}
instance Show (ForeignPtr a) where
showsPrec p f = showsPrec p (unsafeForeignPtrToPtr f)
--- a/lib/Foreign/Ptr.hs
+++ b/lib/Foreign/Ptr.hs
@@ -8,26 +8,63 @@
import Data.Word
import Data.Eq
import Data.Function
+import Data.Ord
+import Numeric(showHex)
import Text.Show
instance forall a . Eq (Ptr a) where
- p == q = primPtrEQ p q
+ p == q = primPtrToWord p == primPtrToWord q
+instance forall a . Ord (Ptr a) where
+ p `compare` q = primPtrToWord p `compare` primPtrToWord q
+ p < q = primPtrToWord p < primPtrToWord q
+ p <= q = primPtrToWord p <= primPtrToWord q
+ p > q = primPtrToWord p > primPtrToWord q
+ p >= q = primPtrToWord p >= primPtrToWord q
+
instance forall a . Show (Ptr a) where
- showsPrec _ p = showString "PTR#" . showsPrec 0 (primPtrToWord p)
+ showsPrec _ p = showString "0x" . showHex (primPtrToWord p)
nullPtr :: forall a . Ptr a
-nullPtr = primPtrNull
+nullPtr = primIntToPtr (0::Int)
castPtr :: forall a b . Ptr a -> Ptr b
castPtr = primUnsafeCoerce
plusPtr :: forall a b . Ptr a -> Int -> Ptr b
-plusPtr = primPtrAdd
+plusPtr p i = primIntToPtr (primPtrToInt p `primIntAdd` i)
minusPtr :: forall a b . Ptr a -> Ptr b -> Int
-minusPtr = primPtrSub
+minusPtr p q = primPtrToInt p `primIntSub` primPtrToInt q
---instance forall a . Show (FunPtr a) where
--- showsPrec _ p = showString "FUNPTR#" . showsPrec 0 (primPtrToWord p)
+-------
+instance forall a . Show (FunPtr a) where
+ showsPrec _ p = showString "0x" . showHex (primFunPtrToWord p)
+
+instance forall a . Eq (FunPtr a) where
+ p == q = primFunPtrToWord p == primFunPtrToWord q
+
+instance forall a . Ord (FunPtr a) where
+ p `compare` q = primFunPtrToWord p `compare` primFunPtrToWord q
+ p < q = primFunPtrToWord p < primFunPtrToWord q
+ p <= q = primFunPtrToWord p <= primFunPtrToWord q
+ p > q = primFunPtrToWord p > primFunPtrToWord q
+ p >= q = primFunPtrToWord p >= primFunPtrToWord q
+
+nullFunPtr :: forall a . FunPtr a
+nullFunPtr = primIntToFunPtr (0::Int)
+
+castFunPtr :: forall a b . FunPtr a -> FunPtr b
+castFunPtr = primUnsafeCoerce
+
+castFunPtrToPtr :: forall a b . FunPtr a -> Ptr b
+castFunPtrToPtr = primFunPtrToPtr
+
+castPtrToFunPtr :: forall a b . Ptr a -> FunPtr b
+castPtrToFunPtr = primPtrToFunPtr
+
+--------
+
+type IntPtr = Int
+type WordPtr = Word
--- a/lib/Primitives.hs
+++ b/lib/Primitives.hs
@@ -226,6 +226,18 @@
primPtrToInt :: forall a . Ptr a -> Int
primPtrToInt = primitive "toInt"
+primFunPtrToWord :: forall a . FunPtr a -> Word
+primFunPtrToWord = primitive "toInt"
+
+primIntToFunPtr :: forall a . Int -> FunPtr a
+primIntToFunPtr = primitive "toFunPtr"
+
+primFunPtrToPtr :: forall a b . FunPtr a -> Ptr b
+primFunPtrToPtr = primitive "toPtr"
+
+primPtrToFunPtr :: forall a b . Ptr a -> FunPtr b
+primPtrToFunPtr = primitive "toFunPtr"
+
-- Size in bits of Word/Int.
-- Will get constant folded on first use.
_wordSize :: Int
@@ -238,21 +250,6 @@
foreign import ccall "iswindows" c_iswindows :: IO Int
_isWindows :: Bool
_isWindows = primPerformIO c_iswindows `primIntEQ` 1
-
-primPtrEQ :: forall a b . Ptr a -> Ptr b -> Bool
-primPtrEQ = primitive "p=="
-
-primPtrNull :: forall a . Ptr a
-primPtrNull = primitive "pnull"
-
-primPtrCast :: forall a b . Ptr a -> Ptr b
-primPtrCast = primitive "pcast"
-
-primPtrAdd :: forall a b . Ptr a -> Int -> Ptr b
-primPtrAdd = primitive "p+"
-
-primPtrSub :: forall a b . Ptr a -> Ptr b -> Int
-primPtrSub = primitive "p-"
primArrAlloc :: forall a . Int -> a -> IO (IOArray a)
primArrAlloc = primitive "A.alloc"
--- a/src/MicroHs/Translate.hs
+++ b/src/MicroHs/Translate.hs
@@ -132,10 +132,7 @@
("toInt", primitive "toInt"), ("toPtr", primitive "toPtr"), ("toDbl", primitive "toDbl"),- ("p==", primitive "p=="),- ("pnull", primitive "pnull"),- ("p+", primitive "p+"),- ("p-", primitive "p-"),+ ("toFunPtr", primitive "toFunPtr"), ("A.alloc", primitive "A.alloc"), ("A.size", primitive "A.size"), ("A.read", primitive "A.read"),--- a/src/runtime/eval.c
+++ b/src/runtime/eval.c
@@ -169,9 +169,8 @@
T_ADD, T_SUB, T_MUL, T_QUOT, T_REM, T_SUBR, T_UQUOT, T_UREM, T_NEG,
T_AND, T_OR, T_XOR, T_INV, T_SHL, T_SHR, T_ASHR,
T_EQ, T_NE, T_LT, T_LE, T_GT, T_GE, T_ULT, T_ULE, T_UGT, T_UGE,
- T_PEQ, T_PNULL, T_PADD, T_PSUB,
T_FPADD, T_FP2P, T_FPNEW, T_FPFIN,
- T_TOPTR, T_TOINT, T_TODBL,
+ T_TOPTR, T_TOINT, T_TODBL, T_TOFUNPTR,
T_BININT2, T_BININT1, T_UNINT1,
T_BINDBL2, T_BINDBL1, T_UNDBL1,
#if WANT_FLOAT
@@ -201,9 +200,8 @@
"ADD", "SUB", "MUL", "QUOT", "REM", "SUBR", "UQUOT", "UREM", "NEG",
"AND", "OR", "XOR", "INV", "SHL", "SHR", "ASHR",
"EQ", "NE", "LT", "LE", "GT", "GE", "ULT", "ULE", "UGT", "UGE",
- "PEQ", "PNULL", "PADD", "PSUB",
"FPADD", "FP2P", "FPNEW", "FPFIN",
- "TOPTR", "TOINT", "TODBL",
+ "TOPTR", "TOINT", "TODBL", "TOFUNPTR",
"BININT2", "BININT1", "UNINT1",
"BINDBL2", "BINDBL1", "UNDBL1",
#if WANT_FLOAT
@@ -223,7 +221,6 @@
"FROMUTF8",
"STR",
"LAST_TAG",
- "?1", "?2", "?3", "?4", "?5", "?6", "?7",
};
#endif
@@ -654,10 +651,6 @@
{ "<=", T_LE, T_GE }, { ">", T_GT, T_LT }, { ">=", T_GE, T_LE },- { "p==", T_PEQ, T_PEQ },- { "pnull", T_PNULL },- { "p+", T_PADD },- { "p-", T_PSUB }, { "fp+", T_FPADD }, { "fp2p", T_FP2P }, { "fpnew", T_FPNEW },@@ -699,6 +692,7 @@
{ "toPtr", T_TOPTR }, { "toInt", T_TOINT }, { "toDbl", T_TODBL },+ { "toFunPtr", T_TOFUNPTR },};
#if GCRED
@@ -2001,10 +1995,6 @@
case T_ULE: putsb("u<=", f); break; case T_UGT: putsb("u>", f); break; case T_UGE: putsb("u>=", f); break;- case T_PEQ: putsb("p==", f); break;- case T_PNULL: putsb("pnull", f); break;- case T_PADD: putsb("p+", f); break;- case T_PSUB: putsb("p-", f); break; case T_FPADD: putsb("fp+", f); break; case T_FP2P: putsb("fp2p", f); break; case T_FPNEW: putsb("fpnew", f); break;@@ -2038,6 +2028,7 @@
case T_TOINT: putsb("toInt", f); break; case T_TOPTR: putsb("toPtr", f); break; case T_TODBL: putsb("toDbl", f); break;+ case T_TOFUNPTR: putsb("toFunPtr", f); break; case T_FROMUTF8: putsb("fromUTF8", f); break;case T_TICK:
putb('!', f);@@ -2552,7 +2543,6 @@
stackptr_t stk = stack_ptr;
NODEPTR x, y, z, w;
value_t xi, yi, r;
- void *xp, *yp;
struct forptr *xfp;
#if WANT_FLOAT
flt_t xd, rd;
@@ -2754,12 +2744,8 @@
case T_TODBL: CONV(T_DBL);
case T_TOINT: CONV(T_INT);
case T_TOPTR: CONV(T_PTR);
+ case T_TOFUNPTR: CONV(T_FUNPTR);
#undef CONV
-
- case T_PEQ: CMPP(==);
- case T_PNULL: SETTAG(n, T_PTR); PTR(n) = 0; RET;
- case T_PADD: CHECK(2); xp = evalptr(ARG(TOP(0))); yi = evalint(ARG(TOP(1))); POP(2); n = TOP(-1); SETPTR(n, (char*)xp + yi); RET;
- case T_PSUB: CHECK(2); xp = evalptr(ARG(TOP(0))); yp = evalptr(ARG(TOP(1))); POP(2); n = TOP(-1); SETINT(n, (char*)xp - (char*)yp); RET;
case T_FPADD: CHECK(2); xfp = evalforptr(ARG(TOP(0))); yi = evalint(ARG(TOP(1))); POP(2); n = TOP(-1); SETFORPTR(n, addForPtr(xfp, yi)); RET;
case T_FP2P: CHECK(1);
--
⑨