Commit 2e43779c authored by Simon Peyton Jones's avatar Simon Peyton Jones

Merge branch 'master' of http://darcs.haskell.org/ghc

parents 545bb796 9f68ccec
This diff is collapsed.
...@@ -48,6 +48,8 @@ module Module ...@@ -48,6 +48,8 @@ module Module
pprModule, pprModule,
mkModule, mkModule,
stableModuleCmp, stableModuleCmp,
HasModule(..),
ContainsModule(..),
-- * The ModuleLocation type -- * The ModuleLocation type
ModLocation(..), ModLocation(..),
...@@ -276,6 +278,12 @@ pprPackagePrefix p mod = getPprStyle doc ...@@ -276,6 +278,12 @@ pprPackagePrefix p mod = getPprStyle doc
-- the PrintUnqualified tells us which modules have to -- the PrintUnqualified tells us which modules have to
-- be qualified with package names -- be qualified with package names
| otherwise = empty | otherwise = empty
class ContainsModule t where
extractModule :: t -> Module
class HasModule m where
getModule :: m Module
\end{code} \end{code}
%************************************************************************ %************************************************************************
......
This diff is collapsed.
...@@ -1065,6 +1065,12 @@ doReturn exprs_code = do ...@@ -1065,6 +1065,12 @@ doReturn exprs_code = do
updfr_off <- getUpdFrameOff updfr_off <- getUpdFrameOff
emit (mkReturnSimple dflags exprs updfr_off) emit (mkReturnSimple dflags exprs updfr_off)
mkReturnSimple :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkReturnSimple dflags actuals updfr_off =
mkReturn dflags e actuals updfr_off
where e = entryCode dflags (CmmLoad (CmmStackSlot Old updfr_off)
(gcWord dflags))
doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse () doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse ()
doRawJump expr_code vols = do doRawJump expr_code vols = do
dflags <- getDynFlags dflags <- getDynFlags
......
...@@ -12,7 +12,7 @@ module MkGraph ...@@ -12,7 +12,7 @@ module MkGraph
, mkJump, mkJumpExtra, mkDirectJump, mkForeignJump, mkForeignJumpExtra , mkJump, mkJumpExtra, mkDirectJump, mkForeignJump, mkForeignJumpExtra
, mkRawJump , mkRawJump
, mkCbranch, mkSwitch , mkCbranch, mkSwitch
, mkReturn, mkReturnSimple, mkComment, mkCallEntry, mkBranch , mkReturn, mkComment, mkCallEntry, mkBranch
, copyInOflow, copyOutOflow , copyInOflow, copyOutOflow
, noExtraStack , noExtraStack
, toCall, Transfer(..) , toCall, Transfer(..)
...@@ -23,7 +23,6 @@ import BlockId ...@@ -23,7 +23,6 @@ import BlockId
import Cmm import Cmm
import CmmCallConv import CmmCallConv
import Compiler.Hoopl hiding (Unique, (<*>), mkFirst, mkMiddle, mkLast, mkLabel, mkBranch, Shape(..)) import Compiler.Hoopl hiding (Unique, (<*>), mkFirst, mkMiddle, mkLast, mkLabel, mkBranch, Shape(..))
import DynFlags import DynFlags
import FastString import FastString
...@@ -241,11 +240,6 @@ mkReturn dflags e actuals updfr_off = ...@@ -241,11 +240,6 @@ mkReturn dflags e actuals updfr_off =
lastWithArgs dflags Ret Old NativeReturn actuals updfr_off $ lastWithArgs dflags Ret Old NativeReturn actuals updfr_off $
toCall e Nothing updfr_off 0 toCall e Nothing updfr_off 0
mkReturnSimple :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
mkReturnSimple dflags actuals updfr_off =
mkReturn dflags e actuals updfr_off
where e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord dflags)
mkBranch :: BlockId -> CmmAGraph mkBranch :: BlockId -> CmmAGraph
mkBranch bid = mkLast (CmmBranch bid) mkBranch bid = mkLast (CmmBranch bid)
......
...@@ -306,6 +306,11 @@ loadThreadState dflags tso stack = do ...@@ -306,6 +306,11 @@ loadThreadState dflags tso stack = do
-- SpLim = stack->stack + RESERVED_STACK_WORDS; -- SpLim = stack->stack + RESERVED_STACK_WORDS;
mkAssign spLim (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags)) mkAssign spLim (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags))
(rESERVED_STACK_WORDS dflags)), (rESERVED_STACK_WORDS dflags)),
-- HpAlloc = 0;
-- HpAlloc is assumed to be set to non-zero only by a failed
-- a heap check, see HeapStackCheck.cmm:GC_GENERIC
mkAssign hpAlloc (zeroExpr dflags),
openNursery dflags, openNursery dflags,
-- and load the current cost centre stack from the TSO when profiling: -- and load the current cost centre stack from the TSO when profiling:
if gopt Opt_SccProfilingOn dflags then if gopt Opt_SccProfilingOn dflags then
...@@ -367,13 +372,14 @@ stgHp = CmmReg hp ...@@ -367,13 +372,14 @@ stgHp = CmmReg hp
stgCurrentTSO = CmmReg currentTSO stgCurrentTSO = CmmReg currentTSO
stgCurrentNursery = CmmReg currentNursery stgCurrentNursery = CmmReg currentNursery
sp, spLim, hp, hpLim, currentTSO, currentNursery :: CmmReg sp, spLim, hp, hpLim, currentTSO, currentNursery, hpAlloc :: CmmReg
sp = CmmGlobal Sp sp = CmmGlobal Sp
spLim = CmmGlobal SpLim spLim = CmmGlobal SpLim
hp = CmmGlobal Hp hp = CmmGlobal Hp
hpLim = CmmGlobal HpLim hpLim = CmmGlobal HpLim
currentTSO = CmmGlobal CurrentTSO currentTSO = CmmGlobal CurrentTSO
currentNursery = CmmGlobal CurrentNursery currentNursery = CmmGlobal CurrentNursery
hpAlloc = CmmGlobal HpAlloc
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- For certain types passed to foreign calls, we adjust the actual -- For certain types passed to foreign calls, we adjust the actual
......
...@@ -6,13 +6,6 @@ ...@@ -6,13 +6,6 @@
-- --
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details
module StgCmmPrim ( module StgCmmPrim (
cgOpApp, cgOpApp,
cgPrimOp -- internal(ish), used by cgCase to get code for a cgPrimOp -- internal(ish), used by cgCase to get code for a
...@@ -36,7 +29,7 @@ import BasicTypes ...@@ -36,7 +29,7 @@ import BasicTypes
import MkGraph import MkGraph
import StgSyn import StgSyn
import Cmm import Cmm
import Type ( Type, tyConAppTyCon ) import Type ( Type, tyConAppTyCon )
import TyCon import TyCon
import CLabel import CLabel
import CmmUtils import CmmUtils
...@@ -51,62 +44,62 @@ import Control.Monad (liftM) ...@@ -51,62 +44,62 @@ import Control.Monad (liftM)
import Data.Bits import Data.Bits
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- Primitive operations and foreign calls -- Primitive operations and foreign calls
------------------------------------------------------------------------ ------------------------------------------------------------------------
{- Note [Foreign call results] {- Note [Foreign call results]
~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~
A foreign call always returns an unboxed tuple of results, one A foreign call always returns an unboxed tuple of results, one
of which is the state token. This seems to happen even for pure of which is the state token. This seems to happen even for pure
calls. calls.
Even if we returned a single result for pure calls, it'd still be Even if we returned a single result for pure calls, it'd still be
right to wrap it in a singleton unboxed tuple, because the result right to wrap it in a singleton unboxed tuple, because the result
might be a Haskell closure pointer, we don't want to evaluate it. -} might be a Haskell closure pointer, we don't want to evaluate it. -}
---------------------------------- ----------------------------------
cgOpApp :: StgOp -- The op cgOpApp :: StgOp -- The op
-> [StgArg] -- Arguments -> [StgArg] -- Arguments
-> Type -- Result type (always an unboxed tuple) -> Type -- Result type (always an unboxed tuple)
-> FCode ReturnKind -> FCode ReturnKind
-- Foreign calls -- Foreign calls
cgOpApp (StgFCallOp fcall _) stg_args res_ty cgOpApp (StgFCallOp fcall _) stg_args res_ty
= cgForeignCall fcall stg_args res_ty = cgForeignCall fcall stg_args res_ty
-- Note [Foreign call results] -- Note [Foreign call results]
-- tagToEnum# is special: we need to pull the constructor -- tagToEnum# is special: we need to pull the constructor
-- out of the table, and perform an appropriate return. -- out of the table, and perform an appropriate return.
cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty
= ASSERT(isEnumerationTyCon tycon) = ASSERT(isEnumerationTyCon tycon)
do { dflags <- getDynFlags do { dflags <- getDynFlags
; args' <- getNonVoidArgAmodes [arg] ; args' <- getNonVoidArgAmodes [arg]
; let amode = case args' of [amode] -> amode ; let amode = case args' of [amode] -> amode
_ -> panic "TagToEnumOp had void arg" _ -> panic "TagToEnumOp had void arg"
; emitReturn [tagToClosure dflags tycon amode] } ; emitReturn [tagToClosure dflags tycon amode] }
where where
-- If you're reading this code in the attempt to figure -- If you're reading this code in the attempt to figure
-- out why the compiler panic'ed here, it is probably because -- out why the compiler panic'ed here, it is probably because
-- you used tagToEnum# in a non-monomorphic setting, e.g., -- you used tagToEnum# in a non-monomorphic setting, e.g.,
-- intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x# -- intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#
-- That won't work. -- That won't work.
tycon = tyConAppTyCon res_ty tycon = tyConAppTyCon res_ty
cgOpApp (StgPrimOp primop) args res_ty cgOpApp (StgPrimOp primop) args res_ty
| primOpOutOfLine primop | primOpOutOfLine primop
= do { cmm_args <- getNonVoidArgAmodes args = do { cmm_args <- getNonVoidArgAmodes args
; let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop)) ; let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))
; emitCall (NativeNodeCall, NativeReturn) fun cmm_args } ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args }
| ReturnsPrim VoidRep <- result_info | ReturnsPrim VoidRep <- result_info
= do cgPrimOp [] primop args = do cgPrimOp [] primop args
emitReturn [] emitReturn []
| ReturnsPrim rep <- result_info | ReturnsPrim rep <- result_info
= do dflags <- getDynFlags = do dflags <- getDynFlags
res <- newTemp (primRepCmmType dflags rep) res <- newTemp (primRepCmmType dflags rep)
cgPrimOp [res] primop args cgPrimOp [res] primop args
emitReturn [CmmReg (CmmLocal res)] emitReturn [CmmReg (CmmLocal res)]
| ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon
...@@ -116,7 +109,7 @@ cgOpApp (StgPrimOp primop) args res_ty ...@@ -116,7 +109,7 @@ cgOpApp (StgPrimOp primop) args res_ty
| ReturnsAlg tycon <- result_info | ReturnsAlg tycon <- result_info
, isEnumerationTyCon tycon , isEnumerationTyCon tycon
-- c.f. cgExpr (...TagToEnumOp...) -- c.f. cgExpr (...TagToEnumOp...)
= do dflags <- getDynFlags = do dflags <- getDynFlags
tag_reg <- newTemp (bWord dflags) tag_reg <- newTemp (bWord dflags)
cgPrimOp [tag_reg] primop args cgPrimOp [tag_reg] primop args
...@@ -128,15 +121,15 @@ cgOpApp (StgPrimOp primop) args res_ty ...@@ -128,15 +121,15 @@ cgOpApp (StgPrimOp primop) args res_ty
result_info = getPrimOpResultInfo primop result_info = getPrimOpResultInfo primop
cgOpApp (StgPrimCallOp primcall) args _res_ty cgOpApp (StgPrimCallOp primcall) args _res_ty
= do { cmm_args <- getNonVoidArgAmodes args = do { cmm_args <- getNonVoidArgAmodes args
; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall)) ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall))
; emitCall (NativeNodeCall, NativeReturn) fun cmm_args } ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args }
--------------------------------------------------- ---------------------------------------------------
cgPrimOp :: [LocalReg] -- where to put the results cgPrimOp :: [LocalReg] -- where to put the results
-> PrimOp -- the op -> PrimOp -- the op
-> [StgArg] -- arguments -> [StgArg] -- arguments
-> FCode () -> FCode ()
cgPrimOp results op args cgPrimOp results op args
= do dflags <- getDynFlags = do dflags <- getDynFlags
...@@ -145,35 +138,35 @@ cgPrimOp results op args ...@@ -145,35 +138,35 @@ cgPrimOp results op args
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- Emitting code for a primop -- Emitting code for a primop
------------------------------------------------------------------------ ------------------------------------------------------------------------
emitPrimOp :: DynFlags emitPrimOp :: DynFlags
-> [LocalReg] -- where to put the results -> [LocalReg] -- where to put the results
-> PrimOp -- the op -> PrimOp -- the op
-> [CmmExpr] -- arguments -> [CmmExpr] -- arguments
-> FCode () -> FCode ()
-- First we handle various awkward cases specially. The remaining -- First we handle various awkward cases specially. The remaining
-- easy cases are then handled by translateOp, defined below. -- easy cases are then handled by translateOp, defined below.
emitPrimOp dflags [res_r,res_c] IntAddCOp [aa,bb] emitPrimOp dflags [res_r,res_c] IntAddCOp [aa,bb]
{- {-
With some bit-twiddling, we can define int{Add,Sub}Czh portably in With some bit-twiddling, we can define int{Add,Sub}Czh portably in
C, and without needing any comparisons. This may not be the C, and without needing any comparisons. This may not be the
fastest way to do it - if you have better code, please send it! --SDM fastest way to do it - if you have better code, please send it! --SDM
Return : r = a + b, c = 0 if no overflow, 1 on overflow. Return : r = a + b, c = 0 if no overflow, 1 on overflow.
We currently don't make use of the r value if c is != 0 (i.e. We currently don't make use of the r value if c is != 0 (i.e.
overflow), we just convert to big integers and try again. This overflow), we just convert to big integers and try again. This
could be improved by making r and c the correct values for could be improved by making r and c the correct values for
plugging into a new J#. plugging into a new J#.
{ r = ((I_)(a)) + ((I_)(b)); \ { r = ((I_)(a)) + ((I_)(b)); \
c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \
>> (BITS_IN (I_) - 1); \ >> (BITS_IN (I_) - 1); \
} }
Wading through the mass of bracketry, it seems to reduce to: Wading through the mass of bracketry, it seems to reduce to:
c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1) c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)
...@@ -181,22 +174,22 @@ emitPrimOp dflags [res_r,res_c] IntAddCOp [aa,bb] ...@@ -181,22 +174,22 @@ emitPrimOp dflags [res_r,res_c] IntAddCOp [aa,bb]
= emit $ catAGraphs [ = emit $ catAGraphs [
mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]), mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]),
mkAssign (CmmLocal res_c) $ mkAssign (CmmLocal res_c) $
CmmMachOp (mo_wordUShr dflags) [ CmmMachOp (mo_wordUShr dflags) [
CmmMachOp (mo_wordAnd dflags) [ CmmMachOp (mo_wordAnd dflags) [
CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]], CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]],
CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]
], ],
mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1) mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)
] ]
] ]
emitPrimOp dflags [res_r,res_c] IntSubCOp [aa,bb] emitPrimOp dflags [res_r,res_c] IntSubCOp [aa,bb]
{- Similarly: {- Similarly:
#define subIntCzh(r,c,a,b) \ #define subIntCzh(r,c,a,b) \
{ r = ((I_)(a)) - ((I_)(b)); \ { r = ((I_)(a)) - ((I_)(b)); \
c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \
>> (BITS_IN (I_) - 1); \ >> (BITS_IN (I_) - 1); \
} }
c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1) c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)
...@@ -204,24 +197,24 @@ emitPrimOp dflags [res_r,res_c] IntSubCOp [aa,bb] ...@@ -204,24 +197,24 @@ emitPrimOp dflags [res_r,res_c] IntSubCOp [aa,bb]
= emit $ catAGraphs [ = emit $ catAGraphs [
mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]), mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]),
mkAssign (CmmLocal res_c) $ mkAssign (CmmLocal res_c) $
CmmMachOp (mo_wordUShr dflags) [ CmmMachOp (mo_wordUShr dflags) [
CmmMachOp (mo_wordAnd dflags) [ CmmMachOp (mo_wordAnd dflags) [
CmmMachOp (mo_wordXor dflags) [aa,bb], CmmMachOp (mo_wordXor dflags) [aa,bb],
CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]
], ],
mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1) mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)
] ]
] ]
emitPrimOp _ [res] ParOp [arg] emitPrimOp _ [res] ParOp [arg]
= =
-- for now, just implement this in a C function -- for now, just implement this in a C function
-- later, we might want to inline it. -- later, we might want to inline it.
emitCCall emitCCall
[(res,NoHint)] [(res,NoHint)]
(CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark")))) (CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark"))))
[(CmmReg (CmmGlobal BaseReg), AddrHint), (arg,AddrHint)] [(CmmReg (CmmGlobal BaseReg), AddrHint), (arg,AddrHint)]
emitPrimOp dflags [res] SparkOp [arg] emitPrimOp dflags [res] SparkOp [arg]
= do = do
...@@ -251,10 +244,10 @@ emitPrimOp dflags [res] ReadMutVarOp [mutv] ...@@ -251,10 +244,10 @@ emitPrimOp dflags [res] ReadMutVarOp [mutv]
emitPrimOp dflags [] WriteMutVarOp [mutv,var] emitPrimOp dflags [] WriteMutVarOp [mutv,var]
= do emitStore (cmmOffsetW dflags mutv (fixedHdrSize dflags)) var = do emitStore (cmmOffsetW dflags mutv (fixedHdrSize dflags)) var
emitCCall emitCCall
[{-no results-}] [{-no results-}]
(CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
[(CmmReg (CmmGlobal BaseReg), AddrHint), (mutv,AddrHint)] [(CmmReg (CmmGlobal BaseReg), AddrHint), (mutv,AddrHint)]
-- #define sizzeofByteArrayzh(r,a) \ -- #define sizzeofByteArrayzh(r,a) \
-- r = ((StgArrWords *)(a))->bytes -- r = ((StgArrWords *)(a))->bytes
...@@ -279,7 +272,7 @@ emitPrimOp dflags [res] ByteArrayContents_Char [arg] ...@@ -279,7 +272,7 @@ emitPrimOp dflags [res] ByteArrayContents_Char [arg]
emitPrimOp dflags [res] StableNameToIntOp [arg] emitPrimOp dflags [res] StableNameToIntOp [arg]
= emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSize dflags) (bWord dflags)) = emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSize dflags) (bWord dflags))
-- #define eqStableNamezh(r,sn1,sn2) \ -- #define eqStableNamezh(r,sn1,sn2) \
-- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn)) -- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
emitPrimOp dflags [res] EqStableNameOp [arg1,arg2] emitPrimOp dflags [res] EqStableNameOp [arg1,arg2]
= emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [ = emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [
...@@ -303,13 +296,13 @@ emitPrimOp dflags [res] DataToTagOp [arg] ...@@ -303,13 +296,13 @@ emitPrimOp dflags [res] DataToTagOp [arg]
{- Freezing arrays-of-ptrs requires changing an info table, for the {- Freezing arrays-of-ptrs requires changing an info table, for the
benefit of the generational collector. It needs to scavenge mutable benefit of the generational collector. It needs to scavenge mutable
objects, even if they are in old space. When they become immutable, objects, even if they are in old space. When they become immutable,
they can be removed from this scavenge list. -} they can be removed from this scavenge list. -}
-- #define unsafeFreezzeArrayzh(r,a) -- #define unsafeFreezzeArrayzh(r,a)
-- { -- {
-- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN0_info); -- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN0_info);
-- r = a; -- r = a;
-- } -- }
emitPrimOp _ [res] UnsafeFreezeArrayOp [arg] emitPrimOp _ [res] UnsafeFreezeArrayOp [arg]
= emit $ catAGraphs = emit $ catAGraphs
[ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)), [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)),
...@@ -319,7 +312,7 @@ emitPrimOp _ [res] UnsafeFreezeArrayArrayOp [arg] ...@@ -319,7 +312,7 @@ emitPrimOp _ [res] UnsafeFreezeArrayArrayOp [arg]
[ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)), [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)),
mkAssign (CmmLocal res) arg ] mkAssign (CmmLocal res) arg ]
-- #define unsafeFreezzeByteArrayzh(r,a) r=(a) -- #define unsafeFreezzeByteArrayzh(r,a) r=(a)
emitPrimOp _ [res] UnsafeFreezeByteArrayOp [arg] emitPrimOp _ [res] UnsafeFreezeByteArrayOp [arg]
= emitAssign (CmmLocal res) arg = emitAssign (CmmLocal res) arg
...@@ -492,16 +485,11 @@ emitPrimOp _ [] SetByteArrayOp [ba,off,len,c] = ...@@ -492,16 +485,11 @@ emitPrimOp _ [] SetByteArrayOp [ba,off,len,c] =
doSetByteArrayOp ba off len c doSetByteArrayOp ba off len c
-- Population count -- Population count
emitPrimOp dflags [res] PopCnt8Op [w] = emitPrimOp _ [res] PopCnt8Op [w] = emitPopCntCall res w W8
emitPopCntCall res (CmmMachOp (mo_WordTo8 dflags) [w]) W8 emitPrimOp _ [res] PopCnt16Op [w] = emitPopCntCall res w W16
emitPrimOp dflags [res] PopCnt16Op [w] = emitPrimOp _ [res] PopCnt32Op [w] = emitPopCntCall res w W32
emitPopCntCall res (CmmMachOp (mo_WordTo16 dflags) [w]) W16 emitPrimOp _ [res] PopCnt64Op [w] = emitPopCntCall res w W64
emitPrimOp dflags [res] PopCnt32Op [w] = emitPrimOp dflags [res] PopCntOp [w] = emitPopCntCall res w (wordWidth dflags)
emitPopCntCall res (CmmMachOp (mo_WordTo32 dflags) [w]) W32
emitPrimOp _ [res] PopCnt64Op [w] =
emitPopCntCall res w W64 -- arg always has type W64, no need to narrow
emitPrimOp dflags [res] PopCntOp [w] =
emitPopCntCall res w (wordWidth dflags)
-- The rest just translate straightforwardly -- The rest just translate straightforwardly
emitPrimOp dflags [res] op [arg] emitPrimOp dflags [res] op [arg]
...@@ -695,9 +683,9 @@ nopOp Int2WordOp = True ...@@ -695,9 +683,9 @@ nopOp Int2WordOp = True
nopOp Word2IntOp = True nopOp Word2IntOp = True
nopOp Int2AddrOp = True nopOp Int2AddrOp = True
nopOp Addr2IntOp = True nopOp Addr2IntOp = True
nopOp ChrOp = True -- Int# and Char# are rep'd the same nopOp ChrOp = True -- Int# and Char# are rep'd the same
nopOp OrdOp = True nopOp OrdOp = True
nopOp _ = False nopOp _ = False
-- These PrimOps turn into double casts -- These PrimOps turn into double casts
...@@ -708,7 +696,7 @@ narrowOp Narrow32IntOp = Just (MO_SS_Conv, W32) ...@@ -708,7 +696,7 @@ narrowOp Narrow32IntOp = Just (MO_SS_Conv, W32)
narrowOp Narrow8WordOp = Just (MO_UU_Conv, W8) narrowOp Narrow8WordOp = Just (MO_UU_Conv, W8)
narrowOp Narrow16WordOp = Just (MO_UU_Conv, W16) narrowOp Narrow16WordOp = Just (MO_UU_Conv, W16)
narrowOp Narrow32WordOp = Just (MO_UU_Conv, W32) narrowOp Narrow32WordOp = Just (MO_UU_Conv, W32)
narrowOp _ = Nothing narrowOp _ = Nothing
-- Native word signless ops -- Native word signless ops
...@@ -879,7 +867,7 @@ doIndexByteArrayOp :: Maybe MachOp -> CmmType -> [LocalReg] -> [CmmExpr] -> FCod ...@@ -879,7 +867,7 @@ doIndexByteArrayOp :: Maybe MachOp -> CmmType -> [LocalReg] -> [CmmExpr] -> FCod
doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx] doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]
= do dflags <- getDynFlags = do dflags <- getDynFlags
mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx
doIndexByteArrayOp _ _ _ _ doIndexByteArrayOp _ _ _ _
= panic "CgPrimOp: doIndexByteArrayOp" = panic "CgPrimOp: doIndexByteArrayOp"
doReadPtrArrayOp :: LocalReg -> CmmExpr -> CmmExpr -> FCode () doReadPtrArrayOp :: LocalReg -> CmmExpr -> CmmExpr -> FCode ()
...@@ -898,7 +886,7 @@ doWriteByteArrayOp :: Maybe MachOp -> [LocalReg] -> [CmmExpr] -> FCode () ...@@ -898,7 +886,7 @@ doWriteByteArrayOp :: Maybe MachOp -> [LocalReg] -> [CmmExpr] -> FCode ()
doWriteByteArrayOp maybe_pre_write_cast [] [addr,idx,val] doWriteByteArrayOp maybe_pre_write_cast [] [addr,idx,val]
= do dflags <- getDynFlags = do dflags <- getDynFlags
mkBasicIndexedWrite (arrWordsHdrSize dflags) maybe_pre_write_cast addr idx val mkBasicIndexedWrite (arrWordsHdrSize dflags) maybe_pre_write_cast addr idx val
doWriteByteArrayOp _ _ _ doWriteByteArrayOp _ _ _
= panic "CgPrimOp: doWriteByteArrayOp" = panic "CgPrimOp: doWriteByteArrayOp"