Fix bugs exposed by testsuite run

3 files changed, 17 insertions, 69 deletions

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index b34640a010..c16db530de 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -152,7 +152,7 @@ dsStrictBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
                              eqn_rhs = cantFailMatchResult body }
        ; var    <- selectMatchVar upat
        ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
-       ; return (scrungleMatch var rhs result) }
+       ; return (bindNonRec var rhs result) }
 
 dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
 
@@ -168,31 +168,6 @@ strictMatchOnly (FunBind { fun_id = L _ id })
   = isUnLiftedType (idType id)
 strictMatchOnly _ = False -- I hope!  Checked immediately by caller in fact
 
-scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr
--- Returns something like (let var = scrut in body)
--- but if var is an unboxed-tuple type, it inlines it in a fragile way
--- Special case to handle unboxed tuple patterns; they can't appear nested
--- The idea is that 
---      case e of (# p1, p2 #) -> rhs
--- should desugar to
---      case e of (# x1, x2 #) -> ... match p1, p2 ...
--- NOT
---      let x = e in case x of ....
---
--- But there may be a big 
---      let fail = ... in case e of ...
--- wrapping the whole case, which complicates matters slightly
--- It all seems a bit fragile.  Test is dsrun013.
-
-scrungleMatch var scrut body
-  | isUnboxedTupleType (idType var) = scrungle body
-  | otherwise                       = bindNonRec var scrut body
-  where
-    scrungle (Case (Var x) bndr ty alts)
-                    | x == var = Case scrut bndr ty alts
-    scrungle (Let binds body)  = Let binds (scrungle body)
-    scrungle other = panic ("scrungleMatch: tuple pattern:\n" ++ showSDoc (ppr other))
-
 \end{code}
 
 %************************************************************************
@@ -324,7 +299,7 @@ dsExpr (HsCase discrim matches@(MatchGroup _ rhs_ty))
   | otherwise
   = do { core_discrim <- dsLExpr discrim
        ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
-       ; return (scrungleMatch discrim_var core_discrim matching_code) }
+       ; return (bindNonRec discrim_var core_discrim matching_code) }
 
 -- Pepe: The binds are in scope in the body but NOT in the binding group
 --       This is to avoid silliness in breakpoints
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index 3a8c9ff6f0..3c2507b391 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -795,7 +795,20 @@ extractSubTerms recurse clos = liftM thirdOf3 . go 0 (nonPtrs clos)
            return (ptr_i, ws, terms0 ++ terms1)
       | otherwise
       = case typePrimRep ty of
-          []       -> go ptr_i ws tys
+          []       -> do
+            -- If we confirm that this is a type represented by void then
+            -- we can represent it as a nullary Prim in the output term.
+            -- This is necessary so that for a GADT like this:
+            --  data Foo a where FooCon :: Int -> Foo Int
+            --
+            -- The output Term looks like:
+            --  Term (Left Foo) [Prim [], Term (Left I#) [..]]
+            --
+            -- This is that when we drop the "theta" from the list of
+            -- terms when displaying the Foo, we drop the (Prim []) and NOT
+            -- the Term (Left I#). If you don't do this then print012 will fail.
+            (ptr_i, ws, terms) <- go ptr_i ws tys
+            return (ptr_i, ws, Prim ty [] : terms)
           [rep] -> do
             (ptr_i, ws, term0)  <- go_rep ptr_i ws ty rep
             (ptr_i, ws, terms1) <- go ptr_i ws tys
@@ -821,44 +834,6 @@ extractSubTerms recurse clos = liftM thirdOf3 . go 0 (nonPtrs clos)
         return (ptr_i, ws1, Prim ty ws0)
 
 
-
-            {-
-            let (subTtypesP, subTtypesNP) = partition isPtrType subTtypes
-            subTermsP <- sequence
-                  [ appArr (go (pred max_depth) ty ty) (ptrs clos) i
-                  | (i,ty) <- zip [0..] subTtypesP]
-            let unboxeds   = extractUnboxed subTtypesNP clos
-                subTermsNP = zipWith Prim subTtypesNP unboxeds
-                subTerms   = reOrderTerms subTermsP subTermsNP subTtypes
-
-
-
-extractUnboxed  :: [Type] -> Closure -> [[Word]]
-extractUnboxed tt clos = go tt (nonPtrs clos)
-   where sizeofType t = primRepSizeW (typePrimRep t)
-         go [] _ = []
-         go (t:tt) xx 
-           | (x, rest) <- splitAt (sizeofType t) xx
-           = x : go tt rest
-
-
-
-
-  -- put together pointed and nonpointed subterms in the
-  --  correct order.
-  reOrderTerms _ _ [] = []
-  reOrderTerms pointed unpointed (ty:tys) 
-   | isPtrType ty = ASSERT2(not(null pointed)
-                            , ptext (sLit "reOrderTerms") $$ 
-                                        (ppr pointed $$ ppr unpointed))
-                    let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
-   | otherwise    = ASSERT2(not(null unpointed)
-                           , ptext (sLit "reOrderTerms") $$ 
-                                       (ppr pointed $$ ppr unpointed))
-                    let (t:tt) = unpointed in t : reOrderTerms pointed tt tys
-            -}
-
-
 -- Fast, breadth-first Type reconstruction
 ------------------------------------------
 cvReconstructType :: HscEnv -> Int -> GhciType -> HValue -> IO (Maybe Type)
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index c5cc8cf4ad..5a397b90e4 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -1421,9 +1421,7 @@ marshalableTyCon :: DynFlags -> TyCon -> Bool
 marshalableTyCon dflags tc
   =  (xopt Opt_UnliftedFFITypes dflags 
       && isUnLiftedTyCon tc
-      && case tyConPrimRep tc of	-- Note [Marshalling VoidRep]
-	   [_] -> True
-	   _   -> False)
+      && not (isUnboxedTupleTyCon tc))
   || boxedMarshalableTyCon tc
 
 boxedMarshalableTyCon :: TyCon -> Bool