Commit 656e9d6b authored by Simon Marlow's avatar Simon Marlow

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

parent ba672345
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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 */
......
......@@ -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;
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment