summaryrefslogtreecommitdiff
path: root/compiler/GHC/StgToCmm
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/StgToCmm')
-rw-r--r--compiler/GHC/StgToCmm/Bind.hs8
-rw-r--r--compiler/GHC/StgToCmm/Expr.hs2
-rw-r--r--compiler/GHC/StgToCmm/Foreign.hs20
-rw-r--r--compiler/GHC/StgToCmm/Prim.hs15
-rw-r--r--compiler/GHC/StgToCmm/Prof.hs12
-rw-r--r--compiler/GHC/StgToCmm/Utils.hs32
6 files changed, 51 insertions, 38 deletions
diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs
index 9e192a0ac8..325686aaa8 100644
--- a/compiler/GHC/StgToCmm/Bind.hs
+++ b/compiler/GHC/StgToCmm/Bind.hs
@@ -52,6 +52,8 @@ import DynFlags
import Control.Monad
+import TyCon (PrimRep (..))
+
------------------------------------------------------------------------
-- Top-level bindings
------------------------------------------------------------------------
@@ -716,9 +718,9 @@ link_caf node = do
; let newCAF_lbl = mkForeignLabel (fsLit "newCAF") Nothing
ForeignLabelInExternalPackage IsFunction
; bh <- newTemp (bWord dflags)
- ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl
- [ (baseExpr, AddrHint),
- (CmmReg (CmmLocal node), AddrHint) ]
+ ; emitRtsCallGen [(bh, AddrRep, AddrHint)] newCAF_lbl
+ [ (baseExpr, AddrRep, AddrHint),
+ (CmmReg (CmmLocal node), AddrRep, AddrHint) ]
False
-- see Note [atomic CAF entry] in rts/sm/Storage.c
diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs
index 07113a4e82..c2d466d7d8 100644
--- a/compiler/GHC/StgToCmm/Expr.hs
+++ b/compiler/GHC/StgToCmm/Expr.hs
@@ -571,7 +571,7 @@ isSimpleScrut _ _ = return False
isSimpleOp :: StgOp -> [StgArg] -> FCode Bool
-- True iff the op cannot block or allocate
-isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe)
+isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe _ _)) _) _ = return $! not (playSafe safe)
-- dataToTag# evalautes its argument, see Note [dataToTag#] in primops.txt.pp
isSimpleOp (StgPrimOp DataToTagOp) _ = return False
isSimpleOp (StgPrimOp op) stg_args = do
diff --git a/compiler/GHC/StgToCmm/Foreign.hs b/compiler/GHC/StgToCmm/Foreign.hs
index 37eb7c5021..9c61b22c63 100644
--- a/compiler/GHC/StgToCmm/Foreign.hs
+++ b/compiler/GHC/StgToCmm/Foreign.hs
@@ -65,7 +65,7 @@ cgForeignCall :: ForeignCall -- the op
-> Type -- result type
-> FCode ReturnKind
-cgForeignCall (CCall (CCallSpec target cconv safety)) typ stg_args res_ty
+cgForeignCall (CCall (CCallSpec target cconv safety ret_rep arg_reps)) typ stg_args res_ty
= do { dflags <- getDynFlags
; let -- in the stdcall calling convention, the symbol needs @size appended
-- to it, where size is the total number of bytes of arguments. We
@@ -97,7 +97,7 @@ cgForeignCall (CCall (CCallSpec target cconv safety)) typ stg_args res_ty
DynamicTarget -> case cmm_args of
(fn,_):rest -> (unzip rest, fn)
[] -> panic "cgForeignCall []"
- fc = ForeignConvention cconv arg_hints res_hints CmmMayReturn
+ fc = ForeignConvention cconv arg_hints res_hints CmmMayReturn ret_rep arg_reps
call_target = ForeignTarget cmm_target fc
-- we want to emit code for the call, and then emitReturn.
@@ -188,17 +188,22 @@ continuation, resulting in just one proc point instead of two. Yay!
-}
-emitCCall :: [(CmmFormal,ForeignHint)]
+emitCCall :: [(CmmFormal, PrimRep, ForeignHint)]
-> CmmExpr
- -> [(CmmActual,ForeignHint)]
+ -> [(CmmActual, PrimRep, ForeignHint)]
-> FCode ()
emitCCall hinted_results fn hinted_args
= void $ emitForeignCall PlayRisky results target args
where
- (args, arg_hints) = unzip hinted_args
- (results, result_hints) = unzip hinted_results
+ (args, arg_reps, arg_hints) = unzip3 hinted_args
+ (results, result_reps, result_hints) = unzip3 hinted_results
+ -- extract result, we can only deal with 0 or 1 result types.
+ res_rep = case result_reps of
+ [] -> VoidRep
+ [r] -> r
+ _ -> error "can not deal with multiple return values in emitCCall"
target = ForeignTarget fn fc
- fc = ForeignConvention CCallConv arg_hints result_hints CmmMayReturn
+ fc = ForeignConvention CCallConv arg_hints result_hints CmmMayReturn res_rep arg_reps
emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode ()
@@ -653,4 +658,3 @@ typeToStgFArgType typ
-- a type in a foreign function signature with a representationally
-- equivalent newtype.
tycon = tyConAppTyCon (unwrapType typ)
-
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index 09eb8bae47..f6689ff979 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -290,15 +290,16 @@ emitPrimOp dflags = \case
-> opAllDone $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)
_ -> PrimopCmmEmit_External
--- First we handle various awkward cases specially.
-
+ -- First we handle various awkward cases specially.
+ -- Note: StgInt newSpark (StgRegTable *reg, StgClosure *p)
+ -- StgInt is Int_64 on 64bit platforms, Int_32 on others
ParOp -> \[arg] -> opAllDone $ \[res] -> do
-- for now, just implement this in a C function
-- later, we might want to inline it.
emitCCall
- [(res,NoHint)]
+ [(res, Int64Rep, SignedHint)]
(CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))
- [(baseExpr, AddrHint), (arg,AddrHint)]
+ [(baseExpr, AddrRep, AddrHint), (arg, AddrRep, AddrHint)]
SparkOp -> \[arg] -> opAllDone $ \[res] -> do
-- returns the value of arg in res. We're going to therefore
@@ -307,9 +308,9 @@ emitPrimOp dflags = \case
tmp <- assignTemp arg
tmp2 <- newTemp (bWord dflags)
emitCCall
- [(tmp2,NoHint)]
+ [(tmp2, Int64Rep, SignedHint)]
(CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))
- [(baseExpr, AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)]
+ [(baseExpr, AddrRep, AddrHint), ((CmmReg (CmmLocal tmp)), AddrRep, AddrHint)]
emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp))
GetCCSOfOp -> \[arg] -> opAllDone $ \[res] -> do
@@ -342,7 +343,7 @@ emitPrimOp dflags = \case
emitCCall
[{-no results-}]
(CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
- [(baseExpr, AddrHint), (mutv, AddrHint), (CmmReg old_val, AddrHint)]
+ [(baseExpr, AddrRep, AddrHint), (mutv, AddrRep, AddrHint), (CmmReg old_val, AddrRep, AddrHint)]
-- #define sizzeofByteArrayzh(r,a) \
-- r = ((StgArrBytes *)(a))->bytes
diff --git a/compiler/GHC/StgToCmm/Prof.hs b/compiler/GHC/StgToCmm/Prof.hs
index 984c371360..c1cb023d89 100644
--- a/compiler/GHC/StgToCmm/Prof.hs
+++ b/compiler/GHC/StgToCmm/Prof.hs
@@ -44,6 +44,8 @@ import Outputable
import Control.Monad
import Data.Char (ord)
+import TyCon (PrimRep (..))
+
-----------------------------------------------------------------------------
--
-- Cost-centre-stack Profiling
@@ -178,8 +180,8 @@ enterCostCentreFun ccs closure =
if isCurrentCCS ccs
then do dflags <- getDynFlags
emitRtsCall rtsUnitId (fsLit "enterFunCCS")
- [(baseExpr, AddrHint),
- (costCentreFrom dflags closure, AddrHint)] False
+ [(baseExpr, AddrRep, AddrHint),
+ (costCentreFrom dflags closure, AddrRep, AddrHint)] False
else return () -- top-level function, nothing to do
ifProfiling :: FCode () -> FCode ()
@@ -278,10 +280,10 @@ emitSetCCC cc tick push
pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()
pushCostCentre result ccs cc
- = emitRtsCallWithResult result AddrHint
+ = emitRtsCallWithResult result AddrRep AddrHint
rtsUnitId
- (fsLit "pushCostCentre") [(ccs,AddrHint),
- (CmmLit (mkCCostCentre cc), AddrHint)]
+ (fsLit "pushCostCentre") [(ccs, AddrRep, AddrHint),
+ (CmmLit (mkCCostCentre cc), AddrRep, AddrHint)]
False
bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph
diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs
index 3b145b5441..d7b95bc9aa 100644
--- a/compiler/GHC/StgToCmm/Utils.hs
+++ b/compiler/GHC/StgToCmm/Utils.hs
@@ -179,19 +179,19 @@ tagToClosure dflags tycon tag
--
-------------------------------------------------------------------------
-emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
+emitRtsCall :: UnitId -> FastString -> [(CmmExpr, PrimRep, ForeignHint)] -> Bool -> FCode ()
emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe
-emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> FastString
- -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
-emitRtsCallWithResult res hint pkg fun args safe
- = emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe
+emitRtsCallWithResult :: LocalReg -> PrimRep -> ForeignHint -> UnitId -> FastString
+ -> [(CmmExpr, PrimRep, ForeignHint)] -> Bool -> FCode ()
+emitRtsCallWithResult res rep hint pkg fun args safe
+ = emitRtsCallGen [(res, rep, hint)] (mkCmmCodeLabel pkg fun) args safe
-- Make a call to an RTS C procedure
emitRtsCallGen
- :: [(LocalReg,ForeignHint)]
+ :: [(LocalReg, PrimRep, ForeignHint)]
-> CLabel
- -> [(CmmExpr,ForeignHint)]
+ -> [(CmmExpr, PrimRep, ForeignHint)]
-> Bool -- True <=> CmmSafe call
-> FCode ()
emitRtsCallGen res lbl args safe
@@ -206,10 +206,14 @@ emitRtsCallGen res lbl args safe
if safe then
emit =<< mkCmmCall fun_expr res' args' updfr_off
else do
- let conv = ForeignConvention CCallConv arg_hints res_hints CmmMayReturn
+ let conv = ForeignConvention CCallConv arg_hints res_hints CmmMayReturn res_rep arg_reps
emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args'
- (args', arg_hints) = unzip args
- (res', res_hints) = unzip res
+ (args', arg_reps, arg_hints) = unzip3 args
+ (res', res_reps, res_hints) = unzip3 res
+ res_rep = case res_reps of
+ [] -> VoidRep
+ [r] -> r
+ _ -> error "can not deal with multiple return values"
fun_expr = mkLblExpr lbl
@@ -608,8 +612,8 @@ emitUpdRemSetPush ptr = do
emitRtsCall
rtsUnitId
(fsLit "updateRemembSetPushClosure_")
- [(CmmReg (CmmGlobal BaseReg), AddrHint),
- (ptr, AddrHint)]
+ [(CmmReg (CmmGlobal BaseReg), AddrRep, AddrHint),
+ (ptr, AddrRep, AddrHint)]
False
emitUpdRemSetPushThunk :: CmmExpr -- ^ the thunk
@@ -618,6 +622,6 @@ emitUpdRemSetPushThunk ptr = do
emitRtsCall
rtsUnitId
(fsLit "updateRemembSetPushThunk_")
- [(CmmReg (CmmGlobal BaseReg), AddrHint),
- (ptr, AddrHint)]
+ [(CmmReg (CmmGlobal BaseReg), AddrRep, AddrHint),
+ (ptr, AddrRep, AddrHint)]
False
View Lorry Controller Status