implement case-on-Word in the byte code generator/interpreter (#2881)

diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs
index 030ef89..d5ffae1 100644 (file)
--- a/compiler/ghci/ByteCodeAsm.lhs
+++ b/compiler/ghci/ByteCodeAsm.lhs
@@ -288,6 +288,10 @@ mkBits findLabel st proto_insns
                                         instr2Large st2 bci_TESTLT_I np (findLabel l)
                TESTEQ_I  i l      -> do (np, st2) <- int st i
                                         instr2Large st2 bci_TESTEQ_I np (findLabel l)
                                         instr2Large st2 bci_TESTLT_I np (findLabel l)
                TESTEQ_I  i l      -> do (np, st2) <- int st i
                                         instr2Large st2 bci_TESTEQ_I np (findLabel l)

+               TESTLT_W  w l      -> do (np, st2) <- word st w
+                                        instr2Large st2 bci_TESTLT_W np (findLabel l)
+               TESTEQ_W  w l      -> do (np, st2) <- word st w
+                                        instr2Large st2 bci_TESTEQ_W np (findLabel l)

                TESTLT_F  f l      -> do (np, st2) <- float st f
                                         instr2Large st2 bci_TESTLT_F np (findLabel l)
                TESTEQ_F  f l      -> do (np, st2) <- float st f
                TESTLT_F  f l      -> do (np, st2) <- float st f
                                         instr2Large st2 bci_TESTLT_F np (findLabel l)
                TESTEQ_F  f l      -> do (np, st2) <- float st f

@@ -362,6 +366,11 @@ mkBits findLabel st proto_insns
                st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
                return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
 
                st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
                return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
 

+       word (st_i0,st_l0,st_p0) w
+          = do let ws = [w]
+               st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
+               return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
+

        int64 (st_i0,st_l0,st_p0) i
           = do let ws = mkLitI64 i
                st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
        int64 (st_i0,st_l0,st_p0) i
           = do let ws = mkLitI64 i
                st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)

@@ -455,6 +464,8 @@ instrSize16s instr
         LABEL{}                 -> 0    -- !!
         TESTLT_I{}              -> 3
         TESTEQ_I{}              -> 3
         LABEL{}                 -> 0    -- !!
         TESTLT_I{}              -> 3
         TESTEQ_I{}              -> 3

+        TESTLT_W{}              -> 3
+        TESTEQ_W{}              -> 3

         TESTLT_F{}              -> 3
         TESTEQ_F{}              -> 3
         TESTLT_D{}              -> 3
         TESTLT_F{}              -> 3
         TESTEQ_F{}              -> 3
         TESTLT_D{}              -> 3

diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index 947382e..ad94e0c 100644 (file)
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -844,6 +844,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
            = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))
         my_discr (LitAlt l, _, _)
            = case l of MachInt i     -> DiscrI (fromInteger i)
            = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))
         my_discr (LitAlt l, _, _)
            = case l of MachInt i     -> DiscrI (fromInteger i)

+                       MachWord w    -> DiscrW (fromInteger w)

                        MachFloat r   -> DiscrF (fromRational r)
                        MachDouble r  -> DiscrD (fromRational r)
                        MachChar i    -> DiscrI (ord i)
                        MachFloat r   -> DiscrF (fromRational r)
                        MachDouble r  -> DiscrD (fromRational r)
                        MachChar i    -> DiscrI (ord i)

@@ -1334,6 +1335,10 @@ mkMultiBranch maybe_ncons raw_ways
                             \(DiscrI i) fail_label -> TESTEQ_I i fail_label,
                             DiscrI minBound,
                             DiscrI maxBound );
                             \(DiscrI i) fail_label -> TESTEQ_I i fail_label,
                             DiscrI minBound,
                             DiscrI maxBound );

+              DiscrW _ -> ( \(DiscrW i) fail_label -> TESTLT_W i fail_label,
+                            \(DiscrW i) fail_label -> TESTEQ_W i fail_label,
+                            DiscrW minBound,
+                            DiscrW maxBound );

               DiscrF _ -> ( \(DiscrF f) fail_label -> TESTLT_F f fail_label,
                             \(DiscrF f) fail_label -> TESTEQ_F f fail_label,
                             DiscrF minF,
               DiscrF _ -> ( \(DiscrF f) fail_label -> TESTLT_F f fail_label,
                             \(DiscrF f) fail_label -> TESTEQ_F f fail_label,
                             DiscrF minF,

@@ -1356,6 +1361,7 @@ mkMultiBranch maybe_ncons raw_ways
                  Nothing -> (minBound, maxBound)
 
          (DiscrI i1) `eqAlt` (DiscrI i2) = i1 == i2
                  Nothing -> (minBound, maxBound)
 
          (DiscrI i1) `eqAlt` (DiscrI i2) = i1 == i2

+         (DiscrW w1) `eqAlt` (DiscrW w2) = w1 == w2

          (DiscrF f1) `eqAlt` (DiscrF f2) = f1 == f2
          (DiscrD d1) `eqAlt` (DiscrD d2) = d1 == d2
          (DiscrP i1) `eqAlt` (DiscrP i2) = i1 == i2
          (DiscrF f1) `eqAlt` (DiscrF f2) = f1 == f2
          (DiscrD d1) `eqAlt` (DiscrD d2) = d1 == d2
          (DiscrP i1) `eqAlt` (DiscrP i2) = i1 == i2

@@ -1363,6 +1369,7 @@ mkMultiBranch maybe_ncons raw_ways
          _           `eqAlt` _           = False
 
          (DiscrI i1) `leAlt` (DiscrI i2) = i1 <= i2
          _           `eqAlt` _           = False
 
          (DiscrI i1) `leAlt` (DiscrI i2) = i1 <= i2

+         (DiscrW w1) `leAlt` (DiscrW w2) = w1 <= w2

          (DiscrF f1) `leAlt` (DiscrF f2) = f1 <= f2
          (DiscrD d1) `leAlt` (DiscrD d2) = d1 <= d2
          (DiscrP i1) `leAlt` (DiscrP i2) = i1 <= i2
          (DiscrF f1) `leAlt` (DiscrF f2) = f1 <= f2
          (DiscrD d1) `leAlt` (DiscrD d2) = d1 <= d2
          (DiscrP i1) `leAlt` (DiscrP i2) = i1 <= i2

@@ -1373,6 +1380,7 @@ mkMultiBranch maybe_ncons raw_ways
          isNoDiscr _       = False
 
          dec (DiscrI i) = DiscrI (i-1)
          isNoDiscr _       = False
 
          dec (DiscrI i) = DiscrI (i-1)

+         dec (DiscrW w) = DiscrW (w-1)

          dec (DiscrP i) = DiscrP (i-1)
          dec other      = other                -- not really right, but if you
                -- do cases on floating values, you'll get what you deserve
          dec (DiscrP i) = DiscrP (i-1)
          dec other      = other                -- not really right, but if you
                -- do cases on floating values, you'll get what you deserve

@@ -1394,6 +1402,7 @@ mkMultiBranch maybe_ncons raw_ways
 -- Describes case alts
 data Discr 
    = DiscrI Int
 -- Describes case alts
 data Discr 
    = DiscrI Int

+   | DiscrW Word

    | DiscrF Float
    | DiscrD Double
    | DiscrP Word16
    | DiscrF Float
    | DiscrD Double
    | DiscrP Word16

@@ -1401,6 +1410,7 @@ data Discr
 
 instance Outputable Discr where
    ppr (DiscrI i) = int i
 
 instance Outputable Discr where
    ppr (DiscrI i) = int i

+   ppr (DiscrW w) = text (show w)

    ppr (DiscrF f) = text (show f)
    ppr (DiscrD d) = text (show d)
    ppr (DiscrP i) = ppr i
    ppr (DiscrF f) = text (show f)
    ppr (DiscrD d) = text (show d)
    ppr (DiscrP i) = ppr i

diff --git a/compiler/ghci/ByteCodeInstr.lhs b/compiler/ghci/ByteCodeInstr.lhs
index 2082826..b83006b 100644 (file)
--- a/compiler/ghci/ByteCodeInstr.lhs
+++ b/compiler/ghci/ByteCodeInstr.lhs
@@ -108,6 +108,8 @@ data BCInstr
    | LABEL     LocalLabel
    | TESTLT_I  Int    LocalLabel
    | TESTEQ_I  Int    LocalLabel
    | LABEL     LocalLabel
    | TESTLT_I  Int    LocalLabel
    | TESTEQ_I  Int    LocalLabel

+   | TESTLT_W  Word   LocalLabel
+   | TESTEQ_W  Word   LocalLabel

    | TESTLT_F  Float  LocalLabel
    | TESTEQ_F  Float  LocalLabel
    | TESTLT_D  Double LocalLabel
    | TESTLT_F  Float  LocalLabel
    | TESTEQ_F  Float  LocalLabel
    | TESTLT_D  Double LocalLabel

@@ -205,6 +207,8 @@ instance Outputable BCInstr where
    ppr (LABEL     lab)       = text "__"       <> ppr lab <> colon
    ppr (TESTLT_I  i lab)     = text "TESTLT_I" <+> int i <+> text "__" <> ppr lab
    ppr (TESTEQ_I  i lab)     = text "TESTEQ_I" <+> int i <+> text "__" <> ppr lab
    ppr (LABEL     lab)       = text "__"       <> ppr lab <> colon
    ppr (TESTLT_I  i lab)     = text "TESTLT_I" <+> int i <+> text "__" <> ppr lab
    ppr (TESTEQ_I  i lab)     = text "TESTEQ_I" <+> int i <+> text "__" <> ppr lab

+   ppr (TESTLT_W  i lab)     = text "TESTLT_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab
+   ppr (TESTEQ_W  i lab)     = text "TESTEQ_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab

    ppr (TESTLT_F  f lab)     = text "TESTLT_F" <+> float f <+> text "__" <> ppr lab
    ppr (TESTEQ_F  f lab)     = text "TESTEQ_F" <+> float f <+> text "__" <> ppr lab
    ppr (TESTLT_D  d lab)     = text "TESTLT_D" <+> double d <+> text "__" <> ppr lab
    ppr (TESTLT_F  f lab)     = text "TESTLT_F" <+> float f <+> text "__" <> ppr lab
    ppr (TESTEQ_F  f lab)     = text "TESTEQ_F" <+> float f <+> text "__" <> ppr lab
    ppr (TESTLT_D  d lab)     = text "TESTLT_D" <+> double d <+> text "__" <> ppr lab

@@ -265,6 +269,8 @@ bciStackUse (UNPACK sz)           = fromIntegral sz
 bciStackUse LABEL{}              = 0
 bciStackUse TESTLT_I{}           = 0
 bciStackUse TESTEQ_I{}           = 0
 bciStackUse LABEL{}              = 0
 bciStackUse TESTLT_I{}           = 0
 bciStackUse TESTEQ_I{}           = 0

+bciStackUse TESTLT_W{}           = 0
+bciStackUse TESTEQ_W{}           = 0

 bciStackUse TESTLT_F{}           = 0
 bciStackUse TESTEQ_F{}           = 0
 bciStackUse TESTLT_D{}           = 0
 bciStackUse TESTLT_F{}           = 0
 bciStackUse TESTEQ_F{}           = 0
 bciStackUse TESTLT_D{}           = 0

diff --git a/includes/rts/Bytecodes.h b/includes/rts/Bytecodes.h
index 8764b18..5e1fc28 100644 (file)
--- a/includes/rts/Bytecodes.h
+++ b/includes/rts/Bytecodes.h
@@ -77,6 +77,8 @@
 #define bci_RETURN_L                   52
 #define bci_RETURN_V                   53
 #define bci_BRK_FUN                    54
 #define bci_RETURN_L                   52
 #define bci_RETURN_V                   53
 #define bci_BRK_FUN                    54

+#define bci_TESTLT_W                           55
+#define bci_TESTEQ_W                   56

 /* If you need to go past 255 then you will run into the flags */
 
 /* If you need to go below 0x0100 then you will run into the instructions */
 /* If you need to go past 255 then you will run into the flags */
 
 /* If you need to go below 0x0100 then you will run into the instructions */

diff --git a/rts/Interpreter.c b/rts/Interpreter.c
index 9c494c1..ea2064f 100644 (file)
--- a/rts/Interpreter.c
+++ b/rts/Interpreter.c
@@ -1227,6 +1227,27 @@ run_BCO:
            goto nextInsn;
        }
 
            goto nextInsn;
        }
 

+       case bci_TESTLT_W: {
+           // There should be an Int at Sp[1], and an info table at Sp[0].
+           int discr   = BCO_NEXT;
+           int failto  = BCO_GET_LARGE_ARG;
+           W_ stackWord = (W_)Sp[1];
+           if (stackWord >= (W_)BCO_LIT(discr))
+               bciPtr = failto;
+           goto nextInsn;
+       }
+
+       case bci_TESTEQ_W: {
+           // There should be an Int at Sp[1], and an info table at Sp[0].
+           int discr   = BCO_NEXT;
+           int failto  = BCO_GET_LARGE_ARG;
+           W_ stackWord = (W_)Sp[1];
+           if (stackWord != (W_)BCO_LIT(discr)) {
+               bciPtr = failto;
+           }
+           goto nextInsn;
+       }
+

        case bci_TESTLT_D: {
            // There should be a Double at Sp[1], and an info table at Sp[0].
            int discr   = BCO_NEXT;
        case bci_TESTLT_D: {
            // There should be a Double at Sp[1], and an info table at Sp[0].
            int discr   = BCO_NEXT;