Commit 6dc22bfa authored by pcapriotti's avatar pcapriotti

Support large SLIDE instructions.

The bytecode generator used to keep track of the stack depth with a
16-bit counter, which could overflow for very large BCOs, resulting in
incorrect bytecode.

This commit switches to a word-sized counter, and eagerly panics
whenever an operand is too big, instead of truncating the result.

This allows us to work around the 16-bit limitation in the case of SLIDE
instructions, since we can simply factor it into multiple SLIDEs with
smaller arguments.
parent e57d23d6
......@@ -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))
......
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