Commit e4de18df authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Merge branch 'master' of darcs.haskell.org:/srv/darcs//ghc

parents 226b9822 739a009b
......@@ -989,7 +989,7 @@ buildPromotedTyCon tc
buildPromotedDataCon :: DataCon -> TyCon
buildPromotedDataCon dc
= ASSERT ( isPromotableType ty )
mkPromotedDataTyCon dc (getName dc) (getUnique dc) kind arity
mkPromotedDataCon dc (getName dc) (getUnique dc) kind arity
where
ty = dataConUserType dc
kind = promoteType ty
......
......@@ -24,17 +24,47 @@ module NameEnv (
foldNameEnv, filterNameEnv,
plusNameEnv, plusNameEnv_C, alterNameEnv,
lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv,
elemNameEnv, mapNameEnv
elemNameEnv, mapNameEnv,
-- ** Dependency analysis
depAnal
) where
#include "HsVersions.h"
import Digraph
import Name
import Unique
import UniqFM
import Maybes
\end{code}
%************************************************************************
%* *
\subsection{Name environment}
%* *
%************************************************************************
\begin{code}
depAnal :: (node -> [Name]) -- Defs
-> (node -> [Name]) -- Uses
-> [node]
-> [SCC node]
-- Peform dependency analysis on a group of definitions,
-- where each definition may define more than one Name
--
-- The get_defs and get_uses functions are called only once per node
depAnal get_defs get_uses nodes
= stronglyConnCompFromEdgedVertices (map mk_node keyed_nodes)
where
keyed_nodes = nodes `zip` [(1::Int)..]
mk_node (node, key) = (node, key, mapCatMaybes (lookupNameEnv key_map) (get_uses node))
key_map :: NameEnv Int -- Maps a Name to the key of the decl that defines it
key_map = mkNameEnv [(name,key) | (node, key) <- keyed_nodes, name <- get_defs node]
\end{code}
%************************************************************************
%* *
\subsection{Name environment}
......
......@@ -78,7 +78,7 @@ module SrcLoc (
-- ** Combining and comparing Located values
eqLocated, cmpLocated, combineLocs, addCLoc,
leftmost_smallest, leftmost_largest, rightmost,
spans, isSubspanOf
spans, isSubspanOf, sortLocated
) where
#include "Typeable.h"
......@@ -181,6 +181,11 @@ instance Ord SrcLoc where
instance Ord RealSrcLoc where
compare = cmpRealSrcLoc
sortLocated :: [Located a] -> [Located a]
sortLocated things = sortLe le things
where
le (L l1 _) (L l2 _) = l1 <= l2
cmpSrcLoc :: SrcLoc -> SrcLoc -> Ordering
cmpSrcLoc (UnhelpfulLoc s1) (UnhelpfulLoc s2) = s1 `compare` s2
cmpSrcLoc (UnhelpfulLoc _) (RealSrcLoc _) = GT
......
......@@ -271,7 +271,7 @@ lintCoreExpr (Cast expr co)
= do { expr_ty <- lintCoreExpr expr
; co' <- applySubstCo co
; (_, from_ty, to_ty) <- lintCoercion co'
; checkTys from_ty expr_ty (mkCastErr from_ty expr_ty)
; checkTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty)
; return to_ty }
lintCoreExpr (Tick (Breakpoint _ ids) expr)
......@@ -1270,12 +1270,14 @@ mkUnboxedTupleMsg binder
= vcat [hsep [ptext (sLit "A variable has unboxed tuple type:"), ppr binder],
hsep [ptext (sLit "Binder's type:"), ppr (idType binder)]]
mkCastErr :: Type -> Type -> MsgDoc
mkCastErr from_ty expr_ty
mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc
mkCastErr expr co from_ty expr_ty
= vcat [ptext (sLit "From-type of Cast differs from type of enclosed expression"),
ptext (sLit "From-type:") <+> ppr from_ty,
ptext (sLit "Type of enclosed expr:") <+> ppr expr_ty
]
ptext (sLit "Type of enclosed expr:") <+> ppr expr_ty,
ptext (sLit "Actual enclosed expr:") <+> ppr expr,
ptext (sLit "Coercion used in cast:") <+> ppr co
]
dupVars :: [[Var]] -> MsgDoc
dupVars vars
......
......@@ -14,7 +14,7 @@
{-# LANGUAGE TypeFamilies #-}
module TrieMap(
CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap,
TypeMap, foldTypeMap,
TypeMap, foldTypeMap, lookupTypeMap_mod,
CoercionMap,
MaybeMap,
ListMap,
......@@ -32,6 +32,8 @@ import UniqFM
import Unique( Unique )
import FastString(FastString)
import Unify ( niFixTvSubst )
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import VarEnv
......@@ -527,6 +529,41 @@ lkT env ty m
go (LitTy l) = tm_tylit >.> lkTyLit l
go (ForAllTy tv ty) = tm_forall >.> lkT (extendCME env tv) ty >=> lkBndr env tv
lkT_mod :: CmEnv
-> TyVarEnv Type -- TvSubstEnv
-> Type
-> TypeMap b -> Maybe b
lkT_mod env s ty m
| EmptyTM <- m = Nothing
| Just ty' <- coreView ty
= lkT_mod env s ty' m
| [] <- candidates
= go env s ty m
| otherwise
= Just $ snd (head candidates) -- Yikes!
where
-- Hopefully intersects is much smaller than traversing the whole vm_fvar
intersects = eltsUFM $
intersectUFM_C (,) s (vm_fvar $ tm_var m)
candidates = [ (u,ct) | (u,ct) <- intersects
, Type.substTy (niFixTvSubst s) u `eqType` ty ]
go env _s (TyVarTy v) = tm_var >.> lkVar env v
go env s (AppTy t1 t2) = tm_app >.> lkT_mod env s t1 >=> lkT_mod env s t2
go env s (FunTy t1 t2) = tm_fun >.> lkT_mod env s t1 >=> lkT_mod env s t2
go env s (TyConApp tc tys) = tm_tc_app >.> lkNamed tc >=> lkList (lkT_mod env s) tys
go _env _s (LitTy l) = tm_tylit >.> lkTyLit l
go _env _s (ForAllTy _tv _ty) = const Nothing
{- DV TODO: Add proper lookup for ForAll -}
lookupTypeMap_mod :: TyVarEnv a -- A substitution to be applied to the /keys/ of type map
-> (a -> Type)
-> Type
-> TypeMap b -> Maybe b
lookupTypeMap_mod s f = lkT_mod emptyCME (mapVarEnv f s)
-----------------
xtT :: CmEnv -> Type -> XT a -> TypeMap a -> TypeMap a
xtT env ty f m
......
......@@ -20,6 +20,7 @@ import StaticFlags
import HscTypes
import HsSyn
import TcRnTypes
import TcRnMonad ( finalSafeMode )
import MkIface
import Id
import Name
......@@ -169,6 +170,7 @@ deSugar hsc_env
; used_th <- readIORef tc_splice_used
; dep_files <- readIORef dependent_files
; safe_mode <- finalSafeMode dflags tcg_env
; let mod_guts = ModGuts {
mg_module = mod,
......@@ -194,6 +196,7 @@ deSugar hsc_env
mg_modBreaks = modBreaks,
mg_vect_decls = ds_vects,
mg_vect_info = noVectInfo,
mg_safe_haskell = safe_mode,
mg_trust_pkg = imp_trust_own_pkg imports,
mg_dependent_files = dep_files
}
......
......@@ -323,11 +323,12 @@ repFamilyFlavour DataFamily = rep2 dataFamName []
-- Represent instance declarations
--
repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repInstD (L loc (FamInstD fi_decl))
repInstD (L loc (FamInstD { lid_inst = fi_decl }))
= do { dec <- repFamInstD fi_decl
; return (loc, dec) }
repInstD (L loc (ClsInstD ty binds prags ats))
repInstD (L loc (ClsInstD { cid_poly_ty = ty, cid_binds = binds
, cid_sigs = prags, cid_fam_insts = ats }))
= do { dec <- addTyVarBinds tvs $ \_ ->
-- We must bring the type variables into scope, so their
-- occurrences don't fail, even though the binders don't
......@@ -352,8 +353,12 @@ repInstD (L loc (ClsInstD ty binds prags ats))
Just (tvs, cxt, cls, tys) = splitHsInstDeclTy_maybe (unLoc ty)
repFamInstD :: FamInstDecl Name -> DsM (Core TH.DecQ)
repFamInstD (FamInstDecl { fid_tycon = tc_name, fid_pats = HsBSig tys tv_names, fid_defn = defn })
= do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
repFamInstD (FamInstDecl { fid_tycon = tc_name
, fid_pats = HsBSig tys (kv_names, tv_names)
, fid_defn = defn })
= WARN( not (null kv_names), ppr kv_names ) -- We have not yet dealt with kind
-- polymorphism in Template Haskell (sigh)
do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
; let loc = getLoc tc_name
hs_tvs = [ L loc (UserTyVar n) | n <- tv_names] -- Yuk
; addTyClTyVarBinds hs_tvs $ \ bndrs ->
......
......@@ -80,7 +80,7 @@ Library
Extensions: CPP, MagicHash, UnboxedTuples, PatternGuards,
ForeignFunctionInterface, EmptyDataDecls,
TypeSynonymInstances, MultiParamTypeClasses,
FlexibleInstances, Rank2Types, ScopedTypeVariables,
FlexibleInstances, RankNTypes, ScopedTypeVariables,
DeriveDataTypeable, BangPatterns
if impl(ghc >= 7.1)
Extensions: NondecreasingIndentation
......
This diff is collapsed.
......@@ -131,11 +131,11 @@ coreExprToBCOs dflags this_mod expr
type BCInstrList = OrdList BCInstr
type Sequel = Word16 -- back off to this depth before ENTER
type Sequel = Word -- back off to this depth before ENTER
-- Maps Ids to the offset from the stack _base_ so we don't have
-- to mess with it after each push/pop.
type BCEnv = Map Id Word16 -- To find vars on the stack
type BCEnv = Map Id Word -- To find vars on the stack
{-
ppBCEnv :: BCEnv -> SDoc
......@@ -298,10 +298,10 @@ schemeR_wrk fvs nm original_body (args, body)
arity bitmap_size bitmap False{-not alts-})
-- introduce break instructions for ticked expressions
schemeER_wrk :: Word16 -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
schemeER_wrk :: Word -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
schemeER_wrk d p rhs
| AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs
= do code <- schemeE d 0 p newRhs
= do code <- schemeE (fromIntegral d) 0 p newRhs
arr <- getBreakArray
this_mod <- getCurrentModule
let idOffSets = getVarOffSets d p fvs
......@@ -315,16 +315,23 @@ schemeER_wrk d p rhs
BA arr# ->
BRK_FUN arr# (fromIntegral tick_no) breakInfo
return $ breakInstr `consOL` code
| otherwise = schemeE d 0 p rhs
| otherwise = schemeE (fromIntegral d) 0 p rhs
getVarOffSets :: Word16 -> BCEnv -> [Id] -> [(Id, Word16)]
getVarOffSets :: Word -> BCEnv -> [Id] -> [(Id, Word16)]
getVarOffSets d p = catMaybes . map (getOffSet d p)
getOffSet :: Word16 -> BCEnv -> Id -> Maybe (Id, Word16)
getOffSet :: Word -> BCEnv -> Id -> Maybe (Id, Word16)
getOffSet d env id
= case lookupBCEnv_maybe id env of
Nothing -> Nothing
Just offset -> Just (id, d - offset)
Just offset -> Just (id, trunc16 $ d - offset)
trunc16 :: Word -> Word16
trunc16 w
| w > fromIntegral (maxBound :: Word16)
= panic "stack depth overflow"
| otherwise
= fromIntegral w
fvsToEnv :: BCEnv -> VarSet -> [Id]
-- Takes the free variables of a right-hand side, and
......@@ -342,7 +349,7 @@ fvsToEnv p fvs = [v | v <- varSetElems fvs,
-- -----------------------------------------------------------------------------
-- schemeE
returnUnboxedAtom :: Word16 -> Sequel -> BCEnv
returnUnboxedAtom :: Word -> Sequel -> BCEnv
-> AnnExpr' Id VarSet -> CgRep
-> BcM BCInstrList
-- Returning an unlifted value.
......@@ -355,7 +362,7 @@ returnUnboxedAtom d s p e e_rep
-- Compile code to apply the given expression to the remaining args
-- on the stack, returning a HNF.
schemeE :: Word16 -> Sequel -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
schemeE :: Word -> Sequel -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
schemeE d s p e
| Just e' <- bcView e
......@@ -404,7 +411,7 @@ schemeE d s p (AnnLet binds (_,body))
-- after the closures have been allocated in the heap (but not
-- filled in), and pointers to them parked on the stack.
p' = Map.insertList (zipE xs (mkStackOffsets d (genericReplicate n_binds 1))) p
d' = d + n_binds
d' = d + fromIntegral n_binds
zipE = zipEqual "schemeE"
-- ToDo: don't build thunks for things with no free variables
......@@ -415,7 +422,7 @@ schemeE d s p (AnnLet binds (_,body))
| otherwise = MKPAP
build_thunk dd (fv:fvs) size bco off arity = do
(push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv)
more_push_code <- build_thunk (dd+pushed_szw) fvs size bco off arity
more_push_code <- build_thunk (dd + fromIntegral pushed_szw) fvs size bco off arity
return (push_code `appOL` more_push_code)
alloc_code = toOL (zipWith mkAlloc sizes arities)
......@@ -542,7 +549,7 @@ schemeE _ _ _ expr
-- 4. Otherwise, it must be a function call. Push the args
-- right to left, SLIDE and ENTER.
schemeT :: Word16 -- Stack depth
schemeT :: Word -- Stack depth
-> Sequel -- Sequel depth
-> BCEnv -- stack env
-> AnnExpr' Id VarSet
......@@ -561,7 +568,7 @@ schemeT d s p app
= do (push, arg_words) <- pushAtom d p arg
tagToId_sequence <- implement_tagToId constr_names
return (push `appOL` tagToId_sequence
`appOL` mkSLIDE 1 (d+arg_words-s)
`appOL` mkSLIDE 1 (d - s + fromIntegral arg_words)
`snocOL` ENTER)
-- Case 1
......@@ -625,7 +632,7 @@ schemeT d s p app
-- Generate code to build a constructor application,
-- leaving it on top of the stack
mkConAppCode :: Word16 -> Sequel -> BCEnv
mkConAppCode :: Word -> Sequel -> BCEnv
-> DataCon -- The data constructor
-> [AnnExpr' Id VarSet] -- Args, in *reverse* order
-> BcM BCInstrList
......@@ -646,12 +653,12 @@ mkConAppCode orig_d _ p con args_r_to_l
do_pushery d (arg:args)
= do (push, arg_words) <- pushAtom d p arg
more_push_code <- do_pushery (d+arg_words) args
more_push_code <- do_pushery (d + fromIntegral arg_words) args
return (push `appOL` more_push_code)
do_pushery d []
= return (unitOL (PACK con n_arg_words))
where
n_arg_words = d - orig_d
n_arg_words = trunc16 $ d - orig_d
-- -----------------------------------------------------------------------------
......@@ -662,19 +669,19 @@ mkConAppCode orig_d _ p con args_r_to_l
-- returned, even if it is a pointed type. We always just return.
unboxedTupleReturn
:: Word16 -> Sequel -> BCEnv
:: Word -> Sequel -> BCEnv
-> AnnExpr' Id VarSet -> BcM BCInstrList
unboxedTupleReturn d s p arg = do
(push, sz) <- pushAtom d p arg
return (push `appOL`
mkSLIDE sz (d-s) `snocOL`
mkSLIDE sz (d - s) `snocOL`
RETURN_UBX (atomRep arg))
-- -----------------------------------------------------------------------------
-- Generate code for a tail-call
doTailCall
:: Word16 -> Sequel -> BCEnv
:: Word -> Sequel -> BCEnv
-> Id -> [AnnExpr' Id VarSet]
-> BcM BCInstrList
doTailCall init_d s p fn args
......@@ -685,7 +692,7 @@ doTailCall init_d s p fn args
(push_fn, sz) <- pushAtom d p (AnnVar fn)
ASSERT( sz == 1 ) return ()
return (push_fn `appOL` (
mkSLIDE ((d-init_d) + 1) (init_d - s) `appOL`
mkSLIDE (trunc16 $ d - init_d + 1) (init_d - s) `appOL`
unitOL ENTER))
do_pushes d args reps = do
let (push_apply, n, rest_of_reps) = findPushSeq reps
......@@ -698,7 +705,7 @@ doTailCall init_d s p fn args
push_seq d [] = return (d, nilOL)
push_seq d (arg:args) = do
(push_code, sz) <- pushAtom d p arg
(final_d, more_push_code) <- push_seq (d+sz) args
(final_d, more_push_code) <- push_seq (d + fromIntegral sz) args
return (final_d, push_code `appOL` more_push_code)
-- v. similar to CgStackery.findMatch, ToDo: merge
......@@ -731,7 +738,7 @@ findPushSeq _
-- -----------------------------------------------------------------------------
-- Case expressions
doCase :: Word16 -> Sequel -> BCEnv
doCase :: Word -> Sequel -> BCEnv
-> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet]
-> Bool -- True <=> is an unboxed tuple case, don't enter the result
-> BcM BCInstrList
......@@ -741,10 +748,12 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
-- underneath it is the pointer to the alt_code BCO.
-- When an alt is entered, it assumes the returned value is
-- on top of the itbl.
ret_frame_sizeW :: Word
ret_frame_sizeW = 2
-- An unlifted value gets an extra info table pushed on top
-- when it is returned.
unlifted_itbl_sizeW :: Word
unlifted_itbl_sizeW | isAlgCase = 0
| otherwise = 1
......@@ -758,7 +767,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
-- Env in which to compile the alts, not including
-- any vars bound by the alts themselves
p_alts = Map.insert bndr (d_bndr - 1) p
p_alts = Map.insert bndr (fromIntegral d_bndr - 1) p
bndr_ty = idType bndr
isAlgCase = not (isUnLiftedType bndr_ty) && not is_unboxed_tuple
......@@ -788,8 +797,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
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)
rhs_code <- schemeE (d_alts + size) s p' rhs
return (my_discr alt, unitOL (UNPACK (trunc16 size)) `appOL` rhs_code)
where
real_bndrs = filterOut isTyVar bndrs
......@@ -828,7 +837,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
-- really want a bitmap up to depth (d-s). This affects compilation of
-- case-of-case expressions, which is the only time we can be compiling a
-- case expression with s /= 0.
bitmap_size = d-s
bitmap_size = trunc16 $ d-s
bitmap_size' :: Int
bitmap_size' = fromIntegral bitmap_size
bitmap = intsToReverseBitmap bitmap_size'{-size-}
......@@ -839,7 +848,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
spread (id, offset)
| isFollowableArg (idCgRep id) = [ rel_offset ]
| otherwise = []
where rel_offset = d - offset - 1
where rel_offset = trunc16 $ d - fromIntegral offset - 1
in do
alt_stuff <- mapM codeAlt alts
......@@ -852,7 +861,9 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
-- in
-- trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
-- "\n bitmap = " ++ show bitmap) $ do
scrut_code <- schemeE (d + ret_frame_sizeW) (d + ret_frame_sizeW) p scrut
scrut_code <- schemeE (d + ret_frame_sizeW)
(d + ret_frame_sizeW)
p scrut
alt_bco' <- emitBc alt_bco
let push_alts
| isAlgCase = PUSH_ALTS alt_bco'
......@@ -869,7 +880,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
-- (machine) code for the ccall, and create bytecodes to call that and
-- then return in the right way.
generateCCall :: Word16 -> Sequel -- stack and sequel depths
generateCCall :: Word -> Sequel -- stack and sequel depths
-> BCEnv
-> CCallSpec -- where to call
-> Id -- of target, for type info
......@@ -896,25 +907,25 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
-- contains.
Just t
| t == arrayPrimTyCon || t == mutableArrayPrimTyCon
-> do rest <- pargs (d + addr_sizeW) az
-> do rest <- pargs (d + fromIntegral addr_sizeW) az
code <- parg_ArrayishRep (fromIntegral arrPtrsHdrSize) d p a
return ((code,AddrRep):rest)
| t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
-> do rest <- pargs (d + addr_sizeW) az
-> do rest <- pargs (d + fromIntegral addr_sizeW) az
code <- parg_ArrayishRep (fromIntegral arrWordsHdrSize) d p a
return ((code,AddrRep):rest)
-- Default case: push taggedly, but otherwise intact.
_
-> do (code_a, sz_a) <- pushAtom d p a
rest <- pargs (d+sz_a) az
rest <- pargs (d + fromIntegral sz_a) az
return ((code_a, atomPrimRep a) : rest)
-- Do magic for Ptr/Byte arrays. Push a ptr to the array on
-- the stack but then advance it over the headers, so as to
-- point to the payload.
parg_ArrayishRep :: Word16 -> Word16 -> BCEnv -> AnnExpr' Id VarSet
parg_ArrayishRep :: Word16 -> Word -> BCEnv -> AnnExpr' Id VarSet
-> BcM BCInstrList
parg_ArrayishRep hdrSize d p a
= do (push_fo, _) <- pushAtom d p a
......@@ -1016,14 +1027,14 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
(push_Addr, d_after_Addr)
| is_static
= (toOL [PUSH_UBX (Right static_target_addr) addr_sizeW],
d_after_args + addr_sizeW)
d_after_args + fromIntegral addr_sizeW)
| otherwise -- is already on the stack
= (nilOL, d_after_args)
-- Push the return placeholder. For a call returning nothing,
-- this is a VoidArg (tag).
r_sizeW = fromIntegral (primRepSizeW r_rep)
d_after_r = d_after_Addr + r_sizeW
d_after_r = d_after_Addr + fromIntegral r_sizeW
r_lit = mkDummyLiteral r_rep
push_r = (if returns_void
then nilOL
......@@ -1035,7 +1046,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
-- instruction needs to describe the chunk of stack containing
-- the ccall args to the GC, so it needs to know how large it
-- is. See comment in Interpreter.c with the CCALL instruction.
stk_offset = d_after_r - s
stk_offset = trunc16 $ d_after_r - s
-- in
-- the only difference in libffi mode is that we prepare a cif
......@@ -1050,7 +1061,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
do_call = unitOL (CCALL stk_offset (castFunPtrToPtr addr_of_marshaller)
(fromIntegral (fromEnum (playInterruptible safety))))
-- slide and return
wrapup = mkSLIDE r_sizeW (d_after_r - r_sizeW - s)
wrapup = mkSLIDE r_sizeW (d_after_r - fromIntegral r_sizeW - s)
`snocOL` RETURN_UBX (primRepToCgRep r_rep)
--in
--trace (show (arg1_offW, args_offW , (map cgRepSizeW a_reps) )) $
......@@ -1150,7 +1161,7 @@ implement_tagToId names
-- to 5 and not to 4. Stack locations are numbered from zero, so a
-- depth 6 stack has valid words 0 .. 5.
pushAtom :: Word16 -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Word16)
pushAtom :: Word -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Word16)
pushAtom d p e
| Just e' <- bcView e
......@@ -1170,7 +1181,7 @@ pushAtom d p (AnnVar v)
= return (unitOL (PUSH_PRIMOP primop), 1)
| Just d_v <- lookupBCEnv_maybe v p -- v is a local variable
= let l = d - d_v + sz - 2
= let l = trunc16 $ d - d_v + fromIntegral 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
......@@ -1401,7 +1412,7 @@ instance Outputable Discr where
ppr NoDiscr = text "DEF"
lookupBCEnv_maybe :: Id -> BCEnv -> Maybe Word16
lookupBCEnv_maybe :: Id -> BCEnv -> Maybe Word
lookupBCEnv_maybe = Map.lookup
idSizeW :: Id -> Int
......@@ -1417,8 +1428,19 @@ unboxedTupleException
" Workaround: use -fobject-code, or compile this module to .o separately."))
mkSLIDE :: Word16 -> Word16 -> OrdList BCInstr
mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d)
mkSLIDE :: Word16 -> Word -> OrdList BCInstr
mkSLIDE n d
-- if the amount to slide doesn't fit in a word,
-- generate multiple slide instructions
| d > fromIntegral limit
= SLIDE n limit `consOL` mkSLIDE n (d - fromIntegral limit)
| d == 0
= nilOL
| otherwise
= if d == 0 then nilOL else unitOL (SLIDE n $ fromIntegral d)
where
limit :: Word16
limit = maxBound
splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann])
-- The arguments are returned in *right-to-left* order
......@@ -1465,7 +1487,7 @@ isPtrAtom e = atomRep e == PtrArg
-- Let szsw be the sizes in words of some items pushed onto the stack,
-- which has initial depth d'. Return the values which the stack environment
-- should map these items to.
mkStackOffsets :: Word16 -> [Word16] -> [Word16]
mkStackOffsets :: Word -> [Word] -> [Word]
mkStackOffsets original_depth szsw
= map (subtract 1) (tail (scanl (+) original_depth szsw))
......
......@@ -15,6 +15,7 @@ ByteCodeItbls: Generate infotables for interpreter-made bytecodes
module ByteCodeItbls ( ItblEnv, ItblPtr(..), itblCode, mkITbls
, StgInfoTable(..)
, State(..), runState, evalState, execState, MonadT(..)
) where
#include "HsVersions.h"
......@@ -31,6 +32,8 @@ import Util
import Foreign
import Foreign.C
import Control.Monad ( liftM )
import GHC.Exts ( Int(I#), addr2Int# )
import GHC.Ptr ( Ptr(..) )
\end{code}
......@@ -286,7 +289,7 @@ instance Storable StgConInfoTable where
, sizeOf (infoTable conInfoTable) ]
alignment _ = SIZEOF_VOID_P
peek ptr
= runState (castPtr ptr) $ do
= evalState (castPtr ptr) $ do
#ifdef GHCI_TABLES_NEXT_TO_CODE
desc <- load
#endif
......@@ -310,7 +313,7 @@ instance Storable StgConInfoTable where
pokeConItbl :: Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable
-> IO ()
pokeConItbl wr_ptr ex_ptr itbl
= runState (castPtr wr_ptr) $ do
= evalState (castPtr wr_ptr) $ do
#ifdef GHCI_TABLES_NEXT_TO_CODE
store (conDesc itbl `minusPtr` (ex_ptr `plusPtr` conInfoTableSizeB))
#endif
......@@ -353,7 +356,7 @@ instance Storable StgInfoTable where
= SIZEOF_VOID_P
poke a0 itbl
= runState (castPtr a0)
= evalState (castPtr a0)
$ do
#ifndef GHCI_TABLES_NEXT_TO_CODE
store (entry itbl)
......@@ -367,7 +370,7 @@ instance Storable StgInfoTable where
#endif
peek a0
= runState (castPtr a0)
= evalState (castPtr a0)
$ do
#ifndef GHCI_TABLES_NEXT_TO_CODE
entry' <- load
......@@ -409,8 +412,14 @@ class (Monad m, Monad (t m)) => MonadT t m where
instance Monad m => MonadT (State s) m where
lift m = State (\s -> m >>= \a -> return (s, a))