summaryrefslogtreecommitdiff
path: root/compiler/codeGen
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/codeGen')
-rw-r--r--compiler/codeGen/StgCmm.hs6
-rw-r--r--compiler/codeGen/StgCmmArgRep.hs3
-rw-r--r--compiler/codeGen/StgCmmClosure.hs10
-rw-r--r--compiler/codeGen/StgCmmEnv.hs5
-rw-r--r--compiler/codeGen/StgCmmExpr.hs18
-rw-r--r--compiler/codeGen/StgCmmForeign.hs11
-rw-r--r--compiler/codeGen/StgCmmUtils.hs6
7 files changed, 33 insertions, 26 deletions
diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs
index aac556d43f..bb82da265e 100644
--- a/compiler/codeGen/StgCmm.hs
+++ b/compiler/codeGen/StgCmm.hs
@@ -232,10 +232,10 @@ cgDataCon data_con
-- We're generating info tables, so we don't know and care about
-- what the actual arguments are. Using () here as the place holder.
arg_reps :: [NonVoid PrimRep]
- arg_reps = [ NonVoid (typePrimRep rep_ty)
+ arg_reps = [ NonVoid rep_ty
| ty <- dataConRepArgTys data_con
- , rep_ty <- repTypeArgs ty
- , not (isVoidTy rep_ty)]
+ , rep_ty <- typePrimRep ty
+ , not (isVoidRep rep_ty) ]
; emitClosureAndInfoTable dyn_info_tbl NativeDirectCall [] $
-- NB: the closure pointer is assumed *untagged* on
diff --git a/compiler/codeGen/StgCmmArgRep.hs b/compiler/codeGen/StgCmmArgRep.hs
index 9821b0a267..969e14f79e 100644
--- a/compiler/codeGen/StgCmmArgRep.hs
+++ b/compiler/codeGen/StgCmmArgRep.hs
@@ -64,7 +64,8 @@ argRepString V64 = "V64"
toArgRep :: PrimRep -> ArgRep
toArgRep VoidRep = V
-toArgRep PtrRep = P
+toArgRep LiftedRep = P
+toArgRep UnliftedRep = P
toArgRep IntRep = N
toArgRep WordRep = N
toArgRep AddrRep = N
diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
index 7b9813a5e3..3cc0af0669 100644
--- a/compiler/codeGen/StgCmmClosure.hs
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -163,8 +163,8 @@ assertNonVoidStgArgs args = ASSERT(not (any (isVoidTy . stgArgType) args))
-- Why are these here?
idPrimRep :: Id -> PrimRep
-idPrimRep id = typePrimRep (idType id)
- -- NB: typePrimRep fails on unboxed tuples,
+idPrimRep id = typePrimRep1 (idType id)
+ -- NB: typePrimRep1 fails on unboxed tuples,
-- but by StgCmm no Ids have unboxed tuple type
addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)]
@@ -176,7 +176,7 @@ addArgReps = map (\arg -> let arg' = fromNonVoid arg
in NonVoid (argPrimRep arg', arg'))
argPrimRep :: StgArg -> PrimRep
-argPrimRep arg = typePrimRep (stgArgType arg)
+argPrimRep arg = typePrimRep1 (stgArgType arg)
-----------------------------------------------------------------------------
@@ -292,8 +292,8 @@ might_be_a_function :: Type -> Bool
-- Return False only if we are *sure* it's a data type
-- Look through newtypes etc as much as poss
might_be_a_function ty
- | UnaryRep rep <- repType ty
- , Just tc <- tyConAppTyCon_maybe rep
+ | [LiftedRep] <- typePrimRep ty
+ , Just tc <- tyConAppTyCon_maybe (unwrapType ty)
, isDataTyCon tc
= False
| otherwise
diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs
index 01c99ecf8c..ba093fee88 100644
--- a/compiler/codeGen/StgCmmEnv.hs
+++ b/compiler/codeGen/StgCmmEnv.hs
@@ -193,7 +193,4 @@ idToReg :: DynFlags -> NonVoid Id -> LocalReg
-- about accidental collision
idToReg dflags (NonVoid id)
= LocalReg (idUnique id)
- (case idPrimRep id of VoidRep -> pprPanic "idToReg" (ppr id)
- _ -> primRepCmmType dflags (idPrimRep id))
-
-
+ (primRepCmmType dflags (idPrimRep id))
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 8282f1ec88..9e1d7fa37f 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -39,8 +39,8 @@ import ForeignCall
import Id
import PrimOp
import TyCon
-import Type
-import RepType ( isVoidTy, countConRepArgs )
+import Type ( isUnliftedType )
+import RepType ( isVoidTy, countConRepArgs, primRepSlot )
import CostCentre ( CostCentreStack, currentCCS )
import Maybes
import Util
@@ -49,6 +49,7 @@ import Outputable
import Control.Monad (unless,void)
import Control.Arrow (first)
+import Data.Function ( on )
import Prelude hiding ((<*>))
@@ -402,14 +403,23 @@ cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts
= -- assignment suffices for unlifted types
do { dflags <- getDynFlags
; unless reps_compatible $
- panic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?"
+ pprPanic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?"
+ (pp_bndr v $$ pp_bndr bndr)
; v_info <- getCgIdInfo v
; emitAssign (CmmLocal (idToReg dflags (NonVoid bndr)))
(idInfoToAmode v_info)
; bindArgToReg (NonVoid bndr)
; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type alts }
where
- reps_compatible = idPrimRep v == idPrimRep bndr
+ reps_compatible = ((==) `on` (primRepSlot . idPrimRep)) v bndr
+ -- Must compare SlotTys, not proper PrimReps, because with unboxed sums,
+ -- the types of the binders are generated from slotPrimRep and might not
+ -- match. Test case:
+ -- swap :: (# Int | Int #) -> (# Int | Int #)
+ -- swap (# x | #) = (# | x #)
+ -- swap (# | y #) = (# y | #)
+
+ pp_bndr id = ppr id <+> dcolon <+> ppr (idType id) <+> parens (ppr (idPrimRep id))
{- Note [Dodgy unsafeCoerce 2, #3132]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
index d12eaaf0b8..2e3ed39a37 100644
--- a/compiler/codeGen/StgCmmForeign.hs
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -525,16 +525,16 @@ getFCallArgs args
= do { mb_cmms <- mapM get args
; return (catMaybes mb_cmms) }
where
- get arg | isVoidRep arg_rep
+ get arg | null arg_reps
= return Nothing
| otherwise
= do { cmm <- getArgAmode (NonVoid arg)
; dflags <- getDynFlags
; return (Just (add_shim dflags arg_ty cmm, hint)) }
where
- arg_ty = stgArgType arg
- arg_rep = typePrimRep arg_ty
- hint = typeForeignHint arg_ty
+ arg_ty = stgArgType arg
+ arg_reps = typePrimRep arg_ty
+ hint = typeForeignHint arg_ty
add_shim :: DynFlags -> Type -> CmmExpr -> CmmExpr
add_shim dflags arg_ty expr
@@ -549,6 +549,5 @@ add_shim dflags arg_ty expr
| otherwise = expr
where
- UnaryRep rep_ty = repType arg_ty
- tycon = tyConAppTyCon rep_ty
+ tycon = tyConAppTyCon (unwrapType arg_ty)
-- should be a tycon app, since this is a foreign call
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index dedc114e9e..4a976e68af 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -362,11 +362,11 @@ newUnboxedTupleRegs res_ty
; sequel <- getSequel
; regs <- choose_regs dflags sequel
; ASSERT( regs `equalLength` reps )
- return (regs, map slotForeignHint reps) }
+ return (regs, map primRepForeignHint reps) }
where
- MultiRep reps = repType res_ty
+ reps = typePrimRep res_ty
choose_regs _ (AssignTo regs _) = return regs
- choose_regs dflags _ = mapM (newTemp . slotCmmType dflags) reps
+ choose_regs dflags _ = mapM (newTemp . primRepCmmType dflags) reps
View Lorry Controller Status