[project @ 2001-02-15 14:30:35 by sewardj]

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

diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs
index 14f0ed4..cea9dbb 100644 (file)
--- a/ghc/compiler/ghci/ByteCodeGen.lhs
+++ b/ghc/compiler/ghci/ByteCodeGen.lhs
@@ -27,7 +27,8 @@ import PrimRep                ( PrimRep(..) )
 import PrimOp          ( PrimOp(..)  )
 import CoreFVs         ( freeVars )
 import Type            ( typePrimRep )
-import DataCon         ( dataConTag, fIRST_TAG, dataConTyCon, dataConWrapId )
+import DataCon         ( dataConTag, fIRST_TAG, dataConTyCon, 
+                          dataConWrapId, isUnboxedTupleCon )
 import TyCon           ( TyCon, tyConFamilySize )
 import Class           ( Class, classTyCon )
 import Util            ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem )
@@ -38,16 +39,19 @@ import CmdLineOpts  ( DynFlags, DynFlag(..) )
 import ErrUtils                ( showPass, dumpIfSet_dyn )
 import Unique          ( mkPseudoUnique3 )
 import FastString      ( FastString(..) )
+import Panic           ( GhcException(..) )
 import PprType         ( pprType )
-import ByteCodeInstr   ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO )
+import ByteCodeInstr   ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO, bciStackUse )
 import ByteCodeItbls   ( ItblEnv, mkITbls )
 import ByteCodeLink    ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO,
-                         ClosureEnv, HValue, linkSomeBCOs, filterNameMap )
+                         ClosureEnv, HValue, linkSomeBCOs, filterNameMap,
+                         iNTERP_STACK_CHECK_THRESH )
 
 import List            ( intersperse, sortBy )
 import Foreign         ( Ptr(..), mallocBytes )
 import Addr            ( Addr(..), addrToInt, writeCharOffAddr )
 import CTypes          ( CInt )
+import Exception       ( throwDyn )
 
 import PrelBase                ( Int(..) )
 import PrelGHC         ( ByteArray# )
@@ -129,15 +133,15 @@ linkIModules gie gce mods
    = do let (bcoss, ies) = unzip mods
             bcos = concat bcoss
             final_gie = foldr plusFM gie ies
-        (final_gce, linked_bcos) <- linkSomeBCOs final_gie gce bcos
+        (final_gce, linked_bcos) <- linkSomeBCOs True final_gie gce bcos
         return (linked_bcos, final_gie, final_gce)
 
 
 linkIExpr :: ItblEnv -> ClosureEnv -> UnlinkedBCOExpr
           -> IO HValue           -- IO BCO# really
 linkIExpr ie ce (root_ul_bco, aux_ul_bcos)
-   = do (aux_ce, _) <- linkSomeBCOs ie ce aux_ul_bcos
-        (_, [root_bco]) <- linkSomeBCOs ie aux_ce [root_ul_bco]
+   = do (aux_ce, _) <- linkSomeBCOs False ie ce aux_ul_bcos
+        (_, [root_bco]) <- linkSomeBCOs False ie aux_ce [root_ul_bco]
         return root_bco
 \end{code}
 
@@ -169,12 +173,35 @@ ppBCEnv p
 -- Create a BCO and do a spot of peephole optimisation on the insns
 -- at the same time.
 mkProtoBCO nm instrs_ordlist origin
-   = ProtoBCO nm (id {-peep-} (fromOL instrs_ordlist)) origin
+   = ProtoBCO nm maybe_with_stack_check origin
      where
+        -- Overestimate the stack usage (in words) of this BCO,
+        -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit
+        -- stack check.  (The interpreter always does a stack check
+        -- for iNTERP_STACK_CHECK_THRESH words at the start of each
+        -- BCO anyway, so we only need to add an explicit on in the
+        -- (hopefully rare) cases when the (overestimated) stack use
+        -- exceeds iNTERP_STACK_CHECK_THRESH.
+        maybe_with_stack_check
+           | stack_overest >= 65535
+           = pprPanic "mkProtoBCO: stack use won't fit in 16 bits" 
+                      (int stack_overest)
+           | stack_overest >= iNTERP_STACK_CHECK_THRESH
+           = (STKCHECK stack_overest) : peep_d
+           | otherwise
+           = peep_d    -- the supposedly common case
+             
+        stack_overest = sum (map bciStackUse peep_d)
+                        + 10 {- just to be really really sure -}
+
+
+        -- Merge local pushes
+        peep_d = peep (fromOL instrs_ordlist)
+
         peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest)
            = PUSH_LLL off1 (off2-1) (off3-2) : peep rest
         peep (PUSH_L off1 : PUSH_L off2 : rest)
-           = PUSH_LL off1 off2 : peep rest
+           = PUSH_LL off1 (off2-1) : peep rest
         peep (i:rest)
            = i : peep rest
         peep []
@@ -332,6 +359,7 @@ schemeE d s p (fvs, AnnCase scrut bndr alts)
            = case scrut_primrep of
                 CharRep -> False ; AddrRep -> False ; WordRep -> False
                 IntRep -> False ; FloatRep -> False ; DoubleRep -> False
+                VoidRep -> False ;
                 PtrRep -> True
                 other  -> pprPanic "ByteCodeGen.schemeE" (ppr other)
 
@@ -348,8 +376,12 @@ schemeE d s p (fvs, AnnCase scrut bndr alts)
              schemeE d' s p' rhs       `thenBc` \ rhs_code ->
              returnBc (my_discr alt, rhs_code)
 
-        my_discr (DEFAULT, binds, rhs)  = NoDiscr
-        my_discr (DataAlt dc, binds, rhs) = DiscrP (dataConTag dc - fIRST_TAG)
+        my_discr (DEFAULT, binds, rhs) = NoDiscr
+        my_discr (DataAlt dc, binds, rhs) 
+           | isUnboxedTupleCon dc
+           = unboxedTupleException
+           | otherwise
+           = DiscrP (dataConTag dc - fIRST_TAG)
         my_discr (LitAlt l, binds, rhs)
            = case l of MachInt i     -> DiscrI (fromInteger i)
                        MachFloat r   -> DiscrF (fromRational r)
@@ -416,7 +448,9 @@ schemeT d s p app
 
    -- Cases 2 and 3
    | otherwise
-   = code
+   = if   is_con_call && isUnboxedTupleCon con
+     then unboxedTupleException
+     else code
 
      where
          -- Extract the args (R->L) and fn
@@ -474,6 +508,7 @@ atomRep (AnnVar v)    = typePrimRep (idType v)
 atomRep (AnnLit l)    = literalPrimRep l
 atomRep (AnnNote n b) = atomRep (snd b)
 atomRep (AnnApp f (_, AnnType _)) = atomRep (snd f)
+atomRep (AnnLam x e) | isTyVar x = atomRep (snd e)
 atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other)))
 
 
@@ -669,6 +704,10 @@ pushAtom tagged d p (AnnApp f (_, AnnType _))
 pushAtom tagged d p (AnnNote note e)
    = pushAtom tagged d p (snd e)
 
+pushAtom tagged d p (AnnLam x e) 
+   | isTyVar x 
+   = pushAtom tagged d p (snd e)
+
 pushAtom tagged d p other
    = pprPanic "ByteCodeGen.pushAtom" 
               (pprCoreExpr (deAnnotate (undefined, other)))
@@ -839,6 +878,10 @@ taggedIdSizeW, untaggedIdSizeW :: Id -> Int
 taggedIdSizeW   = taggedSizeW   . typePrimRep . idType
 untaggedIdSizeW = untaggedSizeW . typePrimRep . idType
 
+unboxedTupleException :: a
+unboxedTupleException 
+   = throwDyn (Panic "bytecode generator can't handle unboxed tuples")
+
 \end{code}
 
 %************************************************************************