X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FByteCodeGen.lhs;h=c07073aee6a5343d8026f139617877802e85531a;hb=668ac8061c35fd5b72816fd3c4dd4881c46db737;hp=7d6bc234f7057647fed86568c6830362fc46d89a;hpb=76349636abcb764e8ed3b9ae548730ad2d85abb2;p=ghc-hetmet.git

diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index 7d6bc23..c07073a 100644
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -30,10 +30,7 @@ import CoreFVs
 import Type
 import DataCon
 import TyCon
--- import Type
 import Util
--- import DataCon
-import Var
 import VarSet
 import TysPrim
 import DynFlags
@@ -253,7 +250,7 @@ schemeR fvs (nm, rhs)
 {-
    | trace (showSDoc (
               (char ' '
-               $$ (ppr.filter (not.isTyCoVar).varSetElems.fst) rhs
+               $$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs
                $$ pprCoreExpr (deAnnotate rhs)
                $$ char ' '
               ))) False
@@ -298,7 +295,7 @@ schemeER_wrk d p rhs
    | Just (tickInfo, (_annot, newRhs)) <- isTickedExp' rhs = do 
         code <- schemeE d 0 p newRhs 
         arr <- getBreakArray 
-        let idOffSets = getVarOffSets (fromIntegral d) p tickInfo 
+        let idOffSets = getVarOffSets d p tickInfo
         let tickNumber = tickInfo_number tickInfo
         let breakInfo = BreakInfo 
                         { breakInfo_module = tickInfo_module tickInfo
@@ -640,13 +637,13 @@ schemeT d s p app
       -- Detect and extract relevant info for the tagToEnum kludge.
       maybe_is_tagToEnum_call
          = let extract_constr_Names ty
-		 | Just (tyc, []) <- splitTyConApp_maybe (repType ty),
+                 | Just (tyc, _) <- splitTyConApp_maybe (repType ty),
 		   isDataTyCon tyc
 		   = map (getName . dataConWorkId) (tyConDataCons tyc)
 		   -- NOTE: use the worker name, not the source name of
 		   -- the DataCon.  See DataCon.lhs for details.
 		 | otherwise
-		   = panic "maybe_is_tagToEnum_call.extract_constr_Ids"
+                   = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty)
            in
            case app of
               (AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg)
@@ -838,7 +835,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
 	     rhs_code <- schemeE (d_alts+size) s p' rhs
              return (my_discr alt, unitOL (UNPACK size) `appOL` rhs_code)
 	   where
-	     real_bndrs = filter (not.isTyCoVar) bndrs
+	     real_bndrs = filterOut isTyVar bndrs
 
         my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}
         my_discr (DataAlt dc, _, _) 
@@ -923,7 +920,7 @@ generateCCall :: Word16 -> Sequel 		-- stack and sequel depths
               -> [AnnExpr' Id VarSet]	-- args (atoms)
               -> BcM BCInstrList
 
-generateCCall d0 s p (CCallSpec target cconv _) fn args_r_to_l
+generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
    = let 
          -- useful constants
          addr_sizeW :: Word16
@@ -1092,7 +1089,8 @@ generateCCall d0 s p (CCallSpec target cconv _) fn args_r_to_l
      recordItblMallocBc (ItblPtr (castFunPtrToPtr addr_of_marshaller))
      let
          -- do the call
-         do_call      = unitOL (CCALL stk_offset (castFunPtrToPtr addr_of_marshaller))
+         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)
                         `snocOL` RETURN_UBX (primRepToCgRep r_rep)
@@ -1200,6 +1198,9 @@ pushAtom d p e
    | Just e' <- bcView e 
    = pushAtom d p e'
 
+pushAtom _ _ (AnnCoercion {})	-- Coercions are zero-width things, 
+   = return (nilOL, 0)	  	-- treated just like a variable VoidArg
+
 pushAtom d p (AnnVar v)
    | idCgRep v == VoidArg
    = return (nilOL, 0)
@@ -1273,9 +1274,6 @@ pushAtom _ _ (AnnLit lit)
                 -- Get the addr on the stack, untaggedly
                 return (unitOL (PUSH_UBX (Right addr) 1), 1)
 
-pushAtom d p (AnnCast e _)
-   = pushAtom d p (snd e)
-
 pushAtom _ _ expr
    = pprPanic "ByteCodeGen.pushAtom" 
               (pprCoreExpr (deAnnotate (undefined, expr)))
@@ -1459,19 +1457,21 @@ bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann)
 -- whereas value lambdas cannot; that is why they are nuked here
 bcView (AnnNote _ (_,e)) 	     = Just e
 bcView (AnnCast (_,e) _) 	     = Just e
-bcView (AnnLam v (_,e)) | isTyCoVar v  = Just e
+bcView (AnnLam v (_,e)) | isTyVar v  = Just e
 bcView (AnnApp (_,e) (_, AnnType _)) = Just e
 bcView _                             = Nothing
 
 isVoidArgAtom :: AnnExpr' Var ann -> Bool
 isVoidArgAtom e | Just e' <- bcView e = isVoidArgAtom e'
 isVoidArgAtom (AnnVar v)              = typePrimRep (idType v) == VoidRep
+isVoidArgAtom (AnnCoercion {})        = True
 isVoidArgAtom _ 	              = False
 
 atomPrimRep :: AnnExpr' Id ann -> PrimRep
 atomPrimRep e | Just e' <- bcView e = atomPrimRep e'
 atomPrimRep (AnnVar v)    	    = typePrimRep (idType v)
 atomPrimRep (AnnLit l)    	    = typePrimRep (literalType l)
+atomPrimRep (AnnCoercion {})        = VoidRep
 atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate (undefined,other)))
 
 atomRep :: AnnExpr' Id ann -> CgRep
@@ -1564,9 +1564,9 @@ getBreakArray = BcM $ \st -> return (st, breakArray st)
 
 newUnique :: BcM Unique
 newUnique = BcM $
-   \st -> case splitUniqSupply (uniqSupply st) of
-             (us1, us2) -> let newState = st { uniqSupply = us2 } 
-                           in  return (newState, uniqFromSupply us1) 
+   \st -> case takeUniqFromSupply (uniqSupply st) of
+             (uniq, us) -> let newState = st { uniqSupply = us }
+                           in  return (newState, uniq)
 
 newId :: Type -> BcM Id
 newId ty = do