projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Refactor PackageTarget back into StaticTarget
[ghc-hetmet.git]
/
compiler
/
ghci
/
ByteCodeGen.lhs
diff --git
a/compiler/ghci/ByteCodeGen.lhs
b/compiler/ghci/ByteCodeGen.lhs
index
8a4b5e2
..
5d1bd27
100644
(file)
--- a/
compiler/ghci/ByteCodeGen.lhs
+++ b/
compiler/ghci/ByteCodeGen.lhs
@@
-438,7
+438,7
@@
schemeE d s p (AnnLet binds (_,body))
compile_bind d' fvs x rhs size arity off = do
bco <- schemeR fvs (x,rhs)
compile_bind d' fvs x rhs size arity off = do
bco <- schemeR fvs (x,rhs)
- build_thunk (fromIntegral d') fvs size bco off arity
+ build_thunk d' fvs size bco off arity
compile_binds =
[ compile_bind d' fvs x rhs size arity n
compile_binds =
[ compile_bind d' fvs x rhs size arity n
@@
-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)
@@
-1027,14
+1028,15
@@
generateCCall d0 s p (CCallSpec target cconv _) fn args_r_to_l
= case target of
DynamicTarget
-> return (False, panic "ByteCodeGen.generateCCall(dyn)")
= case target of
DynamicTarget
-> return (False, panic "ByteCodeGen.generateCCall(dyn)")
- StaticTarget target
+
+ StaticTarget target _
-> do res <- ioToBc (lookupStaticPtr stdcall_adj_target)
return (True, res)
where
stdcall_adj_target
#ifdef mingw32_TARGET_OS
| StdCallConv <- cconv
-> do res <- ioToBc (lookupStaticPtr stdcall_adj_target)
return (True, res)
where
stdcall_adj_target
#ifdef mingw32_TARGET_OS
| StdCallConv <- cconv
- = let size = a_reps_sizeW * wORD_SIZE in
+ = let size = fromIntegral a_reps_sizeW * wORD_SIZE in
mkFastString (unpackFS target ++ '@':show size)
#endif
| otherwise
mkFastString (unpackFS target ++ '@':show size)
#endif
| otherwise
@@
-1203,7
+1205,7
@@
pushAtom d p (AnnVar v)
= return (unitOL (PUSH_PRIMOP primop), 1)
| Just d_v <- lookupBCEnv_maybe p v -- v is a local variable
= return (unitOL (PUSH_PRIMOP primop), 1)
| Just d_v <- lookupBCEnv_maybe p v -- v is a local variable
- = let l = d - fromIntegral d_v + sz - 2
+ = let l = d - d_v + sz - 2
in return (toOL (genericReplicate sz (PUSH_L l)), sz)
-- d - d_v the number of words between the TOS
-- and the 1st slot of the object
in return (toOL (genericReplicate sz (PUSH_L l)), sz)
-- d - d_v the number of words between the TOS
-- and the 1st slot of the object
@@
-1334,6
+1336,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
+1362,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
+1370,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
+1381,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
+1403,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
+1411,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
@@
-1534,7
+1545,10
@@
recordItblMallocBc a
getLabelBc :: BcM Word16
getLabelBc
getLabelBc :: BcM Word16
getLabelBc
- = BcM $ \st -> return (st{nextlabel = 1 + nextlabel st}, nextlabel st)
+ = BcM $ \st -> do let nl = nextlabel st
+ when (nl == maxBound) $
+ panic "getLabelBc: Ran out of labels"
+ return (st{nextlabel = nl + 1}, nl)
getLabelsBc :: Word16 -> BcM [Word16]
getLabelsBc n
getLabelsBc :: Word16 -> BcM [Word16]
getLabelsBc n