From 656e9d6b1db053c88ba1518b6095060347e09418 Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Fri, 18 Sep 2009 13:32:04 +0000 Subject: [PATCH] implement case-on-Word in the byte code generator/interpreter (#2881) --- compiler/ghci/ByteCodeAsm.lhs | 11 +++++++++++ compiler/ghci/ByteCodeGen.lhs | 10 ++++++++++ compiler/ghci/ByteCodeInstr.lhs | 6 ++++++ includes/rts/Bytecodes.h | 2 ++ rts/Interpreter.c | 21 +++++++++++++++++++++ 5 files changed, 50 insertions(+) diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs index 030ef89..d5ffae1 100644 --- 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) + 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 @@ -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)) + 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) @@ -455,6 +464,8 @@ instrSize16s instr LABEL{} -> 0 -- !! TESTLT_I{} -> 3 TESTEQ_I{} -> 3 + TESTLT_W{} -> 3 + TESTEQ_W{} -> 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 --- 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) + MachWord w -> DiscrW (fromInteger w) 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 ); + 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, @@ -1356,6 +1361,7 @@ mkMultiBranch maybe_ncons raw_ways 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 @@ -1363,6 +1369,7 @@ mkMultiBranch maybe_ncons raw_ways _ `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 @@ -1373,6 +1380,7 @@ mkMultiBranch maybe_ncons raw_ways 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 @@ -1394,6 +1402,7 @@ mkMultiBranch maybe_ncons raw_ways -- Describes case alts data Discr = DiscrI Int + | DiscrW Word | DiscrF Float | DiscrD Double | DiscrP Word16 @@ -1401,6 +1410,7 @@ data Discr 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 diff --git a/compiler/ghci/ByteCodeInstr.lhs b/compiler/ghci/ByteCodeInstr.lhs index 2082826..b83006b 100644 --- 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 + | TESTLT_W Word LocalLabel + | TESTEQ_W Word 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 (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 @@ -265,6 +269,8 @@ bciStackUse (UNPACK sz) = fromIntegral sz 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 diff --git a/includes/rts/Bytecodes.h b/includes/rts/Bytecodes.h index 8764b18..5e1fc28 100644 --- 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_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 */ diff --git a/rts/Interpreter.c b/rts/Interpreter.c index 9c494c1..ea2064f 100644 --- a/rts/Interpreter.c +++ b/rts/Interpreter.c @@ -1227,6 +1227,27 @@ run_BCO: 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; -- 1.7.10.4