Finally, I managed to squash an infamous bug in :print

[ghc-hetmet.git] / compiler / ghci / ByteCodeGen.lhs

diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index b09d739..846737e 100644 (file)
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -5,6 +5,13 @@
 ByteCodeGen: Generate bytecode from Core
 
 \begin{code}
+{-# OPTIONS -w #-}
+-- 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/Commentary/CodingStyle#Warnings
+-- for details
+
 module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where
 
 #include "HsVersions.h"
@@ -171,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)
@@ -298,6 +307,7 @@ schemeER_wrk d p rhs
                         { breakInfo_module = tickInfo_module tickInfo
                         , breakInfo_number = tickNumber 
                         , breakInfo_vars = idOffSets
+                        , breakInfo_resty = exprType (deAnnotate' newRhs)
                         }
         let breakInstr = case arr of (BA arr#) -> BRK_FUN arr# tickNumber breakInfo 
         return $ breakInstr `consOL` code
@@ -434,18 +444,24 @@ schemeE d s p (AnnLet binds (_,body))
      thunk_codes <- sequence compile_binds
      return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)
 
--- introduce a let binding for a ticked case expression. This rule *should* only fire when the
--- expression was not already let-bound (the code gen for let bindings should take care of that). 
--- Todo: we call exprFreeVars on a deAnnotated expression, this may not be the best way
--- to calculate the free vars but it seemed like the least intrusive thing to do
+-- introduce a let binding for a ticked case expression. This rule
+-- *should* only fire when the expression was not already let-bound
+-- (the code gen for let bindings should take care of that).  Todo: we
+-- call exprFreeVars on a deAnnotated expression, this may not be the
+-- best way to calculate the free vars but it seemed like the least
+-- intrusive thing to do
 schemeE d s p exp@(AnnCase {})
-   | Just (tickInfo, _exp) <- isTickedExp' exp = do 
-        let fvs = exprFreeVars $ deAnnotate' exp
-        let ty = exprType $ deAnnotate' exp
-        id <- newId ty
-        -- Todo: is emptyVarSet correct on the next line?
-        let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyVarSet, AnnVar id)
-        schemeE d s p letExp
+   | Just (tickInfo,rhs) <- isTickedExp' exp
+   = if isUnLiftedType ty
+        then schemeE d s p (snd rhs)
+        else do
+          id <- newId ty
+          -- Todo: is emptyVarSet correct on the next line?
+          let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyVarSet, AnnVar id)
+          schemeE d s p letExp
+   where exp' = deAnnotate' exp
+         fvs  = exprFreeVars exp'
+         ty   = exprType exp'
 
 schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
    | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1)
@@ -1369,13 +1385,14 @@ lookupBCEnv_maybe = lookupFM
 idSizeW :: Id -> Int
 idSizeW id = cgRepSizeW (typeCgRep (idType id))
 
+-- See bug #1257
 unboxedTupleException :: a
 unboxedTupleException 
    = throwDyn 
-        (Panic 
-           ("Bytecode generator can't handle unboxed tuples.  Possibly due\n" ++
-            "\tto foreign import/export decls in source.  Workaround:\n" ++
-            "\tcompile this module to a .o file, then restart session."))
+        (ProgramError 
+           ("Error: bytecode compiler can't handle unboxed tuples.\n"++
+            "  Possibly due to foreign import/export decls in source.\n"++
+            "  Workaround: use -fobject-code, or compile this module to .o separately."))
 
 
 mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d)