Merge ghc-new-co into master branch
authorSimon Peyton Jones <simonpj@microsoft.com>
Mon, 9 May 2011 10:53:47 +0000 (11:53 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Mon, 9 May 2011 10:53:47 +0000 (11:53 +0100)
1  2 
compiler/ghci/ByteCodeGen.lhs
compiler/main/DynFlags.hs
compiler/typecheck/TcRnMonad.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'
Simple merge
Simple merge