diff options
Diffstat (limited to 'compiler/deSugar')
| -rw-r--r-- | compiler/deSugar/DsExpr.lhs | 31 | ||||
| -rw-r--r-- | compiler/deSugar/DsForeign.lhs | 13 |
2 files changed, 11 insertions, 33 deletions
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index d31c77479d..28c94c8ffb 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -154,7 +154,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) @@ -163,38 +163,13 @@ strictMatchOnly :: HsBind Id -> Bool strictMatchOnly (AbsBinds { abs_binds = binds }) = anyBag (strictMatchOnly . unLoc) binds strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = ty }) - = isUnboxedTupleType ty + = isUnLiftedType ty || isBangLPat lpat || any (isUnLiftedType . idType) (collectPatBinders lpat) 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} %************************************************************************ @@ -326,7 +301,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/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index 88caaef875..01895332ca 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -707,9 +707,12 @@ toCType = f False = pprPanic "toCType" (ppr t) typeTyCon :: Type -> TyCon -typeTyCon ty = case tcSplitTyConApp_maybe (repType ty) of - Just (tc,_) -> tc - Nothing -> pprPanic "DsForeign.typeTyCon" (ppr ty) +typeTyCon ty + | UnaryRep rep_ty <- repType ty + , Just (tc, _) <- tcSplitTyConApp_maybe rep_ty + = tc + | otherwise + = pprPanic "DsForeign.typeTyCon" (ppr ty) insertRetAddr :: DynFlags -> CCallConv -> [(SDoc, SDoc, Type, CmmType)] @@ -739,7 +742,7 @@ ret_addr_arg = (text "original_return_addr", text "void*", undefined, -- This function returns the primitive type associated with the boxed -- type argument to a foreign export (eg. Int ==> Int#). -getPrimTyOf :: Type -> Type +getPrimTyOf :: Type -> UnaryType getPrimTyOf ty | isBoolTy rep_ty = intPrimTy -- Except for Bool, the types we are interested in have a single constructor @@ -752,7 +755,7 @@ getPrimTyOf ty prim_ty _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty) where - rep_ty = repType ty + UnaryRep rep_ty = repType ty -- represent a primitive type as a Char, for building a string that -- described the foreign function type. The types are size-dependent, |