X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcodeGen%2FCgPrimOp.hs;h=207ffe27d72f75d8f8cd3734d34599b4080ac707;hb=3cc90d192495f4f1bc2ad083a45f24427b5eebbf;hp=3993f19197fe16bde6a3ebeeab2815025874deb1;hpb=49c98d143c382a1341e1046f5ca00819a25691ba;p=ghc-hetmet.git diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs index 3993f19..207ffe2 100644 --- a/compiler/codeGen/CgPrimOp.hs +++ b/compiler/codeGen/CgPrimOp.hs @@ -1,3 +1,10 @@ +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + ----------------------------------------------------------------------------- -- -- Code generation for PrimOps. @@ -13,28 +20,27 @@ module CgPrimOp ( #include "HsVersions.h" import ForeignCall +import ClosureInfo import StgSyn import CgForeignCall import CgBindery import CgMonad import CgInfoTbls import CgUtils -import ForeignCall import Cmm import CLabel import CmmUtils import MachOp -import SMRep import PrimOp import SMRep import Constants -import StaticFlags import Outputable +import FastString -- --------------------------------------------------------------------------- -- Code generation for PrimOps -cgPrimOp :: [CmmReg] -- where to put the results +cgPrimOp :: CmmFormalsWithoutKinds -- where to put the results -> PrimOp -- the op -> [StgArg] -- arguments -> StgLiveVars -- live vars, in case we need to save them @@ -46,7 +52,7 @@ cgPrimOp results op args live emitPrimOp results op non_void_args live -emitPrimOp :: [CmmReg] -- where to put the results +emitPrimOp :: CmmFormalsWithoutKinds -- where to put the results -> PrimOp -- the op -> [CmmExpr] -- arguments -> StgLiveVars -- live vars, in case we need to save them @@ -77,12 +83,12 @@ emitPrimOp [res_r,res_c] IntAddCOp [aa,bb] live -} = stmtsC [ - CmmAssign res_r (CmmMachOp mo_wordAdd [aa,bb]), - CmmAssign res_c $ + CmmAssign (CmmLocal res_r) (CmmMachOp mo_wordAdd [aa,bb]), + CmmAssign (CmmLocal res_c) $ CmmMachOp mo_wordUShr [ CmmMachOp mo_wordAnd [ CmmMachOp mo_wordNot [CmmMachOp mo_wordXor [aa,bb]], - CmmMachOp mo_wordXor [aa, CmmReg res_r] + CmmMachOp mo_wordXor [aa, CmmReg (CmmLocal res_r)] ], CmmLit (mkIntCLit (wORD_SIZE_IN_BITS - 1)) ] @@ -100,12 +106,12 @@ emitPrimOp [res_r,res_c] IntSubCOp [aa,bb] live c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1) -} = stmtsC [ - CmmAssign res_r (CmmMachOp mo_wordSub [aa,bb]), - CmmAssign res_c $ + CmmAssign (CmmLocal res_r) (CmmMachOp mo_wordSub [aa,bb]), + CmmAssign (CmmLocal res_c) $ CmmMachOp mo_wordUShr [ CmmMachOp mo_wordAnd [ CmmMachOp mo_wordXor [aa,bb], - CmmMachOp mo_wordXor [aa, CmmReg res_r] + CmmMachOp mo_wordXor [aa, CmmReg (CmmLocal res_r)] ], CmmLit (mkIntCLit (wORD_SIZE_IN_BITS - 1)) ] @@ -118,15 +124,18 @@ emitPrimOp [res] ParOp [arg] live -- later, we might want to inline it. vols <- getVolatileRegs live emitForeignCall' PlayRisky - [(res,NoHint)] - (CmmForeignCall newspark CCallConv) - [(CmmReg (CmmGlobal BaseReg), PtrHint), (arg,PtrHint)] + [CmmHinted res NoHint] + (CmmCallee newspark CCallConv) + [ (CmmHinted (CmmReg (CmmGlobal BaseReg)) PtrHint) + , (CmmHinted arg PtrHint) ] (Just vols) + NoC_SRT -- No SRT b/c we do PlayRisky + CmmMayReturn where newspark = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("newSpark"))) emitPrimOp [res] ReadMutVarOp [mutv] live - = stmtC (CmmAssign res (cmmLoadIndexW mutv fixedHdrSize)) + = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW mutv fixedHdrSize)) emitPrimOp [] WriteMutVarOp [mutv,var] live = do @@ -134,16 +143,19 @@ emitPrimOp [] WriteMutVarOp [mutv,var] live vols <- getVolatileRegs live emitForeignCall' PlayRisky [{-no results-}] - (CmmForeignCall (CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) + (CmmCallee (CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) CCallConv) - [(CmmReg (CmmGlobal BaseReg), PtrHint), (mutv,PtrHint)] + [ (CmmHinted (CmmReg (CmmGlobal BaseReg)) PtrHint) + , (CmmHinted mutv PtrHint) ] (Just vols) + NoC_SRT -- No SRT b/c we do PlayRisky + CmmMayReturn -- #define sizzeofByteArrayzh(r,a) \ -- r = (((StgArrWords *)(a))->words * sizeof(W_)) emitPrimOp [res] SizeofByteArrayOp [arg] live = stmtC $ - CmmAssign res (CmmMachOp mo_wordMul [ + CmmAssign (CmmLocal res) (CmmMachOp mo_wordMul [ cmmLoadIndexW arg fixedHdrSize, CmmLit (mkIntCLit wORD_SIZE) ]) @@ -160,31 +172,32 @@ emitPrimOp [] TouchOp [arg] live -- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a) emitPrimOp [res] ByteArrayContents_Char [arg] live - = stmtC (CmmAssign res (cmmOffsetB arg arrWordsHdrSize)) + = stmtC (CmmAssign (CmmLocal res) (cmmOffsetB arg arrWordsHdrSize)) -- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn) emitPrimOp [res] StableNameToIntOp [arg] live - = stmtC (CmmAssign res (cmmLoadIndexW arg fixedHdrSize)) + = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW arg fixedHdrSize)) -- #define eqStableNamezh(r,sn1,sn2) \ -- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn)) emitPrimOp [res] EqStableNameOp [arg1,arg2] live - = stmtC (CmmAssign res (CmmMachOp mo_wordEq [ + = stmtC (CmmAssign (CmmLocal res) (CmmMachOp mo_wordEq [ cmmLoadIndexW arg1 fixedHdrSize, cmmLoadIndexW arg2 fixedHdrSize ])) emitPrimOp [res] ReallyUnsafePtrEqualityOp [arg1,arg2] live - = stmtC (CmmAssign res (CmmMachOp mo_wordEq [arg1,arg2])) + = stmtC (CmmAssign (CmmLocal res) (CmmMachOp mo_wordEq [arg1,arg2])) -- #define addrToHValuezh(r,a) r=(P_)a emitPrimOp [res] AddrToHValueOp [arg] live - = stmtC (CmmAssign res arg) + = stmtC (CmmAssign (CmmLocal res) arg) -- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info)) +-- Note: argument may be tagged! emitPrimOp [res] DataToTagOp [arg] live - = stmtC (CmmAssign res (getConstrTag arg)) + = stmtC (CmmAssign (CmmLocal res) (getConstrTag (cmmUntag arg))) {- Freezing arrays-of-ptrs requires changing an info table, for the benefit of the generational collector. It needs to scavenge mutable @@ -198,11 +211,11 @@ emitPrimOp [res] DataToTagOp [arg] live -- } emitPrimOp [res] UnsafeFreezeArrayOp [arg] live = stmtsC [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)), - CmmAssign res arg ] + CmmAssign (CmmLocal res) arg ] -- #define unsafeFreezzeByteArrayzh(r,a) r=(a) emitPrimOp [res] UnsafeFreezeByteArrayOp [arg] live - = stmtC (CmmAssign res arg) + = stmtC (CmmAssign (CmmLocal res) arg) -- Reading/writing pointer arrays @@ -328,23 +341,25 @@ emitPrimOp res WriteByteArrayOp_Word64 args live = doWriteByteArrayOp Nothing -- The rest just translate straightforwardly emitPrimOp [res] op [arg] live | nopOp op - = stmtC (CmmAssign res arg) + = stmtC (CmmAssign (CmmLocal res) arg) | Just (mop,rep) <- narrowOp op - = stmtC (CmmAssign res (CmmMachOp (mop rep wordRep) [ + = stmtC (CmmAssign (CmmLocal res) (CmmMachOp (mop rep wordRep) [ CmmMachOp (mop wordRep rep) [arg]])) emitPrimOp [res] op args live | Just prim <- callishOp op = do vols <- getVolatileRegs live emitForeignCall' PlayRisky - [(res,NoHint)] + [CmmHinted res NoHint] (CmmPrim prim) - [(a,NoHint) | a<-args] -- ToDo: hints? + [CmmHinted a NoHint | a<-args] -- ToDo: hints? (Just vols) + NoC_SRT -- No SRT b/c we do PlayRisky + CmmMayReturn | Just mop <- translateOp op - = let stmt = CmmAssign res (CmmMachOp mop args) in + = let stmt = CmmAssign (CmmLocal res) (CmmMachOp mop args) in stmtC stmt emitPrimOp _ op _ _ @@ -557,9 +572,9 @@ doWritePtrArrayOp addr idx val mkBasicIndexedRead off Nothing read_rep res base idx - = stmtC (CmmAssign res (cmmLoadIndexOffExpr off read_rep base idx)) + = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexOffExpr off read_rep base idx)) mkBasicIndexedRead off (Just cast) read_rep res base idx - = stmtC (CmmAssign res (CmmMachOp cast [ + = stmtC (CmmAssign (CmmLocal res) (CmmMachOp cast [ cmmLoadIndexOffExpr off read_rep base idx])) mkBasicIndexedWrite off Nothing write_rep base idx val