X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FByteCodeGen.lhs;h=bb0f591e288a2d98c640d04125690076d87f4b32;hb=a4d1f3a5a560ee8f4cbf32e2d6a9e9d158c8d8ee;hp=3138e8eca8a1b554e8bdaa0739a35d5efab9438d;hpb=ad94d40948668032189ad22a0ad741ac1f645f50;p=ghc-hetmet.git

diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index 3138e8e..bb0f591 100644
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -9,7 +9,7 @@ ByteCodeGen: Generate bytecode from Core
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and fix
 -- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
 -- for details
 
 module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where
@@ -178,17 +178,19 @@ mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_bloc
         -- (hopefully rare) cases when the (overestimated) stack use
         -- exceeds iNTERP_STACK_CHECK_THRESH.
         maybe_with_stack_check
-	   | is_ret = peep_d
-		-- don't do stack checks at return points;
+	   | is_ret && stack_usage < aP_STACK_SPLIM = peep_d
+		-- don't do stack checks at return points,
 		-- everything is aggregated up to the top BCO
-		-- (which must be a function)
-           | stack_overest >= iNTERP_STACK_CHECK_THRESH
-           = STKCHECK stack_overest : peep_d
+		-- (which must be a function).
+                -- That is, unless the stack usage is >= AP_STACK_SPLIM,
+                -- see bug #1466.
+           | stack_usage >= iNTERP_STACK_CHECK_THRESH
+           = STKCHECK stack_usage : peep_d
            | otherwise
            = peep_d	-- the supposedly common case
              
         -- We assume that this sum doesn't wrap
-        stack_overest = sum (map bciStackUse peep_d)
+        stack_usage = sum (map bciStackUse peep_d)
 
         -- Merge local pushes
         peep_d = peep (fromOL instrs_ordlist)
@@ -425,9 +427,15 @@ schemeE d s p (AnnLet binds (_,body))
               return (push_code `appOL` more_push_code)
 
          alloc_code = toOL (zipWith mkAlloc sizes arities)
-	   where mkAlloc sz 0     = ALLOC_AP sz
+	   where mkAlloc sz 0
+                    | is_tick     = ALLOC_AP_NOUPD sz
+                    | otherwise   = ALLOC_AP sz
 		 mkAlloc sz arity = ALLOC_PAP arity sz
 
+         is_tick = case binds of 
+                     AnnNonRec id _ -> occNameFS (getOccName id) == tickFS
+                     _other -> False
+
 	 compile_bind d' fvs x rhs size arity off = do
 		bco <- schemeR fvs (x,rhs)
 		build_thunk d' fvs size bco off arity
@@ -1517,5 +1525,7 @@ newUnique = BcM $
 newId :: Type -> BcM Id
 newId ty = do 
     uniq <- newUnique
-    return $ mkSysLocal FSLIT("ticked") uniq ty
+    return $ mkSysLocal tickFS uniq ty
+
+tickFS = FSLIT("ticked")
 \end{code}