From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Mon, 9 May 2011 10:53:47 +0000 (+0100)
Subject: Merge ghc-new-co into master branch
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=cbebca1c9164a5e5ae9b117d0dcf5ad217defc6d;p=ghc-hetmet.git

Merge ghc-new-co into master branch
---

cbebca1c9164a5e5ae9b117d0dcf5ad217defc6d
diff --cc compiler/ghci/ByteCodeGen.lhs
index b888747,c07073a..426f4f2
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@@ -807,37 -808,37 +806,37 @@@ doCase d s p (_,scrut) bndr alts is_unb
          isAlgCase = not (isUnLiftedType bndr_ty) && not is_unboxed_tuple
  
          -- given an alt, return a discr and code for it.
 -	codeAlt (DEFAULT, _, (_,rhs))
 -	   = do rhs_code <- schemeE d_alts s p_alts rhs
 -	        return (NoDiscr, rhs_code)
 +        codeAlt (DEFAULT, _, (_,rhs))
 +           = do rhs_code <- schemeE d_alts s p_alts rhs
 +                return (NoDiscr, rhs_code)
  
          codeAlt alt@(_, bndrs, (_,rhs))
 -	   -- primitive or nullary constructor alt: no need to UNPACK
 -	   | null real_bndrs = do
 -		rhs_code <- schemeE d_alts s p_alts rhs
 +           -- primitive or nullary constructor alt: no need to UNPACK
 +           | null real_bndrs = do
 +                rhs_code <- schemeE d_alts s p_alts rhs
                  return (my_discr alt, rhs_code)
 -	   -- algebraic alt with some binders
 +           -- algebraic alt with some binders
             | otherwise =
               let
 -		 (ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs
 -		 ptr_sizes    = map (fromIntegral . idSizeW) ptrs
 -		 nptrs_sizes  = map (fromIntegral . idSizeW) nptrs
 -		 bind_sizes   = ptr_sizes ++ nptrs_sizes
 -		 size         = sum ptr_sizes + sum nptrs_sizes
 -		 -- the UNPACK instruction unpacks in reverse order...
 -		 p' = Map.insertList
 -			(zip (reverse (ptrs ++ nptrs))
 -			  (mkStackOffsets d_alts (reverse bind_sizes)))
 -                        p_alts 
 -	     in do
 +                 (ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs
 +                 ptr_sizes    = map (fromIntegral . idSizeW) ptrs
 +                 nptrs_sizes  = map (fromIntegral . idSizeW) nptrs
 +                 bind_sizes   = ptr_sizes ++ nptrs_sizes
 +                 size         = sum ptr_sizes + sum nptrs_sizes
 +                 -- the UNPACK instruction unpacks in reverse order...
 +                 p' = Map.insertList
 +                        (zip (reverse (ptrs ++ nptrs))
 +                          (mkStackOffsets d_alts (reverse bind_sizes)))
 +                        p_alts
 +             in do
               MASSERT(isAlgCase)
 -	     rhs_code <- schemeE (d_alts+size) s p' rhs
 +             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
+ 	   where
+ 	     real_bndrs = filterOut isTyVar bndrs
  
          my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}
 -        my_discr (DataAlt dc, _, _) 
 +        my_discr (DataAlt dc, _, _)
             | isUnboxedTupleCon dc
             = unboxedTupleException
             | otherwise
@@@ -1193,10 -1194,13 +1192,13 @@@ implement_tagToId name
  
  pushAtom :: Word16 -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Word16)
  
 -pushAtom d p e 
 -   | Just e' <- bcView e 
 +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)
@@@ -1270,11 -1274,8 +1272,8 @@@ 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" 
 +   = pprPanic "ByteCodeGen.pushAtom"
                (pprCoreExpr (deAnnotate (undefined, expr)))
  
  foreign import ccall unsafe "memcpy"
@@@ -1452,13 -1453,13 +1451,13 @@@ bcView :: AnnExpr' Var ann -> Maybe (An
  --  b) type applications
  --  c) casts
  --  d) notes
 --- Type lambdas *can* occur in random expressions, 
 +-- Type lambdas *can* occur in random expressions,
  -- 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 (AnnApp (_,e) (_, AnnType _))   = Just e
- bcView _                               = Nothing
+ bcView (AnnNote _ (_,e)) 	     = Just e
+ bcView (AnnCast (_,e) _) 	     = 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'