Implement compare primitives for Int and Word.

lib/Data/Int/Instances.hs

@@ -34,7 +34,7 @@ bin8 op (I8 x) (I8 y) = i8 (x `op` y)
 bini8 :: (Int -> Int -> Int) -> (Int8 -> Int -> Int8)
 bini8 op (I8 x) y = i8 (x `op` y)
 
-cmp8 :: (Int -> Int -> Bool) -> (Int8 -> Int8 -> Bool)
+cmp8 :: (Int -> Int -> a) -> (Int8 -> Int8 -> a)
 cmp8 op (I8 x) (I8 y) = x `op` y
 
 una8 :: (Int -> Int) -> (Int8 -> Int8)
@@ -87,6 +87,7 @@ instance Eq Int8 where
   (/=) = cmp8 primIntNE
 
 instance Ord Int8 where
+  compare = cmp8 primIntCompare
   (<)  = cmp8 primIntLT
   (<=) = cmp8 primIntLE
   (>)  = cmp8 primIntGT
@@ -121,7 +122,7 @@ bin16 op (I16 x) (I16 y) = i16 (x `op` y)
 bini16 :: (Int -> Int -> Int) -> (Int16 -> Int -> Int16)
 bini16 op (I16 x) y = i16 (x `op` y)
 
-cmp16 :: (Int -> Int -> Bool) -> (Int16 -> Int16 -> Bool)
+cmp16 :: (Int -> Int -> a) -> (Int16 -> Int16 -> a)
 cmp16 op (I16 x) (I16 y) = x `op` y
 
 una16 :: (Int -> Int) -> (Int16 -> Int16)
@@ -174,6 +175,7 @@ instance Eq Int16 where
   (/=) = cmp16 primIntNE
 
 instance Ord Int16 where
+  compare = cmp16 primIntCompare
   (<)  = cmp16 primIntLT
   (<=) = cmp16 primIntLE
   (>)  = cmp16 primIntGT
@@ -208,7 +210,7 @@ bin32 op (I32 x) (I32 y) = i32 (x `op` y)
 bini32 :: (Int -> Int -> Int) -> (Int32 -> Int -> Int32)
 bini32 op (I32 x) y = i32 (x `op` y)
 
-cmp32 :: (Int -> Int -> Bool) -> (Int32 -> Int32 -> Bool)
+cmp32 :: (Int -> Int -> a) -> (Int32 -> Int32 -> a)
 cmp32 op (I32 x) (I32 y) = x `op` y
 
 una32 :: (Int -> Int) -> (Int32 -> Int32)
@@ -261,6 +263,7 @@ instance Eq Int32 where
   (/=) = cmp32 primIntNE
 
 instance Ord Int32 where
+  compare = cmp32 primIntCompare
   (<)  = cmp32 primIntLT
   (<=) = cmp32 primIntLE
   (>)  = cmp32 primIntGT
@@ -293,7 +296,7 @@ bin64 op (I64 x) (I64 y) = i64 (x `op` y)
 bini64 :: (Int -> Int -> Int) -> (Int64 -> Int -> Int64)
 bini64 op (I64 x) y = i64 (x `op` y)
 
-cmp64 :: (Int -> Int -> Bool) -> (Int64 -> Int64 -> Bool)
+cmp64 :: (Int -> Int -> a) -> (Int64 -> Int64 -> a)
 cmp64 op (I64 x) (I64 y) = x `op` y
 
 una64 :: (Int -> Int) -> (Int64 -> Int64)
@@ -346,6 +349,7 @@ instance Eq Int64 where
   (/=) = cmp64 primIntNE
 
 instance Ord Int64 where
+  compare = cmp64 primIntCompare
   (<)  = cmp64 primIntLT
   (<=) = cmp64 primIntLE
   (>)  = cmp64 primIntGT

lib/Data/Word.hs

@@ -74,6 +74,7 @@ instance Eq Word where
   (/=) = primWordNE
 
 instance Ord Word where
+  compare = primWordCompare
   (<)  = primWordLT
   (<=) = primWordLE
   (>)  = primWordGT
@@ -113,7 +114,7 @@ bin8 op (W8 x) (W8 y) = w8 (x `op` y)
 bini8 :: (Word -> Int -> Word) -> (Word8 -> Int -> Word8)
 bini8 op (W8 x) y = w8 (x `op` y)
 
-cmp8 :: (Word -> Word -> Bool) -> (Word8 -> Word8 -> Bool)
+cmp8 :: (Word -> Word -> a) -> (Word8 -> Word8 -> a)
 cmp8 op (W8 x) (W8 y) = x `op` y
 
 una8 :: (Word -> Word) -> (Word8 -> Word8)
@@ -166,6 +167,7 @@ instance Eq Word8 where
   (/=) = cmp8 primWordNE
 
 instance Ord Word8 where
+  compare = cmp8 primWordCompare
   (<)  = cmp8 primWordLT
   (<=) = cmp8 primWordLE
   (>)  = cmp8 primWordGT
@@ -202,7 +204,7 @@ bin16 op (W16 x) (W16 y) = w16 (x `op` y)
 bini16 :: (Word -> Int -> Word) -> (Word16 -> Int -> Word16)
 bini16 op (W16 x) y = w16 (x `op` y)
 
-cmp16 :: (Word -> Word -> Bool) -> (Word16 -> Word16 -> Bool)
+cmp16 :: (Word -> Word -> a) -> (Word16 -> Word16 -> a)
 cmp16 op (W16 x) (W16 y) = x `op` y
 
 una16 :: (Word -> Word) -> (Word16 -> Word16)
@@ -255,6 +257,7 @@ instance Eq Word16 where
   (/=) = cmp16 primWordNE
 
 instance Ord Word16 where
+  compare = cmp16 primWordCompare
   (<)  = cmp16 primWordLT
   (<=) = cmp16 primWordLE
   (>)  = cmp16 primWordGT
@@ -291,7 +294,7 @@ bin32 op (W32 x) (W32 y) = w32 (x `op` y)
 bini32 :: (Word -> Int -> Word) -> (Word32 -> Int -> Word32)
 bini32 op (W32 x) y = w32 (x `op` y)
 
-cmp32 :: (Word -> Word -> Bool) -> (Word32 -> Word32 -> Bool)
+cmp32 :: (Word -> Word -> a) -> (Word32 -> Word32 -> a)
 cmp32 op (W32 x) (W32 y) = x `op` y
 
 una32 :: (Word -> Word) -> (Word32 -> Word32)
@@ -344,6 +347,7 @@ instance Eq Word32 where
   (/=) = cmp32 primWordNE
 
 instance Ord Word32 where
+  compare = cmp32 primWordCompare
   (<)  = cmp32 primWordLT
   (<=) = cmp32 primWordLE
   (>)  = cmp32 primWordGT
@@ -380,7 +384,7 @@ bin64 op (W64 x) (W64 y) = w64 (x `op` y)
 bini64 :: (Word -> Int -> Word) -> (Word64 -> Int -> Word64)
 bini64 op (W64 x) y = w64 (x `op` y)
 
-cmp64 :: (Word -> Word -> Bool) -> (Word64 -> Word64 -> Bool)
+cmp64 :: (Word -> Word -> a) -> (Word64 -> Word64 -> a)
 cmp64 op (W64 x) (W64 y) = x `op` y
 
 una64 :: (Word -> Word) -> (Word64 -> Word64)
@@ -433,6 +437,7 @@ instance Eq Word64 where
   (/=) = cmp64 primWordNE
 
 instance Ord Word64 where
+  compare = cmp64 primWordCompare
   (<)  = cmp64 primWordLT
   (<=) = cmp64 primWordLE
   (>)  = cmp64 primWordGT

lib/Primitives.hs

@@ -185,6 +185,8 @@ primIntCompare :: forall a . Int -> Int -> Ordering
 primIntCompare  = primitive "icmp"
 primCharCompare :: forall a . Char -> Char -> Ordering
 primCharCompare  = primitive "icmp"
+primWordCompare :: forall a . Word -> Word -> Ordering
+primWordCompare  = primitive "ucmp"
 
 primStringEQ  :: [Char] -> [Char] -> Bool
 primStringEQ  = primitive "sequal"

src/runtime/eval.c

@@ -172,7 +172,7 @@ enum node_tag { T_FREE, T_IND, T_AP, T_INT, T_DBL, T_PTR, T_FUNPTR, T_FORPTR, T_
                 T_K2, T_K3, T_K4, T_CCB,
                 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_EQ, T_NE, T_LT, T_LE, T_GT, T_GE, T_ULT, T_ULE, T_UGT, T_UGE, T_ICMP, T_UCMP,
                 T_FPADD, T_FP2P, T_FPNEW, T_FPFIN,
                 T_TOPTR, T_TOINT, T_TODBL, T_TOFUNPTR,
                 T_BININT2, T_BININT1, T_UNINT1,
@@ -718,7 +718,8 @@ struct {
   { "sequal", T_EQUAL, T_EQUAL },
   { "compare", T_COMPARE },
   { "scmp", T_COMPARE },
-  { "icmp", T_COMPARE },
+  { "icmp", T_ICMP },
+  { "ucmp", T_UCMP },
   { "rnf", T_RNF },
   { "fromUTF8", T_BSFROMUTF8 },
   { "toUTF8", T_BSTOUTF8 },
@@ -2124,6 +2125,8 @@ printrec(BFILE *f, struct print_bits *pb, NODEPTR n, int prefix)
   case T_ULE: putsb("u<=", f); break;
   case T_UGT: putsb("u>", f); break;
   case T_UGE: putsb("u>=", f); break;
+  case T_ICMP: putsb("icmp", f); break;
+  case T_UCMP: putsb("ucmp", f); break;
   case T_FPADD: putsb("fp+", f); break;
   case T_FP2P: putsb("fp2p", f); break;
   case T_FPNEW: putsb("fpnew", f); break;
@@ -3020,10 +3023,12 @@ evali(NODEPTR an)
   case T_LE:
   case T_GT:
   case T_GE:
+  case T_ICMP:
   case T_ULT:
   case T_ULE:
   case T_UGT:
   case T_UGE:
+  case T_UCMP:
     CHECK(2);
     n = ARG(TOP(1));
     if (GETTAG(n) == T_INT) {
@@ -3371,10 +3376,12 @@ evali(NODEPTR an)
       case T_ULE:   GOIND(xu <= yu ? combTrue : combFalse);
       case T_UGT:   GOIND(xu >  yu ? combTrue : combFalse);
       case T_UGE:   GOIND(xu >= yu ? combTrue : combFalse);
+      case T_UCMP:  GOIND(xu <  yu ? combLT   : xu > yu ? combGT : combEQ);
       case T_LT:    GOIND((value_t)xu <  (value_t)yu ? combTrue : combFalse);
       case T_LE:    GOIND((value_t)xu <= (value_t)yu ? combTrue : combFalse);
       case T_GT:    GOIND((value_t)xu >  (value_t)yu ? combTrue : combFalse);
       case T_GE:    GOIND((value_t)xu >= (value_t)yu ? combTrue : combFalse);
+      case T_ICMP:  GOIND((value_t)xu <  (value_t)yu ? combLT   : (value_t)xu > (value_t)yu ? combGT : combEQ);
 
       default:
         //fprintf(stderr, "tag=%d\n", GETTAG(FUN(TOP(0))));