From fe6618b14712b829b8675fc6024dd33e9598d09a Mon Sep 17 00:00:00 2001
From: Michal Terepeta <michal.terepeta@gmail.com>
Date: Tue, 11 Jul 2017 12:00:16 -0400
Subject: [PATCH] ByteCodeGen: use depth instead of offsets in BCEnv
This is based on unfinished work in D38 started by Simon Marlow and is
the first step for fixing #13825. (next step use byte-indexing for
stack)
The change boils down to adjusting everything in BCEnv by +1, which
simplifies the code a bit.
I've also looked into a weird stack adjustement that we did in
`getIdValFromApStack` and moved it to `ByteCodeGen` to just keep
everything in one place. I've left a comment about this.
Signed-off-by: Michal Terepeta <michal.terepeta@gmail.com>
Test Plan: ./validate
Reviewers: austin, hvr, bgamari, simonmar
Reviewed By: bgamari, simonmar
Subscribers: simonmar, rwbarton, thomie
GHC Trac Issues: #13825
Differential Revision: https://phabricator.haskell.org/D3708
---
compiler/ghci/ByteCodeGen.hs | 60 +++++++++++++++++++-----------------
libraries/ghci/GHCi/Run.hs | 4 +--
2 files changed, 32 insertions(+), 32 deletions(-)
diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
index a7cd6da0e74b..5c236f3dab5a 100644
--- a/compiler/ghci/ByteCodeGen.hs
+++ b/compiler/ghci/ByteCodeGen.hs
@@ -211,8 +211,8 @@ type BCInstrList = OrdList BCInstr
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.
+-- | Maps Ids to their stack depth. This allows us to avoid having to mess with
+-- it after each push/pop.
type BCEnv = Map Id Word -- To find vars on the stack
{-
@@ -403,13 +403,20 @@ schemeER_wrk d p rhs
| otherwise = schemeE (fromIntegral d) 0 p rhs
getVarOffSets :: Word -> BCEnv -> [Id] -> [(Id, Word16)]
-getVarOffSets d p = catMaybes . map (getOffSet d p)
-
-getOffSet :: Word -> BCEnv -> Id -> Maybe (Id, Word16)
-getOffSet d env id
- = case lookupBCEnv_maybe id env of
+getVarOffSets depth env = catMaybes . map getOffSet
+ where
+ getOffSet id = case lookupBCEnv_maybe id env of
Nothing -> Nothing
- Just offset -> Just (id, trunc16 $ d - offset)
+ Just offset ->
+ -- michalt: I'm not entirely sure why we need the stack
+ -- adjustement by 2 here. I initially thought that there's
+ -- something off with getIdValFromApStack (the only user of this
+ -- value), but it looks ok to me. My current hypothesis is that
+ -- this "adjustement" is needed due to stack manipulation for
+ -- BRK_FUN in Interpreter.c In any case, this is used only when
+ -- we trigger a breakpoint.
+ let adjustement = 2
+ in Just (id, trunc16 $ depth - offset + adjustement)
trunc16 :: Word -> Word16
trunc16 w
@@ -471,7 +478,8 @@ schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
-- saturated 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 (Map.insert x d p) body
+ let !d2 = d + 1
+ body_code <- schemeE d2 s (Map.insert x d2 p) body
return (alloc_code `appOL` body_code)
-- General case for let. Generates correct, if inefficient, code in
@@ -861,10 +869,9 @@ 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
- d_bndr' = fromIntegral d_bndr - 1
- p_alts0 = Map.insert bndr d_bndr' p
+ p_alts0 = Map.insert bndr d_bndr p
p_alts = case is_unboxed_tuple of
- Just ubx_bndr -> Map.insert ubx_bndr d_bndr' p_alts0
+ Just ubx_bndr -> Map.insert ubx_bndr d_bndr p_alts0
Nothing -> p_alts0
bndr_ty = idType bndr
@@ -947,7 +954,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
rel_slots = nub $ map fromIntegral $ concat (map spread binds)
spread (id, offset) | isFollowableArg (bcIdArgRep id) = [ rel_offset ]
| otherwise = []
- where rel_offset = trunc16 $ d - fromIntegral offset - 1
+ where rel_offset = trunc16 $ d - fromIntegral offset
alt_stuff <- mapM codeAlt alts
alt_final <- mkMultiBranch maybe_ncons alt_stuff
@@ -1377,18 +1384,14 @@ pushAtom d p (AnnVar v)
= do dflags <- getDynFlags
let sz :: Word16
sz = fromIntegral (idSizeW dflags v)
- l = trunc16 $ d - d_v + fromIntegral sz - 2
+ l = trunc16 $ d - d_v + fromIntegral sz - 1
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
- --
- -- d - d_v - 1 the offset from the TOS of the 1st slot
- --
- -- d - d_v - 1 + sz - 1 the offset from the TOS of the last slot
- -- of the object.
- --
- -- Having found the last slot, we proceed to copy the right number of
- -- slots on to the top of the stack.
+ -- d - d_v offset from TOS to the first slot of the object
+ --
+ -- d - d_v + sz - 1 offset from the TOS of the last slot of the object
+ --
+ -- Having found the last slot, we proceed to copy the right number of
+ -- slots on to the top of the stack.
| otherwise -- v must be a global variable
= do topStrings <- getTopStrings
@@ -1676,12 +1679,11 @@ atomRep e = toArgRep (atomPrimRep e)
isPtrAtom :: AnnExpr' Id ann -> Bool
isPtrAtom e = isFollowableArg (atomRep e)
--- 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.
+-- | Let szsw be the sizes in words of some items pushed onto the stack, which
+-- has initial depth @original_depth@. Return the values which the stack
+-- environment should map these items to.
mkStackOffsets :: Word -> [Word] -> [Word]
-mkStackOffsets original_depth szsw
- = map (subtract 1) (tail (scanl (+) original_depth szsw))
+mkStackOffsets original_depth szsw = tail (scanl' (+) original_depth szsw)
typeArgRep :: Type -> ArgRep
typeArgRep = toArgRep . typePrimRep1
diff --git a/libraries/ghci/GHCi/Run.hs b/libraries/ghci/GHCi/Run.hs
index eecafa1f7585..d05877579a2f 100644
--- a/libraries/ghci/GHCi/Run.hs
+++ b/libraries/ghci/GHCi/Run.hs
@@ -344,9 +344,7 @@ mkCostCentres _ _ = return []
getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
getIdValFromApStack apStack (I# stackDepth) = do
- case getApStackVal# apStack (stackDepth +# 1#) of
- -- The +1 is magic! I don't know where it comes
- -- from, but this makes things line up. --SDM
+ case getApStackVal# apStack stackDepth of
(# ok, result #) ->
case ok of
0# -> return Nothing -- AP_STACK not found
--
GitLab