diff options
| -rw-r--r-- | compiler/deSugar/DsExpr.lhs | 29 | ||||
| -rw-r--r-- | compiler/ghci/RtClosureInspect.hs | 53 | ||||
| -rw-r--r-- | compiler/typecheck/TcType.lhs | 4 |
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 |