import Name
import MkId
import Id
-import FiniteMap
import ForeignCall
import HscTypes
import CoreUtils
import Module
import IdInfo
+import Data.Map (Map)
+import qualified Data.Map as Map
+import qualified FiniteMap as Map
+
-- -----------------------------------------------------------------------------
-- Generating byte code for a complete module
-- Maps Ids to the offset from the stack _base_ so we don't have
-- to mess with it after each push/pop.
-type BCEnv = FiniteMap Id Word16 -- To find vars on the stack
+type BCEnv = Map Id Word16 -- To find vars on the stack
{-
ppBCEnv :: BCEnv -> SDoc
ppBCEnv p
= text "begin-env"
- $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (fmToList p))))
+ $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (Map.toList p))))
$$ text "end-env"
where
pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (idCgRep var)
{-
| trace (showSDoc (
(char ' '
- $$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs
+ $$ (ppr.filter (not.isTyCoVar).varSetElems.fst) rhs
$$ pprCoreExpr (deAnnotate rhs)
$$ char ' '
))) False
szsw_args = map (fromIntegral . idSizeW) all_args
szw_args = sum szsw_args
- p_init = listToFM (zip all_args (mkStackOffsets 0 szsw_args))
+ p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsw_args))
-- make the arg bitmap
bits = argBits (reverse (map idCgRep all_args))
getOffSet :: Word16 -> BCEnv -> Id -> Maybe (Id, Word16)
getOffSet d env id
- = case lookupBCEnv_maybe env id of
+ = case lookupBCEnv_maybe id env of
Nothing -> Nothing
Just offset -> Just (id, d - offset)
-- it, have to agree about this layout
fvsToEnv p fvs = [v | v <- varSetElems fvs,
isId v, -- Could be a type variable
- v `elemFM` p]
+ v `Map.member` p]
-- -----------------------------------------------------------------------------
-- schemeE
-- saturatred constructor application.
-- Just allocate the constructor and carry on
alloc_code <- mkConAppCode d s p data_con args_r_to_l
- body_code <- schemeE (d+1) s (addToFM p x d) body
+ body_code <- schemeE (d+1) s (Map.insert x d p) body
return (alloc_code `appOL` body_code)
-- General case for let. Generates correct, if inefficient, code in
-- are ptrs, so all have size 1. d' and p' reflect the stack
-- after the closures have been allocated in the heap (but not
-- filled in), and pointers to them parked on the stack.
- p' = addListToFM p (zipE xs (mkStackOffsets d (genericReplicate n_binds 1)))
+ p' = Map.insertList (zipE xs (mkStackOffsets d (genericReplicate n_binds 1))) p
d' = d + n_binds
zipE = zipEqual "schemeE"
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
-- Env in which to compile the alts, not including
-- any vars bound by the alts themselves
- p_alts = addToFM p bndr (d_bndr - 1)
+ p_alts = Map.insert bndr (d_bndr - 1) p
bndr_ty = idType bndr
isAlgCase = not (isUnLiftedType bndr_ty) && not is_unboxed_tuple
bind_sizes = ptr_sizes ++ nptrs_sizes
size = sum ptr_sizes + sum nptrs_sizes
-- the UNPACK instruction unpacks in reverse order...
- p' = addListToFM p_alts
+ p' = Map.insertList
(zip (reverse (ptrs ++ nptrs))
(mkStackOffsets d_alts (reverse bind_sizes)))
+ p_alts
in do
MASSERT(isAlgCase)
rhs_code <- schemeE (d_alts+size) s p' rhs
return (my_discr alt, unitOL (UNPACK size) `appOL` rhs_code)
where
- real_bndrs = filter (not.isTyVar) bndrs
+ real_bndrs = filter (not.isTyCoVar) bndrs
my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}
my_discr (DataAlt dc, _, _)
= 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)
bitmap = intsToReverseBitmap bitmap_size'{-size-}
(sortLe (<=) (filter (< bitmap_size') rel_slots))
where
- binds = fmToList p
+ binds = Map.toList p
rel_slots = map fromIntegral $ concat (map spread binds)
spread (id, offset)
| isFollowableArg (idCgRep id) = [ rel_offset ]
= 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
- = let size = a_reps_sizeW * wORD_SIZE in
+ = let size = fromIntegral a_reps_sizeW * wORD_SIZE in
mkFastString (unpackFS target ++ '@':show size)
#endif
| otherwise
-- if it was, it would be impossible
-- to create a valid return value
-- placeholder on the stack
+
+ blargh :: a -- Used at more than one type
blargh = pprPanic "maybe_getCCallReturn: can't handle:"
(pprType fn_ty)
in
| Just primop <- isPrimOpId_maybe v
= 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
+ | Just d_v <- lookupBCEnv_maybe v p -- v is a local variable
+ = 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
\(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,
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
_ `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
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
-- Describes case alts
data Discr
= DiscrI Int
+ | DiscrW Word
| DiscrF Float
| DiscrD Double
| DiscrP Word16
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 NoDiscr = text "DEF"
-lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Word16
-lookupBCEnv_maybe = lookupFM
+lookupBCEnv_maybe :: Id -> BCEnv -> Maybe Word16
+lookupBCEnv_maybe = Map.lookup
idSizeW :: Id -> Int
idSizeW id = cgRepSizeW (typeCgRep (idType id))
-- whereas value lambdas cannot; that is why they are nuked here
bcView (AnnNote _ (_,e)) = Just e
bcView (AnnCast (_,e) _) = Just e
-bcView (AnnLam v (_,e)) | isTyVar v = Just e
+bcView (AnnLam v (_,e)) | isTyCoVar v = Just e
bcView (AnnApp (_,e) (_, AnnType _)) = Just e
bcView _ = Nothing
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