diff options
Diffstat (limited to 'compiler/codeGen')
34 files changed, 2108 insertions, 1995 deletions
diff --git a/compiler/codeGen/CgBindery.lhs b/compiler/codeGen/CgBindery.lhs index 0efc99d370..834276bd7b 100644 --- a/compiler/codeGen/CgBindery.lhs +++ b/compiler/codeGen/CgBindery.lhs @@ -38,8 +38,8 @@ import CgStackery import CgUtils import CLabel import ClosureInfo -import Constants +import DynFlags import OldCmm import PprCmm ( {- instance Outputable -} ) import SMRep @@ -87,8 +87,8 @@ data CgIdInfo , cg_tag :: {-# UNPACK #-} !Int -- tag to be added in idInfoToAmode } -mkCgIdInfo :: Id -> VolatileLoc -> StableLoc -> LambdaFormInfo -> CgIdInfo -mkCgIdInfo id vol stb lf +mkCgIdInfo :: DynFlags -> Id -> VolatileLoc -> StableLoc -> LambdaFormInfo -> CgIdInfo +mkCgIdInfo dflags id vol stb lf = CgIdInfo { cg_id = id, cg_vol = vol, cg_stb = stb, cg_lf = lf, cg_rep = idCgRep id, cg_tag = tag } where @@ -100,10 +100,10 @@ mkCgIdInfo id vol stb lf If yes, we assume that the constructor is evaluated and can be tagged. -} - = tagForCon con + = tagForCon dflags con | otherwise - = funTagLFInfo lf + = funTagLFInfo dflags lf voidIdInfo :: Id -> CgIdInfo voidIdInfo id = CgIdInfo { cg_id = id, cg_vol = NoVolatileLoc @@ -120,11 +120,11 @@ data VolatileLoc -- These locations die across a call -- NB. Byte offset, because we subtract R1's -- tag from the offset. -mkTaggedCgIdInfo :: Id -> VolatileLoc -> StableLoc -> LambdaFormInfo -> DataCon +mkTaggedCgIdInfo :: DynFlags -> Id -> VolatileLoc -> StableLoc -> LambdaFormInfo -> DataCon -> CgIdInfo -mkTaggedCgIdInfo id vol stb lf con +mkTaggedCgIdInfo dflags id vol stb lf con = CgIdInfo { cg_id = id, cg_vol = vol, cg_stb = stb, - cg_lf = lf, cg_rep = idCgRep id, cg_tag = tagForCon con } + cg_lf = lf, cg_rep = idCgRep id, cg_tag = tagForCon dflags con } \end{code} @StableLoc@ encodes where an Id can be found, used by @@ -172,43 +172,52 @@ instance Outputable StableLoc where %************************************************************************ \begin{code} -stableIdInfo :: Id -> CmmExpr -> LambdaFormInfo -> CgIdInfo -stableIdInfo id amode lf_info = mkCgIdInfo id NoVolatileLoc (StableLoc amode) lf_info +stableIdInfo :: DynFlags -> Id -> CmmExpr -> LambdaFormInfo -> CgIdInfo +stableIdInfo dflags id amode lf_info = mkCgIdInfo dflags id NoVolatileLoc (StableLoc amode) lf_info -heapIdInfo :: Id -> VirtualHpOffset -> LambdaFormInfo -> CgIdInfo -heapIdInfo id offset lf_info = mkCgIdInfo id (VirHpLoc offset) NoStableLoc lf_info +heapIdInfo :: DynFlags -> Id -> VirtualHpOffset -> LambdaFormInfo -> CgIdInfo +heapIdInfo dflags id offset lf_info = mkCgIdInfo dflags id (VirHpLoc offset) NoStableLoc lf_info -letNoEscapeIdInfo :: Id -> VirtualSpOffset -> LambdaFormInfo -> CgIdInfo -letNoEscapeIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLNE sp) lf_info +letNoEscapeIdInfo :: DynFlags -> Id -> VirtualSpOffset -> LambdaFormInfo -> CgIdInfo +letNoEscapeIdInfo dflags id sp lf_info + = mkCgIdInfo dflags id NoVolatileLoc (VirStkLNE sp) lf_info -stackIdInfo :: Id -> VirtualSpOffset -> LambdaFormInfo -> CgIdInfo -stackIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLoc sp) lf_info +stackIdInfo :: DynFlags -> Id -> VirtualSpOffset -> LambdaFormInfo -> CgIdInfo +stackIdInfo dflags id sp lf_info + = mkCgIdInfo dflags id NoVolatileLoc (VirStkLoc sp) lf_info -nodeIdInfo :: Id -> Int -> LambdaFormInfo -> CgIdInfo -nodeIdInfo id offset lf_info = mkCgIdInfo id (VirNodeLoc (wORD_SIZE*offset)) NoStableLoc lf_info +nodeIdInfo :: DynFlags -> Id -> Int -> LambdaFormInfo -> CgIdInfo +nodeIdInfo dflags id offset lf_info = mkCgIdInfo dflags id (VirNodeLoc (wORD_SIZE dflags * offset)) NoStableLoc lf_info -regIdInfo :: Id -> CmmReg -> LambdaFormInfo -> CgIdInfo -regIdInfo id reg lf_info = mkCgIdInfo id (RegLoc reg) NoStableLoc lf_info +regIdInfo :: DynFlags -> Id -> CmmReg -> LambdaFormInfo -> CgIdInfo +regIdInfo dflags id reg lf_info = mkCgIdInfo dflags id (RegLoc reg) NoStableLoc lf_info -taggedStableIdInfo :: Id -> CmmExpr -> LambdaFormInfo -> DataCon -> CgIdInfo -taggedStableIdInfo id amode lf_info con - = mkTaggedCgIdInfo id NoVolatileLoc (StableLoc amode) lf_info con +taggedStableIdInfo :: DynFlags -> Id -> CmmExpr -> LambdaFormInfo -> DataCon -> CgIdInfo +taggedStableIdInfo dflags id amode lf_info con + = mkTaggedCgIdInfo dflags id NoVolatileLoc (StableLoc amode) lf_info con -taggedHeapIdInfo :: Id -> VirtualHpOffset -> LambdaFormInfo -> DataCon +taggedHeapIdInfo :: DynFlags -> Id -> VirtualHpOffset -> LambdaFormInfo -> DataCon -> CgIdInfo -taggedHeapIdInfo id offset lf_info con - = mkTaggedCgIdInfo id (VirHpLoc offset) NoStableLoc lf_info con +taggedHeapIdInfo dflags id offset lf_info con + = mkTaggedCgIdInfo dflags id (VirHpLoc offset) NoStableLoc lf_info con -untagNodeIdInfo :: Id -> Int -> LambdaFormInfo -> Int -> CgIdInfo -untagNodeIdInfo id offset lf_info tag - = mkCgIdInfo id (VirNodeLoc (wORD_SIZE*offset - tag)) NoStableLoc lf_info +untagNodeIdInfo :: DynFlags -> Id -> Int -> LambdaFormInfo -> Int -> CgIdInfo +untagNodeIdInfo dflags id offset lf_info tag + = mkCgIdInfo dflags id (VirNodeLoc (wORD_SIZE dflags * offset - tag)) NoStableLoc lf_info idInfoToAmode :: CgIdInfo -> FCode CmmExpr -idInfoToAmode info - = case cg_vol info of { +idInfoToAmode info = do + dflags <- getDynFlags + let mach_rep = argMachRep dflags (cg_rep info) + + maybeTag amode -- add the tag, if we have one + | tag == 0 = amode + | otherwise = cmmOffsetB dflags amode tag + where tag = cg_tag info + case cg_vol info of { RegLoc reg -> returnFC (CmmReg reg) ; - VirNodeLoc nd_off -> returnFC (CmmLoad (cmmOffsetB (CmmReg nodeReg) nd_off) + VirNodeLoc nd_off -> returnFC (CmmLoad (cmmOffsetB dflags (CmmReg nodeReg) nd_off) mach_rep) ; VirHpLoc hp_off -> do { off <- getHpRelOffset hp_off ; return $! maybeTag off }; @@ -228,13 +237,6 @@ idInfoToAmode info NoStableLoc -> pprPanic "idInfoToAmode: no loc" (ppr (cg_id info)) } - where - mach_rep = argMachRep (cg_rep info) - - maybeTag amode -- add the tag, if we have one - | tag == 0 = amode - | otherwise = cmmOffsetB amode tag - where tag = cg_tag info cgIdInfoId :: CgIdInfo -> Id cgIdInfoId = cg_id @@ -283,7 +285,8 @@ modifyBindC name mangle_fn = do getCgIdInfo :: Id -> FCode CgIdInfo getCgIdInfo id - = do { -- Try local bindings first + = do { dflags <- getDynFlags + ; -- Try local bindings first ; local_binds <- getBinds ; case lookupVarEnv local_binds id of { Just info -> return info ; @@ -301,7 +304,7 @@ getCgIdInfo id in if isExternalName name then do let ext_lbl = CmmLit (CmmLabel (mkClosureLabel name $ idCafInfo id)) - return (stableIdInfo id ext_lbl (mkLFImported id)) + return (stableIdInfo dflags id ext_lbl (mkLFImported id)) else if isVoidArg (idCgRep id) then -- Void things are never in the environment @@ -428,9 +431,9 @@ getArgAmodes (atom:atoms) \begin{code} bindArgsToStack :: [(Id, VirtualSpOffset)] -> Code bindArgsToStack args - = mapCs bind args - where - bind(id, offset) = addBindC id (stackIdInfo id offset (mkLFArgument id)) + = do dflags <- getDynFlags + let bind (id, offset) = addBindC id (stackIdInfo dflags id offset (mkLFArgument id)) + mapCs bind args bindArgsToRegs :: [(Id, GlobalReg)] -> Code bindArgsToRegs args @@ -440,30 +443,32 @@ bindArgsToRegs args bindNewToNode :: Id -> VirtualHpOffset -> LambdaFormInfo -> Code bindNewToNode id offset lf_info - = addBindC id (nodeIdInfo id offset lf_info) + = do dflags <- getDynFlags + addBindC id (nodeIdInfo dflags id offset lf_info) bindNewToUntagNode :: Id -> VirtualHpOffset -> LambdaFormInfo -> Int -> Code bindNewToUntagNode id offset lf_info tag - = addBindC id (untagNodeIdInfo id offset lf_info tag) + = do dflags <- getDynFlags + addBindC id (untagNodeIdInfo dflags id offset lf_info tag) -- Create a new temporary whose unique is that in the id, -- bind the id to it, and return the addressing mode for the -- temporary. bindNewToTemp :: Id -> FCode LocalReg bindNewToTemp id - = do addBindC id (regIdInfo id (CmmLocal temp_reg) lf_info) + = do dflags <- getDynFlags + let uniq = getUnique id + temp_reg = LocalReg uniq (argMachRep dflags (idCgRep id)) + lf_info = mkLFArgument id -- Always used of things we + -- know nothing about + addBindC id (regIdInfo dflags id (CmmLocal temp_reg) lf_info) return temp_reg - where - uniq = getUnique id - temp_reg = LocalReg uniq (argMachRep (idCgRep id)) - lf_info = mkLFArgument id -- Always used of things we - -- know nothing about bindNewToReg :: Id -> CmmReg -> LambdaFormInfo -> Code bindNewToReg name reg lf_info - = addBindC name info - where - info = mkCgIdInfo name (RegLoc reg) NoStableLoc lf_info + = do dflags <- getDynFlags + let info = mkCgIdInfo dflags name (RegLoc reg) NoStableLoc lf_info + addBindC name info rebindToStack :: Id -> VirtualSpOffset -> Code rebindToStack name offset @@ -497,9 +502,10 @@ Probably *naughty* to look inside monad... nukeDeadBindings :: StgLiveVars -- All the *live* variables -> Code nukeDeadBindings live_vars = do + dflags <- getDynFlags binds <- getBinds let (dead_stk_slots, bs') = - dead_slots live_vars + dead_slots dflags live_vars [] [] [ (cg_id b, b) | b <- varEnvElts binds ] setBinds $ mkVarEnv bs' @@ -509,7 +515,8 @@ nukeDeadBindings live_vars = do Several boring auxiliary functions to do the dirty work. \begin{code} -dead_slots :: StgLiveVars +dead_slots :: DynFlags + -> StgLiveVars -> [(Id,CgIdInfo)] -> [VirtualSpOffset] -> [(Id,CgIdInfo)] @@ -517,12 +524,12 @@ dead_slots :: StgLiveVars -- dead_slots carries accumulating parameters for -- filtered bindings, dead slots -dead_slots _ fbs ds [] +dead_slots _ _ fbs ds [] = (ds, reverse fbs) -- Finished; rm the dups, if any -dead_slots live_vars fbs ds ((v,i):bs) +dead_slots dflags live_vars fbs ds ((v,i):bs) | v `elementOfUniqSet` live_vars - = dead_slots live_vars ((v,i):fbs) ds bs + = dead_slots dflags live_vars ((v,i):fbs) ds bs -- Live, so don't record it in dead slots -- Instead keep it in the filtered bindings @@ -530,12 +537,12 @@ dead_slots live_vars fbs ds ((v,i):bs) = case cg_stb i of VirStkLoc offset | size > 0 - -> dead_slots live_vars fbs ([offset-size+1 .. offset] ++ ds) bs + -> dead_slots dflags live_vars fbs ([offset-size+1 .. offset] ++ ds) bs - _ -> dead_slots live_vars fbs ds bs + _ -> dead_slots dflags live_vars fbs ds bs where size :: WordOff - size = cgRepSizeW (cg_rep i) + size = cgRepSizeW dflags (cg_rep i) getLiveStackSlots :: FCode [VirtualSpOffset] -- Return the offsets of slots in stack containig live pointers diff --git a/compiler/codeGen/CgCallConv.hs b/compiler/codeGen/CgCallConv.hs index 9443e0e936..45edd64666 100644 --- a/compiler/codeGen/CgCallConv.hs +++ b/compiler/codeGen/CgCallConv.hs @@ -34,7 +34,6 @@ import SMRep import OldCmm import CLabel -import Constants import CgStackery import ClosureInfo( CgRep(..), nonVoidArg, idCgRep, cgRepSizeW, isFollowableArg ) import OldCmmUtils @@ -67,18 +66,18 @@ import Data.Bits ------------------------- mkArgDescr :: Name -> [Id] -> FCode ArgDescr mkArgDescr _nm args - = case stdPattern arg_reps of - Just spec_id -> return (ArgSpec spec_id) - Nothing -> return (ArgGen arg_bits) - where - arg_bits = argBits arg_reps - arg_reps = filter nonVoidArg (map idCgRep args) - -- Getting rid of voids eases matching of standard patterns - -argBits :: [CgRep] -> [Bool] -- True for non-ptr, False for ptr -argBits [] = [] -argBits (PtrArg : args) = False : argBits args -argBits (arg : args) = take (cgRepSizeW arg) (repeat True) ++ argBits args + = do dflags <- getDynFlags + let arg_bits = argBits dflags arg_reps + arg_reps = filter nonVoidArg (map idCgRep args) + -- Getting rid of voids eases matching of standard patterns + case stdPattern arg_reps of + Just spec_id -> return (ArgSpec spec_id) + Nothing -> return (ArgGen arg_bits) + +argBits :: DynFlags -> [CgRep] -> [Bool] -- True for non-ptr, False for ptr +argBits _ [] = [] +argBits dflags (PtrArg : args) = False : argBits dflags args +argBits dflags (arg : args) = take (cgRepSizeW dflags arg) (repeat True) ++ argBits dflags args stdPattern :: [CgRep] -> Maybe StgHalfWord stdPattern [] = Just ARG_NONE -- just void args, probably @@ -226,8 +225,9 @@ getSequelAmode :: FCode CmmExpr getSequelAmode = do { EndOfBlockInfo virt_sp sequel <- getEndOfBlockInfo ; case sequel of - OnStack -> do { sp_rel <- getSpRelOffset virt_sp - ; returnFC (CmmLoad sp_rel bWord) } + OnStack -> do { dflags <- getDynFlags + ; sp_rel <- getSpRelOffset virt_sp + ; returnFC (CmmLoad sp_rel (bWord dflags)) } CaseAlts lbl _ _ -> returnFC (CmmLit (CmmLabel lbl)) } @@ -263,7 +263,7 @@ type AssignRegs a = [(CgRep,a)] -- Arg or result values to assign [(CgRep,a)]) -- Leftover arg or result values assignCallRegs :: DynFlags -> AssignRegs a -assignPrimOpCallRegs :: AssignRegs a +assignPrimOpCallRegs :: DynFlags -> AssignRegs a assignReturnRegs :: DynFlags -> AssignRegs a assignCallRegs dflags args @@ -272,8 +272,8 @@ assignCallRegs dflags args -- never uses Node for argument passing; instead -- Node points to the function closure itself -assignPrimOpCallRegs args - = assign_regs args (mkRegTbl_allRegs []) +assignPrimOpCallRegs dflags args + = assign_regs args (mkRegTbl_allRegs dflags []) -- For primops, *all* arguments must be passed in registers assignReturnRegs dflags args @@ -333,19 +333,19 @@ assign_reg _ _ = Nothing useVanillaRegs :: DynFlags -> Int useVanillaRegs dflags | platformUnregisterised (targetPlatform dflags) = 0 - | otherwise = mAX_Real_Vanilla_REG + | otherwise = mAX_Real_Vanilla_REG dflags useFloatRegs :: DynFlags -> Int useFloatRegs dflags | platformUnregisterised (targetPlatform dflags) = 0 - | otherwise = mAX_Real_Float_REG + | otherwise = mAX_Real_Float_REG dflags useDoubleRegs :: DynFlags -> Int useDoubleRegs dflags | platformUnregisterised (targetPlatform dflags) = 0 - | otherwise = mAX_Real_Double_REG + | otherwise = mAX_Real_Double_REG dflags useLongRegs :: DynFlags -> Int useLongRegs dflags | platformUnregisterised (targetPlatform dflags) = 0 - | otherwise = mAX_Real_Long_REG + | otherwise = mAX_Real_Long_REG dflags vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: DynFlags -> [Int] vanillaRegNos dflags = regList $ useVanillaRegs dflags @@ -353,11 +353,12 @@ floatRegNos dflags = regList $ useFloatRegs dflags doubleRegNos dflags = regList $ useDoubleRegs dflags longRegNos dflags = regList $ useLongRegs dflags -allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos :: [Int] -allVanillaRegNos = regList mAX_Vanilla_REG -allFloatRegNos = regList mAX_Float_REG -allDoubleRegNos = regList mAX_Double_REG -allLongRegNos = regList mAX_Long_REG +allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos + :: DynFlags -> [Int] +allVanillaRegNos dflags = regList $ mAX_Vanilla_REG dflags +allFloatRegNos dflags = regList $ mAX_Float_REG dflags +allDoubleRegNos dflags = regList $ mAX_Double_REG dflags +allLongRegNos dflags = regList $ mAX_Long_REG dflags regList :: Int -> [Int] regList n = [1 .. n] @@ -370,25 +371,29 @@ type AvailRegs = ( [Int] -- available vanilla regs. mkRegTbl :: DynFlags -> [GlobalReg] -> AvailRegs mkRegTbl dflags regs_in_use - = mkRegTbl' regs_in_use (vanillaRegNos dflags) - (floatRegNos dflags) - (doubleRegNos dflags) - (longRegNos dflags) - -mkRegTbl_allRegs :: [GlobalReg] -> AvailRegs -mkRegTbl_allRegs regs_in_use - = mkRegTbl' regs_in_use allVanillaRegNos allFloatRegNos allDoubleRegNos allLongRegNos - -mkRegTbl' :: [GlobalReg] -> [Int] -> [Int] -> [Int] -> [Int] + = mkRegTbl' dflags regs_in_use + vanillaRegNos floatRegNos doubleRegNos longRegNos + +mkRegTbl_allRegs :: DynFlags -> [GlobalReg] -> AvailRegs +mkRegTbl_allRegs dflags regs_in_use + = mkRegTbl' dflags regs_in_use + allVanillaRegNos allFloatRegNos allDoubleRegNos allLongRegNos + +mkRegTbl' :: DynFlags -> [GlobalReg] + -> (DynFlags -> [Int]) + -> (DynFlags -> [Int]) + -> (DynFlags -> [Int]) + -> (DynFlags -> [Int]) -> ([Int], [Int], [Int], [Int]) -mkRegTbl' regs_in_use vanillas floats doubles longs +mkRegTbl' dflags regs_in_use vanillas floats doubles longs = (ok_vanilla, ok_float, ok_double, ok_long) where - ok_vanilla = mapCatMaybes (select (\i -> VanillaReg i VNonGcPtr)) vanillas + ok_vanilla = mapCatMaybes (select (\i -> VanillaReg i VNonGcPtr)) + (vanillas dflags) -- ptrhood isn't looked at, hence we can use any old rep. - ok_float = mapCatMaybes (select FloatReg) floats - ok_double = mapCatMaybes (select DoubleReg) doubles - ok_long = mapCatMaybes (select LongReg) longs + ok_float = mapCatMaybes (select FloatReg) (floats dflags) + ok_double = mapCatMaybes (select DoubleReg) (doubles dflags) + ok_long = mapCatMaybes (select LongReg) (longs dflags) select :: (Int -> GlobalReg) -> Int{-cand-} -> Maybe Int -- one we've unboxed the Int, we make a GlobalReg diff --git a/compiler/codeGen/CgCase.lhs b/compiler/codeGen/CgCase.lhs index ef51aaa620..0d86319057 100644 --- a/compiler/codeGen/CgCase.lhs +++ b/compiler/codeGen/CgCase.lhs @@ -370,10 +370,11 @@ cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts -- (avoiding it avoids the assignment) -- The deadness info is set by StgVarInfo ; whenC (not (isDeadBinder bndr)) - (do { tmp_reg <- bindNewToTemp bndr + (do { dflags <- getDynFlags + ; tmp_reg <- bindNewToTemp bndr ; stmtC (CmmAssign (CmmLocal tmp_reg) - (tagToClosure tycon tag_amode)) }) + (tagToClosure dflags tycon tag_amode)) }) -- Compile the alts ; (branches, mb_deflt) <- cgAlgAlts NoGC Nothing{-cc_slot-} @@ -390,7 +391,8 @@ cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts (_,e) <- getArgAmode arg return e do_enum_primop primop - = do tmp <- newTemp bWord + = do dflags <- getDynFlags + tmp <- newTemp (bWord dflags) cgPrimOp [tmp] primop args live_in_alts returnFC (CmmReg (CmmLocal tmp)) @@ -663,8 +665,9 @@ saveCurrentCostCentre restoreCurrentCostCentre :: Maybe VirtualSpOffset -> Bool -> Code restoreCurrentCostCentre Nothing _freeit = nopC restoreCurrentCostCentre (Just slot) freeit - = do { sp_rel <- getSpRelOffset slot + = do { dflags <- getDynFlags + ; sp_rel <- getSpRelOffset slot ; whenC freeit (freeStackSlots [slot]) - ; stmtC (storeCurCCS (CmmLoad sp_rel bWord)) } + ; stmtC (storeCurCCS (CmmLoad sp_rel (bWord dflags))) } \end{code} diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs index f1da2d4235..11a5091c07 100644 --- a/compiler/codeGen/CgClosure.lhs +++ b/compiler/codeGen/CgClosure.lhs @@ -84,7 +84,7 @@ cgTopRhsClosure id ccs binder_info upd_flag args body = do ; let descr = closureDescription dflags mod_name name closure_info = mkClosureInfo dflags True id lf_info 0 0 srt_info descr closure_label = mkLocalClosureLabel name $ idCafInfo id - cg_id_info = stableIdInfo id (mkLblExpr closure_label) lf_info + cg_id_info = stableIdInfo dflags id (mkLblExpr closure_label) lf_info closure_rep = mkStaticClosureFields dflags closure_info ccs True [] -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY) @@ -136,7 +136,7 @@ cgStdRhsClosure bndr _cc _bndr_info _fvs _args _body lf_info payload ; heap_offset <- allocDynClosure closure_info curCCS curCCS amodes_w_offsets -- RETURN - ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) } + ; returnFC (bndr, heapIdInfo dflags bndr heap_offset lf_info) } \end{code} Here's the general case. @@ -188,7 +188,7 @@ cgRhsClosure bndr cc bndr_info fvs upd_flag args body = do let -- A function closure pointer may be tagged, so we -- must take it into account when accessing the free variables. - mbtag = tagForArity (length args) + mbtag = tagForArity dflags (length args) bind_fv (info, offset) | Just tag <- mbtag = bindNewToUntagNode (cgIdInfoId info) offset (cgIdInfoLF info) tag @@ -211,7 +211,7 @@ cgRhsClosure bndr cc bndr_info fvs upd_flag args body = do ; heap_offset <- allocDynClosure closure_info curCCS curCCS amodes_w_offsets -- RETURN - ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) } + ; returnFC (bndr, heapIdInfo dflags bndr heap_offset lf_info) } mkClosureLFInfo :: Id -- The binder @@ -279,7 +279,7 @@ closureCodeBody _binder_info cl_info cc args body -- eg. if we're compiling a let-no-escape). ; vSp <- getVirtSp ; let (reg_args, other_args) = assignCallRegs dflags (addIdReps args) - (sp_top, stk_args) = mkVirtStkOffsets vSp other_args + (sp_top, stk_args) = mkVirtStkOffsets dflags vSp other_args -- Allocate the global ticky counter ; let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) (clHasCafRefs cl_info) @@ -320,10 +320,11 @@ mkFunEntryCode cl_info cc reg_args stk_args sp_top reg_save_code body = do -- Do the business ; funWrapper cl_info reg_args reg_save_code $ do - { tickyEnterFun cl_info + { dflags <- getDynFlags + ; tickyEnterFun cl_info ; enterCostCentreFun cc - (CmmMachOp mo_wordSub [ CmmReg nodeReg - , CmmLit (mkIntCLit (funTag cl_info)) ]) + (CmmMachOp (mo_wordSub dflags) [ CmmReg nodeReg + , mkIntExpr dflags (funTag dflags cl_info) ]) (node : map snd reg_args) -- live regs ; cgExpr body } @@ -364,22 +365,22 @@ mkSlowEntryCode dflags cl_info reg_args reps_w_regs :: [(CgRep,GlobalReg)] reps_w_regs = [(idCgRep id, reg) | (id,reg) <- reverse reg_args] (final_stk_offset, stk_offsets) - = mapAccumL (\off (rep,_) -> (off + cgRepSizeW rep, off)) + = mapAccumL (\off (rep,_) -> (off + cgRepSizeW dflags rep, off)) 0 reps_w_regs load_assts = zipWithEqual "mk_load" mk_load reps_w_regs stk_offsets mk_load (rep,reg) offset = CmmAssign (CmmGlobal reg) - (CmmLoad (cmmRegOffW spReg offset) - (argMachRep rep)) + (CmmLoad (cmmRegOffW dflags spReg offset) + (argMachRep dflags rep)) save_assts = zipWithEqual "mk_save" mk_save reps_w_regs stk_offsets - mk_save (rep,reg) offset = ASSERT( argMachRep rep `cmmEqType` globalRegType reg ) - CmmStore (cmmRegOffW spReg offset) + mk_save (rep,reg) offset = ASSERT( argMachRep dflags rep `cmmEqType` globalRegType dflags reg ) + CmmStore (cmmRegOffW dflags spReg offset) (CmmReg (CmmGlobal reg)) - stk_adj_pop = CmmAssign spReg (cmmRegOffW spReg final_stk_offset) - stk_adj_push = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset)) + stk_adj_pop = CmmAssign spReg (cmmRegOffW dflags spReg final_stk_offset) + stk_adj_push = CmmAssign spReg (cmmRegOffW dflags spReg (- final_stk_offset)) live_regs = Just $ map snd reps_w_regs jump_to_entry = CmmJump (mkLblExpr (entryLabelFromCI dflags cl_info)) live_regs \end{code} @@ -429,8 +430,8 @@ funWrapper closure_info arg_regs reg_save_code fun_body = do ; whenC (tag /= 0 && node_points) $ do l <- newLabelC stmtC (CmmCondBranch (CmmMachOp mo_wordEq [cmmGetTag (CmmReg nodeReg), - CmmLit (mkIntCLit tag)]) l) - stmtC (CmmStore (CmmLit (mkWordCLit 0)) (CmmLit (mkWordCLit 0))) + mkIntExpr dflags tag)]) l) + stmtC (CmmStore (CmmLit (mkWordCLit 0)) (mkWordExpr 0)) labelC l -} @@ -490,7 +491,7 @@ emitBlackHoleCode is_single_entry = do whenC eager_blackholing $ do tickyBlackHole (not is_single_entry) stmtsC [ - CmmStore (cmmOffsetW (CmmReg nodeReg) (fixedHdrSize dflags)) + CmmStore (cmmOffsetW dflags (CmmReg nodeReg) (fixedHdrSize dflags)) (CmmReg (CmmGlobal CurrentTSO)), CmmCall (CmmPrim MO_WriteBarrier Nothing) [] [] CmmMayReturn, CmmStore (CmmReg nodeReg) (CmmReg (CmmGlobal EagerBlackholeInfo)) @@ -576,11 +577,11 @@ link_caf :: ClosureInfo -- is that we only want to update dynamic heap objects, not static ones, -- so that generational GC is easier. link_caf cl_info _is_upd = do - { -- Alloc black hole specifying CC_HDR(Node) as the cost centre - ; let use_cc = costCentreFrom (CmmReg nodeReg) + { dflags <- getDynFlags + -- Alloc black hole specifying CC_HDR(Node) as the cost centre + ; let use_cc = costCentreFrom dflags (CmmReg nodeReg) blame_cc = use_cc tso = CmmReg (CmmGlobal CurrentTSO) - ; dflags <- getDynFlags ; hp_offset <- allocDynClosure bh_cl_info use_cc blame_cc [(tso, fixedHdrSize dflags)] ; hp_rel <- getHpRelOffset hp_offset @@ -589,7 +590,7 @@ link_caf cl_info _is_upd = do -- so that the garbage collector can find them -- This must be done *before* the info table pointer is overwritten, -- because the old info table ptr is needed for reversion - ; ret <- newTemp bWord + ; ret <- newTemp (bWord dflags) ; emitRtsCallGen [CmmHinted ret NoHint] rtsPackageId (fsLit "newCAF") [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint, CmmHinted (CmmReg nodeReg) AddrHint, @@ -598,11 +599,11 @@ link_caf cl_info _is_upd = do -- node is live, so save it. -- see Note [atomic CAF entry] in rts/sm/Storage.c - ; emitIf (CmmMachOp mo_wordEq [ CmmReg (CmmLocal ret), CmmLit zeroCLit]) $ + ; emitIf (CmmMachOp (mo_wordEq dflags) [ CmmReg (CmmLocal ret), zeroExpr dflags]) $ -- re-enter R1. Doing this directly is slightly dodgy; we're -- assuming lots of things, like the stack pointer hasn't -- moved since we entered the CAF. - let target = entryCode dflags (closureInfoPtr (CmmReg nodeReg)) in + let target = entryCode dflags (closureInfoPtr dflags (CmmReg nodeReg)) in stmtC (CmmJump target $ Just [node]) ; returnFC hp_rel } diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs index 4c451ec339..aeb87235e3 100644 --- a/compiler/codeGen/CgCon.lhs +++ b/compiler/codeGen/CgCon.lhs @@ -36,7 +36,6 @@ import OldCmmUtils import OldCmm import SMRep import CostCentre -import Constants import TyCon import DataCon import Id @@ -99,7 +98,7 @@ cgTopRhsCon id con args ; emitDataLits closure_label closure_rep -- RETURN - ; returnFC (id, taggedStableIdInfo id (mkLblExpr closure_label) lf_info con) } + ; returnFC (id, taggedStableIdInfo dflags id (mkLblExpr closure_label) lf_info con) } \end{code} %************************************************************************ @@ -149,8 +148,8 @@ which have exclusively size-zero (VoidRep) args, we generate no code at all. \begin{code} -buildDynCon' _ _ binder _ con [] - = returnFC (taggedStableIdInfo binder +buildDynCon' dflags _ binder _ con [] + = returnFC (taggedStableIdInfo dflags binder (mkLblExpr (mkClosureLabel (dataConName con) (idCafInfo binder))) (mkConLFInfo con) @@ -189,24 +188,24 @@ buildDynCon' dflags platform binder _ con [arg_amode] , platformOS platform /= OSMinGW32 || not (dopt Opt_PIC dflags) , (_, CmmLit (CmmInt val _)) <- arg_amode , let val_int = (fromIntegral val) :: Int - , val_int <= mAX_INTLIKE && val_int >= mIN_INTLIKE + , val_int <= mAX_INTLIKE dflags && val_int >= mIN_INTLIKE dflags = do { let intlike_lbl = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_INTLIKE_closure") - offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize dflags + 1) + offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSize dflags + 1) -- INTLIKE closures consist of a header and one word payload - intlike_amode = CmmLit (cmmLabelOffW intlike_lbl offsetW) - ; returnFC (taggedStableIdInfo binder intlike_amode (mkConLFInfo con) con) } + intlike_amode = CmmLit (cmmLabelOffW dflags intlike_lbl offsetW) + ; returnFC (taggedStableIdInfo dflags binder intlike_amode (mkConLFInfo con) con) } buildDynCon' dflags platform binder _ con [arg_amode] | maybeCharLikeCon con , platformOS platform /= OSMinGW32 || not (dopt Opt_PIC dflags) , (_, CmmLit (CmmInt val _)) <- arg_amode , let val_int = (fromIntegral val) :: Int - , val_int <= mAX_CHARLIKE && val_int >= mIN_CHARLIKE + , val_int <= mAX_CHARLIKE dflags && val_int >= mIN_CHARLIKE dflags = do { let charlike_lbl = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_CHARLIKE_closure") - offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize dflags + 1) + offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSize dflags + 1) -- CHARLIKE closures consist of a header and one word payload - charlike_amode = CmmLit (cmmLabelOffW charlike_lbl offsetW) - ; returnFC (taggedStableIdInfo binder charlike_amode (mkConLFInfo con) con) } + charlike_amode = CmmLit (cmmLabelOffW dflags charlike_lbl offsetW) + ; returnFC (taggedStableIdInfo dflags binder charlike_amode (mkConLFInfo con) con) } \end{code} @@ -219,7 +218,7 @@ buildDynCon' dflags _ binder ccs con args (closure_info, amodes_w_offsets) = layOutDynConstr dflags con args ; hp_off <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets - ; returnFC (taggedHeapIdInfo binder hp_off lf_info con) } + ; returnFC (taggedHeapIdInfo dflags binder hp_off lf_info con) } where lf_info = mkConLFInfo con @@ -250,7 +249,7 @@ bindConArgs con args let -- The binding below forces the masking out of the tag bits -- when accessing the constructor field. - bind_arg (arg, offset) = bindNewToUntagNode arg offset (mkLFArgument arg) (tagForCon con) + bind_arg (arg, offset) = bindNewToUntagNode arg offset (mkLFArgument arg) (tagForCon dflags con) (_, args_w_offsets) = layOutDynConstr dflags con (addIdReps args) -- ASSERT(not (isUnboxedTupleCon con)) return () @@ -285,8 +284,8 @@ bindUnboxedTupleComponents args -- Allocate the rest on the stack -- The real SP points to the return address, above which any -- leftover unboxed-tuple components will be allocated - (ptr_sp, ptr_offsets) = mkVirtStkOffsets rsp ptr_args - (nptr_sp, nptr_offsets) = mkVirtStkOffsets ptr_sp nptr_args + (ptr_sp, ptr_offsets) = mkVirtStkOffsets dflags rsp ptr_args + (nptr_sp, nptr_offsets) = mkVirtStkOffsets dflags ptr_sp nptr_args ptrs = ptr_sp - rsp nptrs = nptr_sp - ptr_sp @@ -355,8 +354,8 @@ cgReturnDataCon con amodes = do where node_live = Just [node] enter_it dflags - = stmtsC [ CmmAssign nodeReg (cmmUntag (CmmReg nodeReg)), - CmmJump (entryCode dflags $ closureInfoPtr $ CmmReg nodeReg) + = stmtsC [ CmmAssign nodeReg (cmmUntag dflags (CmmReg nodeReg)), + CmmJump (entryCode dflags $ closureInfoPtr dflags $ CmmReg nodeReg) node_live ] jump_to lbl = stmtC $ CmmJump (CmmLit lbl) node_live @@ -419,7 +418,8 @@ closures predeclared. \begin{code} cgTyCon :: TyCon -> FCode CmmGroup -- each constructor gets a separate CmmGroup cgTyCon tycon - = do { constrs <- mapM (getCmm . cgDataCon) (tyConDataCons tycon) + = do { dflags <- getDynFlags + ; constrs <- mapM (getCmm . cgDataCon) (tyConDataCons tycon) -- Generate a table of static closures for an enumeration type -- Put the table after the data constructor decls, because the @@ -432,7 +432,7 @@ cgTyCon tycon ; extra <- if isEnumerationTyCon tycon then do tbl <- getCmm (emitRODataLits "cgTyCon" (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs) - [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs) (tagForCon con) + [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs) (tagForCon dflags con) | con <- tyConDataCons tycon]) return [tbl] else @@ -478,7 +478,7 @@ cgDataCon data_con tickyReturnOldCon (length arg_things) -- The case continuation code is expecting a tagged pointer ; stmtC (CmmAssign nodeReg - (tagCons data_con (CmmReg nodeReg))) + (tagCons dflags data_con (CmmReg nodeReg))) ; performReturn $ emitReturnInstr (Just []) } -- noStmts: Ptr to thing already in Node diff --git a/compiler/codeGen/CgExpr.lhs b/compiler/codeGen/CgExpr.lhs index 0a4466292e..151947665f 100644 --- a/compiler/codeGen/CgExpr.lhs +++ b/compiler/codeGen/CgExpr.lhs @@ -15,7 +15,6 @@ module CgExpr ( cgExpr ) where #include "HsVersions.h" -import Constants import StgSyn import CgMonad @@ -146,10 +145,11 @@ cgExpr (StgOpApp (StgFCallOp fcall _) stg_args res_ty) = do cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty) = ASSERT(isEnumerationTyCon tycon) - do { (_rep,amode) <- getArgAmode arg + do { dflags <- getDynFlags + ; (_rep,amode) <- getArgAmode arg ; amode' <- assignTemp amode -- We're going to use it twice, -- so save in a temp if non-trivial - ; stmtC (CmmAssign nodeReg (tagToClosure tycon amode')) + ; stmtC (CmmAssign nodeReg (tagToClosure dflags tycon amode')) ; performReturn $ emitReturnInstr (Just [node]) } where -- If you're reading this code in the attempt to figure @@ -177,7 +177,8 @@ cgExpr (StgOpApp (StgPrimOp primop) args res_ty) performReturn $ emitReturnInstr (Just []) | ReturnsPrim rep <- result_info - = do res <- newTemp (typeCmmType res_ty) + = do dflags <- getDynFlags + res <- newTemp (typeCmmType dflags res_ty) cgPrimOp [res] primop args emptyVarSet performPrimReturn (primRepToCgRep rep) (CmmReg (CmmLocal res)) @@ -188,10 +189,11 @@ cgExpr (StgOpApp (StgPrimOp primop) args res_ty) | ReturnsAlg tycon <- result_info, isEnumerationTyCon tycon -- c.f. cgExpr (...TagToEnumOp...) - = do tag_reg <- newTemp bWord -- The tag is a word + = do dflags <- getDynFlags + tag_reg <- newTemp (bWord dflags) -- The tag is a word cgPrimOp [tag_reg] primop args emptyVarSet stmtC (CmmAssign nodeReg - (tagToClosure tycon + (tagToClosure dflags tycon (CmmReg (CmmLocal tag_reg)))) -- ToDo: STG Live -- worried about this performReturn $ emitReturnInstr (Just [node]) @@ -349,7 +351,7 @@ mkRhsClosure dflags bndr cc bi (StgApp selectee [{-no args-}]))]) | the_fv == scrutinee -- Scrutinee is the only free variable && maybeToBool maybe_offset -- Selectee is a component of the tuple - && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough + && offset_into_int <= mAX_SPEC_SELECTEE_SIZE dflags -- Offset is small enough = -- NOT TRUE: ASSERT(is_single_constructor) -- The simplifier may have statically determined that the single alternative -- is the only possible case and eliminated the others, even if there are @@ -393,7 +395,7 @@ mkRhsClosure dflags bndr cc bi | args `lengthIs` (arity-1) && all isFollowableArg (map idCgRep fvs) && isUpdatable upd_flag - && arity <= mAX_SPEC_AP_SIZE + && arity <= mAX_SPEC_AP_SIZE dflags && not (dopt Opt_SccProfilingOn dflags) -- not when profiling: we don't want to -- lose information about this particular @@ -481,14 +483,14 @@ Little helper for primitives that return unboxed tuples. \begin{code} newUnboxedTupleRegs :: Type -> FCode ([CgRep], [LocalReg], [ForeignHint]) -newUnboxedTupleRegs res_ty = +newUnboxedTupleRegs res_ty = do + dflags <- getDynFlags let UbxTupleRep ty_args = repType res_ty (reps,hints) = unzip [ (rep, typeForeignHint ty) | ty <- ty_args, let rep = typeCgRep ty, nonVoidArg rep ] - make_new_temp rep = newTemp (argMachRep rep) - in do + make_new_temp rep = newTemp (argMachRep dflags rep) regs <- mapM make_new_temp reps return (reps,regs,hints) \end{code} diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs index a37245ea01..824a82635d 100644 --- a/compiler/codeGen/CgForeignCall.hs +++ b/compiler/codeGen/CgForeignCall.hs @@ -30,7 +30,6 @@ import OldCmm import OldCmmUtils import SMRep import ForeignCall -import Constants import DynFlags import Outputable import Module @@ -70,13 +69,9 @@ emitForeignCall -> StgLiveVars -- live vars, in case we need to save them -> Code -emitForeignCall results (CCall (CCallSpec target cconv safety)) args live - = do vols <- getVolatileRegs live - srt <- getSRTInfo - emitForeignCall' safety results - (CmmCallee cmm_target cconv) call_args (Just vols) srt CmmMayReturn - where - (call_args, cmm_target) +emitForeignCall results (CCall (CCallSpec target cconv safety)) args live = do + dflags <- getDynFlags + let (call_args, cmm_target) = case target of StaticTarget _ _ False -> panic "emitForeignCall: unexpected FFI value import" @@ -103,11 +98,15 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live -- attach this info to the CLabel here, and the CLabel pretty printer -- will generate the suffix when the label is printed. call_size - | StdCallConv <- cconv = Just (sum (map (arg_size.cmmExprType.hintlessCmm) args)) + | StdCallConv <- cconv = Just (sum (map (arg_size . cmmExprType dflags . hintlessCmm) args)) | otherwise = Nothing -- ToDo: this might not be correct for 64-bit API - arg_size rep = max (widthInBytes (typeWidth rep)) wORD_SIZE + arg_size rep = max (widthInBytes (typeWidth rep)) (wORD_SIZE dflags) + vols <- getVolatileRegs live + srt <- getSRTInfo + emitForeignCall' safety results + (CmmCallee cmm_target cconv) call_args (Just vols) srt CmmMayReturn -- alternative entry point, used by CmmParse @@ -137,8 +136,8 @@ emitForeignCall' safety results target args vols _srt ret dflags <- getDynFlags -- Both 'id' and 'new_base' are GCKindNonPtr because they're -- RTS only objects and are not subject to garbage collection - id <- newTemp bWord - new_base <- newTemp (cmmRegType (CmmGlobal BaseReg)) + id <- newTemp (bWord dflags) + new_base <- newTemp (cmmRegType dflags (CmmGlobal BaseReg)) temp_args <- load_args_into_temps args temp_target <- load_target_into_temp target let (caller_save, caller_load) = callerSaveVolatileRegs dflags vols @@ -152,7 +151,7 @@ emitForeignCall' safety results target args vols _srt ret stmtC (CmmCall (CmmCallee suspendThread CCallConv) [ CmmHinted id AddrHint ] [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint - , CmmHinted (CmmLit (CmmInt (fromIntegral (fromEnum (playInterruptible safety))) wordWidth)) NoHint] + , CmmHinted (CmmLit (CmmInt (fromIntegral (fromEnum (playInterruptible safety))) (wordWidth dflags))) NoHint] ret) stmtC (CmmCall temp_target results temp_args ret) stmtC (CmmCall (CmmCallee resumeThread CCallConv) @@ -194,10 +193,11 @@ maybe_assign_temp :: CmmExpr -> FCode CmmExpr maybe_assign_temp e | hasNoGlobalRegs e = return e | otherwise = do + dflags <- getDynFlags -- don't use assignTemp, it uses its own notion of "trivial" -- expressions, which are wrong here. -- this is a NonPtr because it only duplicates an existing - reg <- newTemp (cmmExprType e) --TODO FIXME NOW + reg <- newTemp (cmmExprType dflags e) --TODO FIXME NOW stmtC (CmmAssign (CmmLocal reg) e) return (CmmReg (CmmLocal reg)) @@ -211,78 +211,81 @@ emitSaveThreadState :: Code emitSaveThreadState = do dflags <- getDynFlags -- CurrentTSO->stackobj->sp = Sp; - stmtC $ CmmStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO (tso_stackobj dflags)) bWord) + stmtC $ CmmStore (cmmOffset dflags (CmmLoad (cmmOffset dflags stgCurrentTSO (tso_stackobj dflags)) (bWord dflags)) (stack_SP dflags)) stgSp emitCloseNursery -- and save the current cost centre stack in the TSO when profiling: when (dopt Opt_SccProfilingOn dflags) $ - stmtC (CmmStore (cmmOffset stgCurrentTSO (tso_CCCS dflags)) curCCS) + stmtC (CmmStore (cmmOffset dflags stgCurrentTSO (tso_CCCS dflags)) curCCS) -- CurrentNursery->free = Hp+1; emitCloseNursery :: Code -emitCloseNursery = stmtC $ CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1) +emitCloseNursery = do dflags <- getDynFlags + stmtC $ CmmStore (nursery_bdescr_free dflags) (cmmOffsetW dflags stgHp 1) emitLoadThreadState :: Code emitLoadThreadState = do dflags <- getDynFlags - tso <- newTemp bWord -- TODO FIXME NOW - stack <- newTemp bWord -- TODO FIXME NOW + tso <- newTemp (bWord dflags) -- TODO FIXME NOW + stack <- newTemp (bWord dflags) -- TODO FIXME NOW stmtsC [ -- tso = CurrentTSO CmmAssign (CmmLocal tso) stgCurrentTSO, -- stack = tso->stackobj - CmmAssign (CmmLocal stack) (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) bWord), + CmmAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)), -- Sp = stack->sp; - CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal stack)) (stack_SP dflags)) - bWord), + CmmAssign sp (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) + (bWord dflags)), -- SpLim = stack->stack + RESERVED_STACK_WORDS; - CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal stack)) (stack_STACK dflags)) - rESERVED_STACK_WORDS), + CmmAssign spLim (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK 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 - CmmAssign hpAlloc (CmmLit zeroCLit) + CmmAssign hpAlloc (CmmLit (zeroCLit dflags)) ] emitOpenNursery -- and load the current cost centre stack from the TSO when profiling: when (dopt Opt_SccProfilingOn dflags) $ stmtC $ storeCurCCS $ - CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) bWord + CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) (bWord dflags) emitOpenNursery :: Code -emitOpenNursery = stmtsC [ +emitOpenNursery = + do dflags <- getDynFlags + stmtsC [ -- Hp = CurrentNursery->free - 1; - CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free gcWord) (-1)), + CmmAssign hp (cmmOffsetW dflags (CmmLoad (nursery_bdescr_free dflags) (gcWord dflags)) (-1)), -- HpLim = CurrentNursery->start + -- CurrentNursery->blocks*BLOCK_SIZE_W - 1; CmmAssign hpLim - (cmmOffsetExpr - (CmmLoad nursery_bdescr_start bWord) - (cmmOffset - (CmmMachOp mo_wordMul [ - CmmMachOp (MO_SS_Conv W32 wordWidth) - [CmmLoad nursery_bdescr_blocks b32], - CmmLit (mkIntCLit bLOCK_SIZE) + (cmmOffsetExpr dflags + (CmmLoad (nursery_bdescr_start dflags) (bWord dflags)) + (cmmOffset dflags + (CmmMachOp (mo_wordMul dflags) [ + CmmMachOp (MO_SS_Conv W32 (wordWidth dflags)) + [CmmLoad (nursery_bdescr_blocks dflags) b32], + mkIntExpr dflags (bLOCK_SIZE dflags) ]) (-1) ) ) - ] + ] -nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: CmmExpr -nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free -nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start -nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks +nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: DynFlags -> CmmExpr +nursery_bdescr_free dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_free dflags) +nursery_bdescr_start dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_start dflags) +nursery_bdescr_blocks dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_blocks dflags) tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: DynFlags -> ByteOff -tso_stackobj dflags = closureField dflags oFFSET_StgTSO_stackobj -tso_CCCS dflags = closureField dflags oFFSET_StgTSO_cccs -stack_STACK dflags = closureField dflags oFFSET_StgStack_stack -stack_SP dflags = closureField dflags oFFSET_StgStack_sp +tso_stackobj dflags = closureField dflags (oFFSET_StgTSO_stackobj dflags) +tso_CCCS dflags = closureField dflags (oFFSET_StgTSO_cccs dflags) +stack_STACK dflags = closureField dflags (oFFSET_StgStack_stack dflags) +stack_SP dflags = closureField dflags (oFFSET_StgStack_sp dflags) closureField :: DynFlags -> ByteOff -> ByteOff -closureField dflags off = off + fixedHdrSize dflags * wORD_SIZE +closureField dflags off = off + fixedHdrSize dflags * wORD_SIZE dflags stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr stgSp = CmmReg sp @@ -307,10 +310,10 @@ hpAlloc = CmmGlobal HpAlloc shimForeignCallArg :: DynFlags -> StgArg -> CmmExpr -> CmmExpr shimForeignCallArg dflags arg expr | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon - = cmmOffsetB expr (arrPtrsHdrSize dflags) + = cmmOffsetB dflags expr (arrPtrsHdrSize dflags) | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon - = cmmOffsetB expr (arrWordsHdrSize dflags) + = cmmOffsetB dflags expr (arrWordsHdrSize dflags) | otherwise = expr where diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs index 2ce37cf565..c7f6f294ce 100644 --- a/compiler/codeGen/CgHeapery.lhs +++ b/compiler/codeGen/CgHeapery.lhs @@ -42,7 +42,6 @@ import TyCon import CostCentre import Util import Module -import Constants import Outputable import DynFlags import FastString @@ -103,8 +102,9 @@ setRealHp new_realHp getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr getHpRelOffset virtual_offset - = do { hp_usg <- getHpUsage - ; return (cmmRegOffW hpReg (hpRel (realHp hp_usg) virtual_offset)) } + = do { dflags <- getDynFlags + ; hp_usg <- getHpUsage + ; return (cmmRegOffW dflags hpReg (hpRel (realHp hp_usg) virtual_offset)) } \end{code} @@ -165,7 +165,7 @@ mkVirtHeapOffsets dflags is_thunk things | otherwise = fixedHdrSize dflags computeOffset wds_so_far (rep, thing) - = (wds_so_far + cgRepSizeW rep, (thing, hdr_size + wds_so_far)) + = (wds_so_far + cgRepSizeW dflags rep, (thing, hdr_size + wds_so_far)) \end{code} @@ -208,29 +208,29 @@ mkStaticClosureFields dflags cl_info ccs caf_refs payload padding_wds | not is_caf = [] - | otherwise = ASSERT(null payload) [mkIntCLit 0] + | otherwise = ASSERT(null payload) [mkIntCLit dflags 0] static_link_field | is_caf || staticClosureNeedsLink cl_info = [static_link_value] | otherwise = [] saved_info_field - | is_caf = [mkIntCLit 0] + | is_caf = [mkIntCLit dflags 0] | otherwise = [] -- for a static constructor which has NoCafRefs, we set the -- static link field to a non-zero value so the garbage -- collector will ignore it. static_link_value - | caf_refs = mkIntCLit 0 - | otherwise = mkIntCLit 1 + | caf_refs = mkIntCLit dflags 0 + | otherwise = mkIntCLit dflags 1 mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] mkStaticClosure dflags info_lbl ccs payload padding_wds static_link_field saved_info_field = [CmmLabel info_lbl] ++ variable_header_words - ++ concatMap padLitToWord payload + ++ concatMap (padLitToWord dflags) payload ++ padding_wds ++ static_link_field ++ saved_info_field @@ -241,10 +241,10 @@ mkStaticClosure dflags info_lbl ccs payload padding_wds static_link_field saved_ ++ staticProfHdr dflags ccs ++ staticTickyHdr -padLitToWord :: CmmLit -> [CmmLit] -padLitToWord lit = lit : padding pad_length - where width = typeWidth (cmmLitType lit) - pad_length = wORD_SIZE - widthInBytes width :: Int +padLitToWord :: DynFlags -> CmmLit -> [CmmLit] +padLitToWord dflags lit = lit : padding pad_length + where width = typeWidth (cmmLitType dflags lit) + pad_length = wORD_SIZE dflags - widthInBytes width :: Int padding n | n <= 0 = [] | n `rem` 2 /= 0 = CmmInt 0 W8 : padding (n-1) @@ -412,18 +412,18 @@ unbxTupleHeapCheck regs ptrs nptrs fail_code code | ptrs > 255 || nptrs > 255 = panic "altHeapCheck" | otherwise = initHeapUsage $ \ hpHw -> do - { codeOnly $ do { do_checks 0 {- no stack check -} hpHw + { dflags <- getDynFlags + ; let full_fail_code = fail_code `plusStmts` oneStmt assign_liveness + assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9 VNonGcPtr)) -- Ho ho ho! + (CmmLit (mkWordCLit dflags liveness)) + liveness = mkRegLiveness regs ptrs nptrs + live = Just $ map snd regs + rts_label = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_ut"))) + ; codeOnly $ do { do_checks 0 {- no stack check -} hpHw full_fail_code rts_label live ; tickyAllocHeap hpHw } ; setRealHp hpHw ; code } - where - full_fail_code = fail_code `plusStmts` oneStmt assign_liveness - assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9 VNonGcPtr)) -- Ho ho ho! - (CmmLit (mkWordCLit liveness)) - liveness = mkRegLiveness regs ptrs nptrs - live = Just $ map snd regs - rts_label = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_ut"))) \end{code} @@ -452,25 +452,37 @@ do_checks :: WordOff -- Stack headroom -> Code do_checks 0 0 _ _ _ = nopC -do_checks _ hp _ _ _ - | hp > bLOCKS_PER_MBLOCK * bLOCK_SIZE_W - = sorry (unlines [ - "Trying to allocate more than " ++ show (bLOCKS_PER_MBLOCK * bLOCK_SIZE) ++ " bytes.", - "", - "See: http://hackage.haskell.org/trac/ghc/ticket/4505", - "Suggestion: read data from a file instead of having large static data", - "structures in the code."]) - do_checks stk hp reg_save_code rts_lbl live - = do_checks' (CmmLit (mkIntCLit (stk*wORD_SIZE))) - (CmmLit (mkIntCLit (hp*wORD_SIZE))) - (stk /= 0) (hp /= 0) reg_save_code rts_lbl live + = do dflags <- getDynFlags + if hp > bLOCKS_PER_MBLOCK dflags * bLOCK_SIZE_W dflags + then sorry (unlines [ + "Trying to allocate more than " ++ show (bLOCKS_PER_MBLOCK dflags * bLOCK_SIZE dflags) ++ " bytes.", + "", + "See: http://hackage.haskell.org/trac/ghc/ticket/4505", + "Suggestion: read data from a file instead of having large static data", + "structures in the code."]) + else do_checks' (mkIntExpr dflags (stk * wORD_SIZE dflags)) + (mkIntExpr dflags (hp * wORD_SIZE dflags)) + (stk /= 0) (hp /= 0) reg_save_code rts_lbl live -- The offsets are now in *bytes* do_checks' :: CmmExpr -> CmmExpr -> Bool -> Bool -> CmmStmts -> CmmExpr -> Maybe [GlobalReg] -> Code do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl live - = do { doGranAllocate hp_expr + = do { dflags <- getDynFlags + + -- Stk overflow if (Sp - stk_bytes < SpLim) + ; let stk_oflo = CmmMachOp (mo_wordULt dflags) + [CmmMachOp (mo_wordSub dflags) [CmmReg spReg, stk_expr], + CmmReg (CmmGlobal SpLim)] + + -- Hp overflow if (Hp > HpLim) + -- (Hp has been incremented by now) + -- HpLim points to the LAST WORD of valid allocation space. + hp_oflo = CmmMachOp (mo_wordUGt dflags) + [CmmReg hpReg, CmmReg (CmmGlobal HpLim)] + + ; doGranAllocate hp_expr -- The failure block: this saves the registers and jumps to -- the appropriate RTS stub. @@ -496,7 +508,7 @@ do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl live ; whenC hp_nonzero (stmtsC [CmmAssign hpReg - (cmmOffsetExprB (CmmReg hpReg) hp_expr), + (cmmOffsetExprB dflags (CmmReg hpReg) hp_expr), CmmCondBranch hp_oflo hp_blk_id]) -- Bump heap pointer, and test for heap exhaustion -- Note that we don't move the heap pointer unless the @@ -504,17 +516,6 @@ do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl live -- with slop at the end of the current block, which can -- confuse the LDV profiler. } - where - -- Stk overflow if (Sp - stk_bytes < SpLim) - stk_oflo = CmmMachOp mo_wordULt - [CmmMachOp mo_wordSub [CmmReg spReg, stk_expr], - CmmReg (CmmGlobal SpLim)] - - -- Hp overflow if (Hp > HpLim) - -- (Hp has been incremented by now) - -- HpLim points to the LAST WORD of valid allocation space. - hp_oflo = CmmMachOp mo_wordUGt - [CmmReg hpReg, CmmReg (CmmGlobal HpLim)] \end{code} %************************************************************************ @@ -528,38 +529,38 @@ hpChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code hpChkGen bytes liveness reentry = do dflags <- getDynFlags let platform = targetPlatform dflags - do_checks' (CmmLit (mkIntCLit 0)) bytes False True assigns + assigns = mkStmts [ mk_vanilla_assignment dflags 9 liveness, + mk_vanilla_assignment dflags 10 reentry ] + do_checks' (zeroExpr dflags) bytes False True assigns stg_gc_gen (Just (activeStgRegs platform)) - where - assigns = mkStmts [ mk_vanilla_assignment 9 liveness, - mk_vanilla_assignment 10 reentry ] -- a heap check where R1 points to the closure to enter on return, and -- we want to assign to Sp[0] on failure (used in AutoApply.cmm:BUILD_PAP). hpChkNodePointsAssignSp0 :: CmmExpr -> CmmExpr -> Code hpChkNodePointsAssignSp0 bytes sp0 - = do_checks' (CmmLit (mkIntCLit 0)) bytes False True assign - stg_gc_enter1 (Just [node]) + = do dflags <- getDynFlags + do_checks' (zeroExpr dflags) bytes False True assign + stg_gc_enter1 (Just [node]) where assign = oneStmt (CmmStore (CmmReg spReg) sp0) stkChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code stkChkGen bytes liveness reentry = do dflags <- getDynFlags let platform = targetPlatform dflags - do_checks' bytes (CmmLit (mkIntCLit 0)) True False assigns + assigns = mkStmts [ mk_vanilla_assignment dflags 9 liveness, + mk_vanilla_assignment dflags 10 reentry ] + do_checks' bytes (zeroExpr dflags) True False assigns stg_gc_gen (Just (activeStgRegs platform)) - where - assigns = mkStmts [ mk_vanilla_assignment 9 liveness, - mk_vanilla_assignment 10 reentry ] -mk_vanilla_assignment :: Int -> CmmExpr -> CmmStmt -mk_vanilla_assignment n e - = CmmAssign (CmmGlobal (VanillaReg n (vgcFlag (cmmExprType e)))) e +mk_vanilla_assignment :: DynFlags -> Int -> CmmExpr -> CmmStmt +mk_vanilla_assignment dflags n e + = CmmAssign (CmmGlobal (VanillaReg n (vgcFlag (cmmExprType dflags e)))) e stkChkNodePoints :: CmmExpr -> Code stkChkNodePoints bytes - = do_checks' bytes (CmmLit (mkIntCLit 0)) True False noStmts - stg_gc_enter1 (Just [node]) + = do dflags <- getDynFlags + do_checks' bytes (zeroExpr dflags) True False noStmts + stg_gc_enter1 (Just [node]) stg_gc_gen :: CmmExpr stg_gc_gen = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_gen"))) @@ -630,8 +631,9 @@ initDynHdr dflags info_ptr cc hpStore :: CmmExpr -> [(CmmExpr, VirtualHpOffset)] -> Code -- Store the item (expr,off) in base[off] hpStore base es - = stmtsC [ CmmStore (cmmOffsetW base off) val - | (val, off) <- es ] + = do dflags <- getDynFlags + stmtsC [ CmmStore (cmmOffsetW dflags base off) val + | (val, off) <- es ] emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> Code emitSetDynHdr base info_ptr ccs diff --git a/compiler/codeGen/CgHpc.hs b/compiler/codeGen/CgHpc.hs index a134f00067..407de7b647 100644 --- a/compiler/codeGen/CgHpc.hs +++ b/compiler/codeGen/CgHpc.hs @@ -18,7 +18,8 @@ import HscTypes cgTickBox :: Module -> Int -> Code cgTickBox mod n = do - let tick_box = (cmmIndex W64 + dflags <- getDynFlags + let tick_box = (cmmIndex dflags W64 (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod) n ) diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs index 3f8e6c0222..e2a3aa2efd 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -43,7 +43,6 @@ import CLabel import Name import Unique -import Constants import DynFlags import Util import Outputable @@ -94,16 +93,17 @@ emitReturnTarget -> CgStmts -- The direct-return code (if any) -> FCode CLabel emitReturnTarget name stmts - = do { srt_info <- getSRTInfo - ; blks <- cgStmtsToBlocks stmts - ; frame <- mkStackLayout - ; let smrep = mkStackRep (mkLiveness frame) - info = CmmInfoTable { cit_lbl = info_lbl - , cit_prof = NoProfilingInfo - , cit_rep = smrep - , cit_srt = srt_info } - ; emitInfoTableAndCode entry_lbl info args blks - ; return info_lbl } + = do dflags <- getDynFlags + srt_info <- getSRTInfo + blks <- cgStmtsToBlocks stmts + frame <- mkStackLayout + let smrep = mkStackRep (mkLiveness dflags frame) + info = CmmInfoTable { cit_lbl = info_lbl + , cit_prof = NoProfilingInfo + , cit_rep = smrep + , cit_srt = srt_info } + emitInfoTableAndCode entry_lbl info args blks + return info_lbl where args = {- trace "emitReturnTarget: missing args" -} [] uniq = getUnique name @@ -151,6 +151,7 @@ is not present in the list (it is always assumed). -} mkStackLayout :: FCode [Maybe LocalReg] mkStackLayout = do + dflags <- getDynFlags StackUsage { realSp = real_sp, frameSp = frame_sp } <- getStkUsage binds <- getLiveStackBindings @@ -162,21 +163,22 @@ mkStackLayout = do WARN( not (all (\bind -> fst bind >= 0) rel_binds), ppr binds $$ ppr rel_binds $$ ppr frame_size $$ ppr real_sp $$ ppr frame_sp ) - return $ stack_layout rel_binds frame_size + return $ stack_layout dflags rel_binds frame_size -stack_layout :: [(VirtualSpOffset, CgIdInfo)] +stack_layout :: DynFlags + -> [(VirtualSpOffset, CgIdInfo)] -> WordOff -> [Maybe LocalReg] -stack_layout [] sizeW = replicate sizeW Nothing -stack_layout ((off, bind):binds) sizeW | off == sizeW - 1 = - (Just stack_bind) : (stack_layout binds (sizeW - rep_size)) +stack_layout _ [] sizeW = replicate sizeW Nothing +stack_layout dflags ((off, bind):binds) sizeW | off == sizeW - 1 = + (Just stack_bind) : (stack_layout dflags binds (sizeW - rep_size)) where - rep_size = cgRepSizeW (cgIdInfoArgRep bind) + rep_size = cgRepSizeW dflags (cgIdInfoArgRep bind) stack_bind = LocalReg unique machRep unique = getUnique (cgIdInfoId bind) - machRep = argMachRep (cgIdInfoArgRep bind) -stack_layout binds@(_:_) sizeW | otherwise = - Nothing : (stack_layout binds (sizeW - 1)) + machRep = argMachRep dflags (cgIdInfoArgRep bind) +stack_layout dflags binds@(_:_) sizeW | otherwise = + Nothing : (stack_layout dflags binds (sizeW - 1)) {- Another way to write the function that might be less error prone (untested) stack_layout offsets sizeW = result @@ -212,15 +214,15 @@ emitAlgReturnTarget -> FCode (CLabel, SemiTaggingStuff) emitAlgReturnTarget name branches mb_deflt fam_sz - = do { blks <- getCgStmts $ + = do { blks <- getCgStmts $ do -- is the constructor tag in the node reg? - if isSmallFamily fam_sz + dflags <- getDynFlags + if isSmallFamily dflags fam_sz then do -- yes, node has constr. tag - let tag_expr = cmmConstrTag1 (CmmReg nodeReg) + let tag_expr = cmmConstrTag1 dflags (CmmReg nodeReg) branches' = [(tag+1,branch)|(tag,branch)<-branches] emitSwitch tag_expr branches' mb_deflt 1 fam_sz else do -- no, get tag from info table - dflags <- getDynFlags let -- Note that ptr _always_ has tag 1 -- when the family size is big enough untagged_ptr = cmmRegOffB nodeReg (-1) @@ -256,7 +258,7 @@ stdInfoTableSizeW dflags | otherwise = 0 stdInfoTableSizeB :: DynFlags -> ByteOff -stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE +stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE dflags stdSrtBitmapOffset :: DynFlags -> ByteOff -- Byte offset of the SRT bitmap half-word which is @@ -265,11 +267,11 @@ stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE stdClosureTypeOffset :: DynFlags -> ByteOff -- Byte offset of the closure type half-word -stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE +stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff -stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2*wORD_SIZE -stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2*wORD_SIZE + hALF_WORD_SIZE +stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags +stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE ------------------------------------------------------------------------- -- @@ -277,16 +279,16 @@ stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2*wORD_SIZE + hALF_WORD_SIZ -- ------------------------------------------------------------------------- -closureInfoPtr :: CmmExpr -> CmmExpr +closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr -- Takes a closure pointer and returns the info table pointer -closureInfoPtr e = CmmLoad e bWord +closureInfoPtr dflags e = CmmLoad e (bWord dflags) entryCode :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info pointer (the first word of a closure) -- and returns its entry code entryCode dflags e | tablesNextToCode dflags = e - | otherwise = CmmLoad e bWord + | otherwise = CmmLoad e (bWord dflags) getConstrTag :: DynFlags -> CmmExpr -> CmmExpr -- Takes a closure pointer, and return the *zero-indexed* @@ -294,25 +296,25 @@ getConstrTag :: DynFlags -> CmmExpr -> CmmExpr -- This lives in the SRT field of the info table -- (constructors don't need SRTs). getConstrTag dflags closure_ptr - = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableConstrTag dflags info_table] + = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableConstrTag dflags info_table] where - info_table = infoTable dflags (closureInfoPtr closure_ptr) + info_table = infoTable dflags (closureInfoPtr dflags closure_ptr) cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr -- Takes a closure pointer, and return the closure type -- obtained from the info table cmmGetClosureType dflags closure_ptr - = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableClosureType dflags info_table] + = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableClosureType dflags info_table] where - info_table = infoTable dflags (closureInfoPtr closure_ptr) + info_table = infoTable dflags (closureInfoPtr dflags closure_ptr) infoTable :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info pointer (the first word of a closure) -- and returns a pointer to the first word of the standard-form -- info table, excluding the entry-code word (if present) infoTable dflags info_ptr - | tablesNextToCode dflags = cmmOffsetB info_ptr (- stdInfoTableSizeB dflags) - | otherwise = cmmOffsetW info_ptr 1 -- Past the entry code pointer + | tablesNextToCode dflags = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags) + | otherwise = cmmOffsetW dflags info_ptr 1 -- Past the entry code pointer infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info table pointer (from infoTable) and returns the constr tag @@ -323,21 +325,21 @@ infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info table pointer (from infoTable) and returns the srt_bitmap -- field of the info table infoTableSrtBitmap dflags info_tbl - = CmmLoad (cmmOffsetB info_tbl (stdSrtBitmapOffset dflags)) bHalfWord + = CmmLoad (cmmOffsetB dflags info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord dflags) infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info table pointer (from infoTable) and returns the closure type -- field of the info table. infoTableClosureType dflags info_tbl - = CmmLoad (cmmOffsetB info_tbl (stdClosureTypeOffset dflags)) bHalfWord + = CmmLoad (cmmOffsetB dflags info_tbl (stdClosureTypeOffset dflags)) (bHalfWord dflags) infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr infoTablePtrs dflags info_tbl - = CmmLoad (cmmOffsetB info_tbl (stdPtrsOffset dflags)) bHalfWord + = CmmLoad (cmmOffsetB dflags info_tbl (stdPtrsOffset dflags)) (bHalfWord dflags) infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr infoTableNonPtrs dflags info_tbl - = CmmLoad (cmmOffsetB info_tbl (stdNonPtrsOffset dflags)) bHalfWord + = CmmLoad (cmmOffsetB dflags info_tbl (stdNonPtrsOffset dflags)) (bHalfWord dflags) funInfoTable :: DynFlags -> CmmExpr -> CmmExpr -- Takes the info pointer of a function, @@ -345,9 +347,9 @@ funInfoTable :: DynFlags -> CmmExpr -> CmmExpr -- in the info table. funInfoTable dflags info_ptr | tablesNextToCode dflags - = cmmOffsetB info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev) + = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags) | otherwise - = cmmOffsetW info_ptr (1 + stdInfoTableSizeW dflags) + = cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags) -- Past the entry code pointer ------------------------------------------------------------------------- diff --git a/compiler/codeGen/CgLetNoEscape.lhs b/compiler/codeGen/CgLetNoEscape.lhs index 2fb603baed..610869ad89 100644 --- a/compiler/codeGen/CgLetNoEscape.lhs +++ b/compiler/codeGen/CgLetNoEscape.lhs @@ -162,7 +162,8 @@ cgLetNoEscapeClosure in -- saveVolatileVarsAndRegs done earlier in cgExpr. - do { (vSp, _) <- forkEvalHelp rhs_eob_info + do { dflags <- getDynFlags + ; (vSp, _) <- forkEvalHelp rhs_eob_info (do { allocStackTop retAddrSizeW ; nukeDeadBindings full_live_in_rhss }) @@ -176,7 +177,7 @@ cgLetNoEscapeClosure ; _ <- emitReturnTarget (idName bndr) abs_c ; return () }) - ; returnFC (bndr, letNoEscapeIdInfo bndr vSp lf_info) } + ; returnFC (bndr, letNoEscapeIdInfo dflags bndr vSp lf_info) } \end{code} \begin{code} diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs index a2e50e0c0d..98c7e21332 100644 --- a/compiler/codeGen/CgPrimOp.hs +++ b/compiler/codeGen/CgPrimOp.hs @@ -28,12 +28,12 @@ import OldCmmUtils import PrimOp import SMRep import Module -import Constants import Outputable import DynFlags import FastString import Control.Monad +import Data.Bits -- --------------------------------------------------------------------------- -- Code generation for PrimOps @@ -45,12 +45,14 @@ cgPrimOp :: [CmmFormal] -- where to put the results -> Code cgPrimOp results op args live - = do arg_exprs <- getArgAmodes args + = do dflags <- getDynFlags + arg_exprs <- getArgAmodes args let non_void_args = [ e | (r,e) <- arg_exprs, nonVoidArg r ] - emitPrimOp results op non_void_args live + emitPrimOp dflags results op non_void_args live -emitPrimOp :: [CmmFormal] -- where to put the results +emitPrimOp :: DynFlags + -> [CmmFormal] -- where to put the results -> PrimOp -- the op -> [CmmExpr] -- arguments -> StgLiveVars -- live vars, in case we need to save them @@ -59,7 +61,7 @@ emitPrimOp :: [CmmFormal] -- where to put the results -- First we handle various awkward cases specially. The remaining -- easy cases are then handled by translateOp, defined below. -emitPrimOp [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 C, and without needing any comparisons. This may not be the @@ -81,19 +83,19 @@ emitPrimOp [res_r,res_c] IntAddCOp [aa,bb] _ -} = stmtsC [ - CmmAssign (CmmLocal res_r) (CmmMachOp mo_wordAdd [aa,bb]), + CmmAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [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 (CmmLocal res_r)] + CmmMachOp (mo_wordUShr dflags) [ + CmmMachOp (mo_wordAnd dflags) [ + CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]], + CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] ], - CmmLit (mkIntCLit (wORD_SIZE_IN_BITS - 1)) + mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1) ] ] -emitPrimOp [res_r,res_c] IntSubCOp [aa,bb] _ +emitPrimOp dflags [res_r,res_c] IntSubCOp [aa,bb] _ {- Similarly: #define subIntCzh(r,c,a,b) \ { r = ((I_)(a)) - ((I_)(b)); \ @@ -104,19 +106,19 @@ emitPrimOp [res_r,res_c] IntSubCOp [aa,bb] _ c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1) -} = stmtsC [ - CmmAssign (CmmLocal res_r) (CmmMachOp mo_wordSub [aa,bb]), + CmmAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]), CmmAssign (CmmLocal res_c) $ - CmmMachOp mo_wordUShr [ - CmmMachOp mo_wordAnd [ - CmmMachOp mo_wordXor [aa,bb], - CmmMachOp mo_wordXor [aa, CmmReg (CmmLocal res_r)] + CmmMachOp (mo_wordUShr dflags) [ + CmmMachOp (mo_wordAnd dflags) [ + CmmMachOp (mo_wordXor dflags) [aa,bb], + CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] ], - CmmLit (mkIntCLit (wORD_SIZE_IN_BITS - 1)) + mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1) ] ] -emitPrimOp [res] ParOp [arg] live +emitPrimOp _ [res] ParOp [arg] live = do -- for now, just implement this in a C function -- later, we might want to inline it. @@ -132,15 +134,15 @@ emitPrimOp [res] ParOp [arg] live where newspark = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark"))) -emitPrimOp [res] SparkOp [arg] live = do +emitPrimOp dflags [res] SparkOp [arg] live = do -- returns the value of arg in res. We're going to therefore -- refer to arg twice (once to pass to newSpark(), and once to -- assign to res), so put it in a temporary. - tmp <- newTemp bWord + tmp <- newTemp (bWord dflags) stmtC (CmmAssign (CmmLocal tmp) arg) vols <- getVolatileRegs live - res' <- newTemp bWord + res' <- newTemp (bWord dflags) emitForeignCall' PlayRisky [CmmHinted res' NoHint] (CmmCallee newspark CCallConv) @@ -153,24 +155,21 @@ emitPrimOp [res] SparkOp [arg] live = do where newspark = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark"))) -emitPrimOp [res] GetCCSOfOp [arg] _live - = do dflags <- getDynFlags - stmtC (CmmAssign (CmmLocal res) (val dflags)) +emitPrimOp dflags [res] GetCCSOfOp [arg] _live + = stmtC (CmmAssign (CmmLocal res) val) where - val dflags - | dopt Opt_SccProfilingOn dflags = costCentreFrom (cmmUntag arg) - | otherwise = CmmLit zeroCLit + val + | dopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag dflags arg) + | otherwise = CmmLit (zeroCLit dflags) -emitPrimOp [res] GetCurrentCCSOp [_dummy_arg] _live +emitPrimOp _ [res] GetCurrentCCSOp [_dummy_arg] _live = stmtC (CmmAssign (CmmLocal res) curCCS) -emitPrimOp [res] ReadMutVarOp [mutv] _ - = do dflags <- getDynFlags - stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW mutv (fixedHdrSize dflags) gcWord)) +emitPrimOp dflags [res] ReadMutVarOp [mutv] _ + = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW dflags mutv (fixedHdrSize dflags) (gcWord dflags))) -emitPrimOp [] WriteMutVarOp [mutv,var] live - = do dflags <- getDynFlags - stmtC (CmmStore (cmmOffsetW mutv (fixedHdrSize dflags)) var) +emitPrimOp dflags [] WriteMutVarOp [mutv,var] live + = do stmtC (CmmStore (cmmOffsetW dflags mutv (fixedHdrSize dflags)) var) vols <- getVolatileRegs live emitForeignCall' PlayRisky [{-no results-}] @@ -184,54 +183,49 @@ emitPrimOp [] WriteMutVarOp [mutv,var] live -- #define sizzeofByteArrayzh(r,a) \ -- r = ((StgArrWords *)(a))->bytes -emitPrimOp [res] SizeofByteArrayOp [arg] _ - = do dflags <- getDynFlags - stmtC $ - CmmAssign (CmmLocal res) - (cmmLoadIndexW arg (fixedHdrSize dflags) bWord) +emitPrimOp dflags [res] SizeofByteArrayOp [arg] _ + = stmtC $ + CmmAssign (CmmLocal res) + (cmmLoadIndexW dflags arg (fixedHdrSize dflags) (bWord dflags)) -- #define sizzeofMutableByteArrayzh(r,a) \ -- r = ((StgArrWords *)(a))->bytes -emitPrimOp [res] SizeofMutableByteArrayOp [arg] live - = emitPrimOp [res] SizeofByteArrayOp [arg] live +emitPrimOp dflags [res] SizeofMutableByteArrayOp [arg] live + = emitPrimOp dflags [res] SizeofByteArrayOp [arg] live -- #define touchzh(o) /* nothing */ -emitPrimOp [] TouchOp [_] _ +emitPrimOp _ [] TouchOp [_] _ = nopC -- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a) -emitPrimOp [res] ByteArrayContents_Char [arg] _ - = do dflags <- getDynFlags - stmtC (CmmAssign (CmmLocal res) (cmmOffsetB arg (arrWordsHdrSize dflags))) +emitPrimOp dflags [res] ByteArrayContents_Char [arg] _ + = stmtC (CmmAssign (CmmLocal res) (cmmOffsetB dflags arg (arrWordsHdrSize dflags))) -- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn) -emitPrimOp [res] StableNameToIntOp [arg] _ - = do dflags <- getDynFlags - stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW arg (fixedHdrSize dflags) bWord)) +emitPrimOp dflags [res] StableNameToIntOp [arg] _ + = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSize dflags) (bWord dflags))) -- #define eqStableNamezh(r,sn1,sn2) \ -- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn)) -emitPrimOp [res] EqStableNameOp [arg1,arg2] _ - = do dflags <- getDynFlags - stmtC (CmmAssign (CmmLocal res) (CmmMachOp mo_wordEq [ - cmmLoadIndexW arg1 (fixedHdrSize dflags) bWord, - cmmLoadIndexW arg2 (fixedHdrSize dflags) bWord - ])) +emitPrimOp dflags [res] EqStableNameOp [arg1,arg2] _ + = stmtC (CmmAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [ + cmmLoadIndexW dflags arg1 (fixedHdrSize dflags) (bWord dflags), + cmmLoadIndexW dflags arg2 (fixedHdrSize dflags) (bWord dflags) + ])) -emitPrimOp [res] ReallyUnsafePtrEqualityOp [arg1,arg2] _ - = stmtC (CmmAssign (CmmLocal res) (CmmMachOp mo_wordEq [arg1,arg2])) +emitPrimOp dflags [res] ReallyUnsafePtrEqualityOp [arg1,arg2] _ + = stmtC (CmmAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2])) -- #define addrToHValuezh(r,a) r=(P_)a -emitPrimOp [res] AddrToAnyOp [arg] _ +emitPrimOp _ [res] AddrToAnyOp [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] _ - = do dflags <- getDynFlags - stmtC (CmmAssign (CmmLocal res) (getConstrTag dflags (cmmUntag arg))) +emitPrimOp dflags [res] DataToTagOp [arg] _ + = stmtC (CmmAssign (CmmLocal res) (getConstrTag dflags (cmmUntag dflags arg))) {- Freezing arrays-of-ptrs requires changing an info table, for the benefit of the generational collector. It needs to scavenge mutable @@ -243,203 +237,211 @@ emitPrimOp [res] DataToTagOp [arg] _ -- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN0_info); -- r = a; -- } -emitPrimOp [res] UnsafeFreezeArrayOp [arg] _ +emitPrimOp _ [res] UnsafeFreezeArrayOp [arg] _ = stmtsC [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)), CmmAssign (CmmLocal res) arg ] -emitPrimOp [res] UnsafeFreezeArrayArrayOp [arg] _ +emitPrimOp _ [res] UnsafeFreezeArrayArrayOp [arg] _ = stmtsC [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)), CmmAssign (CmmLocal res) arg ] -- #define unsafeFreezzeByteArrayzh(r,a) r=(a) -emitPrimOp [res] UnsafeFreezeByteArrayOp [arg] _ +emitPrimOp _ [res] UnsafeFreezeByteArrayOp [arg] _ = stmtC (CmmAssign (CmmLocal res) arg) -emitPrimOp [] CopyArrayOp [src,src_off,dst,dst_off,n] live = +emitPrimOp _ [] CopyArrayOp [src,src_off,dst,dst_off,n] live = doCopyArrayOp src src_off dst dst_off n live -emitPrimOp [] CopyMutableArrayOp [src,src_off,dst,dst_off,n] live = +emitPrimOp _ [] CopyMutableArrayOp [src,src_off,dst,dst_off,n] live = doCopyMutableArrayOp src src_off dst dst_off n live -emitPrimOp [res] CloneArrayOp [src,src_off,n] live = +emitPrimOp _ [res] CloneArrayOp [src,src_off,n] live = emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n live -emitPrimOp [res] CloneMutableArrayOp [src,src_off,n] live = +emitPrimOp _ [res] CloneMutableArrayOp [src,src_off,n] live = emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n live -emitPrimOp [res] FreezeArrayOp [src,src_off,n] live = +emitPrimOp _ [res] FreezeArrayOp [src,src_off,n] live = emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n live -emitPrimOp [res] ThawArrayOp [src,src_off,n] live = +emitPrimOp _ [res] ThawArrayOp [src,src_off,n] live = emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n live -emitPrimOp [] CopyArrayArrayOp [src,src_off,dst,dst_off,n] live = +emitPrimOp _ [] CopyArrayArrayOp [src,src_off,dst,dst_off,n] live = doCopyArrayOp src src_off dst dst_off n live -emitPrimOp [] CopyMutableArrayArrayOp [src,src_off,dst,dst_off,n] live = +emitPrimOp _ [] CopyMutableArrayArrayOp [src,src_off,dst,dst_off,n] live = doCopyMutableArrayOp src src_off dst dst_off n live -- Reading/writing pointer arrays -emitPrimOp [r] ReadArrayOp [obj,ix] _ = doReadPtrArrayOp r obj ix -emitPrimOp [r] IndexArrayOp [obj,ix] _ = doReadPtrArrayOp r obj ix -emitPrimOp [] WriteArrayOp [obj,ix,v] _ = doWritePtrArrayOp obj ix v - -emitPrimOp [r] IndexArrayArrayOp_ByteArray [obj,ix] _ = doReadPtrArrayOp r obj ix -emitPrimOp [r] IndexArrayArrayOp_ArrayArray [obj,ix] _ = doReadPtrArrayOp r obj ix -emitPrimOp [r] ReadArrayArrayOp_ByteArray [obj,ix] _ = doReadPtrArrayOp r obj ix -emitPrimOp [r] ReadArrayArrayOp_MutableByteArray [obj,ix] _ = doReadPtrArrayOp r obj ix -emitPrimOp [r] ReadArrayArrayOp_ArrayArray [obj,ix] _ = doReadPtrArrayOp r obj ix -emitPrimOp [r] ReadArrayArrayOp_MutableArrayArray [obj,ix] _ = doReadPtrArrayOp r obj ix -emitPrimOp [] WriteArrayArrayOp_ByteArray [obj,ix,v] _ = doWritePtrArrayOp obj ix v -emitPrimOp [] WriteArrayArrayOp_MutableByteArray [obj,ix,v] _ = doWritePtrArrayOp obj ix v -emitPrimOp [] WriteArrayArrayOp_ArrayArray [obj,ix,v] _ = doWritePtrArrayOp obj ix v -emitPrimOp [] WriteArrayArrayOp_MutableArrayArray [obj,ix,v] _ = doWritePtrArrayOp obj ix v - -emitPrimOp [res] SizeofArrayOp [arg] _ - = do dflags <- getDynFlags - stmtC $ CmmAssign (CmmLocal res) - (cmmLoadIndexW arg (fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs) bWord) -emitPrimOp [res] SizeofMutableArrayOp [arg] live - = emitPrimOp [res] SizeofArrayOp [arg] live -emitPrimOp [res] SizeofArrayArrayOp [arg] live - = emitPrimOp [res] SizeofArrayOp [arg] live -emitPrimOp [res] SizeofMutableArrayArrayOp [arg] live - = emitPrimOp [res] SizeofArrayOp [arg] live +emitPrimOp _ [r] ReadArrayOp [obj,ix] _ = doReadPtrArrayOp r obj ix +emitPrimOp _ [r] IndexArrayOp [obj,ix] _ = doReadPtrArrayOp r obj ix +emitPrimOp _ [] WriteArrayOp [obj,ix,v] _ = doWritePtrArrayOp obj ix v + +emitPrimOp _ [r] IndexArrayArrayOp_ByteArray [obj,ix] _ = doReadPtrArrayOp r obj ix +emitPrimOp _ [r] IndexArrayArrayOp_ArrayArray [obj,ix] _ = doReadPtrArrayOp r obj ix +emitPrimOp _ [r] ReadArrayArrayOp_ByteArray [obj,ix] _ = doReadPtrArrayOp r obj ix +emitPrimOp _ [r] ReadArrayArrayOp_MutableByteArray [obj,ix] _ = doReadPtrArrayOp r obj ix +emitPrimOp _ [r] ReadArrayArrayOp_ArrayArray [obj,ix] _ = doReadPtrArrayOp r obj ix +emitPrimOp _ [r] ReadArrayArrayOp_MutableArrayArray [obj,ix] _ = doReadPtrArrayOp r obj ix +emitPrimOp _ [] WriteArrayArrayOp_ByteArray [obj,ix,v] _ = doWritePtrArrayOp obj ix v +emitPrimOp _ [] WriteArrayArrayOp_MutableByteArray [obj,ix,v] _ = doWritePtrArrayOp obj ix v +emitPrimOp _ [] WriteArrayArrayOp_ArrayArray [obj,ix,v] _ = doWritePtrArrayOp obj ix v +emitPrimOp _ [] WriteArrayArrayOp_MutableArrayArray [obj,ix,v] _ = doWritePtrArrayOp obj ix v + +emitPrimOp dflags [res] SizeofArrayOp [arg] _ + = stmtC $ CmmAssign (CmmLocal res) + (cmmLoadIndexW dflags arg (fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags) (bWord dflags)) +emitPrimOp dflags [res] SizeofMutableArrayOp [arg] live + = emitPrimOp dflags [res] SizeofArrayOp [arg] live +emitPrimOp dflags [res] SizeofArrayArrayOp [arg] live + = emitPrimOp dflags [res] SizeofArrayOp [arg] live +emitPrimOp dflags [res] SizeofMutableArrayArrayOp [arg] live + = emitPrimOp dflags [res] SizeofArrayOp [arg] live -- IndexXXXoffAddr -emitPrimOp res IndexOffAddrOp_Char args _ = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args -emitPrimOp res IndexOffAddrOp_WideChar args _ = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args -emitPrimOp res IndexOffAddrOp_Int args _ = doIndexOffAddrOp Nothing bWord res args -emitPrimOp res IndexOffAddrOp_Word args _ = doIndexOffAddrOp Nothing bWord res args -emitPrimOp res IndexOffAddrOp_Addr args _ = doIndexOffAddrOp Nothing bWord res args -emitPrimOp res IndexOffAddrOp_Float args _ = doIndexOffAddrOp Nothing f32 res args -emitPrimOp res IndexOffAddrOp_Double args _ = doIndexOffAddrOp Nothing f64 res args -emitPrimOp res IndexOffAddrOp_StablePtr args _ = doIndexOffAddrOp Nothing bWord res args -emitPrimOp res IndexOffAddrOp_Int8 args _ = doIndexOffAddrOp (Just mo_s_8ToWord) b8 res args -emitPrimOp res IndexOffAddrOp_Int16 args _ = doIndexOffAddrOp (Just mo_s_16ToWord) b16 res args -emitPrimOp res IndexOffAddrOp_Int32 args _ = doIndexOffAddrOp (Just mo_s_32ToWord) b32 res args -emitPrimOp res IndexOffAddrOp_Int64 args _ = doIndexOffAddrOp Nothing b64 res args -emitPrimOp res IndexOffAddrOp_Word8 args _ = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args -emitPrimOp res IndexOffAddrOp_Word16 args _ = doIndexOffAddrOp (Just mo_u_16ToWord) b16 res args -emitPrimOp res IndexOffAddrOp_Word32 args _ = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args -emitPrimOp res IndexOffAddrOp_Word64 args _ = doIndexOffAddrOp Nothing b64 res args +emitPrimOp dflags res IndexOffAddrOp_Char args _ = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexOffAddrOp_WideChar args _ = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp dflags res IndexOffAddrOp_Int args _ = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res IndexOffAddrOp_Word args _ = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res IndexOffAddrOp_Addr args _ = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp _ res IndexOffAddrOp_Float args _ = doIndexOffAddrOp Nothing f32 res args +emitPrimOp _ res IndexOffAddrOp_Double args _ = doIndexOffAddrOp Nothing f64 res args +emitPrimOp dflags res IndexOffAddrOp_StablePtr args _ = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res IndexOffAddrOp_Int8 args _ = doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexOffAddrOp_Int16 args _ = doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args +emitPrimOp dflags res IndexOffAddrOp_Int32 args _ = doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args +emitPrimOp _ res IndexOffAddrOp_Int64 args _ = doIndexOffAddrOp Nothing b64 res args +emitPrimOp dflags res IndexOffAddrOp_Word8 args _ = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexOffAddrOp_Word16 args _ = doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args +emitPrimOp dflags res IndexOffAddrOp_Word32 args _ = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp _ res IndexOffAddrOp_Word64 args _ = doIndexOffAddrOp Nothing b64 res args -- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr. -emitPrimOp res ReadOffAddrOp_Char args _ = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args -emitPrimOp res ReadOffAddrOp_WideChar args _ = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args -emitPrimOp res ReadOffAddrOp_Int args _ = doIndexOffAddrOp Nothing bWord res args -emitPrimOp res ReadOffAddrOp_Word args _ = doIndexOffAddrOp Nothing bWord res args -emitPrimOp res ReadOffAddrOp_Addr args _ = doIndexOffAddrOp Nothing bWord res args -emitPrimOp res ReadOffAddrOp_Float args _ = doIndexOffAddrOp Nothing f32 res args -emitPrimOp res ReadOffAddrOp_Double args _ = doIndexOffAddrOp Nothing f64 res args -emitPrimOp res ReadOffAddrOp_StablePtr args _ = doIndexOffAddrOp Nothing bWord res args -emitPrimOp res ReadOffAddrOp_Int8 args _ = doIndexOffAddrOp (Just mo_s_8ToWord) b8 res args -emitPrimOp res ReadOffAddrOp_Int16 args _ = doIndexOffAddrOp (Just mo_s_16ToWord) b16 res args -emitPrimOp res ReadOffAddrOp_Int32 args _ = doIndexOffAddrOp (Just mo_s_32ToWord) b32 res args -emitPrimOp res ReadOffAddrOp_Int64 args _ = doIndexOffAddrOp Nothing b64 res args -emitPrimOp res ReadOffAddrOp_Word8 args _ = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args -emitPrimOp res ReadOffAddrOp_Word16 args _ = doIndexOffAddrOp (Just mo_u_16ToWord) b16 res args -emitPrimOp res ReadOffAddrOp_Word32 args _ = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args -emitPrimOp res ReadOffAddrOp_Word64 args _ = doIndexOffAddrOp Nothing b64 res args +emitPrimOp dflags res ReadOffAddrOp_Char args _ = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadOffAddrOp_WideChar args _ = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp dflags res ReadOffAddrOp_Int args _ = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res ReadOffAddrOp_Word args _ = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res ReadOffAddrOp_Addr args _ = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp _ res ReadOffAddrOp_Float args _ = doIndexOffAddrOp Nothing f32 res args +emitPrimOp _ res ReadOffAddrOp_Double args _ = doIndexOffAddrOp Nothing f64 res args +emitPrimOp dflags res ReadOffAddrOp_StablePtr args _ = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res ReadOffAddrOp_Int8 args _ = doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadOffAddrOp_Int16 args _ = doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args +emitPrimOp dflags res ReadOffAddrOp_Int32 args _ = doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args +emitPrimOp _ res ReadOffAddrOp_Int64 args _ = doIndexOffAddrOp Nothing b64 res args +emitPrimOp dflags res ReadOffAddrOp_Word8 args _ = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadOffAddrOp_Word16 args _ = doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args +emitPrimOp dflags res ReadOffAddrOp_Word32 args _ = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp _ res ReadOffAddrOp_Word64 args _ = doIndexOffAddrOp Nothing b64 res args -- IndexXXXArray -emitPrimOp res IndexByteArrayOp_Char args _ = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args -emitPrimOp res IndexByteArrayOp_WideChar args _ = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args -emitPrimOp res IndexByteArrayOp_Int args _ = doIndexByteArrayOp Nothing bWord res args -emitPrimOp res IndexByteArrayOp_Word args _ = doIndexByteArrayOp Nothing bWord res args -emitPrimOp res IndexByteArrayOp_Addr args _ = doIndexByteArrayOp Nothing bWord res args -emitPrimOp res IndexByteArrayOp_Float args _ = doIndexByteArrayOp Nothing f32 res args -emitPrimOp res IndexByteArrayOp_Double args _ = doIndexByteArrayOp Nothing f64 res args -emitPrimOp res IndexByteArrayOp_StablePtr args _ = doIndexByteArrayOp Nothing bWord res args -emitPrimOp res IndexByteArrayOp_Int8 args _ = doIndexByteArrayOp (Just mo_s_8ToWord) b8 res args -emitPrimOp res IndexByteArrayOp_Int16 args _ = doIndexByteArrayOp (Just mo_s_16ToWord) b16 res args -emitPrimOp res IndexByteArrayOp_Int32 args _ = doIndexByteArrayOp (Just mo_s_32ToWord) b32 res args -emitPrimOp res IndexByteArrayOp_Int64 args _ = doIndexByteArrayOp Nothing b64 res args -emitPrimOp res IndexByteArrayOp_Word8 args _ = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args -emitPrimOp res IndexByteArrayOp_Word16 args _ = doIndexByteArrayOp (Just mo_u_16ToWord) b16 res args -emitPrimOp res IndexByteArrayOp_Word32 args _ = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args -emitPrimOp res IndexByteArrayOp_Word64 args _ = doIndexByteArrayOp Nothing b64 res args +emitPrimOp dflags res IndexByteArrayOp_Char args _ = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexByteArrayOp_WideChar args _ = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp dflags res IndexByteArrayOp_Int args _ = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res IndexByteArrayOp_Word args _ = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res IndexByteArrayOp_Addr args _ = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp _ res IndexByteArrayOp_Float args _ = doIndexByteArrayOp Nothing f32 res args +emitPrimOp _ res IndexByteArrayOp_Double args _ = doIndexByteArrayOp Nothing f64 res args +emitPrimOp dflags res IndexByteArrayOp_StablePtr args _ = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res IndexByteArrayOp_Int8 args _ = doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexByteArrayOp_Int16 args _ = doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16 res args +emitPrimOp dflags res IndexByteArrayOp_Int32 args _ = doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32 res args +emitPrimOp _ res IndexByteArrayOp_Int64 args _ = doIndexByteArrayOp Nothing b64 res args +emitPrimOp dflags res IndexByteArrayOp_Word8 args _ = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexByteArrayOp_Word16 args _ = doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16 res args +emitPrimOp dflags res IndexByteArrayOp_Word32 args _ = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp _ res IndexByteArrayOp_Word64 args _ = doIndexByteArrayOp Nothing b64 res args -- ReadXXXArray, identical to IndexXXXArray. -emitPrimOp res ReadByteArrayOp_Char args _ = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args -emitPrimOp res ReadByteArrayOp_WideChar args _ = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args -emitPrimOp res ReadByteArrayOp_Int args _ = doIndexByteArrayOp Nothing bWord res args -emitPrimOp res ReadByteArrayOp_Word args _ = doIndexByteArrayOp Nothing bWord res args -emitPrimOp res ReadByteArrayOp_Addr args _ = doIndexByteArrayOp Nothing bWord res args -emitPrimOp res ReadByteArrayOp_Float args _ = doIndexByteArrayOp Nothing f32 res args -emitPrimOp res ReadByteArrayOp_Double args _ = doIndexByteArrayOp Nothing f64 res args -emitPrimOp res ReadByteArrayOp_StablePtr args _ = doIndexByteArrayOp Nothing bWord res args -emitPrimOp res ReadByteArrayOp_Int8 args _ = doIndexByteArrayOp (Just mo_s_8ToWord) b8 res args -emitPrimOp res ReadByteArrayOp_Int16 args _ = doIndexByteArrayOp (Just mo_s_16ToWord) b16 res args -emitPrimOp res ReadByteArrayOp_Int32 args _ = doIndexByteArrayOp (Just mo_s_32ToWord) b32 res args -emitPrimOp res ReadByteArrayOp_Int64 args _ = doIndexByteArrayOp Nothing b64 res args -emitPrimOp res ReadByteArrayOp_Word8 args _ = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args -emitPrimOp res ReadByteArrayOp_Word16 args _ = doIndexByteArrayOp (Just mo_u_16ToWord) b16 res args -emitPrimOp res ReadByteArrayOp_Word32 args _ = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args -emitPrimOp res ReadByteArrayOp_Word64 args _ = doIndexByteArrayOp Nothing b64 res args +emitPrimOp dflags res ReadByteArrayOp_Char args _ = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadByteArrayOp_WideChar args _ = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp dflags res ReadByteArrayOp_Int args _ = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res ReadByteArrayOp_Word args _ = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res ReadByteArrayOp_Addr args _ = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp _ res ReadByteArrayOp_Float args _ = doIndexByteArrayOp Nothing f32 res args +emitPrimOp _ res ReadByteArrayOp_Double args _ = doIndexByteArrayOp Nothing f64 res args +emitPrimOp dflags res ReadByteArrayOp_StablePtr args _ = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res ReadByteArrayOp_Int8 args _ = doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadByteArrayOp_Int16 args _ = doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16 res args +emitPrimOp dflags res ReadByteArrayOp_Int32 args _ = doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32 res args +emitPrimOp _ res ReadByteArrayOp_Int64 args _ = doIndexByteArrayOp Nothing b64 res args +emitPrimOp dflags res ReadByteArrayOp_Word8 args _ = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadByteArrayOp_Word16 args _ = doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16 res args +emitPrimOp dflags res ReadByteArrayOp_Word32 args _ = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp _ res ReadByteArrayOp_Word64 args _ = doIndexByteArrayOp Nothing b64 res args -- WriteXXXoffAddr -emitPrimOp res WriteOffAddrOp_Char args _ = doWriteOffAddrOp (Just mo_WordTo8) b8 res args -emitPrimOp res WriteOffAddrOp_WideChar args _ = doWriteOffAddrOp (Just mo_WordTo32) b32 res args -emitPrimOp res WriteOffAddrOp_Int args _ = doWriteOffAddrOp Nothing bWord res args -emitPrimOp res WriteOffAddrOp_Word args _ = doWriteOffAddrOp Nothing bWord res args -emitPrimOp res WriteOffAddrOp_Addr args _ = doWriteOffAddrOp Nothing bWord res args -emitPrimOp res WriteOffAddrOp_Float args _ = doWriteOffAddrOp Nothing f32 res args -emitPrimOp res WriteOffAddrOp_Double args _ = doWriteOffAddrOp Nothing f64 res args -emitPrimOp res WriteOffAddrOp_StablePtr args _ = doWriteOffAddrOp Nothing bWord res args -emitPrimOp res WriteOffAddrOp_Int8 args _ = doWriteOffAddrOp (Just mo_WordTo8) b8 res args -emitPrimOp res WriteOffAddrOp_Int16 args _ = doWriteOffAddrOp (Just mo_WordTo16) b16 res args -emitPrimOp res WriteOffAddrOp_Int32 args _ = doWriteOffAddrOp (Just mo_WordTo32) b32 res args -emitPrimOp res WriteOffAddrOp_Int64 args _ = doWriteOffAddrOp Nothing b64 res args -emitPrimOp res WriteOffAddrOp_Word8 args _ = doWriteOffAddrOp (Just mo_WordTo8) b8 res args -emitPrimOp res WriteOffAddrOp_Word16 args _ = doWriteOffAddrOp (Just mo_WordTo16) b16 res args -emitPrimOp res WriteOffAddrOp_Word32 args _ = doWriteOffAddrOp (Just mo_WordTo32) b32 res args -emitPrimOp res WriteOffAddrOp_Word64 args _ = doWriteOffAddrOp Nothing b64 res args +emitPrimOp dflags res WriteOffAddrOp_Char args _ = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8 res args +emitPrimOp dflags res WriteOffAddrOp_WideChar args _ = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args +emitPrimOp dflags res WriteOffAddrOp_Int args _ = doWriteOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res WriteOffAddrOp_Word args _ = doWriteOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res WriteOffAddrOp_Addr args _ = doWriteOffAddrOp Nothing (bWord dflags) res args +emitPrimOp _ res WriteOffAddrOp_Float args _ = doWriteOffAddrOp Nothing f32 res args +emitPrimOp _ res WriteOffAddrOp_Double args _ = doWriteOffAddrOp Nothing f64 res args +emitPrimOp dflags res WriteOffAddrOp_StablePtr args _ = doWriteOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res WriteOffAddrOp_Int8 args _ = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8 res args +emitPrimOp dflags res WriteOffAddrOp_Int16 args _ = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args +emitPrimOp dflags res WriteOffAddrOp_Int32 args _ = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args +emitPrimOp _ res WriteOffAddrOp_Int64 args _ = doWriteOffAddrOp Nothing b64 res args +emitPrimOp dflags res WriteOffAddrOp_Word8 args _ = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8 res args +emitPrimOp dflags res WriteOffAddrOp_Word16 args _ = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args +emitPrimOp dflags res WriteOffAddrOp_Word32 args _ = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args +emitPrimOp _ res WriteOffAddrOp_Word64 args _ = doWriteOffAddrOp Nothing b64 res args -- WriteXXXArray -emitPrimOp res WriteByteArrayOp_Char args _ = doWriteByteArrayOp (Just mo_WordTo8) b8 res args -emitPrimOp res WriteByteArrayOp_WideChar args _ = doWriteByteArrayOp (Just mo_WordTo32) b32 res args -emitPrimOp res WriteByteArrayOp_Int args _ = doWriteByteArrayOp Nothing bWord res args -emitPrimOp res WriteByteArrayOp_Word args _ = doWriteByteArrayOp Nothing bWord res args -emitPrimOp res WriteByteArrayOp_Addr args _ = doWriteByteArrayOp Nothing bWord res args -emitPrimOp res WriteByteArrayOp_Float args _ = doWriteByteArrayOp Nothing f32 res args -emitPrimOp res WriteByteArrayOp_Double args _ = doWriteByteArrayOp Nothing f64 res args -emitPrimOp res WriteByteArrayOp_StablePtr args _ = doWriteByteArrayOp Nothing bWord res args -emitPrimOp res WriteByteArrayOp_Int8 args _ = doWriteByteArrayOp (Just mo_WordTo8) b8 res args -emitPrimOp res WriteByteArrayOp_Int16 args _ = doWriteByteArrayOp (Just mo_WordTo16) b16 res args -emitPrimOp res WriteByteArrayOp_Int32 args _ = doWriteByteArrayOp (Just mo_WordTo32) b32 res args -emitPrimOp res WriteByteArrayOp_Int64 args _ = doWriteByteArrayOp Nothing b64 res args -emitPrimOp res WriteByteArrayOp_Word8 args _ = doWriteByteArrayOp (Just mo_WordTo8) b8 res args -emitPrimOp res WriteByteArrayOp_Word16 args _ = doWriteByteArrayOp (Just mo_WordTo16) b16 res args -emitPrimOp res WriteByteArrayOp_Word32 args _ = doWriteByteArrayOp (Just mo_WordTo32) b32 res args -emitPrimOp res WriteByteArrayOp_Word64 args _ = doWriteByteArrayOp Nothing b64 res args +emitPrimOp dflags res WriteByteArrayOp_Char args _ = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args +emitPrimOp dflags res WriteByteArrayOp_WideChar args _ = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args +emitPrimOp dflags res WriteByteArrayOp_Int args _ = doWriteByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res WriteByteArrayOp_Word args _ = doWriteByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res WriteByteArrayOp_Addr args _ = doWriteByteArrayOp Nothing (bWord dflags) res args +emitPrimOp _ res WriteByteArrayOp_Float args _ = doWriteByteArrayOp Nothing f32 res args +emitPrimOp _ res WriteByteArrayOp_Double args _ = doWriteByteArrayOp Nothing f64 res args +emitPrimOp dflags res WriteByteArrayOp_StablePtr args _ = doWriteByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res WriteByteArrayOp_Int8 args _ = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args +emitPrimOp dflags res WriteByteArrayOp_Int16 args _ = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args +emitPrimOp dflags res WriteByteArrayOp_Int32 args _ = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args +emitPrimOp _ res WriteByteArrayOp_Int64 args _ = doWriteByteArrayOp Nothing b64 res args +emitPrimOp dflags res WriteByteArrayOp_Word8 args _ = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args +emitPrimOp dflags res WriteByteArrayOp_Word16 args _ = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args +emitPrimOp dflags res WriteByteArrayOp_Word32 args _ = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args +emitPrimOp _ res WriteByteArrayOp_Word64 args _ = doWriteByteArrayOp Nothing b64 res args -- Copying and setting byte arrays -emitPrimOp [] CopyByteArrayOp [src,src_off,dst,dst_off,n] live = +emitPrimOp _ [] CopyByteArrayOp [src,src_off,dst,dst_off,n] live = doCopyByteArrayOp src src_off dst dst_off n live -emitPrimOp [] CopyMutableByteArrayOp [src,src_off,dst,dst_off,n] live = +emitPrimOp _ [] CopyMutableByteArrayOp [src,src_off,dst,dst_off,n] live = doCopyMutableByteArrayOp src src_off dst dst_off n live -emitPrimOp [] SetByteArrayOp [ba,off,len,c] live = +emitPrimOp _ [] SetByteArrayOp [ba,off,len,c] live = doSetByteArrayOp ba off len c live --- Population count -emitPrimOp [res] PopCnt8Op [w] live = emitPopCntCall res w W8 live -emitPrimOp [res] PopCnt16Op [w] live = emitPopCntCall res w W16 live -emitPrimOp [res] PopCnt32Op [w] live = emitPopCntCall res w W32 live -emitPrimOp [res] PopCnt64Op [w] live = emitPopCntCall res w W64 live -emitPrimOp [res] PopCntOp [w] live = emitPopCntCall res w wordWidth live +-- Population count. +-- The type of the primop takes a Word#, so we have to be careful to narrow +-- to the correct width before calling the primop. Otherwise this can result +-- in a crash e.g. when calling the helper hs_popcnt8() which assumes that the +-- argument is <=0xff. +emitPrimOp dflags [res] PopCnt8Op [w] live = + emitPopCntCall res (CmmMachOp (mo_WordTo8 dflags) [w]) W8 live +emitPrimOp dflags [res] PopCnt16Op [w] live = + emitPopCntCall res (CmmMachOp (mo_WordTo16 dflags) [w]) W16 live +emitPrimOp dflags [res] PopCnt32Op [w] live = + emitPopCntCall res (CmmMachOp (mo_WordTo32 dflags) [w]) W32 live +emitPrimOp dflags [res] PopCnt64Op [w] live = + emitPopCntCall res (CmmMachOp (mo_WordTo64 dflags) [w]) W64 live +emitPrimOp dflags [res] PopCntOp [w] live = + emitPopCntCall res w (wordWidth dflags) live -- The rest just translate straightforwardly -emitPrimOp [res] op [arg] _ +emitPrimOp dflags [res] op [arg] _ | nopOp op = stmtC (CmmAssign (CmmLocal res) arg) | Just (mop,rep) <- narrowOp op = stmtC (CmmAssign (CmmLocal res) $ - CmmMachOp (mop rep wordWidth) [CmmMachOp (mop wordWidth rep) [arg]]) + CmmMachOp (mop rep (wordWidth dflags)) [CmmMachOp (mop (wordWidth dflags) rep) [arg]]) -emitPrimOp [res] op args live +emitPrimOp dflags [res] op args live | Just prim <- callishOp op = do vols <- getVolatileRegs live emitForeignCall' PlayRisky @@ -450,49 +452,49 @@ emitPrimOp [res] op args live NoC_SRT -- No SRT b/c we do PlayRisky CmmMayReturn - | Just mop <- translateOp op + | Just mop <- translateOp dflags op = let stmt = CmmAssign (CmmLocal res) (CmmMachOp mop args) in stmtC stmt -emitPrimOp [res_q, res_r] IntQuotRemOp [arg_x, arg_y] _ +emitPrimOp dflags [res_q, res_r] IntQuotRemOp [arg_x, arg_y] _ = let genericImpl = [CmmAssign (CmmLocal res_q) - (CmmMachOp (MO_S_Quot wordWidth) [arg_x, arg_y]), + (CmmMachOp (MO_S_Quot (wordWidth dflags)) [arg_x, arg_y]), CmmAssign (CmmLocal res_r) - (CmmMachOp (MO_S_Rem wordWidth) [arg_x, arg_y])] - stmt = CmmCall (CmmPrim (MO_S_QuotRem wordWidth) (Just genericImpl)) + (CmmMachOp (MO_S_Rem (wordWidth dflags)) [arg_x, arg_y])] + stmt = CmmCall (CmmPrim (MO_S_QuotRem (wordWidth dflags)) (Just genericImpl)) [CmmHinted res_q NoHint, CmmHinted res_r NoHint] [CmmHinted arg_x NoHint, CmmHinted arg_y NoHint] CmmMayReturn in stmtC stmt -emitPrimOp [res_q, res_r] WordQuotRemOp [arg_x, arg_y] _ +emitPrimOp dflags [res_q, res_r] WordQuotRemOp [arg_x, arg_y] _ = let genericImpl = [CmmAssign (CmmLocal res_q) - (CmmMachOp (MO_U_Quot wordWidth) [arg_x, arg_y]), + (CmmMachOp (MO_U_Quot (wordWidth dflags)) [arg_x, arg_y]), CmmAssign (CmmLocal res_r) - (CmmMachOp (MO_U_Rem wordWidth) [arg_x, arg_y])] - stmt = CmmCall (CmmPrim (MO_U_QuotRem wordWidth) (Just genericImpl)) + (CmmMachOp (MO_U_Rem (wordWidth dflags)) [arg_x, arg_y])] + stmt = CmmCall (CmmPrim (MO_U_QuotRem (wordWidth dflags)) (Just genericImpl)) [CmmHinted res_q NoHint, CmmHinted res_r NoHint] [CmmHinted arg_x NoHint, CmmHinted arg_y NoHint] CmmMayReturn in stmtC stmt -emitPrimOp [res_q, res_r] WordQuotRem2Op [arg_x_high, arg_x_low, arg_y] _ - = do let ty = cmmExprType arg_x_high - shl x i = CmmMachOp (MO_Shl wordWidth) [x, i] - shr x i = CmmMachOp (MO_U_Shr wordWidth) [x, i] - or x y = CmmMachOp (MO_Or wordWidth) [x, y] - ge x y = CmmMachOp (MO_U_Ge wordWidth) [x, y] - ne x y = CmmMachOp (MO_Ne wordWidth) [x, y] - minus x y = CmmMachOp (MO_Sub wordWidth) [x, y] - times x y = CmmMachOp (MO_Mul wordWidth) [x, y] +emitPrimOp dflags [res_q, res_r] WordQuotRem2Op [arg_x_high, arg_x_low, arg_y] _ + = do let ty = cmmExprType dflags arg_x_high + shl x i = CmmMachOp (MO_Shl (wordWidth dflags)) [x, i] + shr x i = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, i] + or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y] + ge x y = CmmMachOp (MO_U_Ge (wordWidth dflags)) [x, y] + ne x y = CmmMachOp (MO_Ne (wordWidth dflags)) [x, y] + minus x y = CmmMachOp (MO_Sub (wordWidth dflags)) [x, y] + times x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y] zero = lit 0 one = lit 1 - negone = lit (fromIntegral (widthInBits wordWidth) - 1) - lit i = CmmLit (CmmInt i wordWidth) + negone = lit (fromIntegral (widthInBits (wordWidth dflags)) - 1) + lit i = CmmLit (CmmInt i (wordWidth dflags)) f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode [CmmStmt] f 0 acc high _ = return [CmmAssign (CmmLocal res_q) acc, CmmAssign (CmmLocal res_r) high] @@ -523,8 +525,8 @@ emitPrimOp [res_q, res_r] WordQuotRem2Op [arg_x_high, arg_x_low, arg_y] _ (CmmReg (CmmLocal rhigh'')) (CmmReg (CmmLocal rlow')) return (this ++ rest) - genericImpl <- f (widthInBits wordWidth) zero arg_x_high arg_x_low - let stmt = CmmCall (CmmPrim (MO_U_QuotRem2 wordWidth) (Just genericImpl)) + genericImpl <- f (widthInBits (wordWidth dflags)) zero arg_x_high arg_x_low + let stmt = CmmCall (CmmPrim (MO_U_QuotRem2 (wordWidth dflags)) (Just genericImpl)) [CmmHinted res_q NoHint, CmmHinted res_r NoHint] [CmmHinted arg_x_high NoHint, @@ -533,9 +535,9 @@ emitPrimOp [res_q, res_r] WordQuotRem2Op [arg_x_high, arg_x_low, arg_y] _ CmmMayReturn stmtC stmt -emitPrimOp [res_h, res_l] WordAdd2Op [arg_x, arg_y] _ - = do r1 <- newLocalReg (cmmExprType arg_x) - r2 <- newLocalReg (cmmExprType arg_x) +emitPrimOp dflags [res_h, res_l] WordAdd2Op [arg_x, arg_y] _ + = do r1 <- newLocalReg (cmmExprType dflags arg_x) + r2 <- newLocalReg (cmmExprType dflags arg_x) -- This generic implementation is very simple and slow. We might -- well be able to do better, but for now this at least works. let genericImpl @@ -549,23 +551,23 @@ emitPrimOp [res_h, res_l] WordAdd2Op [arg_x, arg_y] _ CmmAssign (CmmLocal res_l) (or (toTopHalf (CmmReg (CmmLocal r2))) (bottomHalf (CmmReg (CmmLocal r1))))] - where topHalf x = CmmMachOp (MO_U_Shr wordWidth) [x, hww] - toTopHalf x = CmmMachOp (MO_Shl wordWidth) [x, hww] - bottomHalf x = CmmMachOp (MO_And wordWidth) [x, hwm] - add x y = CmmMachOp (MO_Add wordWidth) [x, y] - or x y = CmmMachOp (MO_Or wordWidth) [x, y] - hww = CmmLit (CmmInt (fromIntegral (widthInBits halfWordWidth)) - wordWidth) - hwm = CmmLit (CmmInt halfWordMask wordWidth) - stmt = CmmCall (CmmPrim (MO_Add2 wordWidth) (Just genericImpl)) + where topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww] + toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww] + bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm] + add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y] + or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y] + hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags))) + (wordWidth dflags)) + hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags)) + stmt = CmmCall (CmmPrim (MO_Add2 (wordWidth dflags)) (Just genericImpl)) [CmmHinted res_h NoHint, CmmHinted res_l NoHint] [CmmHinted arg_x NoHint, CmmHinted arg_y NoHint] CmmMayReturn stmtC stmt -emitPrimOp [res_h, res_l] WordMul2Op [arg_x, arg_y] _ - = do let t = cmmExprType arg_x +emitPrimOp dflags [res_h, res_l] WordMul2Op [arg_x, arg_y] _ + = do let t = cmmExprType dflags arg_x xlyl <- liftM CmmLocal $ newLocalReg t xlyh <- liftM CmmLocal $ newLocalReg t xhyl <- liftM CmmLocal $ newLocalReg t @@ -591,17 +593,17 @@ emitPrimOp [res_h, res_l] WordMul2Op [arg_x, arg_y] _ topHalf (CmmReg xhyl), topHalf (CmmReg xlyh), topHalf (CmmReg r)])] - where topHalf x = CmmMachOp (MO_U_Shr wordWidth) [x, hww] - toTopHalf x = CmmMachOp (MO_Shl wordWidth) [x, hww] - bottomHalf x = CmmMachOp (MO_And wordWidth) [x, hwm] - add x y = CmmMachOp (MO_Add wordWidth) [x, y] + where topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww] + toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww] + bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm] + add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y] sum = foldl1 add - mul x y = CmmMachOp (MO_Mul wordWidth) [x, y] - or x y = CmmMachOp (MO_Or wordWidth) [x, y] - hww = CmmLit (CmmInt (fromIntegral (widthInBits halfWordWidth)) - wordWidth) - hwm = CmmLit (CmmInt halfWordMask wordWidth) - stmt = CmmCall (CmmPrim (MO_U_Mul2 wordWidth) (Just genericImpl)) + mul x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y] + or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y] + hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags))) + (wordWidth dflags)) + hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags)) + stmt = CmmCall (CmmPrim (MO_U_Mul2 (wordWidth dflags)) (Just genericImpl)) [CmmHinted res_h NoHint, CmmHinted res_l NoHint] [CmmHinted arg_x NoHint, @@ -609,7 +611,7 @@ emitPrimOp [res_h, res_l] WordMul2Op [arg_x, arg_y] _ CmmMayReturn stmtC stmt -emitPrimOp _ op _ _ +emitPrimOp _ _ op _ _ = pprPanic "emitPrimOp: can't translate PrimOp" (ppr op) newLocalReg :: CmmType -> FCode LocalReg @@ -640,125 +642,125 @@ narrowOp _ = Nothing -- Native word signless ops -translateOp :: PrimOp -> Maybe MachOp -translateOp IntAddOp = Just mo_wordAdd -translateOp IntSubOp = Just mo_wordSub -translateOp WordAddOp = Just mo_wordAdd -translateOp WordSubOp = Just mo_wordSub -translateOp AddrAddOp = Just mo_wordAdd -translateOp AddrSubOp = Just mo_wordSub - -translateOp IntEqOp = Just mo_wordEq -translateOp IntNeOp = Just mo_wordNe -translateOp WordEqOp = Just mo_wordEq -translateOp WordNeOp = Just mo_wordNe -translateOp AddrEqOp = Just mo_wordEq -translateOp AddrNeOp = Just mo_wordNe - -translateOp AndOp = Just mo_wordAnd -translateOp OrOp = Just mo_wordOr -translateOp XorOp = Just mo_wordXor -translateOp NotOp = Just mo_wordNot -translateOp SllOp = Just mo_wordShl -translateOp SrlOp = Just mo_wordUShr - -translateOp AddrRemOp = Just mo_wordURem +translateOp :: DynFlags -> PrimOp -> Maybe MachOp +translateOp dflags IntAddOp = Just (mo_wordAdd dflags) +translateOp dflags IntSubOp = Just (mo_wordSub dflags) +translateOp dflags WordAddOp = Just (mo_wordAdd dflags) +translateOp dflags WordSubOp = Just (mo_wordSub dflags) +translateOp dflags AddrAddOp = Just (mo_wordAdd dflags) +translateOp dflags AddrSubOp = Just (mo_wordSub dflags) + +translateOp dflags IntEqOp = Just (mo_wordEq dflags) +translateOp dflags IntNeOp = Just (mo_wordNe dflags) +translateOp dflags WordEqOp = Just (mo_wordEq dflags) +translateOp dflags WordNeOp = Just (mo_wordNe dflags) +translateOp dflags AddrEqOp = Just (mo_wordEq dflags) +translateOp dflags AddrNeOp = Just (mo_wordNe dflags) + +translateOp dflags AndOp = Just (mo_wordAnd dflags) +translateOp dflags OrOp = Just (mo_wordOr dflags) +translateOp dflags XorOp = Just (mo_wordXor dflags) +translateOp dflags NotOp = Just (mo_wordNot dflags) +translateOp dflags SllOp = Just (mo_wordShl dflags) +translateOp dflags SrlOp = Just (mo_wordUShr dflags) + +translateOp dflags AddrRemOp = Just (mo_wordURem dflags) -- Native word signed ops -translateOp IntMulOp = Just mo_wordMul -translateOp IntMulMayOfloOp = Just (MO_S_MulMayOflo wordWidth) -translateOp IntQuotOp = Just mo_wordSQuot -translateOp IntRemOp = Just mo_wordSRem -translateOp IntNegOp = Just mo_wordSNeg +translateOp dflags IntMulOp = Just (mo_wordMul dflags) +translateOp dflags IntMulMayOfloOp = Just (MO_S_MulMayOflo (wordWidth dflags)) +translateOp dflags IntQuotOp = Just (mo_wordSQuot dflags) +translateOp dflags IntRemOp = Just (mo_wordSRem dflags) +translateOp dflags IntNegOp = Just (mo_wordSNeg dflags) -translateOp IntGeOp = Just mo_wordSGe -translateOp IntLeOp = Just mo_wordSLe -translateOp IntGtOp = Just mo_wordSGt -translateOp IntLtOp = Just mo_wordSLt +translateOp dflags IntGeOp = Just (mo_wordSGe dflags) +translateOp dflags IntLeOp = Just (mo_wordSLe dflags) +translateOp dflags IntGtOp = Just (mo_wordSGt dflags) +translateOp dflags IntLtOp = Just (mo_wordSLt dflags) -translateOp ISllOp = Just mo_wordShl -translateOp ISraOp = Just mo_wordSShr -translateOp ISrlOp = Just mo_wordUShr +translateOp dflags ISllOp = Just (mo_wordShl dflags) +translateOp dflags ISraOp = Just (mo_wordSShr dflags) +translateOp dflags ISrlOp = Just (mo_wordUShr dflags) -- Native word unsigned ops -translateOp WordGeOp = Just mo_wordUGe -translateOp WordLeOp = Just mo_wordULe -translateOp WordGtOp = Just mo_wordUGt -translateOp WordLtOp = Just mo_wordULt +translateOp dflags WordGeOp = Just (mo_wordUGe dflags) +translateOp dflags WordLeOp = Just (mo_wordULe dflags) +translateOp dflags WordGtOp = Just (mo_wordUGt dflags) +translateOp dflags WordLtOp = Just (mo_wordULt dflags) -translateOp WordMulOp = Just mo_wordMul -translateOp WordQuotOp = Just mo_wordUQuot -translateOp WordRemOp = Just mo_wordURem +translateOp dflags WordMulOp = Just (mo_wordMul dflags) +translateOp dflags WordQuotOp = Just (mo_wordUQuot dflags) +translateOp dflags WordRemOp = Just (mo_wordURem dflags) -translateOp AddrGeOp = Just mo_wordUGe -translateOp AddrLeOp = Just mo_wordULe -translateOp AddrGtOp = Just mo_wordUGt -translateOp AddrLtOp = Just mo_wordULt +translateOp dflags AddrGeOp = Just (mo_wordUGe dflags) +translateOp dflags AddrLeOp = Just (mo_wordULe dflags) +translateOp dflags AddrGtOp = Just (mo_wordUGt dflags) +translateOp dflags AddrLtOp = Just (mo_wordULt dflags) -- Char# ops -translateOp CharEqOp = Just (MO_Eq wordWidth) -translateOp CharNeOp = Just (MO_Ne wordWidth) -translateOp CharGeOp = Just (MO_U_Ge wordWidth) -translateOp CharLeOp = Just (MO_U_Le wordWidth) -translateOp CharGtOp = Just (MO_U_Gt wordWidth) -translateOp CharLtOp = Just (MO_U_Lt wordWidth) +translateOp dflags CharEqOp = Just (MO_Eq (wordWidth dflags)) +translateOp dflags CharNeOp = Just (MO_Ne (wordWidth dflags)) +translateOp dflags CharGeOp = Just (MO_U_Ge (wordWidth dflags)) +translateOp dflags CharLeOp = Just (MO_U_Le (wordWidth dflags)) +translateOp dflags CharGtOp = Just (MO_U_Gt (wordWidth dflags)) +translateOp dflags CharLtOp = Just (MO_U_Lt (wordWidth dflags)) -- Double ops -translateOp DoubleEqOp = Just (MO_F_Eq W64) -translateOp DoubleNeOp = Just (MO_F_Ne W64) -translateOp DoubleGeOp = Just (MO_F_Ge W64) -translateOp DoubleLeOp = Just (MO_F_Le W64) -translateOp DoubleGtOp = Just (MO_F_Gt W64) -translateOp DoubleLtOp = Just (MO_F_Lt W64) +translateOp _ DoubleEqOp = Just (MO_F_Eq W64) +translateOp _ DoubleNeOp = Just (MO_F_Ne W64) +translateOp _ DoubleGeOp = Just (MO_F_Ge W64) +translateOp _ DoubleLeOp = Just (MO_F_Le W64) +translateOp _ DoubleGtOp = Just (MO_F_Gt W64) +translateOp _ DoubleLtOp = Just (MO_F_Lt W64) -translateOp DoubleAddOp = Just (MO_F_Add W64) -translateOp DoubleSubOp = Just (MO_F_Sub W64) -translateOp DoubleMulOp = Just (MO_F_Mul W64) -translateOp DoubleDivOp = Just (MO_F_Quot W64) -translateOp DoubleNegOp = Just (MO_F_Neg W64) +translateOp _ DoubleAddOp = Just (MO_F_Add W64) +translateOp _ DoubleSubOp = Just (MO_F_Sub W64) +translateOp _ DoubleMulOp = Just (MO_F_Mul W64) +translateOp _ DoubleDivOp = Just (MO_F_Quot W64) +translateOp _ DoubleNegOp = Just (MO_F_Neg W64) -- Float ops -translateOp FloatEqOp = Just (MO_F_Eq W32) -translateOp FloatNeOp = Just (MO_F_Ne W32) -translateOp FloatGeOp = Just (MO_F_Ge W32) -translateOp FloatLeOp = Just (MO_F_Le W32) -translateOp FloatGtOp = Just (MO_F_Gt W32) -translateOp FloatLtOp = Just (MO_F_Lt W32) +translateOp _ FloatEqOp = Just (MO_F_Eq W32) +translateOp _ FloatNeOp = Just (MO_F_Ne W32) +translateOp _ FloatGeOp = Just (MO_F_Ge W32) +translateOp _ FloatLeOp = Just (MO_F_Le W32) +translateOp _ FloatGtOp = Just (MO_F_Gt W32) +translateOp _ FloatLtOp = Just (MO_F_Lt W32) -translateOp FloatAddOp = Just (MO_F_Add W32) -translateOp FloatSubOp = Just (MO_F_Sub W32) -translateOp FloatMulOp = Just (MO_F_Mul W32) -translateOp FloatDivOp = Just (MO_F_Quot W32) -translateOp FloatNegOp = Just (MO_F_Neg W32) +translateOp _ FloatAddOp = Just (MO_F_Add W32) +translateOp _ FloatSubOp = Just (MO_F_Sub W32) +translateOp _ FloatMulOp = Just (MO_F_Mul W32) +translateOp _ FloatDivOp = Just (MO_F_Quot W32) +translateOp _ FloatNegOp = Just (MO_F_Neg W32) -- Conversions -translateOp Int2DoubleOp = Just (MO_SF_Conv wordWidth W64) -translateOp Double2IntOp = Just (MO_FS_Conv W64 wordWidth) +translateOp dflags Int2DoubleOp = Just (MO_SF_Conv (wordWidth dflags) W64) +translateOp dflags Double2IntOp = Just (MO_FS_Conv W64 (wordWidth dflags)) -translateOp Int2FloatOp = Just (MO_SF_Conv wordWidth W32) -translateOp Float2IntOp = Just (MO_FS_Conv W32 wordWidth) +translateOp dflags Int2FloatOp = Just (MO_SF_Conv (wordWidth dflags) W32) +translateOp dflags Float2IntOp = Just (MO_FS_Conv W32 (wordWidth dflags)) -translateOp Float2DoubleOp = Just (MO_FF_Conv W32 W64) -translateOp Double2FloatOp = Just (MO_FF_Conv W64 W32) +translateOp _ Float2DoubleOp = Just (MO_FF_Conv W32 W64) +translateOp _ Double2FloatOp = Just (MO_FF_Conv W64 W32) -- Word comparisons masquerading as more exotic things. -translateOp SameMutVarOp = Just mo_wordEq -translateOp SameMVarOp = Just mo_wordEq -translateOp SameMutableArrayOp = Just mo_wordEq -translateOp SameMutableByteArrayOp = Just mo_wordEq -translateOp SameMutableArrayArrayOp= Just mo_wordEq -translateOp SameTVarOp = Just mo_wordEq -translateOp EqStablePtrOp = Just mo_wordEq +translateOp dflags SameMutVarOp = Just (mo_wordEq dflags) +translateOp dflags SameMVarOp = Just (mo_wordEq dflags) +translateOp dflags SameMutableArrayOp = Just (mo_wordEq dflags) +translateOp dflags SameMutableByteArrayOp = Just (mo_wordEq dflags) +translateOp dflags SameMutableArrayArrayOp= Just (mo_wordEq dflags) +translateOp dflags SameTVarOp = Just (mo_wordEq dflags) +translateOp dflags EqStablePtrOp = Just (mo_wordEq dflags) -translateOp _ = Nothing +translateOp _ _ = Nothing -- These primops are implemented by CallishMachOps, because they sometimes -- turn into foreign calls depending on the backend. @@ -815,7 +817,7 @@ doIndexByteArrayOp _ _ _ _ doReadPtrArrayOp :: LocalReg -> CmmExpr -> CmmExpr -> Code doReadPtrArrayOp res addr idx = do dflags <- getDynFlags - mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing gcWord res addr idx + mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr idx doWriteOffAddrOp, doWriteByteArrayOp @@ -835,47 +837,50 @@ doWriteByteArrayOp _ _ _ _ doWritePtrArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> Code doWritePtrArrayOp addr idx val = do dflags <- getDynFlags - mkBasicIndexedWrite (arrPtrsHdrSize dflags) Nothing bWord addr idx val + mkBasicIndexedWrite (arrPtrsHdrSize dflags) Nothing (bWord dflags) addr idx val stmtC (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) -- the write barrier. We must write a byte into the mark table: -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N] stmtC $ CmmStore ( - cmmOffsetExpr - (cmmOffsetExprW (cmmOffsetB addr (arrPtrsHdrSize dflags)) + cmmOffsetExpr dflags + (cmmOffsetExprW dflags (cmmOffsetB dflags addr (arrPtrsHdrSize dflags)) (loadArrPtrsSize dflags addr)) - (CmmMachOp mo_wordUShr [idx, - CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)]) + (card dflags idx) ) (CmmLit (CmmInt 1 W8)) loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr -loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB addr off) bWord - where off = fixedHdrSize dflags * wORD_SIZE + oFFSET_StgMutArrPtrs_ptrs +loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB dflags addr off) (bWord dflags) + where off = fixedHdrSize dflags * wORD_SIZE dflags + oFFSET_StgMutArrPtrs_ptrs dflags mkBasicIndexedRead :: ByteOff -> Maybe MachOp -> CmmType -> LocalReg -> CmmExpr -> CmmExpr -> Code mkBasicIndexedRead off Nothing read_rep res base idx - = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexOffExpr off read_rep base idx)) + = do dflags <- getDynFlags + stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexOffExpr dflags off read_rep base idx)) mkBasicIndexedRead off (Just cast) read_rep res base idx - = stmtC (CmmAssign (CmmLocal res) (CmmMachOp cast [ - cmmLoadIndexOffExpr off read_rep base idx])) + = do dflags <- getDynFlags + stmtC (CmmAssign (CmmLocal res) (CmmMachOp cast [ + cmmLoadIndexOffExpr dflags off read_rep base idx])) mkBasicIndexedWrite :: ByteOff -> Maybe MachOp -> CmmType -> CmmExpr -> CmmExpr -> CmmExpr -> Code mkBasicIndexedWrite off Nothing write_rep base idx val - = stmtC (CmmStore (cmmIndexOffExpr off write_rep base idx) val) + = do dflags <- getDynFlags + stmtC (CmmStore (cmmIndexOffExpr dflags off write_rep base idx) val) mkBasicIndexedWrite off (Just cast) write_rep base idx val - = stmtC (CmmStore (cmmIndexOffExpr off write_rep base idx) (CmmMachOp cast [val])) + = do dflags <- getDynFlags + stmtC (CmmStore (cmmIndexOffExpr dflags off write_rep base idx) (CmmMachOp cast [val])) -- ---------------------------------------------------------------------------- -- Misc utils -cmmIndexOffExpr :: ByteOff -> CmmType -> CmmExpr -> CmmExpr -> CmmExpr -cmmIndexOffExpr off rep base idx - = cmmIndexExpr (typeWidth rep) (cmmOffsetB base off) idx +cmmIndexOffExpr :: DynFlags -> ByteOff -> CmmType -> CmmExpr -> CmmExpr -> CmmExpr +cmmIndexOffExpr dflags off rep base idx + = cmmIndexExpr dflags (typeWidth rep) (cmmOffsetB dflags base off) idx -cmmLoadIndexOffExpr :: ByteOff -> CmmType -> CmmExpr -> CmmExpr -> CmmExpr -cmmLoadIndexOffExpr off rep base idx - = CmmLoad (cmmIndexOffExpr off rep base idx) rep +cmmLoadIndexOffExpr :: DynFlags -> ByteOff -> CmmType -> CmmExpr -> CmmExpr -> CmmExpr +cmmLoadIndexOffExpr dflags off rep base idx + = CmmLoad (cmmIndexOffExpr dflags off rep base idx) rep setInfo :: CmmExpr -> CmmExpr -> CmmStmt setInfo closure_ptr info_ptr = CmmStore closure_ptr info_ptr @@ -894,7 +899,8 @@ doCopyByteArrayOp = emitCopyByteArray copy -- Copy data (we assume the arrays aren't overlapping since -- they're of different types) copy _src _dst dst_p src_p bytes live = - emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit 1)) live + do dflags <- getDynFlags + emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit dflags 1)) live -- | Takes a source 'MutableByteArray#', an offset in the source -- array, a destination 'MutableByteArray#', an offset into the @@ -909,9 +915,10 @@ doCopyMutableByteArrayOp = emitCopyByteArray copy -- we were provided are the same array! -- TODO: Optimize branch for common case of no aliasing. copy src dst dst_p src_p bytes live = - emitIfThenElse (cmmEqWord src dst) - (emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit 1)) live) - (emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit 1)) live) + do dflags <- getDynFlags + emitIfThenElse (cmmEqWord dflags src dst) + (emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit dflags 1)) live) + (emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit dflags 1)) live) emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code) @@ -920,8 +927,8 @@ emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> Code emitCopyByteArray copy src src_off dst dst_off n live = do dflags <- getDynFlags - dst_p <- assignTemp $ cmmOffsetExpr (cmmOffsetB dst (arrWordsHdrSize dflags)) dst_off - src_p <- assignTemp $ cmmOffsetExpr (cmmOffsetB src (arrWordsHdrSize dflags)) src_off + dst_p <- assignTemp $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off + src_p <- assignTemp $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off copy src dst dst_p src_p n live -- ---------------------------------------------------------------------------- @@ -934,8 +941,8 @@ doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code doSetByteArrayOp ba off len c live = do dflags <- getDynFlags - p <- assignTemp $ cmmOffsetExpr (cmmOffsetB ba (arrWordsHdrSize dflags)) off - emitMemsetCall p c len (CmmLit (mkIntCLit 1)) live + p <- assignTemp $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off + emitMemsetCall p c len (CmmLit (mkIntCLit dflags 1)) live -- ---------------------------------------------------------------------------- -- Copying pointer arrays @@ -958,7 +965,8 @@ doCopyArrayOp = emitCopyArray copy -- Copy data (we assume the arrays aren't overlapping since -- they're of different types) copy _src _dst dst_p src_p bytes live = - emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)) live + do dflags <- getDynFlags + emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit dflags (wORD_SIZE dflags))) live -- | Takes a source 'MutableArray#', an offset in the source array, a -- destination 'MutableArray#', an offset into the destination array, @@ -972,9 +980,10 @@ doCopyMutableArrayOp = emitCopyArray copy -- we were provided are the same array! -- TODO: Optimize branch for common case of no aliasing. copy src dst dst_p src_p bytes live = - emitIfThenElse (cmmEqWord src dst) - (emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)) live) - (emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)) live) + do dflags <- getDynFlags + emitIfThenElse (cmmEqWord dflags src dst) + (emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit dflags (wORD_SIZE dflags))) live) + (emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit dflags (wORD_SIZE dflags))) live) emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code) @@ -994,15 +1003,15 @@ emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 live = do -- Set the dirty bit in the header. stmtC (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) - dst_elems_p <- assignTemp $ cmmOffsetB dst (arrPtrsHdrSize dflags) - dst_p <- assignTemp $ cmmOffsetExprW dst_elems_p dst_off - src_p <- assignTemp $ cmmOffsetExprW (cmmOffsetB src (arrPtrsHdrSize dflags)) src_off - bytes <- assignTemp $ cmmMulWord n (CmmLit (mkIntCLit wORD_SIZE)) + dst_elems_p <- assignTemp $ cmmOffsetB dflags dst (arrPtrsHdrSize dflags) + dst_p <- assignTemp $ cmmOffsetExprW dflags dst_elems_p dst_off + src_p <- assignTemp $ cmmOffsetExprW dflags (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off + bytes <- assignTemp $ cmmMulWord dflags n (CmmLit (mkIntCLit dflags (wORD_SIZE dflags))) copy src dst dst_p src_p bytes live -- The base address of the destination card table - dst_cards_p <- assignTemp $ cmmOffsetExprW dst_elems_p (loadArrPtrsSize dflags dst) + dst_cards_p <- assignTemp $ cmmOffsetExprW dflags dst_elems_p (loadArrPtrsSize dflags dst) emitSetCards dst_off dst_cards_p n live @@ -1014,65 +1023,75 @@ emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code emitCloneArray info_p res_r src0 src_off0 n0 live = do dflags <- getDynFlags + let arrPtrsHdrSizeW dflags = CmmLit $ mkIntCLit dflags $ fixedHdrSize dflags + + (sIZEOF_StgMutArrPtrs_NoHdr dflags `div` wORD_SIZE dflags) + myCapability = cmmSubWord dflags (CmmReg baseReg) + (CmmLit (mkIntCLit dflags (oFFSET_Capability_r dflags))) -- Assign the arguments to temporaries so the code generator can -- calculate liveness for us. src <- assignTemp_ src0 src_off <- assignTemp_ src_off0 n <- assignTemp_ n0 - card_words <- assignTemp $ (n `cmmUShrWord` - (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS))) - `cmmAddWord` CmmLit (mkIntCLit 1) - size <- assignTemp $ n `cmmAddWord` card_words - words <- assignTemp $ arrPtrsHdrSizeW dflags `cmmAddWord` size + card_bytes <- assignTemp $ cardRoundUp dflags n + size <- assignTemp $ cmmAddWord dflags n (bytesToWordsRoundUp dflags card_bytes) + words <- assignTemp $ cmmAddWord dflags (arrPtrsHdrSizeW dflags) size - arr_r <- newTemp bWord + arr_r <- newTemp (bWord dflags) emitAllocateCall arr_r myCapability words live - tickyAllocPrim (CmmLit (mkIntCLit (arrPtrsHdrSize dflags))) (n `cmmMulWord` wordSize) - (CmmLit $ mkIntCLit 0) + tickyAllocPrim (CmmLit (mkIntCLit dflags (arrPtrsHdrSize dflags))) (cmmMulWord dflags n (wordSize dflags)) + (CmmLit $ mkIntCLit dflags 0) let arr = CmmReg (CmmLocal arr_r) emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCS - stmtC $ CmmStore (cmmOffsetB arr (fixedHdrSize dflags * wORD_SIZE + - oFFSET_StgMutArrPtrs_ptrs)) n - stmtC $ CmmStore (cmmOffsetB arr (fixedHdrSize dflags * wORD_SIZE + - oFFSET_StgMutArrPtrs_size)) size + stmtC $ CmmStore (cmmOffsetB dflags arr (fixedHdrSize dflags * wORD_SIZE dflags + + oFFSET_StgMutArrPtrs_ptrs dflags)) n + stmtC $ CmmStore (cmmOffsetB dflags arr (fixedHdrSize dflags * wORD_SIZE dflags + + oFFSET_StgMutArrPtrs_size dflags)) size - dst_p <- assignTemp $ cmmOffsetB arr (arrPtrsHdrSize dflags) - src_p <- assignTemp $ cmmOffsetExprW (cmmOffsetB src (arrPtrsHdrSize dflags)) + dst_p <- assignTemp $ cmmOffsetB dflags arr (arrPtrsHdrSize dflags) + src_p <- assignTemp $ cmmOffsetExprW dflags (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off - emitMemcpyCall dst_p src_p (n `cmmMulWord` wordSize) - (CmmLit (mkIntCLit wORD_SIZE)) live + emitMemcpyCall dst_p src_p (cmmMulWord dflags n (wordSize dflags)) + (CmmLit (mkIntCLit dflags (wORD_SIZE dflags))) live - emitMemsetCall (cmmOffsetExprW dst_p n) - (CmmLit (mkIntCLit 1)) - (card_words `cmmMulWord` wordSize) - (CmmLit (mkIntCLit wORD_SIZE)) + emitMemsetCall (cmmOffsetExprW dflags dst_p n) + (CmmLit (mkIntCLit dflags 1)) + card_bytes + (CmmLit (mkIntCLit dflags (wORD_SIZE dflags))) live stmtC $ CmmAssign (CmmLocal res_r) arr - where - arrPtrsHdrSizeW dflags = CmmLit $ mkIntCLit $ fixedHdrSize dflags + - (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE) - wordSize = CmmLit (mkIntCLit wORD_SIZE) - myCapability = CmmReg baseReg `cmmSubWord` - CmmLit (mkIntCLit oFFSET_Capability_r) -- | Takes and offset in the destination array, the base address of -- the card table, and the number of elements affected (*not* the -- number of cards). Marks the relevant cards as dirty. emitSetCards :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code emitSetCards dst_start dst_cards_start n live = do - start_card <- assignTemp $ card dst_start - emitMemsetCall (dst_cards_start `cmmAddWord` start_card) - (CmmLit (mkIntCLit 1)) - ((card (dst_start `cmmAddWord` n) `cmmSubWord` start_card) - `cmmAddWord` CmmLit (mkIntCLit 1)) - (CmmLit (mkIntCLit wORD_SIZE)) + dflags <- getDynFlags + start_card <- assignTemp $ card dflags dst_start + emitMemsetCall (cmmAddWord dflags dst_cards_start start_card) + (CmmLit (mkIntCLit dflags 1)) + (cardRoundUp dflags n) + (CmmLit (mkIntCLit dflags 1)) -- no alignment (1 byte) live - where - -- Convert an element index to a card index - card i = i `cmmUShrWord` (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)) + +-- Convert an element index to a card index +card :: DynFlags -> CmmExpr -> CmmExpr +card dflags i = cmmUShrWord dflags i (CmmLit (mkIntCLit dflags (mUT_ARR_PTRS_CARD_BITS dflags))) + +-- Convert a number of elements to a number of cards, rounding up +cardRoundUp :: DynFlags -> CmmExpr -> CmmExpr +cardRoundUp dflags i = card dflags (cmmAddWord dflags i (CmmLit (mkIntCLit dflags ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS dflags) - 1)))) + +bytesToWordsRoundUp :: DynFlags -> CmmExpr -> CmmExpr +bytesToWordsRoundUp dflags e + = cmmQuotWord dflags + (cmmAddWord dflags e (CmmLit (mkIntCLit dflags (wORD_SIZE dflags - 1)))) + (wordSize dflags) + +wordSize :: DynFlags -> CmmExpr +wordSize dflags = CmmLit (mkIntCLit dflags (wORD_SIZE dflags)) -- | Emit a call to @memcpy@. emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs index 2eccae7926..6d87ee7127 100644 --- a/compiler/codeGen/CgProf.hs +++ b/compiler/codeGen/CgProf.hs @@ -6,37 +6,30 @@ -- ----------------------------------------------------------------------------- -{-# 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 CgProf ( - mkCCostCentre, mkCCostCentreStack, + mkCCostCentre, mkCCostCentreStack, - -- Cost-centre Profiling + -- Cost-centre Profiling dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf, enterCostCentreThunk, enterCostCentreFun, costCentreFrom, curCCS, storeCurCCS, - emitCostCentreDecl, emitCostCentreStackDecl, + emitCostCentreDecl, emitCostCentreStackDecl, emitSetCCC, - -- Lag/drag/void stuff - ldvEnter, ldvEnterClosure, ldvRecordCreate + -- Lag/drag/void stuff + ldvEnter, ldvEnterClosure, ldvRecordCreate ) where #include "HsVersions.h" #include "../includes/MachDeps.h" -- For WORD_SIZE_IN_BITS only. #include "../includes/rts/Constants.h" - -- For LDV_CREATE_MASK, LDV_STATE_USE - -- which are StgWords + -- For LDV_CREATE_MASK, LDV_STATE_USE + -- which are StgWords #include "../includes/dist-derivedconstants/header/DerivedConstants.h" - -- For REP_xxx constants, which are MachReps + -- For REP_xxx constants, which are MachReps import ClosureInfo import CgUtils @@ -52,7 +45,6 @@ import CostCentre import DynFlags import FastString import Module -import Constants -- Lots of field offsets import Outputable import Data.Char @@ -77,27 +69,30 @@ mkCCostCentre cc = CmmLabel (mkCCLabel cc) mkCCostCentreStack :: CostCentreStack -> CmmLit mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs) -costCentreFrom :: CmmExpr -- A closure pointer - -> CmmExpr -- The cost centre from that closure -costCentreFrom cl = CmmLoad (cmmOffsetB cl oFFSET_StgHeader_ccs) bWord +costCentreFrom :: DynFlags + -> CmmExpr -- A closure pointer + -> CmmExpr -- The cost centre from that closure +costCentreFrom dflags cl + = CmmLoad (cmmOffsetB dflags cl (oFFSET_StgHeader_ccs dflags)) (bWord dflags) staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit] -- The profiling header words in a static closure -- Was SET_STATIC_PROF_HDR staticProfHdr dflags ccs = ifProfilingL dflags [mkCCostCentreStack ccs, - staticLdvInit] + staticLdvInit dflags] dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr] -- Profiling header words in a dynamic closure -dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit] +dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags] initUpdFrameProf :: CmmExpr -> Code -- Initialise the profiling field of an update frame -initUpdFrameProf frame_amode - = ifProfiling $ -- frame->header.prof.ccs = CCCS - stmtC (CmmStore (cmmOffsetB frame_amode oFFSET_StgHeader_ccs) curCCS) - -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0) - -- is unnecessary because it is not used anyhow. +initUpdFrameProf frame_amode + = ifProfiling $ -- frame->header.prof.ccs = CCCS + do dflags <- getDynFlags + stmtC (CmmStore (cmmOffsetB dflags frame_amode (oFFSET_StgHeader_ccs dflags)) curCCS) + -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0) + -- is unnecessary because it is not used anyhow. -- ----------------------------------------------------------------------------- -- Recording allocation in a cost centre @@ -108,7 +103,7 @@ profDynAlloc :: ClosureInfo -> CmmExpr -> Code profDynAlloc cl_info ccs = ifProfiling $ do dflags <- getDynFlags - profAlloc (CmmLit (mkIntCLit (closureSize dflags cl_info))) ccs + profAlloc (mkIntExpr dflags (closureSize dflags cl_info)) ccs -- | Record the allocation of a closure (size is given by a CmmExpr) -- The size must be in words, because the allocation counter in a CCS counts @@ -121,30 +116,32 @@ profAlloc words ccs = ifProfiling $ do dflags <- getDynFlags stmtC (addToMemE alloc_rep - (cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc) - (CmmMachOp (MO_UU_Conv wordWidth alloc_rep) $ - [CmmMachOp mo_wordSub [words, - CmmLit (mkIntCLit (profHdrSize dflags))]])) + (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_mem_alloc dflags)) + (CmmMachOp (MO_UU_Conv (wordWidth dflags) alloc_rep) $ + [CmmMachOp (mo_wordSub dflags) [words, + mkIntExpr dflags (profHdrSize dflags)]])) -- subtract the "profiling overhead", which is the -- profiling header in a closure. - where + where alloc_rep = typeWidth REP_CostCentreStack_mem_alloc -- ----------------------------------------------------------------------- -- Setting the current cost centre on entry to a closure enterCostCentreThunk :: CmmExpr -> Code -enterCostCentreThunk closure = - ifProfiling $ do - stmtC $ storeCurCCS (costCentreFrom closure) +enterCostCentreThunk closure = + ifProfiling $ do + dflags <- getDynFlags + stmtC $ storeCurCCS (costCentreFrom dflags closure) enterCostCentreFun :: CostCentreStack -> CmmExpr -> [GlobalReg] -> Code enterCostCentreFun ccs closure vols = ifProfiling $ do if isCurrentCCS ccs - then emitRtsCallWithVols rtsPackageId (fsLit "enterFunCCS") - [CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint, - CmmHinted (costCentreFrom closure) AddrHint] vols + then do dflags <- getDynFlags + emitRtsCallWithVols rtsPackageId (fsLit "enterFunCCS") + [CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint, + CmmHinted (costCentreFrom dflags closure) AddrHint] vols else return () -- top-level function, nothing to do ifProfiling :: Code -> Code @@ -163,7 +160,7 @@ ifProfilingL dflags xs emitCostCentreDecl :: CostCentre -> Code -emitCostCentreDecl cc = do +emitCostCentreDecl cc = do -- NB. bytesFS: we want the UTF-8 bytes here (#5559) { label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc) ; modl <- newByteStringCLit (bytesFS $ Module.moduleNameFS @@ -177,51 +174,53 @@ emitCostCentreDecl cc = do showPpr dflags (costCentreSrcSpan cc) -- XXX going via FastString to get UTF-8 encoding is silly ; let - lits = [ zero, -- StgInt ccID, - label, -- char *label, - modl, -- char *module, + is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF + | otherwise = zero dflags + lits = [ zero dflags, -- StgInt ccID, + label, -- char *label, + modl, -- char *module, loc, -- char *srcloc, zero64, -- StgWord64 mem_alloc - zero, -- StgWord time_ticks + zero dflags, -- StgWord time_ticks is_caf, -- StgInt is_caf - zero -- struct _CostCentre *link - ] + zero dflags -- struct _CostCentre *link + ] ; emitDataLits (mkCCLabel cc) lits } - where - is_caf | isCafCC cc = mkIntCLit (ord 'c') -- 'c' == is a CAF - | otherwise = zero emitCostCentreStackDecl :: CostCentreStack -> Code -emitCostCentreStackDecl ccs +emitCostCentreStackDecl ccs | Just cc <- maybeSingletonCCS ccs = do - { let - -- Note: to avoid making any assumptions about how the - -- C compiler (that compiles the RTS, in particular) does - -- layouts of structs containing long-longs, simply - -- pad out the struct with zero words until we hit the - -- size of the overall struct (which we get via DerivedConstants.h) - -- - lits = zero : mkCCostCentre cc : replicate (sizeof_ccs_words - 2) zero + { dflags <- getDynFlags + ; let + -- Note: to avoid making any assumptions about how the + -- C compiler (that compiles the RTS, in particular) does + -- layouts of structs containing long-longs, simply + -- pad out the struct with zero words until we hit the + -- size of the overall struct (which we get via DerivedConstants.h) + -- + lits = zero dflags + : mkCCostCentre cc + : replicate (sizeof_ccs_words dflags - 2) (zero dflags) ; emitDataLits (mkCCSLabel ccs) lits } | otherwise = pprPanic "emitCostCentreStackDecl" (ppr ccs) -zero :: CmmLit -zero = mkIntCLit 0 +zero :: DynFlags -> CmmLit +zero dflags = mkIntCLit dflags 0 zero64 :: CmmLit zero64 = CmmInt 0 W64 -sizeof_ccs_words :: Int -sizeof_ccs_words +sizeof_ccs_words :: DynFlags -> Int +sizeof_ccs_words dflags -- round up to the next word. | ms == 0 = ws | otherwise = ws + 1 where - (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE + (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE dflags -- --------------------------------------------------------------------------- -- Set the current cost centre stack @@ -230,51 +229,52 @@ emitSetCCC :: CostCentre -> Bool -> Bool -> Code emitSetCCC cc tick push = do dflags <- getDynFlags if dopt Opt_SccProfilingOn dflags - then do tmp <- newTemp bWord -- TODO FIXME NOW + then do tmp <- newTemp (bWord dflags) -- TODO FIXME NOW pushCostCentre tmp curCCS cc - when tick $ stmtC (bumpSccCount (CmmReg (CmmLocal tmp))) + when tick $ stmtC (bumpSccCount dflags (CmmReg (CmmLocal tmp))) when push $ stmtC (storeCurCCS (CmmReg (CmmLocal tmp))) else nopC pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> Code pushCostCentre result ccs cc = emitRtsCallWithResult result AddrHint - rtsPackageId + rtsPackageId (fsLit "pushCostCentre") [CmmHinted ccs AddrHint, CmmHinted (CmmLit (mkCCostCentre cc)) AddrHint] -bumpSccCount :: CmmExpr -> CmmStmt -bumpSccCount ccs +bumpSccCount :: DynFlags -> CmmExpr -> CmmStmt +bumpSccCount dflags ccs = addToMem (typeWidth REP_CostCentreStack_scc_count) - (cmmOffsetB ccs oFFSET_CostCentreStack_scc_count) 1 + (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1 ----------------------------------------------------------------------------- -- --- Lag/drag/void stuff +-- Lag/drag/void stuff -- ----------------------------------------------------------------------------- -- -- Initial value for the LDV field in a static closure -- -staticLdvInit :: CmmLit +staticLdvInit :: DynFlags -> CmmLit staticLdvInit = zeroCLit -- -- Initial value of the LDV field in a dynamic closure -- -dynLdvInit :: CmmExpr -dynLdvInit = -- (era << LDV_SHIFT) | LDV_STATE_CREATE - CmmMachOp mo_wordOr [ - CmmMachOp mo_wordShl [loadEra, CmmLit (mkIntCLit lDV_SHIFT) ], - CmmLit (mkWordCLit lDV_STATE_CREATE) +dynLdvInit :: DynFlags -> CmmExpr +dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE + CmmMachOp (mo_wordOr dflags) [ + CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags lDV_SHIFT ], + CmmLit (mkWordCLit dflags lDV_STATE_CREATE) ] - + -- -- Initialise the LDV word of a new closure -- ldvRecordCreate :: CmmExpr -> Code -ldvRecordCreate closure = stmtC $ CmmStore (ldvWord closure) dynLdvInit +ldvRecordCreate closure = do dflags <- getDynFlags + stmtC $ CmmStore (ldvWord dflags closure) (dynLdvInit dflags) -- -- Called when a closure is entered, marks the closure as having been "used". @@ -283,34 +283,38 @@ ldvRecordCreate closure = stmtC $ CmmStore (ldvWord closure) dynLdvInit -- profiling. -- ldvEnterClosure :: ClosureInfo -> Code -ldvEnterClosure closure_info = ldvEnter (cmmOffsetB (CmmReg nodeReg) (-tag)) - where tag = funTag closure_info +ldvEnterClosure closure_info + = do dflags <- getDynFlags + let tag = funTag dflags closure_info + ldvEnter (cmmOffsetB dflags (CmmReg nodeReg) (-tag)) -- don't forget to substract node's tag - + ldvEnter :: CmmExpr -> Code -- Argument is a closure pointer -ldvEnter cl_ptr - = ifProfiling $ +ldvEnter cl_ptr = do + dflags <- getDynFlags + let + -- don't forget to substract node's tag + ldv_wd = ldvWord dflags cl_ptr + new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags)) + (CmmLit (mkWordCLit dflags lDV_CREATE_MASK))) + (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags lDV_STATE_USE))) + ifProfiling $ -- if (era > 0) { -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) | -- era | LDV_STATE_USE } - emitIf (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit]) - (stmtC (CmmStore ldv_wd new_ldv_wd)) - where - -- don't forget to substract node's tag - ldv_wd = ldvWord cl_ptr - new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd bWord) - (CmmLit (mkWordCLit lDV_CREATE_MASK))) - (cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE))) + emitIf (CmmMachOp (mo_wordUGt dflags) [loadEra dflags, CmmLit (zeroCLit dflags)]) + (stmtC (CmmStore ldv_wd new_ldv_wd)) -loadEra :: CmmExpr -loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth) - [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId $ fsLit("era"))) cInt] +loadEra :: DynFlags -> CmmExpr +loadEra dflags = CmmMachOp (MO_UU_Conv cIntWidth (wordWidth dflags)) + [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId $ fsLit("era"))) cInt] -ldvWord :: CmmExpr -> CmmExpr --- Takes the address of a closure, and returns +ldvWord :: DynFlags -> CmmExpr -> CmmExpr +-- Takes the address of a closure, and returns -- the address of the LDV word in the closure -ldvWord closure_ptr = cmmOffsetB closure_ptr oFFSET_StgHeader_ldvw +ldvWord dflags closure_ptr + = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags) -- LDV constants, from ghc/includes/Constants.h lDV_SHIFT :: Int diff --git a/compiler/codeGen/CgStackery.lhs b/compiler/codeGen/CgStackery.lhs index 217586a9d1..2f7bdfc083 100644 --- a/compiler/codeGen/CgStackery.lhs +++ b/compiler/codeGen/CgStackery.lhs @@ -37,7 +37,6 @@ import SMRep import OldCmm import OldCmmUtils import CLabel -import Constants import DynFlags import Util import OrdList @@ -101,8 +100,9 @@ setRealSp new_real_sp getSpRelOffset :: VirtualSpOffset -> FCode CmmExpr getSpRelOffset virtual_offset - = do { real_sp <- getRealSp - ; return (cmmRegOffW spReg (spRel real_sp virtual_offset)) } + = do dflags <- getDynFlags + real_sp <- getRealSp + return (cmmRegOffW dflags spReg (spRel real_sp virtual_offset)) \end{code} @@ -118,12 +118,13 @@ increase towards the top of stack). \begin{code} mkVirtStkOffsets - :: VirtualSpOffset -- Offset of the last allocated thing + :: DynFlags + -> VirtualSpOffset -- Offset of the last allocated thing -> [(CgRep,a)] -- things to make offsets for -> (VirtualSpOffset, -- OUTPUTS: Topmost allocated word [(a, VirtualSpOffset)]) -- things with offsets (voids filtered out) -mkVirtStkOffsets init_Sp_offset things +mkVirtStkOffsets dflags init_Sp_offset things = loop init_Sp_offset [] (reverse things) where loop offset offs [] = (offset,offs) @@ -132,7 +133,7 @@ mkVirtStkOffsets init_Sp_offset things loop offset offs ((rep,t):things) = loop thing_slot ((t,thing_slot):offs) things where - thing_slot = offset + cgRepSizeW rep + thing_slot = offset + cgRepSizeW dflags rep -- offset of thing is offset+size, because we're -- growing the stack *downwards* as the offsets increase. @@ -149,12 +150,13 @@ mkStkAmodes CmmStmts) -- Assignments to appropriate stk slots mkStkAmodes tail_Sp things - = do { rSp <- getRealSp - ; let (last_Sp_offset, offsets) = mkVirtStkOffsets tail_Sp things - abs_cs = [ CmmStore (cmmRegOffW spReg (spRel rSp offset)) amode - | (amode, offset) <- offsets - ] - ; returnFC (last_Sp_offset, toOL abs_cs) } + = do dflags <- getDynFlags + rSp <- getRealSp + let (last_Sp_offset, offsets) = mkVirtStkOffsets dflags tail_Sp things + abs_cs = [ CmmStore (cmmRegOffW dflags spReg (spRel rSp offset)) amode + | (amode, offset) <- offsets + ] + returnFC (last_Sp_offset, toOL abs_cs) \end{code} %************************************************************************ @@ -167,7 +169,11 @@ Allocate a virtual offset for something. \begin{code} allocPrimStack :: CgRep -> FCode VirtualSpOffset -allocPrimStack rep +allocPrimStack rep = do dflags <- getDynFlags + allocPrimStack' dflags rep + +allocPrimStack' :: DynFlags -> CgRep -> FCode VirtualSpOffset +allocPrimStack' dflags rep = do { stk_usg <- getStkUsage ; let free_stk = freeStk stk_usg ; case find_block free_stk of @@ -183,7 +189,7 @@ allocPrimStack rep } where size :: WordOff - size = cgRepSizeW rep + size = cgRepSizeW dflags rep -- Find_block looks for a contiguous chunk of free slots -- returning the offset of its topmost word @@ -289,7 +295,7 @@ pushSpecUpdateFrame lbl updatee code ; MASSERT(case sequel of { OnStack -> True; _ -> False}) } ; dflags <- getDynFlags ; allocStackTop (fixedHdrSize dflags + - sIZEOF_StgUpdateFrame_NoHdr `quot` wORD_SIZE) + sIZEOF_StgUpdateFrame_NoHdr dflags `quot` wORD_SIZE dflags) ; vsp <- getVirtSp ; setStackFrame vsp ; frame_addr <- getSpRelOffset vsp @@ -317,12 +323,12 @@ emitSpecPushUpdateFrame lbl frame_addr updatee = do stmtsC [ -- Set the info word CmmStore frame_addr (mkLblExpr lbl) , -- And the updatee - CmmStore (cmmOffsetB frame_addr (off_updatee dflags)) updatee ] + CmmStore (cmmOffsetB dflags frame_addr (off_updatee dflags)) updatee ] initUpdFrameProf frame_addr off_updatee :: DynFlags -> ByteOff off_updatee dflags - = fixedHdrSize dflags * wORD_SIZE + oFFSET_StgUpdateFrame_updatee + = fixedHdrSize dflags * wORD_SIZE dflags + oFFSET_StgUpdateFrame_updatee dflags \end{code} diff --git a/compiler/codeGen/CgTailCall.lhs b/compiler/codeGen/CgTailCall.lhs index 6db1b46d77..3e64e6007d 100644 --- a/compiler/codeGen/CgTailCall.lhs +++ b/compiler/codeGen/CgTailCall.lhs @@ -127,7 +127,7 @@ performTailCall fun_info arg_amodes pending_assts -- Node must always point to things we enter EnterIt -> do { emitSimultaneously (node_asst `plusStmts` pending_assts) - ; let target = entryCode dflags (closureInfoPtr (CmmReg nodeReg)) + ; let target = entryCode dflags (closureInfoPtr dflags (CmmReg nodeReg)) enterClosure = stmtC (CmmJump target node_live) -- If this is a scrutinee -- let's check if the closure is a constructor @@ -193,7 +193,7 @@ performTailCall fun_info arg_amodes pending_assts fun_name = idName fun_id lf_info = cgIdInfoLF fun_info fun_has_cafs = idCafInfo fun_id - untag_node = CmmAssign nodeReg (cmmUntag (CmmReg nodeReg)) + untag_node dflags = CmmAssign nodeReg (cmmUntag dflags (CmmReg nodeReg)) -- Test if closure is a constructor maybeSwitchOnCons dflags enterClosure eob | EndOfBlockInfo _ (CaseAlts lbl _ _) <- eob, @@ -203,7 +203,7 @@ performTailCall fun_info arg_amodes pending_assts = do { is_constr <- newLabelC -- Is the pointer tagged? -- Yes, jump to switch statement - ; stmtC (CmmCondBranch (cmmIsTagged (CmmReg nodeReg)) + ; stmtC (CmmCondBranch (cmmIsTagged dflags (CmmReg nodeReg)) is_constr) -- No, enter the closure. ; enterClosure @@ -232,7 +232,7 @@ performTailCall fun_info arg_amodes pending_assts -} -- No case expression involved, enter the closure. | otherwise - = do { stmtC untag_node + = do { stmtC $ untag_node dflags ; enterClosure } where @@ -413,11 +413,12 @@ tailCallPrimCall primcall tailCallPrim :: CLabel -> [StgArg] -> Code tailCallPrim lbl args - = do { -- We're going to perform a normal-looking tail call, + = do { dflags <- getDynFlags + -- We're going to perform a normal-looking tail call, -- except that *all* the arguments will be in registers. -- Hence the ASSERT( null leftovers ) - arg_amodes <- getArgAmodes args - ; let (arg_regs, leftovers) = assignPrimOpCallRegs arg_amodes + ; arg_amodes <- getArgAmodes args + ; let (arg_regs, leftovers) = assignPrimOpCallRegs dflags arg_amodes live_regs = Just $ map snd arg_regs jump_to_primop = jumpToLbl lbl live_regs diff --git a/compiler/codeGen/CgTicky.hs b/compiler/codeGen/CgTicky.hs index cfef1087cc..9e981755be 100644 --- a/compiler/codeGen/CgTicky.hs +++ b/compiler/codeGen/CgTicky.hs @@ -59,7 +59,6 @@ import Id import IdInfo import BasicTypes import FastString -import Constants import Outputable import Module @@ -98,14 +97,14 @@ emitTickyCounter cl_info args on_stk -- krc: note that all the fields are I32 now; some were I16 before, -- but the code generator wasn't handling that properly and it led to chaos, -- panic and disorder. - [ mkIntCLit 0, - mkIntCLit (length args),-- Arity - mkIntCLit on_stk, -- Words passed on stack + [ mkIntCLit dflags 0, + mkIntCLit dflags (length args),-- Arity + mkIntCLit dflags on_stk, -- Words passed on stack fun_descr_lit, arg_descr_lit, - zeroCLit, -- Entry count - zeroCLit, -- Allocs - zeroCLit -- Link + zeroCLit dflags, -- Entry count + zeroCLit dflags, -- Allocs + zeroCLit dflags -- Link ] } where name = closureName cl_info @@ -161,10 +160,11 @@ tickyUpdateBhCaf cl_info tickyEnterFun :: ClosureInfo -> Code tickyEnterFun cl_info = ifTicky $ - do { bumpTickyCounter ctr + do { dflags <- getDynFlags + ; bumpTickyCounter ctr ; fun_ctr_lbl <- getTickyCtrLabel ; registerTickyCtr fun_ctr_lbl - ; bumpTickyCounter' (cmmLabelOffB fun_ctr_lbl oFFSET_StgEntCounter_entry_count) + ; bumpTickyCounter' (cmmLabelOffB fun_ctr_lbl (oFFSET_StgEntCounter_entry_count dflags)) } where ctr | isStaticClosure cl_info = fsLit "ENT_STATIC_FUN_DIRECT_ctr" @@ -177,21 +177,21 @@ registerTickyCtr :: CLabel -> Code -- ticky_entry_ctrs = & (f_ct); /* mark it as "registered" */ -- f_ct.registeredp = 1 } registerTickyCtr ctr_lbl - = emitIf test (stmtsC register_stmts) - where - -- krc: code generator doesn't handle Not, so we test for Eq 0 instead - test = CmmMachOp (MO_Eq wordWidth) - [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl - oFFSET_StgEntCounter_registeredp)) bWord, - CmmLit (mkIntCLit 0)] - register_stmts - = [ CmmStore (CmmLit (cmmLabelOffB ctr_lbl oFFSET_StgEntCounter_link)) - (CmmLoad ticky_entry_ctrs bWord) - , CmmStore ticky_entry_ctrs (mkLblExpr ctr_lbl) - , CmmStore (CmmLit (cmmLabelOffB ctr_lbl - oFFSET_StgEntCounter_registeredp)) - (CmmLit (mkIntCLit 1)) ] - ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs")) + = do dflags <- getDynFlags + let -- krc: code generator doesn't handle Not, so we test for Eq 0 instead + test = CmmMachOp (MO_Eq (wordWidth dflags)) + [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl + (oFFSET_StgEntCounter_registeredp dflags))) (bWord dflags), + CmmLit (mkIntCLit dflags 0)] + register_stmts + = [ CmmStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_link dflags))) + (CmmLoad ticky_entry_ctrs (bWord dflags)) + , CmmStore ticky_entry_ctrs (mkLblExpr ctr_lbl) + , CmmStore (CmmLit (cmmLabelOffB ctr_lbl + (oFFSET_StgEntCounter_registeredp dflags))) + (CmmLit (mkIntCLit dflags 1)) ] + ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs")) + emitIf test (stmtsC register_stmts) tickyReturnOldCon, tickyReturnNewCon :: Arity -> Code tickyReturnOldCon arity @@ -292,14 +292,15 @@ tickyAllocHeap :: VirtualHpOffset -> Code -- Called when doing a heap check [TICK_ALLOC_HEAP] tickyAllocHeap hp = ifTicky $ - do { ticky_ctr <- getTickyCtrLabel + do { dflags <- getDynFlags + ; ticky_ctr <- getTickyCtrLabel ; stmtsC $ if hp == 0 then [] -- Inside the stmtC to avoid control else [ -- dependency on the argument -- Bump the allcoation count in the StgEntCounter addToMem (typeWidth REP_StgEntCounter_allocs) (CmmLit (cmmLabelOffB ticky_ctr - oFFSET_StgEntCounter_allocs)) hp, + (oFFSET_StgEntCounter_allocs dflags))) hp, -- Bump ALLOC_HEAP_ctr addToMemLbl cLongWidth (mkCmmDataLabel rtsPackageId $ fsLit "ALLOC_HEAP_ctr") 1, -- Bump ALLOC_HEAP_tot @@ -310,8 +311,8 @@ tickyAllocHeap hp ifTicky :: Code -> Code ifTicky code = do dflags <- getDynFlags - if doingTickyProfiling dflags then code - else nopC + if dopt Opt_Ticky dflags then code + else nopC addToMemLbl :: Width -> CLabel -> Int -> CmmStmt addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 298143bd08..c52c8a8c99 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -53,7 +53,6 @@ import TyCon import DataCon import Id import IdInfo -import Constants import SMRep import OldCmm import OldCmmUtils @@ -69,7 +68,6 @@ import Util import DynFlags import FastString import Outputable -import Platform import Data.Char import Data.Word @@ -94,33 +92,34 @@ addIdReps ids = [(idCgRep id, id) | id <- ids] cgLit :: Literal -> FCode CmmLit cgLit (MachStr s) = newByteStringCLit (bytesFB s) -cgLit other_lit = return (mkSimpleLit other_lit) - -mkSimpleLit :: Literal -> CmmLit -mkSimpleLit (MachChar c) = CmmInt (fromIntegral (ord c)) wordWidth -mkSimpleLit MachNullAddr = zeroCLit -mkSimpleLit (MachInt i) = CmmInt i wordWidth -mkSimpleLit (MachInt64 i) = CmmInt i W64 -mkSimpleLit (MachWord i) = CmmInt i wordWidth -mkSimpleLit (MachWord64 i) = CmmInt i W64 -mkSimpleLit (MachFloat r) = CmmFloat r W32 -mkSimpleLit (MachDouble r) = CmmFloat r W64 -mkSimpleLit (MachLabel fs ms fod) +cgLit other_lit = do dflags <- getDynFlags + return (mkSimpleLit dflags other_lit) + +mkSimpleLit :: DynFlags -> Literal -> CmmLit +mkSimpleLit dflags (MachChar c) = CmmInt (fromIntegral (ord c)) (wordWidth dflags) +mkSimpleLit dflags MachNullAddr = zeroCLit dflags +mkSimpleLit dflags (MachInt i) = CmmInt i (wordWidth dflags) +mkSimpleLit _ (MachInt64 i) = CmmInt i W64 +mkSimpleLit dflags (MachWord i) = CmmInt i (wordWidth dflags) +mkSimpleLit _ (MachWord64 i) = CmmInt i W64 +mkSimpleLit _ (MachFloat r) = CmmFloat r W32 +mkSimpleLit _ (MachDouble r) = CmmFloat r W64 +mkSimpleLit _ (MachLabel fs ms fod) = CmmLabel (mkForeignLabel fs ms labelSrc fod) where -- TODO: Literal labels might not actually be in the current package... labelSrc = ForeignLabelInThisPackage -mkSimpleLit (MachStr _) = panic "mkSimpleLit: MachStr" +mkSimpleLit _ (MachStr _) = panic "mkSimpleLit: MachStr" -- No LitInteger's should be left by the time this is called. CorePrep -- should have converted them all to a real core representation. -mkSimpleLit (LitInteger {}) = panic "mkSimpleLit: LitInteger" +mkSimpleLit _ (LitInteger {}) = panic "mkSimpleLit: LitInteger" -mkLtOp :: Literal -> MachOp +mkLtOp :: DynFlags -> Literal -> MachOp -- On signed literals we must do a signed comparison -mkLtOp (MachInt _) = MO_S_Lt wordWidth -mkLtOp (MachFloat _) = MO_F_Lt W32 -mkLtOp (MachDouble _) = MO_F_Lt W64 -mkLtOp lit = MO_U_Lt (typeWidth (cmmLitType (mkSimpleLit lit))) +mkLtOp dflags (MachInt _) = MO_S_Lt (wordWidth dflags) +mkLtOp _ (MachFloat _) = MO_F_Lt W32 +mkLtOp _ (MachDouble _) = MO_F_Lt W64 +mkLtOp dflags lit = MO_U_Lt (typeWidth (cmmLitType dflags (mkSimpleLit dflags lit))) --------------------------------------------------- @@ -142,20 +141,20 @@ mkLtOp lit = MO_U_Lt (typeWidth (cmmLitType (mkSimpleLit lit))) Big families only use the tag value 1 to represent evaluatedness. -} -isSmallFamily :: Int -> Bool -isSmallFamily fam_size = fam_size <= mAX_PTR_TAG +isSmallFamily :: DynFlags -> Int -> Bool +isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags -tagForCon :: DataCon -> ConTagZ -tagForCon con = tag +tagForCon :: DynFlags -> DataCon -> ConTagZ +tagForCon dflags con = tag where con_tag = dataConTagZ con fam_size = tyConFamilySize (dataConTyCon con) - tag | isSmallFamily fam_size = con_tag + 1 - | otherwise = 1 + tag | isSmallFamily dflags fam_size = con_tag + 1 + | otherwise = 1 --Tag an expression, to do: refactor, this appears in some other module. -tagCons :: DataCon -> CmmExpr -> CmmExpr -tagCons con expr = cmmOffsetB expr (tagForCon con) +tagCons :: DynFlags -> DataCon -> CmmExpr -> CmmExpr +tagCons dflags con expr = cmmOffsetB dflags expr (tagForCon dflags con) -------------------------------------------------------------------------- -- @@ -183,9 +182,9 @@ addToMemE width ptr n -- ------------------------------------------------------------------------- -tagToClosure :: TyCon -> CmmExpr -> CmmExpr -tagToClosure tycon tag - = CmmLoad (cmmOffsetExprW closure_tbl tag) gcWord +tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr +tagToClosure dflags tycon tag + = CmmLoad (cmmOffsetExprW dflags closure_tbl tag) (gcWord dflags) where closure_tbl = CmmLit (CmmLabel lbl) lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs @@ -299,23 +298,23 @@ callerSaveVolatileRegs dflags vols = (caller_save, caller_load) vol_list = case vols of Nothing -> all_of_em; Just regs -> regs - all_of_em = [ VanillaReg n VNonGcPtr | n <- [0..mAX_Vanilla_REG] ] + all_of_em = [ VanillaReg n VNonGcPtr | n <- [0 .. mAX_Vanilla_REG dflags] ] -- The VNonGcPtr is a lie, but I don't think it matters - ++ [ FloatReg n | n <- [0..mAX_Float_REG] ] - ++ [ DoubleReg n | n <- [0..mAX_Double_REG] ] - ++ [ LongReg n | n <- [0..mAX_Long_REG] ] + ++ [ FloatReg n | n <- [0 .. mAX_Float_REG dflags] ] + ++ [ DoubleReg n | n <- [0 .. mAX_Double_REG dflags] ] + ++ [ LongReg n | n <- [0 .. mAX_Long_REG dflags] ] callerSaveGlobalReg reg next | callerSaves platform reg = - CmmStore (get_GlobalReg_addr platform reg) + CmmStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg)) : next | otherwise = next callerRestoreGlobalReg reg next | callerSaves platform reg = CmmAssign (CmmGlobal reg) - (CmmLoad (get_GlobalReg_addr platform reg) - (globalRegType reg)) + (CmmLoad (get_GlobalReg_addr dflags reg) + (globalRegType dflags reg)) : next | otherwise = next @@ -323,42 +322,42 @@ callerSaveVolatileRegs dflags vols = (caller_save, caller_load) -- ----------------------------------------------------------------------------- -- Information about global registers -baseRegOffset :: GlobalReg -> Int - -baseRegOffset (VanillaReg 1 _) = oFFSET_StgRegTable_rR1 -baseRegOffset (VanillaReg 2 _) = oFFSET_StgRegTable_rR2 -baseRegOffset (VanillaReg 3 _) = oFFSET_StgRegTable_rR3 -baseRegOffset (VanillaReg 4 _) = oFFSET_StgRegTable_rR4 -baseRegOffset (VanillaReg 5 _) = oFFSET_StgRegTable_rR5 -baseRegOffset (VanillaReg 6 _) = oFFSET_StgRegTable_rR6 -baseRegOffset (VanillaReg 7 _) = oFFSET_StgRegTable_rR7 -baseRegOffset (VanillaReg 8 _) = oFFSET_StgRegTable_rR8 -baseRegOffset (VanillaReg 9 _) = oFFSET_StgRegTable_rR9 -baseRegOffset (VanillaReg 10 _) = oFFSET_StgRegTable_rR10 -baseRegOffset (VanillaReg n _) = panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")") -baseRegOffset (FloatReg 1) = oFFSET_StgRegTable_rF1 -baseRegOffset (FloatReg 2) = oFFSET_StgRegTable_rF2 -baseRegOffset (FloatReg 3) = oFFSET_StgRegTable_rF3 -baseRegOffset (FloatReg 4) = oFFSET_StgRegTable_rF4 -baseRegOffset (FloatReg n) = panic ("Registers above F4 are not supported (tried to use F" ++ show n ++ ")") -baseRegOffset (DoubleReg 1) = oFFSET_StgRegTable_rD1 -baseRegOffset (DoubleReg 2) = oFFSET_StgRegTable_rD2 -baseRegOffset (DoubleReg n) = panic ("Registers above D2 are not supported (tried to use D" ++ show n ++ ")") -baseRegOffset Sp = oFFSET_StgRegTable_rSp -baseRegOffset SpLim = oFFSET_StgRegTable_rSpLim -baseRegOffset (LongReg 1) = oFFSET_StgRegTable_rL1 -baseRegOffset (LongReg n) = panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")") -baseRegOffset Hp = oFFSET_StgRegTable_rHp -baseRegOffset HpLim = oFFSET_StgRegTable_rHpLim -baseRegOffset CCCS = oFFSET_StgRegTable_rCCCS -baseRegOffset CurrentTSO = oFFSET_StgRegTable_rCurrentTSO -baseRegOffset CurrentNursery = oFFSET_StgRegTable_rCurrentNursery -baseRegOffset HpAlloc = oFFSET_StgRegTable_rHpAlloc -baseRegOffset EagerBlackholeInfo = oFFSET_stgEagerBlackholeInfo -baseRegOffset GCEnter1 = oFFSET_stgGCEnter1 -baseRegOffset GCFun = oFFSET_stgGCFun -baseRegOffset BaseReg = panic "baseRegOffset:BaseReg" -baseRegOffset PicBaseReg = panic "baseRegOffset:PicBaseReg" +baseRegOffset :: DynFlags -> GlobalReg -> Int + +baseRegOffset dflags (VanillaReg 1 _) = oFFSET_StgRegTable_rR1 dflags +baseRegOffset dflags (VanillaReg 2 _) = oFFSET_StgRegTable_rR2 dflags +baseRegOffset dflags (VanillaReg 3 _) = oFFSET_StgRegTable_rR3 dflags +baseRegOffset dflags (VanillaReg 4 _) = oFFSET_StgRegTable_rR4 dflags +baseRegOffset dflags (VanillaReg 5 _) = oFFSET_StgRegTable_rR5 dflags +baseRegOffset dflags (VanillaReg 6 _) = oFFSET_StgRegTable_rR6 dflags +baseRegOffset dflags (VanillaReg 7 _) = oFFSET_StgRegTable_rR7 dflags +baseRegOffset dflags (VanillaReg 8 _) = oFFSET_StgRegTable_rR8 dflags +baseRegOffset dflags (VanillaReg 9 _) = oFFSET_StgRegTable_rR9 dflags +baseRegOffset dflags (VanillaReg 10 _) = oFFSET_StgRegTable_rR10 dflags +baseRegOffset _ (VanillaReg n _) = panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")") +baseRegOffset dflags (FloatReg 1) = oFFSET_StgRegTable_rF1 dflags +baseRegOffset dflags (FloatReg 2) = oFFSET_StgRegTable_rF2 dflags +baseRegOffset dflags (FloatReg 3) = oFFSET_StgRegTable_rF3 dflags +baseRegOffset dflags (FloatReg 4) = oFFSET_StgRegTable_rF4 dflags +baseRegOffset _ (FloatReg n) = panic ("Registers above F4 are not supported (tried to use F" ++ show n ++ ")") +baseRegOffset dflags (DoubleReg 1) = oFFSET_StgRegTable_rD1 dflags +baseRegOffset dflags (DoubleReg 2) = oFFSET_StgRegTable_rD2 dflags +baseRegOffset _ (DoubleReg n) = panic ("Registers above D2 are not supported (tried to use D" ++ show n ++ ")") +baseRegOffset dflags Sp = oFFSET_StgRegTable_rSp dflags +baseRegOffset dflags SpLim = oFFSET_StgRegTable_rSpLim dflags +baseRegOffset dflags (LongReg 1) = oFFSET_StgRegTable_rL1 dflags +baseRegOffset _ (LongReg n) = panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")") +baseRegOffset dflags Hp = oFFSET_StgRegTable_rHp dflags +baseRegOffset dflags HpLim = oFFSET_StgRegTable_rHpLim dflags +baseRegOffset dflags CCCS = oFFSET_StgRegTable_rCCCS dflags +baseRegOffset dflags CurrentTSO = oFFSET_StgRegTable_rCurrentTSO dflags +baseRegOffset dflags CurrentNursery = oFFSET_StgRegTable_rCurrentNursery dflags +baseRegOffset dflags HpAlloc = oFFSET_StgRegTable_rHpAlloc dflags +baseRegOffset dflags EagerBlackholeInfo = oFFSET_stgEagerBlackholeInfo dflags +baseRegOffset dflags GCEnter1 = oFFSET_stgGCEnter1 dflags +baseRegOffset dflags GCFun = oFFSET_stgGCFun dflags +baseRegOffset _ BaseReg = panic "baseRegOffset:BaseReg" +baseRegOffset _ PicBaseReg = panic "baseRegOffset:PicBaseReg" ------------------------------------------------------------------------- @@ -402,9 +401,10 @@ assignTemp :: CmmExpr -> FCode CmmExpr -- variable and assign the expression to it assignTemp e | isTrivialCmmExpr e = return e - | otherwise = do { reg <- newTemp (cmmExprType e) - ; stmtC (CmmAssign (CmmLocal reg) e) - ; return (CmmReg (CmmLocal reg)) } + | otherwise = do dflags <- getDynFlags + reg <- newTemp (cmmExprType dflags e) + stmtC (CmmAssign (CmmLocal reg) e) + return (CmmReg (CmmLocal reg)) -- | If the expression is trivial and doesn't refer to a global -- register, return it. Otherwise, assign the expression to a @@ -414,7 +414,8 @@ assignTemp_ :: CmmExpr -> FCode CmmExpr assignTemp_ e | isTrivialCmmExpr e && hasNoGlobalRegs e = return e | otherwise = do - reg <- newTemp (cmmExprType e) + dflags <- getDynFlags + reg <- newTemp (cmmExprType dflags e) stmtC (CmmAssign (CmmLocal reg) e) return (CmmReg (CmmLocal reg)) @@ -477,12 +478,13 @@ mk_switch _tag_expr [(_tag,stmts)] Nothing _lo_tag _hi_tag _via_C -- can't happen, so no need to test -- SINGLETON BRANCH: one equality check to do -mk_switch tag_expr [(tag,stmts)] (Just deflt) _lo_tag _hi_tag _via_C - = return (CmmCondBranch cond deflt `consCgStmt` stmts) - where - cond = cmmNeWord tag_expr (CmmLit (mkIntCLit tag)) +mk_switch tag_expr [(tag,stmts)] (Just deflt) _lo_tag _hi_tag _via_C = do + dflags <- getDynFlags + let + cond = cmmNeWord dflags tag_expr (CmmLit (mkIntCLit dflags tag)) -- We have lo_tag < hi_tag, but there's only one branch, -- so there must be a default + return (CmmCondBranch cond deflt `consCgStmt` stmts) -- ToDo: we might want to check for the two branch case, where one of -- the branches is the tag 0, because comparing '== 0' is likely to be @@ -499,7 +501,8 @@ mk_switch tag_expr [(tag,stmts)] (Just deflt) _lo_tag _hi_tag _via_C -- mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C | use_switch -- Use a switch - = do { branch_ids <- mapM forkCgStmts (map snd branches) + = do { dflags <- getDynFlags + ; branch_ids <- mapM forkCgStmts (map snd branches) ; let tagged_blk_ids = zip (map fst branches) (map Just branch_ids) @@ -511,7 +514,7 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C -- tag of a real branch is real_lo_tag (not lo_tag). arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]] - switch_stmt = CmmSwitch (cmmOffset tag_expr (- real_lo_tag)) arms + switch_stmt = CmmSwitch (cmmOffset dflags tag_expr (- real_lo_tag)) arms ; ASSERT(not (all isNothing arms)) return (oneCgStmt switch_stmt) @@ -519,8 +522,9 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C -- if we can knock off a bunch of default cases with one if, then do so | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches - = do { (assign_tag, tag_expr') <- assignTemp' tag_expr - ; let cond = cmmULtWord tag_expr' (CmmLit (mkIntCLit lowest_branch)) + = do { dflags <- getDynFlags + ; (assign_tag, tag_expr') <- assignTemp' tag_expr + ; let cond = cmmULtWord dflags tag_expr' (CmmLit (mkIntCLit dflags lowest_branch)) branch = CmmCondBranch cond deflt ; stmts <- mk_switch tag_expr' branches mb_deflt lowest_branch hi_tag via_C @@ -528,8 +532,9 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C } | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches - = do { (assign_tag, tag_expr') <- assignTemp' tag_expr - ; let cond = cmmUGtWord tag_expr' (CmmLit (mkIntCLit highest_branch)) + = do { dflags <- getDynFlags + ; (assign_tag, tag_expr') <- assignTemp' tag_expr + ; let cond = cmmUGtWord dflags tag_expr' (CmmLit (mkIntCLit dflags highest_branch)) branch = CmmCondBranch cond deflt ; stmts <- mk_switch tag_expr' branches mb_deflt lo_tag highest_branch via_C @@ -537,14 +542,15 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C } | otherwise -- Use an if-tree - = do { (assign_tag, tag_expr') <- assignTemp' tag_expr + = do { dflags <- getDynFlags + ; (assign_tag, tag_expr') <- assignTemp' tag_expr -- To avoid duplication ; lo_stmts <- mk_switch tag_expr' lo_branches mb_deflt lo_tag (mid_tag-1) via_C ; hi_stmts <- mk_switch tag_expr' hi_branches mb_deflt mid_tag hi_tag via_C ; hi_id <- forkCgStmts hi_stmts - ; let cond = cmmUGeWord tag_expr' (CmmLit (mkIntCLit mid_tag)) + ; let cond = cmmUGeWord dflags tag_expr' (CmmLit (mkIntCLit dflags mid_tag)) branch_stmt = CmmCondBranch cond hi_id ; return (assign_tag `consCgStmt` (branch_stmt `consCgStmt` lo_stmts)) } @@ -604,8 +610,9 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C assignTemp' :: CmmExpr -> FCode (CmmStmt, CmmExpr) assignTemp' e | isTrivialCmmExpr e = return (CmmNop, e) - | otherwise = do { reg <- newTemp (cmmExprType e) - ; return (CmmAssign (CmmLocal reg) e, CmmReg (CmmLocal reg)) } + | otherwise = do dflags <- getDynFlags + reg <- newTemp (cmmExprType dflags e) + return (CmmAssign (CmmLocal reg) e, CmmReg (CmmLocal reg)) emitLitSwitch :: CmmExpr -- Tag to switch on -> [(Literal, CgStmts)] -- Tagged branches @@ -628,19 +635,20 @@ mk_lit_switch :: CmmExpr -> BlockId -> [(Literal,CgStmts)] -> FCode CgStmts mk_lit_switch scrut deflt_blk_id [(lit,blk)] - = return (consCgStmt if_stmt blk) - where - cmm_lit = mkSimpleLit lit - rep = cmmLitType cmm_lit - ne = if isFloatType rep then MO_F_Ne else MO_Ne - cond = CmmMachOp (ne (typeWidth rep)) [scrut, CmmLit cmm_lit] - if_stmt = CmmCondBranch cond deflt_blk_id + = do dflags <- getDynFlags + let cmm_lit = mkSimpleLit dflags lit + rep = cmmLitType dflags cmm_lit + ne = if isFloatType rep then MO_F_Ne else MO_Ne + cond = CmmMachOp (ne (typeWidth rep)) [scrut, CmmLit cmm_lit] + if_stmt = CmmCondBranch cond deflt_blk_id + return (consCgStmt if_stmt blk) mk_lit_switch scrut deflt_blk_id branches - = do { hi_blk <- mk_lit_switch scrut deflt_blk_id hi_branches + = do { dflags <- getDynFlags + ; hi_blk <- mk_lit_switch scrut deflt_blk_id hi_branches ; lo_blk <- mk_lit_switch scrut deflt_blk_id lo_branches ; lo_blk_id <- forkCgStmts lo_blk - ; let if_stmt = CmmCondBranch cond lo_blk_id + ; let if_stmt = CmmCondBranch (cond dflags) lo_blk_id ; return (if_stmt `consCgStmt` hi_blk) } where n_branches = length branches @@ -650,8 +658,8 @@ mk_lit_switch scrut deflt_blk_id branches (lo_branches, hi_branches) = span is_lo branches is_lo (t,_) = t < mid_lit - cond = CmmMachOp (mkLtOp mid_lit) - [scrut, CmmLit (mkSimpleLit mid_lit)] + cond dflags = CmmMachOp (mkLtOp dflags mid_lit) + [scrut, CmmLit (mkSimpleLit dflags mid_lit)] ------------------------------------------------------------------------- -- @@ -687,13 +695,14 @@ emitSimultaneously stmts stmt_list -> doSimultaneously1 (zip [(1::Int)..] stmt_list) doSimultaneously1 :: [CVertex] -> Code -doSimultaneously1 vertices - = let +doSimultaneously1 vertices = do + dflags <- getDynFlags + let edges = [ (vertex, key1, edges_from stmt1) | vertex@(key1, stmt1) <- vertices ] edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices, - stmt1 `mustFollow` stmt2 + mustFollow dflags stmt1 stmt2 ] components = stronglyConnCompFromEdgedVertices edges @@ -712,23 +721,24 @@ doSimultaneously1 vertices ; stmtC from_temp } go_via_temp (CmmAssign dest src) - = do { tmp <- newTemp (cmmRegType dest) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong + = do { dflags <- getDynFlags + ; tmp <- newTemp (cmmRegType dflags dest) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong ; stmtC (CmmAssign (CmmLocal tmp) src) ; return (CmmAssign dest (CmmReg (CmmLocal tmp))) } go_via_temp (CmmStore dest src) - = do { tmp <- newTemp (cmmExprType src) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong + = do { tmp <- newTemp (cmmExprType dflags src) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong ; stmtC (CmmAssign (CmmLocal tmp) src) ; return (CmmStore dest (CmmReg (CmmLocal tmp))) } go_via_temp _ = panic "doSimultaneously1: go_via_temp" - in mapCs do_component components -mustFollow :: CmmStmt -> CmmStmt -> Bool -CmmAssign reg _ `mustFollow` stmt = anySrc (reg `regUsedIn`) stmt -CmmStore loc e `mustFollow` stmt = anySrc (locUsedIn loc (cmmExprType e)) stmt -CmmNop `mustFollow` _ = False -CmmComment _ `mustFollow` _ = False -_ `mustFollow` _ = panic "mustFollow" +mustFollow :: DynFlags -> CmmStmt -> CmmStmt -> Bool +mustFollow dflags x y = x `mustFollow'` y + where CmmAssign reg _ `mustFollow'` stmt = anySrc (reg `regUsedIn`) stmt + CmmStore loc e `mustFollow'` stmt = anySrc (locUsedIn loc (cmmExprType dflags e)) stmt + CmmNop `mustFollow'` _ = False + CmmComment _ `mustFollow'` _ = False + _ `mustFollow'` _ = panic "mustFollow" anySrc :: (CmmExpr -> Bool) -> CmmStmt -> Bool @@ -776,6 +786,7 @@ possiblySameLoc _ _ _ _ = True -- Conservative getSRTInfo :: FCode C_SRT getSRTInfo = do + dflags <- getDynFlags srt_lbl <- getSRTLabel srt <- getSRT case srt of @@ -788,9 +799,9 @@ getSRTInfo = do -> do id <- newUnique let srt_desc_lbl = mkLargeSRTLabel id emitRODataLits "getSRTInfo" srt_desc_lbl - ( cmmLabelOffW srt_lbl off - : mkWordCLit (fromIntegral len) - : map mkWordCLit bmp) + ( cmmLabelOffW dflags srt_lbl off + : mkWordCLit dflags (fromIntegral len) + : map (mkWordCLit dflags) bmp) return (C_SRT srt_desc_lbl 0 srt_escape) | otherwise @@ -810,80 +821,81 @@ srt_escape = -1 -- to real machine registers or stored as offsets from BaseReg. Given -- a GlobalReg, get_GlobalReg_addr always produces the -- register table address for it. -get_GlobalReg_addr :: Platform -> GlobalReg -> CmmExpr -get_GlobalReg_addr _ BaseReg = regTableOffset 0 -get_GlobalReg_addr platform mid - = get_Regtable_addr_from_offset platform - (globalRegType mid) (baseRegOffset mid) +get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr +get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0 +get_GlobalReg_addr dflags mid + = get_Regtable_addr_from_offset dflags + (globalRegType dflags mid) (baseRegOffset dflags mid) -- Calculate a literal representing an offset into the register table. -- Used when we don't have an actual BaseReg to offset from. -regTableOffset :: Int -> CmmExpr -regTableOffset n = - CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n)) +regTableOffset :: DynFlags -> Int -> CmmExpr +regTableOffset dflags n = + CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n)) -get_Regtable_addr_from_offset :: Platform -> CmmType -> Int -> CmmExpr -get_Regtable_addr_from_offset platform _ offset = - if haveRegBase platform +get_Regtable_addr_from_offset :: DynFlags -> CmmType -> Int -> CmmExpr +get_Regtable_addr_from_offset dflags _ offset = + if haveRegBase (targetPlatform dflags) then CmmRegOff (CmmGlobal BaseReg) offset - else regTableOffset offset + else regTableOffset dflags offset -- | Fixup global registers so that they assign to locations within the -- RegTable if they aren't pinned for the current target. -fixStgRegisters :: Platform -> RawCmmDecl -> RawCmmDecl +fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl fixStgRegisters _ top@(CmmData _ _) = top -fixStgRegisters platform (CmmProc info lbl (ListGraph blocks)) = - let blocks' = map (fixStgRegBlock platform) blocks +fixStgRegisters dflags (CmmProc info lbl (ListGraph blocks)) = + let blocks' = map (fixStgRegBlock dflags) blocks in CmmProc info lbl $ ListGraph blocks' -fixStgRegBlock :: Platform -> CmmBasicBlock -> CmmBasicBlock -fixStgRegBlock platform (BasicBlock id stmts) = - let stmts' = map (fixStgRegStmt platform) stmts +fixStgRegBlock :: DynFlags -> CmmBasicBlock -> CmmBasicBlock +fixStgRegBlock dflags (BasicBlock id stmts) = + let stmts' = map (fixStgRegStmt dflags) stmts in BasicBlock id stmts' -fixStgRegStmt :: Platform -> CmmStmt -> CmmStmt -fixStgRegStmt platform stmt +fixStgRegStmt :: DynFlags -> CmmStmt -> CmmStmt +fixStgRegStmt dflags stmt = case stmt of CmmAssign (CmmGlobal reg) src -> - let src' = fixStgRegExpr platform src - baseAddr = get_GlobalReg_addr platform reg + let src' = fixStgRegExpr dflags src + baseAddr = get_GlobalReg_addr dflags reg in case reg `elem` activeStgRegs platform of True -> CmmAssign (CmmGlobal reg) src' False -> CmmStore baseAddr src' CmmAssign reg src -> - let src' = fixStgRegExpr platform src + let src' = fixStgRegExpr dflags src in CmmAssign reg src' - CmmStore addr src -> CmmStore (fixStgRegExpr platform addr) (fixStgRegExpr platform src) + CmmStore addr src -> CmmStore (fixStgRegExpr dflags addr) (fixStgRegExpr dflags src) CmmCall target regs args returns -> let target' = case target of - CmmCallee e conv -> CmmCallee (fixStgRegExpr platform e) conv + CmmCallee e conv -> CmmCallee (fixStgRegExpr dflags e) conv CmmPrim op mStmts -> - CmmPrim op (fmap (map (fixStgRegStmt platform)) mStmts) + CmmPrim op (fmap (map (fixStgRegStmt dflags)) mStmts) args' = map (\(CmmHinted arg hint) -> - (CmmHinted (fixStgRegExpr platform arg) hint)) args + (CmmHinted (fixStgRegExpr dflags arg) hint)) args in CmmCall target' regs args' returns - CmmCondBranch test dest -> CmmCondBranch (fixStgRegExpr platform test) dest + CmmCondBranch test dest -> CmmCondBranch (fixStgRegExpr dflags test) dest - CmmSwitch expr ids -> CmmSwitch (fixStgRegExpr platform expr) ids + CmmSwitch expr ids -> CmmSwitch (fixStgRegExpr dflags expr) ids - CmmJump addr live -> CmmJump (fixStgRegExpr platform addr) live + CmmJump addr live -> CmmJump (fixStgRegExpr dflags addr) live -- CmmNop, CmmComment, CmmBranch, CmmReturn _other -> stmt + where platform = targetPlatform dflags -fixStgRegExpr :: Platform -> CmmExpr -> CmmExpr -fixStgRegExpr platform expr +fixStgRegExpr :: DynFlags -> CmmExpr -> CmmExpr +fixStgRegExpr dflags expr = case expr of - CmmLoad addr ty -> CmmLoad (fixStgRegExpr platform addr) ty + CmmLoad addr ty -> CmmLoad (fixStgRegExpr dflags addr) ty CmmMachOp mop args -> CmmMachOp mop args' - where args' = map (fixStgRegExpr platform) args + where args' = map (fixStgRegExpr dflags) args CmmReg (CmmGlobal reg) -> -- Replace register leaves with appropriate StixTrees for @@ -895,11 +907,11 @@ fixStgRegExpr platform expr case reg `elem` activeStgRegs platform of True -> expr False -> - let baseAddr = get_GlobalReg_addr platform reg + let baseAddr = get_GlobalReg_addr dflags reg in case reg of - BaseReg -> fixStgRegExpr platform baseAddr - _other -> fixStgRegExpr platform - (CmmLoad baseAddr (globalRegType reg)) + BaseReg -> fixStgRegExpr dflags baseAddr + _other -> fixStgRegExpr dflags + (CmmLoad baseAddr (globalRegType dflags reg)) CmmRegOff (CmmGlobal reg) offset -> -- RegOf leaves are just a shorthand form. If the reg maps @@ -907,11 +919,12 @@ fixStgRegExpr platform expr -- expand it and defer to the above code. case reg `elem` activeStgRegs platform of True -> expr - False -> fixStgRegExpr platform (CmmMachOp (MO_Add wordWidth) [ + False -> fixStgRegExpr dflags (CmmMachOp (MO_Add (wordWidth dflags)) [ CmmReg (CmmGlobal reg), CmmLit (CmmInt (fromIntegral offset) - wordWidth)]) + (wordWidth dflags))]) -- CmmLit, CmmReg (CmmLocal), CmmStackSlot _other -> expr + where platform = targetPlatform dflags diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs index d3db24ce4c..7a72a00602 100644 --- a/compiler/codeGen/ClosureInfo.lhs +++ b/compiler/codeGen/ClosureInfo.lhs @@ -265,13 +265,13 @@ instance Outputable CgRep where ppr FloatArg = ptext (sLit "F_") ppr DoubleArg = ptext (sLit "D_") -argMachRep :: CgRep -> CmmType -argMachRep PtrArg = gcWord -argMachRep NonPtrArg = bWord -argMachRep LongArg = b64 -argMachRep FloatArg = f32 -argMachRep DoubleArg = f64 -argMachRep VoidArg = panic "argMachRep:VoidRep" +argMachRep :: DynFlags -> CgRep -> CmmType +argMachRep dflags PtrArg = gcWord dflags +argMachRep dflags NonPtrArg = bWord dflags +argMachRep _ LongArg = b64 +argMachRep _ FloatArg = f32 +argMachRep _ DoubleArg = f64 +argMachRep _ VoidArg = panic "argMachRep:VoidRep" primRepToCgRep :: PrimRep -> CgRep primRepToCgRep VoidRep = VoidArg @@ -342,17 +342,17 @@ separateByPtrFollowness things \end{code} \begin{code} -cgRepSizeB :: CgRep -> ByteOff -cgRepSizeB DoubleArg = dOUBLE_SIZE -cgRepSizeB LongArg = wORD64_SIZE -cgRepSizeB VoidArg = 0 -cgRepSizeB _ = wORD_SIZE - -cgRepSizeW :: CgRep -> ByteOff -cgRepSizeW DoubleArg = dOUBLE_SIZE `quot` wORD_SIZE -cgRepSizeW LongArg = wORD64_SIZE `quot` wORD_SIZE -cgRepSizeW VoidArg = 0 -cgRepSizeW _ = 1 +cgRepSizeB :: DynFlags -> CgRep -> ByteOff +cgRepSizeB dflags DoubleArg = dOUBLE_SIZE dflags +cgRepSizeB _ LongArg = wORD64_SIZE +cgRepSizeB _ VoidArg = 0 +cgRepSizeB dflags _ = wORD_SIZE dflags + +cgRepSizeW :: DynFlags -> CgRep -> ByteOff +cgRepSizeW dflags DoubleArg = dOUBLE_SIZE dflags `quot` wORD_SIZE dflags +cgRepSizeW dflags LongArg = wORD64_SIZE `quot` wORD_SIZE dflags +cgRepSizeW _ VoidArg = 0 +cgRepSizeW _ _ = 1 retAddrSizeW :: WordOff retAddrSizeW = 1 -- One word @@ -689,7 +689,7 @@ getCallMethod _dflags _name _caf (LFThunk _ _ _updatable _std_form_info is_fun) -- So the right thing to do is just to enter the thing -- Old version: --- | updatable || doingTickyProfiling dflags -- to catch double entry +-- | updatable || dopt Opt_Ticky dflags -- to catch double entry -- = EnterIt -- | otherwise -- Jump direct to code for single-entry thunks -- = JumpToIt (thunkEntryLabel name caf std_form_info updatable) @@ -927,25 +927,27 @@ lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr) lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc) lfFunInfo _ = Nothing -funTag :: ClosureInfo -> Int -funTag (ClosureInfo { closureLFInfo = lf_info }) = funTagLFInfo lf_info -funTag _ = 0 +funTag :: DynFlags -> ClosureInfo -> Int +funTag dflags (ClosureInfo { closureLFInfo = lf_info }) + = funTagLFInfo dflags lf_info +funTag _ _ = 0 -- maybe this should do constructor tags too? -funTagLFInfo :: LambdaFormInfo -> Int -funTagLFInfo lf +funTagLFInfo :: DynFlags -> LambdaFormInfo -> Int +funTagLFInfo dflags lf -- A function is tagged with its arity | Just (arity,_) <- lfFunInfo lf, - Just tag <- tagForArity arity + Just tag <- tagForArity dflags arity = tag -- other closures (and unknown ones) are not tagged | otherwise = 0 -tagForArity :: RepArity -> Maybe Int -tagForArity i | i <= mAX_PTR_TAG = Just i - | otherwise = Nothing +tagForArity :: DynFlags -> RepArity -> Maybe Int +tagForArity dflags i + | i <= mAX_PTR_TAG dflags = Just i + | otherwise = Nothing clHasCafRefs :: ClosureInfo -> CafInfo clHasCafRefs (ClosureInfo {closureSRT = srt}) = diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs index 29193137a7..311f947248 100644 --- a/compiler/codeGen/CodeGen.lhs +++ b/compiler/codeGen/CodeGen.lhs @@ -35,7 +35,6 @@ import OldPprCmm () import StgSyn import PrelNames import DynFlags -import StaticFlags import HscTypes import CostCentre @@ -101,7 +100,7 @@ mkModuleInit mkModuleInit dflags cost_centre_info this_mod hpc_info = do { -- Allocate the static boolean that records if this - ; whenC (opt_Hpc) $ + ; whenC (dopt Opt_Hpc dflags) $ hpcTable this_mod hpc_info ; whenC (dopt Opt_SccProfilingOn dflags) $ do diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index b8ed1aa939..f1022e5280 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -143,7 +143,6 @@ cgTopRhs bndr (StgRhsCon _cc con args) cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag _srt args body) = ASSERT(null fvs) -- There should be no free variables - setSRTLabel (mkSRTLabel (idName bndr) (idCafInfo bndr)) $ forkStatics (cgTopRhsClosure bndr cc bi upd_flag args body) @@ -206,9 +205,10 @@ mkModuleInit cost_centre_info this_mod hpc_info cgEnumerationTyCon :: TyCon -> FCode () cgEnumerationTyCon tycon - = emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs) + = do dflags <- getDynFlags + emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs) [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs) - (tagForCon con) + (tagForCon dflags con) | con <- tyConDataCons tycon] @@ -236,8 +236,8 @@ cgDataCon data_con do { _ <- ticky_code ; ldvEnter (CmmReg nodeReg) ; tickyReturnOldCon (length arg_things) - ; void $ emitReturn [cmmOffsetB (CmmReg nodeReg) - (tagForCon data_con)] + ; void $ emitReturn [cmmOffsetB dflags (CmmReg nodeReg) + (tagForCon dflags data_con)] } -- The case continuation code expects a tagged pointer diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 0f0bfb8467..02d3d0246f 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -43,7 +43,6 @@ import Module import ListSetOps import Util import BasicTypes -import Constants import Outputable import FastString import Maybes @@ -65,9 +64,10 @@ cgTopRhsClosure :: Id -> FCode (CgIdInfo, FCode ()) cgTopRhsClosure id ccs _ upd_flag args body - = do { lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args + = do { dflags <- getDynFlags + ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args ; let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id) - cg_id_info = litIdInfo id lf_info (CmmLabel closure_label) + cg_id_info = litIdInfo dflags id lf_info (CmmLabel closure_label) ; return (cg_id_info, gen_code lf_info closure_label) } where @@ -242,7 +242,7 @@ mkRhsClosure dflags bndr _cc _bi (StgApp selectee [{-no args-}]))]) | the_fv == scrutinee -- Scrutinee is the only free variable && maybeToBool maybe_offset -- Selectee is a component of the tuple - && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough + && offset_into_int <= mAX_SPEC_SELECTEE_SIZE dflags -- Offset is small enough = -- NOT TRUE: ASSERT(is_single_constructor) -- The simplifier may have statically determined that the single alternative -- is the only possible case and eliminated the others, even if there are @@ -271,7 +271,7 @@ mkRhsClosure dflags bndr _cc _bi | args `lengthIs` (arity-1) && all (isGcPtrRep . idPrimRep . stripNV) fvs && isUpdatable upd_flag - && arity <= mAX_SPEC_AP_SIZE + && arity <= mAX_SPEC_AP_SIZE dflags && not (dopt Opt_SccProfilingOn dflags) -- not when profiling: we don't want to -- lose information about this particular @@ -340,7 +340,7 @@ mkRhsClosure _ bndr cc _ fvs upd_flag args body (map toVarArg fv_details) -- RETURN - ; return (mkRhsInit reg lf_info hp_plus_n) } + ; return (mkRhsInit dflags reg lf_info hp_plus_n) } -- Use with care; if used inappropriately, it could break invariants. @@ -381,7 +381,7 @@ cgRhsStdThunk bndr lf_info payload use_cc blame_cc payload_w_offsets -- RETURN - ; return (mkRhsInit reg lf_info hp_plus_n) } + ; return (mkRhsInit dflags reg lf_info hp_plus_n) } mkClosureLFInfo :: Id -- The binder @@ -457,9 +457,9 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details node' = if node_points then Just node else Nothing ; tickyEnterFun cl_info ; enterCostCentreFun cc - (CmmMachOp mo_wordSub + (CmmMachOp (mo_wordSub dflags) [ CmmReg nodeReg - , CmmLit (mkIntCLit (funTag cl_info)) ]) + , mkIntExpr dflags (funTag dflags cl_info) ]) ; whenC node_points (ldvEnterClosure cl_info) ; granYield arg_regs node_points @@ -481,8 +481,9 @@ bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) } load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, WordOff)] -> FCode () load_fvs node lf_info = mapM_ (\ (reg, off) -> - emit $ mkTaggedObjectLoad reg node off tag) - where tag = lfDynTag lf_info + do dflags <- getDynFlags + let tag = lfDynTag dflags lf_info + emit $ mkTaggedObjectLoad dflags reg node off tag) ----------------------------------------- -- The "slow entry" code for a function. This entry point takes its @@ -506,7 +507,7 @@ mkSlowEntryCode cl_info arg_regs -- function closure is already in `Node' jump = mkDirectJump dflags (mkLblExpr fast_lbl) (map (CmmReg . CmmLocal) arg_regs) - initUpdFrameOff + (initUpdFrameOff dflags) emitProcWithConvention Slow Nothing slow_lbl arg_regs jump | otherwise = return () @@ -580,7 +581,7 @@ emitBlackHoleCode is_single_entry = do whenC eager_blackholing $ do tickyBlackHole (not is_single_entry) - emitStore (cmmOffsetW (CmmReg nodeReg) (fixedHdrSize dflags)) + emitStore (cmmOffsetW dflags (CmmReg nodeReg) (fixedHdrSize dflags)) (CmmReg (CmmGlobal CurrentTSO)) emitPrimCall [] MO_WriteBarrier [] emitStore (CmmReg nodeReg) (CmmReg (CmmGlobal EagerBlackholeInfo)) @@ -632,9 +633,9 @@ pushUpdateFrame lbl updatee body updfr <- getUpdFrameOff dflags <- getDynFlags let - hdr = fixedHdrSize dflags * wORD_SIZE - frame = updfr + hdr + sIZEOF_StgUpdateFrame_NoHdr - off_updatee = hdr + oFFSET_StgUpdateFrame_updatee + hdr = fixedHdrSize dflags * wORD_SIZE dflags + frame = updfr + hdr + sIZEOF_StgUpdateFrame_NoHdr dflags + off_updatee = hdr + oFFSET_StgUpdateFrame_updatee dflags -- emitStore (CmmStackSlot Old frame) (mkLblExpr lbl) emitStore (CmmStackSlot Old (frame - off_updatee)) updatee @@ -686,7 +687,7 @@ link_caf :: LocalReg -- pointer to the closure link_caf node _is_upd = do { dflags <- getDynFlags -- Alloc black hole specifying CC_HDR(Node) as the cost centre - ; let use_cc = costCentreFrom (CmmReg nodeReg) + ; let use_cc = costCentreFrom dflags (CmmReg nodeReg) blame_cc = use_cc tso = CmmReg (CmmGlobal CurrentTSO) @@ -703,7 +704,7 @@ link_caf node _is_upd = do -- so that the garbage collector can find them -- This must be done *before* the info table pointer is overwritten, -- because the old info table ptr is needed for reversion - ; ret <- newTemp bWord + ; ret <- newTemp (bWord dflags) ; emitRtsCallGen [(ret,NoHint)] rtsPackageId (fsLit "newCAF") [ (CmmReg (CmmGlobal BaseReg), AddrHint), (CmmReg (CmmLocal node), AddrHint), @@ -714,11 +715,11 @@ link_caf node _is_upd = do -- see Note [atomic CAF entry] in rts/sm/Storage.c ; updfr <- getUpdFrameOff ; emit =<< mkCmmIfThen - (CmmMachOp mo_wordEq [ CmmReg (CmmLocal ret), CmmLit zeroCLit]) + (CmmMachOp (mo_wordEq dflags) [ CmmReg (CmmLocal ret), CmmLit (zeroCLit dflags)]) -- re-enter R1. Doing this directly is slightly dodgy; we're -- assuming lots of things, like the stack pointer hasn't -- moved since we entered the CAF. - (let target = entryCode dflags (closureInfoPtr (CmmReg (CmmLocal node))) in + (let target = entryCode dflags (closureInfoPtr dflags (CmmReg (CmmLocal node))) in mkJump dflags target [] updfr) ; return hp_rel } diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index 2afcb6a8c7..85346da205 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -86,7 +86,6 @@ import TcType import TyCon import BasicTypes import Outputable -import Constants import DynFlags import Util @@ -299,32 +298,33 @@ Big families only use the tag value 1 to represent evaluatedness. We don't have very many tag bits: for example, we have 2 bits on x86-32 and 3 bits on x86-64. -} -isSmallFamily :: Int -> Bool -isSmallFamily fam_size = fam_size <= mAX_PTR_TAG +isSmallFamily :: DynFlags -> Int -> Bool +isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags -- We keep the *zero-indexed* tag in the srt_len field of the info -- table of a data constructor. dataConTagZ :: DataCon -> ConTagZ dataConTagZ con = dataConTag con - fIRST_TAG -tagForCon :: DataCon -> DynTag -tagForCon con - | isSmallFamily fam_size = con_tag + 1 - | otherwise = 1 +tagForCon :: DynFlags -> DataCon -> DynTag +tagForCon dflags con + | isSmallFamily dflags fam_size = con_tag + 1 + | otherwise = 1 where con_tag = dataConTagZ con fam_size = tyConFamilySize (dataConTyCon con) -tagForArity :: RepArity -> DynTag -tagForArity arity | isSmallFamily arity = arity - | otherwise = 0 +tagForArity :: DynFlags -> RepArity -> DynTag +tagForArity dflags arity + | isSmallFamily dflags arity = arity + | otherwise = 0 -lfDynTag :: LambdaFormInfo -> DynTag +lfDynTag :: DynFlags -> LambdaFormInfo -> DynTag -- Return the tag in the low order bits of a variable bound -- to this LambdaForm -lfDynTag (LFCon con) = tagForCon con -lfDynTag (LFReEntrant _ arity _ _) = tagForArity arity -lfDynTag _other = 0 +lfDynTag dflags (LFCon con) = tagForCon dflags con +lfDynTag dflags (LFReEntrant _ arity _ _) = tagForArity dflags arity +lfDynTag _ _other = 0 ----------------------------------------------------------------------------- @@ -498,7 +498,7 @@ getCallMethod dflags name caf (LFThunk _ _ updatable std_form_info is_fun) n_arg -- is the fast-entry code] -- Since is_fun is False, we are *definitely* looking at a data value - | updatable || doingTickyProfiling dflags -- to catch double entry + | updatable || dopt Opt_Ticky dflags -- to catch double entry {- OLD: || opt_SMP I decided to remove this, because in SMP mode it doesn't matter if we enter the same thunk multiple times, so the optimisation @@ -755,8 +755,9 @@ lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr) lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc) lfFunInfo _ = Nothing -funTag :: ClosureInfo -> DynTag -funTag (ClosureInfo { closureLFInfo = lf_info }) = lfDynTag lf_info +funTag :: DynFlags -> ClosureInfo -> DynTag +funTag dflags (ClosureInfo { closureLFInfo = lf_info }) + = lfDynTag dflags lf_info isToplevClosure :: ClosureInfo -> Bool isToplevClosure (ClosureInfo { closureLFInfo = lf_info }) diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index 083e615b78..c822a64e2c 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -31,7 +31,6 @@ import MkGraph import SMRep import CostCentre import Module -import Constants import DataCon import DynFlags import FastString @@ -56,14 +55,14 @@ cgTopRhsCon :: Id -- Name of thing bound to this RHS -> [StgArg] -- Args -> FCode (CgIdInfo, FCode ()) cgTopRhsCon id con args - = return ( id_info, gen_code ) + = do dflags <- getDynFlags + let id_info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label) + return ( id_info, gen_code ) where name = idName id caffy = idCafInfo id -- any stgArgHasCafRefs args closure_label = mkClosureLabel name caffy - id_info = litIdInfo id (mkConLFInfo con) (CmmLabel closure_label) - gen_code = do { dflags <- getDynFlags ; when (platformOS (targetPlatform dflags) == OSMinGW32) $ @@ -149,8 +148,8 @@ premature looking at the args will cause the compiler to black-hole! -- which have exclusively size-zero (VoidRep) args, we generate no code -- at all. -buildDynCon' _ _ binder _cc con [] - = return (litIdInfo binder (mkConLFInfo con) +buildDynCon' dflags _ binder _cc con [] + = return (litIdInfo dflags binder (mkConLFInfo con) (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))), return mkNop) @@ -184,14 +183,14 @@ buildDynCon' dflags platform binder _cc con [arg] | maybeIntLikeCon con , platformOS platform /= OSMinGW32 || not (dopt Opt_PIC dflags) , StgLitArg (MachInt val) <- arg - , val <= fromIntegral mAX_INTLIKE -- Comparisons at type Integer! - , val >= fromIntegral mIN_INTLIKE -- ...ditto... + , val <= fromIntegral (mAX_INTLIKE dflags) -- Comparisons at type Integer! + , val >= fromIntegral (mIN_INTLIKE dflags) -- ...ditto... = do { let intlike_lbl = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_INTLIKE_closure") val_int = fromIntegral val :: Int - offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize dflags + 1) + offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSize dflags + 1) -- INTLIKE closures consist of a header and one word payload - intlike_amode = cmmLabelOffW intlike_lbl offsetW - ; return ( litIdInfo binder (mkConLFInfo con) intlike_amode + intlike_amode = cmmLabelOffW dflags intlike_lbl offsetW + ; return ( litIdInfo dflags binder (mkConLFInfo con) intlike_amode , return mkNop) } buildDynCon' dflags platform binder _cc con [arg] @@ -199,13 +198,13 @@ buildDynCon' dflags platform binder _cc con [arg] , platformOS platform /= OSMinGW32 || not (dopt Opt_PIC dflags) , StgLitArg (MachChar val) <- arg , let val_int = ord val :: Int - , val_int <= mAX_CHARLIKE - , val_int >= mIN_CHARLIKE + , val_int <= mAX_CHARLIKE dflags + , val_int >= mIN_CHARLIKE dflags = do { let charlike_lbl = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_CHARLIKE_closure") - offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize dflags + 1) + offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSize dflags + 1) -- CHARLIKE closures consist of a header and one word payload - charlike_amode = cmmLabelOffW charlike_lbl offsetW - ; return ( litIdInfo binder (mkConLFInfo con) charlike_amode + charlike_amode = cmmLabelOffW dflags charlike_lbl offsetW + ; return ( litIdInfo dflags binder (mkConLFInfo con) charlike_amode , return mkNop) } -------- buildDynCon': the general case ----------- @@ -225,7 +224,7 @@ buildDynCon' dflags _ binder ccs con args ptr_wds nonptr_wds ; hp_plus_n <- allocDynClosure info_tbl lf_info use_cc blame_cc args_w_offsets - ; return (mkRhsInit reg lf_info hp_plus_n) } + ; return (mkRhsInit dflags reg lf_info hp_plus_n) } where use_cc -- cost-centre to stick in the object | isCurrentCCS ccs = curCCS @@ -247,16 +246,15 @@ bindConArgs (DataAlt con) base args = ASSERT(not (isUnboxedTupleCon con)) do dflags <- getDynFlags let (_, _, args_w_offsets) = mkVirtConstrOffsets dflags (addIdReps args) + tag = tagForCon dflags con + + -- The binding below forces the masking out of the tag bits + -- when accessing the constructor field. + bind_arg :: (NonVoid Id, VirtualHpOffset) -> FCode LocalReg + bind_arg (arg, offset) + = do emit $ mkTaggedObjectLoad dflags (idToReg dflags arg) base offset tag + bindArgToReg arg mapM bind_arg args_w_offsets - where - tag = tagForCon con - - -- The binding below forces the masking out of the tag bits - -- when accessing the constructor field. - bind_arg :: (NonVoid Id, VirtualHpOffset) -> FCode LocalReg - bind_arg (arg, offset) - = do { emit $ mkTaggedObjectLoad (idToReg arg) base offset tag - ; bindArgToReg arg } bindConArgs _other_con _base args = ASSERT( null args ) return [] diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs index 9f1f161d37..5106b971b1 100644 --- a/compiler/codeGen/StgCmmEnv.hs +++ b/compiler/codeGen/StgCmmEnv.hs @@ -41,6 +41,7 @@ import StgCmmClosure import CLabel +import DynFlags import MkGraph import BlockId import CmmExpr @@ -75,25 +76,25 @@ nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidRep (idPrimRep id))] -- Manipulating CgIdInfo ------------------------------------- -mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo -mkCgIdInfo id lf expr +mkCgIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo +mkCgIdInfo dflags id lf expr = CgIdInfo { cg_id = id, cg_lf = lf , cg_loc = CmmLoc expr, - cg_tag = lfDynTag lf } + cg_tag = lfDynTag dflags lf } -litIdInfo :: Id -> LambdaFormInfo -> CmmLit -> CgIdInfo -litIdInfo id lf lit +litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo +litIdInfo dflags id lf lit = CgIdInfo { cg_id = id, cg_lf = lf - , cg_loc = CmmLoc (addDynTag (CmmLit lit) tag) + , cg_loc = CmmLoc (addDynTag dflags (CmmLit lit) tag) , cg_tag = tag } where - tag = lfDynTag lf + tag = lfDynTag dflags lf -lneIdInfo :: Id -> [NonVoid Id] -> CgIdInfo -lneIdInfo id regs +lneIdInfo :: DynFlags -> Id -> [NonVoid Id] -> CgIdInfo +lneIdInfo dflags id regs = CgIdInfo { cg_id = id, cg_lf = lf - , cg_loc = LneLoc blk_id (map idToReg regs) - , cg_tag = lfDynTag lf } + , cg_loc = LneLoc blk_id (map (idToReg dflags) regs) + , cg_tag = lfDynTag dflags lf } where lf = mkLFLetNoEscape blk_id = mkBlockId (idUnique id) @@ -101,12 +102,13 @@ lneIdInfo id regs rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg) rhsIdInfo id lf_info - = do { reg <- newTemp gcWord - ; return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg) } + = do dflags <- getDynFlags + reg <- newTemp (gcWord dflags) + return (mkCgIdInfo dflags id lf_info (CmmReg (CmmLocal reg)), reg) -mkRhsInit :: LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph -mkRhsInit reg lf_info expr - = mkAssign (CmmLocal reg) (addDynTag expr (lfDynTag lf_info)) +mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph +mkRhsInit dflags reg lf_info expr + = mkAssign (CmmLocal reg) (addDynTag dflags expr (lfDynTag dflags lf_info)) idInfoToAmode :: CgIdInfo -> CmmExpr -- Returns a CmmExpr for the *tagged* pointer @@ -114,9 +116,9 @@ idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e idInfoToAmode cg_info = pprPanic "idInfoToAmode" (ppr (cg_id cg_info)) -- LneLoc -addDynTag :: CmmExpr -> DynTag -> CmmExpr +addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr -- A tag adds a byte offset to the pointer -addDynTag expr tag = cmmOffsetB expr tag +addDynTag dflags expr tag = cmmOffsetB dflags expr tag cgIdInfoId :: CgIdInfo -> Id cgIdInfoId = cg_id @@ -170,7 +172,8 @@ getCgIdInfo id in if isExternalName name then do let ext_lbl = CmmLabel (mkClosureLabel name $ idCafInfo id) - return (litIdInfo id (mkLFImported id) ext_lbl) + dflags <- getDynFlags + return (litIdInfo dflags id (mkLFImported id) ext_lbl) else -- Bug cgLookupPanic id @@ -180,15 +183,13 @@ cgLookupPanic :: Id -> FCode a cgLookupPanic id = do static_binds <- getStaticBinds local_binds <- getBinds - srt <- getSRTLabel - pprPanic "StgCmmEnv: variable not found" + pprPanic "StgCmmEnv: variable not found" (vcat [ppr id, ptext (sLit "static binds for:"), vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ], ptext (sLit "local binds for:"), - vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ], - ptext (sLit "SRT label") <+> ppr srt - ]) + vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ] + ]) -------------------- @@ -214,9 +215,10 @@ getNonVoidArgAmodes (arg:args) bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg -- Bind an Id to a fresh LocalReg bindToReg nvid@(NonVoid id) lf_info - = do { let reg = idToReg nvid - ; addBindC id (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg))) - ; return reg } + = do dflags <- getDynFlags + let reg = idToReg dflags nvid + addBindC id (mkCgIdInfo dflags id lf_info (CmmReg (CmmLocal reg))) + return reg rebindToReg :: NonVoid Id -> FCode LocalReg -- Like bindToReg, but the Id is already in scope, so @@ -231,7 +233,7 @@ bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id) bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg] bindArgsToRegs args = mapM bindArgToReg args -idToReg :: NonVoid Id -> LocalReg +idToReg :: DynFlags -> NonVoid Id -> LocalReg -- Make a register from an Id, typically a function argument, -- free variable, or case binder -- @@ -239,8 +241,9 @@ idToReg :: NonVoid Id -> LocalReg -- -- By now the Ids should be uniquely named; else one would worry -- about accidental collision -idToReg (NonVoid id) = LocalReg (idUnique id) +idToReg dflags (NonVoid id) + = LocalReg (idUnique id) (case idPrimRep id of VoidRep -> pprPanic "idToReg" (ppr id) - _ -> primRepCmmType (idPrimRep id)) + _ -> primRepCmmType dflags (idPrimRep id)) diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index ab6f888835..307d3715b3 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -61,7 +61,9 @@ cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = cgExpr (StgOpApp op args ty) = cgOpApp op args ty cgExpr (StgConApp con args) = cgConApp con args cgExpr (StgSCC cc tick push expr) = do { emitSetCCC cc tick push; cgExpr expr } -cgExpr (StgTick m n expr) = do { emit (mkTickBox m n); cgExpr expr } +cgExpr (StgTick m n expr) = do dflags <- getDynFlags + emit (mkTickBox dflags m n) + cgExpr expr cgExpr (StgLit lit) = do cmm_lit <- cgLit lit emitReturn [CmmLit cmm_lit] @@ -154,8 +156,9 @@ cgLetNoEscapeClosure -> FCode (CgIdInfo, FCode ()) cgLetNoEscapeClosure bndr cc_slot _unused_cc args body - = return ( lneIdInfo bndr args - , code ) + = do dflags <- getDynFlags + return ( lneIdInfo dflags bndr args + , code ) where code = forkProc $ do { restoreCurrentCostCentre cc_slot @@ -289,9 +292,10 @@ cgCase (StgOpApp (StgPrimOp op) args _) bndr (AlgAlt tycon) alts -- If the binder is not dead, convert the tag to a constructor -- and assign it. ; when (not (isDeadBinder bndr)) $ do - { tmp_reg <- bindArgToReg (NonVoid bndr) + { dflags <- getDynFlags + ; tmp_reg <- bindArgToReg (NonVoid bndr) ; emitAssign (CmmLocal tmp_reg) - (tagToClosure tycon tag_expr) } + (tagToClosure dflags tycon tag_expr) } ; (mb_deflt, branches) <- cgAlgAltRhss (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alts @@ -303,7 +307,8 @@ cgCase (StgOpApp (StgPrimOp op) args _) bndr (AlgAlt tycon) alts do_enum_primop TagToEnumOp [arg] -- No code! = getArgAmode (NonVoid arg) do_enum_primop primop args - = do tmp <- newTemp bWord + = do dflags <- getDynFlags + tmp <- newTemp (bWord dflags) cgPrimOp [tmp] primop args return (CmmReg (CmmLocal tmp)) @@ -362,10 +367,11 @@ cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts | isUnLiftedType (idType v) || reps_compatible = -- assignment suffices for unlifted types - do { when (not reps_compatible) $ + do { dflags <- getDynFlags + ; when (not reps_compatible) $ panic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?" ; v_info <- getCgIdInfo v - ; emitAssign (CmmLocal (idToReg (NonVoid bndr))) (idInfoToAmode v_info) + ; emitAssign (CmmLocal (idToReg dflags (NonVoid bndr))) (idInfoToAmode v_info) ; _ <- bindArgsToRegs [NonVoid bndr] ; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type alts } where @@ -373,8 +379,9 @@ cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts cgCase scrut@(StgApp v []) _ (PrimAlt _) _ = -- fail at run-time, not compile-time - do { mb_cc <- maybeSaveCostCentre True - ; _ <- withSequel (AssignTo [idToReg (NonVoid v)] False) (cgExpr scrut) + do { dflags <- getDynFlags + ; mb_cc <- maybeSaveCostCentre True + ; _ <- withSequel (AssignTo [idToReg dflags (NonVoid v)] False) (cgExpr scrut) ; restoreCurrentCostCentre mb_cc ; emitComment $ mkFastString "should be unreachable code" ; l <- newLabelC @@ -401,9 +408,10 @@ cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts cgCase scrut bndr alt_type alts = -- the general case - do { up_hp_usg <- getVirtHp -- Upstream heap usage + do { dflags <- getDynFlags + ; up_hp_usg <- getVirtHp -- Upstream heap usage ; let ret_bndrs = chooseReturnBndrs bndr alt_type alts - alt_regs = map idToReg ret_bndrs + alt_regs = map (idToReg dflags) ret_bndrs simple_scrut = isSimpleScrut scrut alt_type do_gc | not simple_scrut = True | isSingleton alts = False @@ -481,9 +489,11 @@ cgAlts gc_plan _bndr (UbxTupAlt _) [(_, _, _, rhs)] -- Here bndrs are *already* in scope, so don't rebind them cgAlts gc_plan bndr (PrimAlt _) alts - = do { tagged_cmms <- cgAltRhss gc_plan bndr alts + = do { dflags <- getDynFlags - ; let bndr_reg = CmmLocal (idToReg bndr) + ; tagged_cmms <- cgAltRhss gc_plan bndr alts + + ; let bndr_reg = CmmLocal (idToReg dflags bndr) (DEFAULT,deflt) = head tagged_cmms -- PrimAlts always have a DEFAULT case -- and it always comes first @@ -494,16 +504,18 @@ cgAlts gc_plan bndr (PrimAlt _) alts ; return AssignedDirectly } cgAlts gc_plan bndr (AlgAlt tycon) alts - = do { (mb_deflt, branches) <- cgAlgAltRhss gc_plan bndr alts + = do { dflags <- getDynFlags + + ; (mb_deflt, branches) <- cgAlgAltRhss gc_plan bndr alts ; let fam_sz = tyConFamilySize tycon - bndr_reg = CmmLocal (idToReg bndr) + bndr_reg = CmmLocal (idToReg dflags bndr) -- Is the constructor tag in the node reg? - ; if isSmallFamily fam_sz + ; if isSmallFamily dflags fam_sz then do let -- Yes, bndr_reg has constr. tag in ls bits - tag_expr = cmmConstrTag1 (CmmReg bndr_reg) + tag_expr = cmmConstrTag1 dflags (CmmReg bndr_reg) branches' = [(tag+1,branch) | (tag,branch) <- branches] emitSwitch tag_expr branches' mb_deflt 1 fam_sz return AssignedDirectly @@ -564,10 +576,10 @@ cgAlgAltRhss gc_plan bndr alts ------------------- cgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [StgAlt] -> FCode [(AltCon, CmmAGraph)] -cgAltRhss gc_plan bndr alts - = forkAlts (map cg_alt alts) - where - base_reg = idToReg bndr +cgAltRhss gc_plan bndr alts = do + dflags <- getDynFlags + let + base_reg = idToReg dflags bndr cg_alt :: StgAlt -> FCode (AltCon, CmmAGraph) cg_alt (con, bndrs, _uses, rhs) = getCodeR $ @@ -575,6 +587,7 @@ cgAltRhss gc_plan bndr alts do { _ <- bindConArgs con base_reg bndrs ; _ <- cgExpr rhs ; return con } + forkAlts (map cg_alt alts) maybeAltHeapCheck :: (GcPlan,ReturnKind) -> FCode a -> FCode a maybeAltHeapCheck (NoGcInAlts,_) code = code @@ -611,7 +624,10 @@ cgIdApp fun_id args = do { fun_info <- getCgIdInfo fun_id ; case maybeLetNoEscape fun_info of Just (blk_id, lne_regs) -> cgLneJump blk_id lne_regs args - Nothing -> cgTailCall fun_id fun_info args } + Nothing -> cgTailCall (cg_id fun_info) fun_info args } + -- NB. use (cg_id fun_info) instead of fun_id, because the former + -- may be externalised for -split-objs. + -- See StgCmm.maybeExternaliseId. cgLneJump :: BlockId -> [LocalReg] -> [StgArg] -> FCode ReturnKind cgLneJump blk_id lne_regs args -- Join point; discard sequel @@ -670,9 +686,9 @@ emitEnter fun = do -- Right now, we do what the old codegen did, and omit the tag -- test, just generating an enter. Return _ -> do - { let entry = entryCode dflags $ closureInfoPtr $ CmmReg nodeReg + { let entry = entryCode dflags $ closureInfoPtr dflags $ CmmReg nodeReg ; emit $ mkForeignJump dflags NativeNodeCall entry - [cmmUntag fun] updfr_off + [cmmUntag dflags fun] updfr_off ; return AssignedDirectly } @@ -712,11 +728,11 @@ emitEnter fun = do -- refer to fun via nodeReg after the copyout, to avoid having -- both live simultaneously; this sometimes enables fun to be -- inlined in the RHS of the R1 assignment. - ; let entry = entryCode dflags (closureInfoPtr (CmmReg nodeReg)) + ; let entry = entryCode dflags (closureInfoPtr dflags (CmmReg nodeReg)) the_call = toCall entry (Just lret) updfr_off off outArgs regs ; emit $ copyout <*> - mkCbranch (cmmIsTagged (CmmReg nodeReg)) lret lcall <*> + mkCbranch (cmmIsTagged dflags (CmmReg nodeReg)) lret lcall <*> outOfLine lcall the_call <*> mkLabel lret <*> copyin diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index 5a717bbc65..9e4db9cdaa 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -34,7 +34,6 @@ import TysPrim import CLabel import SMRep import ForeignCall -import Constants import DynFlags import Maybes import Outputable @@ -55,7 +54,19 @@ cgForeignCall :: ForeignCall -- the op -> FCode ReturnKind cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty - = do { cmm_args <- getFCallArgs stg_args + = 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 + -- attach this info to the CLabel here, and the CLabel pretty printer + -- will generate the suffix when the label is printed. + call_size args + | StdCallConv <- cconv = Just (sum (map arg_size args)) + | otherwise = Nothing + + -- ToDo: this might not be correct for 64-bit API + arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType dflags arg) + (wORD_SIZE dflags) + ; cmm_args <- getFCallArgs stg_args ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty ; let ((call_args, arg_hints), cmm_target) = case target of @@ -98,18 +109,6 @@ cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty ; emitReturn (map (CmmReg . CmmLocal) res_regs) } } - where - -- in the stdcall calling convention, the symbol needs @size appended - -- to it, where size is the total number of bytes of arguments. We - -- attach this info to the CLabel here, and the CLabel pretty printer - -- will generate the suffix when the label is printed. - call_size args - | StdCallConv <- cconv = Just (sum (map arg_size args)) - | otherwise = Nothing - - -- ToDo: this might not be correct for 64-bit API - arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType arg) - wORD_SIZE {- Note [safe foreign call convention] @@ -222,7 +221,7 @@ emitForeignCall safety results target args _ret let (off, copyout) = copyInOflow dflags NativeReturn (Young k) results -- see Note [safe foreign call convention] emit $ - ( mkStore (CmmStackSlot (Young k) (widthInBytes wordWidth)) + ( mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth dflags))) (CmmLit (CmmBlock k)) <*> mkLast (CmmForeignCall { tgt = temp_target , res = results @@ -262,10 +261,11 @@ maybe_assign_temp :: CmmExpr -> FCode CmmExpr maybe_assign_temp e | hasNoGlobalRegs e = return e | otherwise = do + dflags <- getDynFlags -- don't use assignTemp, it uses its own notion of "trivial" -- expressions, which are wrong here. -- this is a NonPtr because it only duplicates an existing - reg <- newTemp (cmmExprType e) --TODO FIXME NOW + reg <- newTemp (cmmExprType dflags e) --TODO FIXME NOW emitAssign (CmmLocal reg) e return (CmmReg (CmmLocal reg)) @@ -278,11 +278,11 @@ maybe_assign_temp e saveThreadState :: DynFlags -> CmmAGraph saveThreadState dflags = -- CurrentTSO->stackobj->sp = Sp; - mkStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO (tso_stackobj dflags)) bWord) (stack_SP dflags)) stgSp - <*> closeNursery + mkStore (cmmOffset dflags (CmmLoad (cmmOffset dflags stgCurrentTSO (tso_stackobj dflags)) (bWord dflags)) (stack_SP dflags)) stgSp + <*> closeNursery dflags -- and save the current cost centre stack in the TSO when profiling: <*> if dopt Opt_SccProfilingOn dflags then - mkStore (cmmOffset stgCurrentTSO (tso_CCCS dflags)) curCCS + mkStore (cmmOffset dflags stgCurrentTSO (tso_CCCS dflags)) curCCS else mkNop emitSaveThreadState :: BlockId -> FCode () @@ -290,78 +290,79 @@ emitSaveThreadState bid = do dflags <- getDynFlags -- CurrentTSO->stackobj->sp = Sp; - emitStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO (tso_stackobj dflags)) bWord) (stack_SP dflags)) - (CmmStackSlot (Young bid) (widthInBytes (typeWidth gcWord))) - emit closeNursery + emitStore (cmmOffset dflags (CmmLoad (cmmOffset dflags stgCurrentTSO (tso_stackobj dflags)) (bWord dflags)) (stack_SP dflags)) + (CmmStackSlot (Young bid) (widthInBytes (typeWidth (gcWord dflags)))) + emit $ closeNursery dflags -- and save the current cost centre stack in the TSO when profiling: when (dopt Opt_SccProfilingOn dflags) $ - emitStore (cmmOffset stgCurrentTSO (tso_CCCS dflags)) curCCS + emitStore (cmmOffset dflags stgCurrentTSO (tso_CCCS dflags)) curCCS -- CurrentNursery->free = Hp+1; -closeNursery :: CmmAGraph -closeNursery = mkStore nursery_bdescr_free (cmmOffsetW stgHp 1) +closeNursery :: DynFlags -> CmmAGraph +closeNursery dflags = mkStore (nursery_bdescr_free dflags) (cmmOffsetW dflags stgHp 1) loadThreadState :: DynFlags -> LocalReg -> LocalReg -> CmmAGraph loadThreadState dflags tso stack = do - -- tso <- newTemp gcWord -- TODO FIXME NOW - -- stack <- newTemp gcWord -- TODO FIXME NOW + -- tso <- newTemp (gcWord dflags) -- TODO FIXME NOW + -- stack <- newTemp (gcWord dflags) -- TODO FIXME NOW catAGraphs [ -- tso = CurrentTSO; mkAssign (CmmLocal tso) stgCurrentTSO, -- stack = tso->stackobj; - mkAssign (CmmLocal stack) (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) bWord), + mkAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)), -- Sp = stack->sp; - mkAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal stack)) (stack_SP dflags)) bWord), + mkAssign sp (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord dflags)), -- SpLim = stack->stack + RESERVED_STACK_WORDS; - mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal stack)) (stack_STACK dflags)) - rESERVED_STACK_WORDS), - openNursery, + mkAssign spLim (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags)) + (rESERVED_STACK_WORDS dflags)), + openNursery dflags, -- and load the current cost centre stack from the TSO when profiling: if dopt Opt_SccProfilingOn dflags then storeCurCCS - (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) ccsType) + (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) (ccsType dflags)) else mkNop] emitLoadThreadState :: LocalReg -> LocalReg -> FCode () emitLoadThreadState tso stack = do dflags <- getDynFlags emit $ loadThreadState dflags tso stack -openNursery :: CmmAGraph -openNursery = catAGraphs [ +openNursery :: DynFlags -> CmmAGraph +openNursery dflags = catAGraphs [ -- Hp = CurrentNursery->free - 1; - mkAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (-1)), + mkAssign hp (cmmOffsetW dflags (CmmLoad (nursery_bdescr_free dflags) (bWord dflags)) (-1)), -- HpLim = CurrentNursery->start + -- CurrentNursery->blocks*BLOCK_SIZE_W - 1; mkAssign hpLim - (cmmOffsetExpr - (CmmLoad nursery_bdescr_start bWord) - (cmmOffset - (CmmMachOp mo_wordMul [ - CmmMachOp (MO_SS_Conv W32 wordWidth) - [CmmLoad nursery_bdescr_blocks b32], - CmmLit (mkIntCLit bLOCK_SIZE) + (cmmOffsetExpr dflags + (CmmLoad (nursery_bdescr_start dflags) (bWord dflags)) + (cmmOffset dflags + (CmmMachOp (mo_wordMul dflags) [ + CmmMachOp (MO_SS_Conv W32 (wordWidth dflags)) + [CmmLoad (nursery_bdescr_blocks dflags) b32], + mkIntExpr dflags (bLOCK_SIZE dflags) ]) (-1) ) ) ] emitOpenNursery :: FCode () -emitOpenNursery = emit openNursery +emitOpenNursery = do dflags <- getDynFlags + emit $ openNursery dflags -nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: CmmExpr -nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free -nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start -nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks +nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: DynFlags -> CmmExpr +nursery_bdescr_free dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_free dflags) +nursery_bdescr_start dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_start dflags) +nursery_bdescr_blocks dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_blocks dflags) tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: DynFlags -> ByteOff -tso_stackobj dflags = closureField dflags oFFSET_StgTSO_stackobj -tso_CCCS dflags = closureField dflags oFFSET_StgTSO_cccs -stack_STACK dflags = closureField dflags oFFSET_StgStack_stack -stack_SP dflags = closureField dflags oFFSET_StgStack_sp +tso_stackobj dflags = closureField dflags (oFFSET_StgTSO_stackobj dflags) +tso_CCCS dflags = closureField dflags (oFFSET_StgTSO_cccs dflags) +stack_STACK dflags = closureField dflags (oFFSET_StgStack_stack dflags) +stack_SP dflags = closureField dflags (oFFSET_StgStack_sp dflags) closureField :: DynFlags -> ByteOff -> ByteOff -closureField dflags off = off + fixedHdrSize dflags * wORD_SIZE +closureField dflags off = off + fixedHdrSize dflags * wORD_SIZE dflags stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr stgSp = CmmReg sp @@ -405,10 +406,10 @@ getFCallArgs args add_shim :: DynFlags -> Type -> CmmExpr -> CmmExpr add_shim dflags arg_ty expr | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon - = cmmOffsetB expr (arrPtrsHdrSize dflags) + = cmmOffsetB dflags expr (arrPtrsHdrSize dflags) | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon - = cmmOffsetB expr (arrWordsHdrSize dflags) + = cmmOffsetB dflags expr (arrWordsHdrSize dflags) | otherwise = expr where diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index 12f3b1347e..fb3739177c 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -44,7 +44,6 @@ import IdInfo( CafInfo(..), mayHaveCafRefs ) import Module import DynFlags import FastString( mkFastString, fsLit ) -import Constants import Util import Control.Monad (when) @@ -140,9 +139,9 @@ emitSetDynHdr base info_ptr ccs hpStore :: CmmExpr -> [CmmExpr] -> [VirtualHpOffset] -> FCode () -- Store the item (expr,off) in base[off] hpStore base vals offs - = emit (catAGraphs (zipWith mk_store vals offs)) - where - mk_store val off = mkStore (cmmOffsetW base off) val + = do dflags <- getDynFlags + let mk_store val off = mkStore (cmmOffsetW dflags base off) val + emit (catAGraphs (zipWith mk_store vals offs)) ----------------------------------------------------------- @@ -181,7 +180,7 @@ mkStaticClosureFields dflags info_tbl ccs caf_refs payload padding | not is_caf = [] - | otherwise = ASSERT(null payload) [mkIntCLit 0] + | otherwise = ASSERT(null payload) [mkIntCLit dflags 0] static_link_field | is_caf || staticClosureNeedsLink (mayHaveCafRefs caf_refs) info_tbl @@ -190,15 +189,15 @@ mkStaticClosureFields dflags info_tbl ccs caf_refs payload = [] saved_info_field - | is_caf = [mkIntCLit 0] + | is_caf = [mkIntCLit dflags 0] | otherwise = [] -- For a static constructor which has NoCafRefs, we set the -- static link field to a non-zero value so the garbage -- collector will ignore it. static_link_value - | mayHaveCafRefs caf_refs = mkIntCLit 0 - | otherwise = mkIntCLit 1 -- No CAF refs + | mayHaveCafRefs caf_refs = mkIntCLit dflags 0 + | otherwise = mkIntCLit dflags 1 -- No CAF refs mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit] @@ -206,7 +205,7 @@ mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit] mkStaticClosure dflags info_lbl ccs payload padding static_link_field saved_info_field = [CmmLabel info_lbl] ++ variable_header_words - ++ concatMap padLitToWord payload + ++ concatMap (padLitToWord dflags) payload ++ padding ++ static_link_field ++ saved_info_field @@ -219,10 +218,10 @@ mkStaticClosure dflags info_lbl ccs payload padding static_link_field saved_info -- JD: Simon had ellided this padding, but without it the C back end asserts -- failure. Maybe it's a bad assertion, and this padding is indeed unnecessary? -padLitToWord :: CmmLit -> [CmmLit] -padLitToWord lit = lit : padding pad_length - where width = typeWidth (cmmLitType lit) - pad_length = wORD_SIZE - widthInBytes width :: Int +padLitToWord :: DynFlags -> CmmLit -> [CmmLit] +padLitToWord dflags lit = lit : padding pad_length + where width = typeWidth (cmmLitType dflags lit) + pad_length = wORD_SIZE dflags - widthInBytes width :: Int padding n | n <= 0 = [] | n `rem` 2 /= 0 = CmmInt 0 W8 : padding (n-1) @@ -401,9 +400,9 @@ entryHeapCheck cl_info nodeSet arity args code W32 -> Just (sLit "stg_gc_f1") W64 -> Just (sLit "stg_gc_d1") _other -> Nothing - | width == wordWidth = Just (mkGcLabel "stg_gc_unbx_r1") - | width == W64 = Just (mkGcLabel "stg_gc_l1") - | otherwise = Nothing + | width == wordWidth dflags = Just (mkGcLabel "stg_gc_unbx_r1") + | width == W64 = Just (mkGcLabel "stg_gc_l1") + | otherwise = Nothing where ty = localRegType reg width = typeWidth ty @@ -437,11 +436,11 @@ entryHeapCheck cl_info nodeSet arity args code -- else we do a normal call to stg_gc_noregs altHeapCheck :: [LocalReg] -> FCode a -> FCode a -altHeapCheck regs code - = case cannedGCEntryPoint regs of +altHeapCheck regs code = do + dflags <- getDynFlags + case cannedGCEntryPoint dflags regs of Nothing -> genericGC code Just gc -> do - dflags <- getDynFlags lret <- newLabelC let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) regs lcont <- newLabelC @@ -451,9 +450,10 @@ altHeapCheck regs code altHeapCheckReturnsTo :: [LocalReg] -> Label -> ByteOff -> FCode a -> FCode a altHeapCheckReturnsTo regs lret off code - = case cannedGCEntryPoint regs of - Nothing -> genericGC code - Just gc -> cannedGCReturnsTo True gc regs lret off code + = do dflags <- getDynFlags + case cannedGCEntryPoint dflags regs of + Nothing -> genericGC code + Just gc -> cannedGCReturnsTo True gc regs lret off code cannedGCReturnsTo :: Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff -> FCode a @@ -478,8 +478,8 @@ genericGC code call <- mkCall generic_gc (GC, GC) [] [] updfr_sz (0,[]) heapCheck False (call <*> mkBranch lretry) code -cannedGCEntryPoint :: [LocalReg] -> Maybe CmmExpr -cannedGCEntryPoint regs +cannedGCEntryPoint :: DynFlags -> [LocalReg] -> Maybe CmmExpr +cannedGCEntryPoint dflags regs = case regs of [] -> Just (mkGcLabel "stg_gc_noregs") [reg] @@ -489,9 +489,9 @@ cannedGCEntryPoint regs W64 -> Just (mkGcLabel "stg_gc_d1") _ -> Nothing - | width == wordWidth -> Just (mkGcLabel "stg_gc_unbx_r1") - | width == W64 -> Just (mkGcLabel "stg_gc_l1") - | otherwise -> Nothing + | width == wordWidth dflags -> Just (mkGcLabel "stg_gc_unbx_r1") + | width == W64 -> Just (mkGcLabel "stg_gc_l1") + | otherwise -> Nothing where ty = localRegType reg width = typeWidth ty @@ -540,9 +540,27 @@ do_checks :: Bool -- Should we check the stack? -> CmmAGraph -- What to do on failure -> FCode () do_checks checkStack alloc do_gc = do + dflags <- getDynFlags + let + alloc_lit = mkIntExpr dflags (alloc * wORD_SIZE dflags) -- Bytes + bump_hp = cmmOffsetExprB dflags (CmmReg hpReg) alloc_lit + + -- Sp overflow if (Sp - CmmHighStack < SpLim) + sp_oflo = CmmMachOp (mo_wordULt dflags) + [CmmMachOp (MO_Sub (typeWidth (cmmRegType dflags spReg))) + [CmmReg spReg, CmmLit CmmHighStackMark], + CmmReg spLimReg] + + -- Hp overflow if (Hp > HpLim) + -- (Hp has been incremented by now) + -- HpLim points to the LAST WORD of valid allocation space. + hp_oflo = CmmMachOp (mo_wordUGt dflags) + [CmmReg hpReg, CmmReg (CmmGlobal HpLim)] + + alloc_n = mkAssign (CmmGlobal HpAlloc) alloc_lit gc_id <- newLabelC - when checkStack $ + when checkStack $ do emit =<< mkCmmIfGoto sp_oflo gc_id when (alloc /= 0) $ do @@ -558,23 +576,6 @@ do_checks checkStack alloc do_gc = do -- stack check succeeds. Otherwise we might end up -- with slop at the end of the current block, which can -- confuse the LDV profiler. - where - alloc_lit = CmmLit (mkIntCLit (alloc*wORD_SIZE)) -- Bytes - bump_hp = cmmOffsetExprB (CmmReg hpReg) alloc_lit - - -- Sp overflow if (Sp - CmmHighStack < SpLim) - sp_oflo = CmmMachOp mo_wordULt - [CmmMachOp (MO_Sub (typeWidth (cmmRegType spReg))) - [CmmReg spReg, CmmLit CmmHighStackMark], - CmmReg spLimReg] - - -- Hp overflow if (Hp > HpLim) - -- (Hp has been incremented by now) - -- HpLim points to the LAST WORD of valid allocation space. - hp_oflo = CmmMachOp mo_wordUGt - [CmmReg hpReg, CmmReg (CmmGlobal HpLim)] - - alloc_n = mkAssign (CmmGlobal HpAlloc) alloc_lit {- diff --git a/compiler/codeGen/StgCmmHpc.hs b/compiler/codeGen/StgCmmHpc.hs index 4465e30b04..cb60e9dd71 100644 --- a/compiler/codeGen/StgCmmHpc.hs +++ b/compiler/codeGen/StgCmmHpc.hs @@ -17,16 +17,16 @@ import Module import CmmUtils import StgCmmUtils import HscTypes -import StaticFlags +import DynFlags -mkTickBox :: Module -> Int -> CmmAGraph -mkTickBox mod n +mkTickBox :: DynFlags -> Module -> Int -> CmmAGraph +mkTickBox dflags mod n = mkStore tick_box (CmmMachOp (MO_Add W64) [ CmmLoad tick_box b64 , CmmLit (CmmInt 1 W64) ]) where - tick_box = cmmIndex W64 + tick_box = cmmIndex dflags W64 (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod) n @@ -35,9 +35,10 @@ initHpc :: Module -> HpcInfo -> FCode () initHpc _ (NoHpcInfo {}) = return () initHpc this_mod (HpcInfo tickCount _hashNo) - = whenC opt_Hpc $ - do { emitDataLits (mkHpcTicksLabel this_mod) - [ (CmmInt 0 W64) - | _ <- take tickCount [0::Int ..] - ] - } + = do dflags <- getDynFlags + whenC (dopt Opt_Hpc dflags) $ + do emitDataLits (mkHpcTicksLabel this_mod) + [ (CmmInt 0 W64) + | _ <- take tickCount [0 :: Int ..] + ] + diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index e20e4a29bd..142100e109 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -219,7 +219,7 @@ direct_call caller call_conv lbl arity args emitCallWithExtraStack (call_conv, NativeReturn) target (nonVArgs fast_args) - (mkStkOffsets (stack_args dflags)) + (mkStkOffsets dflags (stack_args dflags)) where target = CmmLit (CmmLabel lbl) (fast_args, rest_args) = splitAt real_arity args @@ -329,10 +329,11 @@ slowCallPattern [] = (fsLit "stg_ap_0", 0) -- See Note [over-saturated calls]. mkStkOffsets - :: [(ArgRep, Maybe CmmExpr)] -- things to make offsets for + :: DynFlags + -> [(ArgRep, Maybe CmmExpr)] -- things to make offsets for -> ( ByteOff -- OUTPUTS: Topmost allocated word , [(CmmExpr, ByteOff)] ) -- things with offsets (voids filtered out) -mkStkOffsets things +mkStkOffsets dflags things = loop 0 [] (reverse things) where loop offset offs [] = (offset,offs) @@ -341,7 +342,7 @@ mkStkOffsets things loop offset offs ((rep,Just thing):things) = loop thing_off ((thing, thing_off):offs) things where - thing_off = offset + argRepSizeW rep * wORD_SIZE + thing_off = offset + argRepSizeW dflags rep * wORD_SIZE dflags -- offset of thing is offset+size, because we're -- growing the stack *downwards* as the offsets increase. @@ -382,13 +383,13 @@ isNonV :: ArgRep -> Bool isNonV V = False isNonV _ = True -argRepSizeW :: ArgRep -> WordOff -- Size in words -argRepSizeW N = 1 -argRepSizeW P = 1 -argRepSizeW F = 1 -argRepSizeW L = wORD64_SIZE `quot` wORD_SIZE -argRepSizeW D = dOUBLE_SIZE `quot` wORD_SIZE -argRepSizeW V = 0 +argRepSizeW :: DynFlags -> ArgRep -> WordOff -- Size in words +argRepSizeW _ N = 1 +argRepSizeW _ P = 1 +argRepSizeW _ F = 1 +argRepSizeW dflags L = wORD64_SIZE `quot` wORD_SIZE dflags +argRepSizeW dflags D = dOUBLE_SIZE dflags `quot` wORD_SIZE dflags +argRepSizeW _ V = 0 idArgRep :: Id -> ArgRep idArgRep = toArgRep . idPrimRep @@ -405,8 +406,9 @@ hpRel hp off = off - hp getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr getHpRelOffset virtual_offset - = do { hp_usg <- getHpUsage - ; return (cmmRegOffW hpReg (hpRel (realHp hp_usg) virtual_offset)) } + = do dflags <- getDynFlags + hp_usg <- getHpUsage + return (cmmRegOffW dflags hpReg (hpRel (realHp hp_usg) virtual_offset)) mkVirtHeapOffsets :: DynFlags @@ -438,7 +440,7 @@ mkVirtHeapOffsets dflags is_thunk things | otherwise = fixedHdrSize dflags computeOffset wds_so_far (rep, thing) - = (wds_so_far + argRepSizeW (toArgRep rep), + = (wds_so_far + argRepSizeW dflags (toArgRep rep), (NonVoid thing, hdr_size + wds_so_far)) mkVirtConstrOffsets :: DynFlags -> [(PrimRep,a)] -> (WordOff, WordOff, [(NonVoid a, VirtualHpOffset)]) @@ -462,19 +464,20 @@ mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags False #include "../includes/rts/storage/FunTypes.h" mkArgDescr :: Name -> [Id] -> FCode ArgDescr -mkArgDescr _nm args - = case stdPattern arg_reps of - Just spec_id -> return (ArgSpec spec_id) - Nothing -> return (ArgGen arg_bits) - where - arg_bits = argBits arg_reps - arg_reps = filter isNonV (map idArgRep args) - -- Getting rid of voids eases matching of standard patterns - -argBits :: [ArgRep] -> [Bool] -- True for non-ptr, False for ptr -argBits [] = [] -argBits (P : args) = False : argBits args -argBits (arg : args) = take (argRepSizeW arg) (repeat True) ++ argBits args +mkArgDescr _nm args + = do dflags <- getDynFlags + let arg_bits = argBits dflags arg_reps + arg_reps = filter isNonV (map idArgRep args) + -- Getting rid of voids eases matching of standard patterns + case stdPattern arg_reps of + Just spec_id -> return (ArgSpec spec_id) + Nothing -> return (ArgGen arg_bits) + +argBits :: DynFlags -> [ArgRep] -> [Bool] -- True for non-ptr, False for ptr +argBits _ [] = [] +argBits dflags (P : args) = False : argBits dflags args +argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True) + ++ argBits dflags args ---------------------- stdPattern :: [ArgRep] -> Maybe StgHalfWord @@ -527,13 +530,12 @@ emitClosureProcAndInfoTable :: Bool -- top-level? -> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body -> FCode () emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body - = do { + = do { dflags <- getDynFlags -- Bind the binder itself, but only if it's not a top-level -- binding. We need non-top let-bindings to refer to the -- top-level binding, which this binding would incorrectly shadow. - ; node <- if top_lvl then return $ idToReg (NonVoid bndr) + ; node <- if top_lvl then return $ idToReg dflags (NonVoid bndr) else bindToReg (NonVoid bndr) lf_info - ; dflags <- getDynFlags ; let node_points = nodeMustPointToIt dflags lf_info ; arg_regs <- bindArgsToRegs args ; let args' = if node_points then (node : arg_regs) else arg_regs @@ -571,7 +573,7 @@ stdInfoTableSizeW dflags | otherwise = 0 stdInfoTableSizeB :: DynFlags -> ByteOff -stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE :: ByteOff +stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE dflags stdSrtBitmapOffset :: DynFlags -> ByteOff -- Byte offset of the SRT bitmap half-word which is @@ -580,11 +582,11 @@ stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE stdClosureTypeOffset :: DynFlags -> ByteOff -- Byte offset of the closure type half-word -stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE +stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff -stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2*wORD_SIZE -stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2*wORD_SIZE + hALF_WORD_SIZE +stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags +stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE ------------------------------------------------------------------------- -- @@ -592,16 +594,16 @@ stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2*wORD_SIZE + hALF_WORD_SIZ -- ------------------------------------------------------------------------- -closureInfoPtr :: CmmExpr -> CmmExpr +closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr -- Takes a closure pointer and returns the info table pointer -closureInfoPtr e = CmmLoad e bWord +closureInfoPtr dflags e = CmmLoad e (bWord dflags) entryCode :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info pointer (the first word of a closure) -- and returns its entry code entryCode dflags e | tablesNextToCode dflags = e - | otherwise = CmmLoad e bWord + | otherwise = CmmLoad e (bWord dflags) getConstrTag :: DynFlags -> CmmExpr -> CmmExpr -- Takes a closure pointer, and return the *zero-indexed* @@ -609,25 +611,25 @@ getConstrTag :: DynFlags -> CmmExpr -> CmmExpr -- This lives in the SRT field of the info table -- (constructors don't need SRTs). getConstrTag dflags closure_ptr - = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableConstrTag dflags info_table] + = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableConstrTag dflags info_table] where - info_table = infoTable dflags (closureInfoPtr closure_ptr) + info_table = infoTable dflags (closureInfoPtr dflags closure_ptr) cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr -- Takes a closure pointer, and return the closure type -- obtained from the info table cmmGetClosureType dflags closure_ptr - = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableClosureType dflags info_table] + = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableClosureType dflags info_table] where - info_table = infoTable dflags (closureInfoPtr closure_ptr) + info_table = infoTable dflags (closureInfoPtr dflags closure_ptr) infoTable :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info pointer (the first word of a closure) -- and returns a pointer to the first word of the standard-form -- info table, excluding the entry-code word (if present) infoTable dflags info_ptr - | tablesNextToCode dflags = cmmOffsetB info_ptr (- stdInfoTableSizeB dflags) - | otherwise = cmmOffsetW info_ptr 1 -- Past the entry code pointer + | tablesNextToCode dflags = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags) + | otherwise = cmmOffsetW dflags info_ptr 1 -- Past the entry code pointer infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info table pointer (from infoTable) and returns the constr tag @@ -638,21 +640,21 @@ infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info table pointer (from infoTable) and returns the srt_bitmap -- field of the info table infoTableSrtBitmap dflags info_tbl - = CmmLoad (cmmOffsetB info_tbl (stdSrtBitmapOffset dflags)) bHalfWord + = CmmLoad (cmmOffsetB dflags info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord dflags) infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr -- Takes an info table pointer (from infoTable) and returns the closure type -- field of the info table. infoTableClosureType dflags info_tbl - = CmmLoad (cmmOffsetB info_tbl (stdClosureTypeOffset dflags)) bHalfWord + = CmmLoad (cmmOffsetB dflags info_tbl (stdClosureTypeOffset dflags)) (bHalfWord dflags) infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr infoTablePtrs dflags info_tbl - = CmmLoad (cmmOffsetB info_tbl (stdPtrsOffset dflags)) bHalfWord + = CmmLoad (cmmOffsetB dflags info_tbl (stdPtrsOffset dflags)) (bHalfWord dflags) infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr infoTableNonPtrs dflags info_tbl - = CmmLoad (cmmOffsetB info_tbl (stdNonPtrsOffset dflags)) bHalfWord + = CmmLoad (cmmOffsetB dflags info_tbl (stdNonPtrsOffset dflags)) (bHalfWord dflags) funInfoTable :: DynFlags -> CmmExpr -> CmmExpr -- Takes the info pointer of a function, @@ -660,8 +662,8 @@ funInfoTable :: DynFlags -> CmmExpr -> CmmExpr -- in the info table. funInfoTable dflags info_ptr | tablesNextToCode dflags - = cmmOffsetB info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev) + = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags) | otherwise - = cmmOffsetW info_ptr (1 + stdInfoTableSizeW dflags) + = cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags) -- Past the entry code pointer diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 2290914310..fb290d8e96 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -39,8 +39,7 @@ module StgCmmMonad ( Sequel(..), ReturnKind(..), withSequel, getSequel, - setSRTLabel, getSRTLabel, - setTickyCtrLabel, getTickyCtrLabel, + setTickyCtrLabel, getTickyCtrLabel, withUpdFrameOff, getUpdFrameOff, initUpdFrameOff, @@ -155,8 +154,7 @@ data CgInfoDownwards -- information only passed *downwards* by the monad cgd_dflags :: DynFlags, cgd_mod :: Module, -- Module being compiled cgd_statics :: CgBindings, -- [Id -> info] : static environment - cgd_srt_lbl :: CLabel, -- Label of the current top-level SRT - cgd_updfr_off :: UpdFrameOffset, -- Size of current update frame + cgd_updfr_off :: UpdFrameOffset, -- Size of current update frame cgd_ticky :: CLabel, -- Current destination for ticky counts cgd_sequel :: Sequel -- What to do at end of basic block } @@ -285,16 +283,15 @@ initCgInfoDown dflags mod = MkCgInfoDown { cgd_dflags = dflags, cgd_mod = mod, cgd_statics = emptyVarEnv, - cgd_srt_lbl = error "initC: srt_lbl", - cgd_updfr_off = initUpdFrameOff, + cgd_updfr_off = initUpdFrameOff dflags, cgd_ticky = mkTopTickyCtrLabel, cgd_sequel = initSequel } initSequel :: Sequel initSequel = Return False -initUpdFrameOff :: UpdFrameOffset -initUpdFrameOff = widthInBytes wordWidth -- space for the RA +initUpdFrameOff :: DynFlags -> UpdFrameOffset +initUpdFrameOff dflags = widthInBytes (wordWidth dflags) -- space for the RA -------------------------------------------------------- @@ -472,22 +469,6 @@ getSequel = do { info <- getInfoDown ; return (cgd_sequel info) } -- ---------------------------------------------------------------------------- --- Get/set the current SRT label - --- There is just one SRT for each top level binding; all the nested --- bindings use sub-sections of this SRT. The label is passed down to --- the nested bindings via the monad. - -getSRTLabel :: FCode CLabel -- Used only by cgPanic -getSRTLabel = do info <- getInfoDown - return (cgd_srt_lbl info) - -setSRTLabel :: CLabel -> FCode a -> FCode a -setSRTLabel srt_lbl code - = do info <- getInfoDown - withInfoDown code (info { cgd_srt_lbl = srt_lbl}) - --- ---------------------------------------------------------------------------- -- Get/set the size of the update frame -- We keep track of the size of the update frame so that we @@ -537,11 +518,12 @@ forkClosureBody :: FCode () -> FCode () -- C-- from the fork is incorporated. forkClosureBody body_code - = do { info <- getInfoDown + = do { dflags <- getDynFlags + ; info <- getInfoDown ; us <- newUniqSupply ; state <- getState ; let body_info_down = info { cgd_sequel = initSequel - , cgd_updfr_off = initUpdFrameOff } + , cgd_updfr_off = initUpdFrameOff dflags } fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } ((),fork_state_out) = doFCode body_code body_info_down fork_state_in @@ -553,12 +535,13 @@ forkStatics :: FCode a -> FCode a -- The Abstract~C returned is attached to the current state, but the -- bindings and usage information is otherwise unchanged. forkStatics body_code - = do { info <- getInfoDown + = do { dflags <- getDynFlags + ; info <- getInfoDown ; us <- newUniqSupply ; state <- getState ; let rhs_info_down = info { cgd_statics = cgs_binds state , cgd_sequel = initSequel - , cgd_updfr_off = initUpdFrameOff } + , cgd_updfr_off = initUpdFrameOff dflags } (result, fork_state_out) = doFCode body_code rhs_info_down (initCgState us) ; setState (state `addCodeBlocksFrom` fork_state_out) @@ -699,7 +682,7 @@ emitProcWithConvention conv mb_info lbl args blocks ; us <- newUniqSupply ; let (offset, entry) = mkCallEntry dflags conv args blks = initUs_ us $ lgraphOfAGraph $ entry <*> blocks - ; let sinfo = StackInfo {arg_space = offset, updfr_space = Just initUpdFrameOff} + ; let sinfo = StackInfo {arg_space = offset, updfr_space = Just (initUpdFrameOff dflags)} tinfo = TopInfo {info_tbls = infos, stack_info=sinfo} proc_block = CmmProc tinfo lbl blks diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index d9585c6d61..cbb2aa70bd 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -42,13 +42,13 @@ import CLabel import CmmUtils import PrimOp import SMRep -import Constants import Module import FastString import Outputable import Util import Control.Monad (liftM) +import Data.Bits ------------------------------------------------------------------------ -- Primitive operations and foreign calls @@ -80,10 +80,11 @@ cgOpApp (StgFCallOp fcall _) stg_args res_ty cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty = ASSERT(isEnumerationTyCon tycon) - do { args' <- getNonVoidArgAmodes [arg] + do { dflags <- getDynFlags + ; args' <- getNonVoidArgAmodes [arg] ; let amode = case args' of [amode] -> amode _ -> panic "TagToEnumOp had void arg" - ; emitReturn [tagToClosure tycon amode] } + ; emitReturn [tagToClosure dflags tycon amode] } where -- If you're reading this code in the attempt to figure -- out why the compiler panic'ed here, it is probably because @@ -103,7 +104,8 @@ cgOpApp (StgPrimOp primop) args res_ty emitReturn [] | ReturnsPrim rep <- result_info - = do res <- newTemp (primRepCmmType rep) + = do dflags <- getDynFlags + res <- newTemp (primRepCmmType dflags rep) cgPrimOp [res] primop args emitReturn [CmmReg (CmmLocal res)] @@ -115,10 +117,11 @@ cgOpApp (StgPrimOp primop) args res_ty | ReturnsAlg tycon <- result_info , isEnumerationTyCon tycon -- c.f. cgExpr (...TagToEnumOp...) - = do tag_reg <- newTemp bWord - cgPrimOp [tag_reg] primop args - emitReturn [tagToClosure tycon - (CmmReg (CmmLocal tag_reg))] + = do dflags <- getDynFlags + tag_reg <- newTemp (bWord dflags) + cgPrimOp [tag_reg] primop args + emitReturn [tagToClosure dflags tycon + (CmmReg (CmmLocal tag_reg))] | otherwise = panic "cgPrimop" where @@ -136,15 +139,17 @@ cgPrimOp :: [LocalReg] -- where to put the results -> FCode () cgPrimOp results op args - = do arg_exprs <- getNonVoidArgAmodes args - emitPrimOp results op arg_exprs + = do dflags <- getDynFlags + arg_exprs <- getNonVoidArgAmodes args + emitPrimOp dflags results op arg_exprs ------------------------------------------------------------------------ -- Emitting code for a primop ------------------------------------------------------------------------ -emitPrimOp :: [LocalReg] -- where to put the results +emitPrimOp :: DynFlags + -> [LocalReg] -- where to put the results -> PrimOp -- the op -> [CmmExpr] -- arguments -> FCode () @@ -152,7 +157,7 @@ emitPrimOp :: [LocalReg] -- where to put the results -- First we handle various awkward cases specially. The remaining -- easy cases are then handled by translateOp, defined below. -emitPrimOp [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 C, and without needing any comparisons. This may not be the @@ -174,19 +179,19 @@ emitPrimOp [res_r,res_c] IntAddCOp [aa,bb] -} = emit $ catAGraphs [ - mkAssign (CmmLocal res_r) (CmmMachOp mo_wordAdd [aa,bb]), + mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]), mkAssign (CmmLocal res_c) $ - CmmMachOp mo_wordUShr [ - CmmMachOp mo_wordAnd [ - CmmMachOp mo_wordNot [CmmMachOp mo_wordXor [aa,bb]], - CmmMachOp mo_wordXor [aa, CmmReg (CmmLocal res_r)] + CmmMachOp (mo_wordUShr dflags) [ + CmmMachOp (mo_wordAnd dflags) [ + CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]], + CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] ], - CmmLit (mkIntCLit (wORD_SIZE_IN_BITS - 1)) + mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1) ] ] -emitPrimOp [res_r,res_c] IntSubCOp [aa,bb] +emitPrimOp dflags [res_r,res_c] IntSubCOp [aa,bb] {- Similarly: #define subIntCzh(r,c,a,b) \ { r = ((I_)(a)) - ((I_)(b)); \ @@ -197,19 +202,19 @@ emitPrimOp [res_r,res_c] IntSubCOp [aa,bb] c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1) -} = emit $ catAGraphs [ - mkAssign (CmmLocal res_r) (CmmMachOp mo_wordSub [aa,bb]), + mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]), mkAssign (CmmLocal res_c) $ - CmmMachOp mo_wordUShr [ - CmmMachOp mo_wordAnd [ - CmmMachOp mo_wordXor [aa,bb], - CmmMachOp mo_wordXor [aa, CmmReg (CmmLocal res_r)] + CmmMachOp (mo_wordUShr dflags) [ + CmmMachOp (mo_wordAnd dflags) [ + CmmMachOp (mo_wordXor dflags) [aa,bb], + CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] ], - CmmLit (mkIntCLit (wORD_SIZE_IN_BITS - 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 -- later, we might want to inline it. @@ -218,37 +223,34 @@ emitPrimOp [res] ParOp [arg] (CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark")))) [(CmmReg (CmmGlobal BaseReg), AddrHint), (arg,AddrHint)] -emitPrimOp [res] SparkOp [arg] +emitPrimOp dflags [res] SparkOp [arg] = do -- returns the value of arg in res. We're going to therefore -- refer to arg twice (once to pass to newSpark(), and once to -- assign to res), so put it in a temporary. tmp <- assignTemp arg - tmp2 <- newTemp bWord + tmp2 <- newTemp (bWord dflags) emitCCall [(tmp2,NoHint)] (CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark")))) [(CmmReg (CmmGlobal BaseReg), AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)] emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp)) -emitPrimOp [res] GetCCSOfOp [arg] - = do dflags <- getDynFlags - emitAssign (CmmLocal res) (val dflags) +emitPrimOp dflags [res] GetCCSOfOp [arg] + = emitAssign (CmmLocal res) val where - val dflags - | dopt Opt_SccProfilingOn dflags = costCentreFrom (cmmUntag arg) - | otherwise = CmmLit zeroCLit + val + | dopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag dflags arg) + | otherwise = CmmLit (zeroCLit dflags) -emitPrimOp [res] GetCurrentCCSOp [_dummy_arg] +emitPrimOp _ [res] GetCurrentCCSOp [_dummy_arg] = emitAssign (CmmLocal res) curCCS -emitPrimOp [res] ReadMutVarOp [mutv] - = do dflags <- getDynFlags - emitAssign (CmmLocal res) (cmmLoadIndexW mutv (fixedHdrSize dflags) gcWord) +emitPrimOp dflags [res] ReadMutVarOp [mutv] + = emitAssign (CmmLocal res) (cmmLoadIndexW dflags mutv (fixedHdrSize dflags) (gcWord dflags)) -emitPrimOp [] WriteMutVarOp [mutv,var] - = do dflags <- getDynFlags - emitStore (cmmOffsetW mutv (fixedHdrSize dflags)) var +emitPrimOp dflags [] WriteMutVarOp [mutv,var] + = do emitStore (cmmOffsetW dflags mutv (fixedHdrSize dflags)) var emitCCall [{-no results-}] (CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) @@ -256,53 +258,47 @@ emitPrimOp [] WriteMutVarOp [mutv,var] -- #define sizzeofByteArrayzh(r,a) \ -- r = ((StgArrWords *)(a))->bytes -emitPrimOp [res] SizeofByteArrayOp [arg] - = do dflags <- getDynFlags - emit $ - mkAssign (CmmLocal res) (cmmLoadIndexW arg (fixedHdrSize dflags) bWord) +emitPrimOp dflags [res] SizeofByteArrayOp [arg] + = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSize dflags) (bWord dflags)) -- #define sizzeofMutableByteArrayzh(r,a) \ -- r = ((StgArrWords *)(a))->bytes -emitPrimOp [res] SizeofMutableByteArrayOp [arg] - = emitPrimOp [res] SizeofByteArrayOp [arg] +emitPrimOp dflags [res] SizeofMutableByteArrayOp [arg] + = emitPrimOp dflags [res] SizeofByteArrayOp [arg] -- #define touchzh(o) /* nothing */ -emitPrimOp res@[] TouchOp args@[_arg] +emitPrimOp _ res@[] TouchOp args@[_arg] = do emitPrimCall res MO_Touch args -- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a) -emitPrimOp [res] ByteArrayContents_Char [arg] - = do dflags <- getDynFlags - emitAssign (CmmLocal res) (cmmOffsetB arg (arrWordsHdrSize dflags)) +emitPrimOp dflags [res] ByteArrayContents_Char [arg] + = emitAssign (CmmLocal res) (cmmOffsetB dflags arg (arrWordsHdrSize dflags)) -- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn) -emitPrimOp [res] StableNameToIntOp [arg] - = do dflags <- getDynFlags - emitAssign (CmmLocal res) (cmmLoadIndexW arg (fixedHdrSize dflags) bWord) +emitPrimOp dflags [res] StableNameToIntOp [arg] + = emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSize dflags) (bWord dflags)) -- #define eqStableNamezh(r,sn1,sn2) \ -- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn)) -emitPrimOp [res] EqStableNameOp [arg1,arg2] - = do dflags <- getDynFlags - emitAssign (CmmLocal res) (CmmMachOp mo_wordEq [ - cmmLoadIndexW arg1 (fixedHdrSize dflags) bWord, - cmmLoadIndexW arg2 (fixedHdrSize dflags) bWord +emitPrimOp dflags [res] EqStableNameOp [arg1,arg2] + = emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [ + cmmLoadIndexW dflags arg1 (fixedHdrSize dflags) (bWord dflags), + cmmLoadIndexW dflags arg2 (fixedHdrSize dflags) (bWord dflags) ]) -emitPrimOp [res] ReallyUnsafePtrEqualityOp [arg1,arg2] - = emitAssign (CmmLocal res) (CmmMachOp mo_wordEq [arg1,arg2]) +emitPrimOp dflags [res] ReallyUnsafePtrEqualityOp [arg1,arg2] + = emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2]) -- #define addrToHValuezh(r,a) r=(P_)a -emitPrimOp [res] AddrToAnyOp [arg] +emitPrimOp _ [res] AddrToAnyOp [arg] = emitAssign (CmmLocal res) arg -- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info)) -- Note: argument may be tagged! -emitPrimOp [res] DataToTagOp [arg] - = do dflags <- getDynFlags - emitAssign (CmmLocal res) (getConstrTag dflags (cmmUntag arg)) +emitPrimOp dflags [res] DataToTagOp [arg] + = emitAssign (CmmLocal res) (getConstrTag dflags (cmmUntag dflags arg)) {- Freezing arrays-of-ptrs requires changing an info table, for the benefit of the generational collector. It needs to scavenge mutable @@ -314,215 +310,218 @@ emitPrimOp [res] DataToTagOp [arg] -- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN0_info); -- r = a; -- } -emitPrimOp [res] UnsafeFreezeArrayOp [arg] +emitPrimOp _ [res] UnsafeFreezeArrayOp [arg] = emit $ catAGraphs [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)), mkAssign (CmmLocal res) arg ] -emitPrimOp [res] UnsafeFreezeArrayArrayOp [arg] +emitPrimOp _ [res] UnsafeFreezeArrayArrayOp [arg] = emit $ catAGraphs [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)), mkAssign (CmmLocal res) arg ] -- #define unsafeFreezzeByteArrayzh(r,a) r=(a) -emitPrimOp [res] UnsafeFreezeByteArrayOp [arg] +emitPrimOp _ [res] UnsafeFreezeByteArrayOp [arg] = emitAssign (CmmLocal res) arg -- Copying pointer arrays -emitPrimOp [] CopyArrayOp [src,src_off,dst,dst_off,n] = +emitPrimOp _ [] CopyArrayOp [src,src_off,dst,dst_off,n] = doCopyArrayOp src src_off dst dst_off n -emitPrimOp [] CopyMutableArrayOp [src,src_off,dst,dst_off,n] = +emitPrimOp _ [] CopyMutableArrayOp [src,src_off,dst,dst_off,n] = doCopyMutableArrayOp src src_off dst dst_off n -emitPrimOp [res] CloneArrayOp [src,src_off,n] = +emitPrimOp _ [res] CloneArrayOp [src,src_off,n] = emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n -emitPrimOp [res] CloneMutableArrayOp [src,src_off,n] = +emitPrimOp _ [res] CloneMutableArrayOp [src,src_off,n] = emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n -emitPrimOp [res] FreezeArrayOp [src,src_off,n] = +emitPrimOp _ [res] FreezeArrayOp [src,src_off,n] = emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n -emitPrimOp [res] ThawArrayOp [src,src_off,n] = +emitPrimOp _ [res] ThawArrayOp [src,src_off,n] = emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n -emitPrimOp [] CopyArrayArrayOp [src,src_off,dst,dst_off,n] = +emitPrimOp _ [] CopyArrayArrayOp [src,src_off,dst,dst_off,n] = doCopyArrayOp src src_off dst dst_off n -emitPrimOp [] CopyMutableArrayArrayOp [src,src_off,dst,dst_off,n] = +emitPrimOp _ [] CopyMutableArrayArrayOp [src,src_off,dst,dst_off,n] = doCopyMutableArrayOp src src_off dst dst_off n -- Reading/writing pointer arrays -emitPrimOp [res] ReadArrayOp [obj,ix] = doReadPtrArrayOp res obj ix -emitPrimOp [res] IndexArrayOp [obj,ix] = doReadPtrArrayOp res obj ix -emitPrimOp [] WriteArrayOp [obj,ix,v] = doWritePtrArrayOp obj ix v - -emitPrimOp [res] IndexArrayArrayOp_ByteArray [obj,ix] = doReadPtrArrayOp res obj ix -emitPrimOp [res] IndexArrayArrayOp_ArrayArray [obj,ix] = doReadPtrArrayOp res obj ix -emitPrimOp [res] ReadArrayArrayOp_ByteArray [obj,ix] = doReadPtrArrayOp res obj ix -emitPrimOp [res] ReadArrayArrayOp_MutableByteArray [obj,ix] = doReadPtrArrayOp res obj ix -emitPrimOp [res] ReadArrayArrayOp_ArrayArray [obj,ix] = doReadPtrArrayOp res obj ix -emitPrimOp [res] ReadArrayArrayOp_MutableArrayArray [obj,ix] = doReadPtrArrayOp res obj ix -emitPrimOp [] WriteArrayArrayOp_ByteArray [obj,ix,v] = doWritePtrArrayOp obj ix v -emitPrimOp [] WriteArrayArrayOp_MutableByteArray [obj,ix,v] = doWritePtrArrayOp obj ix v -emitPrimOp [] WriteArrayArrayOp_ArrayArray [obj,ix,v] = doWritePtrArrayOp obj ix v -emitPrimOp [] WriteArrayArrayOp_MutableArrayArray [obj,ix,v] = doWritePtrArrayOp obj ix v - -emitPrimOp [res] SizeofArrayOp [arg] - = do dflags <- getDynFlags - emit $ mkAssign (CmmLocal res) (cmmLoadIndexW arg (fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs) bWord) -emitPrimOp [res] SizeofMutableArrayOp [arg] - = emitPrimOp [res] SizeofArrayOp [arg] -emitPrimOp [res] SizeofArrayArrayOp [arg] - = emitPrimOp [res] SizeofArrayOp [arg] -emitPrimOp [res] SizeofMutableArrayArrayOp [arg] - = emitPrimOp [res] SizeofArrayOp [arg] +emitPrimOp _ [res] ReadArrayOp [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp _ [res] IndexArrayOp [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp _ [] WriteArrayOp [obj,ix,v] = doWritePtrArrayOp obj ix v + +emitPrimOp _ [res] IndexArrayArrayOp_ByteArray [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp _ [res] IndexArrayArrayOp_ArrayArray [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp _ [res] ReadArrayArrayOp_ByteArray [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp _ [res] ReadArrayArrayOp_MutableByteArray [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp _ [res] ReadArrayArrayOp_ArrayArray [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp _ [res] ReadArrayArrayOp_MutableArrayArray [obj,ix] = doReadPtrArrayOp res obj ix +emitPrimOp _ [] WriteArrayArrayOp_ByteArray [obj,ix,v] = doWritePtrArrayOp obj ix v +emitPrimOp _ [] WriteArrayArrayOp_MutableByteArray [obj,ix,v] = doWritePtrArrayOp obj ix v +emitPrimOp _ [] WriteArrayArrayOp_ArrayArray [obj,ix,v] = doWritePtrArrayOp obj ix v +emitPrimOp _ [] WriteArrayArrayOp_MutableArrayArray [obj,ix,v] = doWritePtrArrayOp obj ix v + +emitPrimOp dflags [res] SizeofArrayOp [arg] + = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags) (bWord dflags)) +emitPrimOp dflags [res] SizeofMutableArrayOp [arg] + = emitPrimOp dflags [res] SizeofArrayOp [arg] +emitPrimOp dflags [res] SizeofArrayArrayOp [arg] + = emitPrimOp dflags [res] SizeofArrayOp [arg] +emitPrimOp dflags [res] SizeofMutableArrayArrayOp [arg] + = emitPrimOp dflags [res] SizeofArrayOp [arg] -- IndexXXXoffAddr -emitPrimOp res IndexOffAddrOp_Char args = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args -emitPrimOp res IndexOffAddrOp_WideChar args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args -emitPrimOp res IndexOffAddrOp_Int args = doIndexOffAddrOp Nothing bWord res args -emitPrimOp res IndexOffAddrOp_Word args = doIndexOffAddrOp Nothing bWord res args -emitPrimOp res IndexOffAddrOp_Addr args = doIndexOffAddrOp Nothing bWord res args -emitPrimOp res IndexOffAddrOp_Float args = doIndexOffAddrOp Nothing f32 res args -emitPrimOp res IndexOffAddrOp_Double args = doIndexOffAddrOp Nothing f64 res args -emitPrimOp res IndexOffAddrOp_StablePtr args = doIndexOffAddrOp Nothing bWord res args -emitPrimOp res IndexOffAddrOp_Int8 args = doIndexOffAddrOp (Just mo_s_8ToWord) b8 res args -emitPrimOp res IndexOffAddrOp_Int16 args = doIndexOffAddrOp (Just mo_s_16ToWord) b16 res args -emitPrimOp res IndexOffAddrOp_Int32 args = doIndexOffAddrOp (Just mo_s_32ToWord) b32 res args -emitPrimOp res IndexOffAddrOp_Int64 args = doIndexOffAddrOp Nothing b64 res args -emitPrimOp res IndexOffAddrOp_Word8 args = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args -emitPrimOp res IndexOffAddrOp_Word16 args = doIndexOffAddrOp (Just mo_u_16ToWord) b16 res args -emitPrimOp res IndexOffAddrOp_Word32 args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args -emitPrimOp res IndexOffAddrOp_Word64 args = doIndexOffAddrOp Nothing b64 res args +emitPrimOp dflags res IndexOffAddrOp_Char args = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexOffAddrOp_WideChar args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp dflags res IndexOffAddrOp_Int args = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res IndexOffAddrOp_Word args = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res IndexOffAddrOp_Addr args = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp _ res IndexOffAddrOp_Float args = doIndexOffAddrOp Nothing f32 res args +emitPrimOp _ res IndexOffAddrOp_Double args = doIndexOffAddrOp Nothing f64 res args +emitPrimOp dflags res IndexOffAddrOp_StablePtr args = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res IndexOffAddrOp_Int8 args = doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexOffAddrOp_Int16 args = doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args +emitPrimOp dflags res IndexOffAddrOp_Int32 args = doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args +emitPrimOp _ res IndexOffAddrOp_Int64 args = doIndexOffAddrOp Nothing b64 res args +emitPrimOp dflags res IndexOffAddrOp_Word8 args = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexOffAddrOp_Word16 args = doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args +emitPrimOp dflags res IndexOffAddrOp_Word32 args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp _ res IndexOffAddrOp_Word64 args = doIndexOffAddrOp Nothing b64 res args -- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr. -emitPrimOp res ReadOffAddrOp_Char args = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args -emitPrimOp res ReadOffAddrOp_WideChar args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args -emitPrimOp res ReadOffAddrOp_Int args = doIndexOffAddrOp Nothing bWord res args -emitPrimOp res ReadOffAddrOp_Word args = doIndexOffAddrOp Nothing bWord res args -emitPrimOp res ReadOffAddrOp_Addr args = doIndexOffAddrOp Nothing bWord res args -emitPrimOp res ReadOffAddrOp_Float args = doIndexOffAddrOp Nothing f32 res args -emitPrimOp res ReadOffAddrOp_Double args = doIndexOffAddrOp Nothing f64 res args -emitPrimOp res ReadOffAddrOp_StablePtr args = doIndexOffAddrOp Nothing bWord res args -emitPrimOp res ReadOffAddrOp_Int8 args = doIndexOffAddrOp (Just mo_s_8ToWord) b8 res args -emitPrimOp res ReadOffAddrOp_Int16 args = doIndexOffAddrOp (Just mo_s_16ToWord) b16 res args -emitPrimOp res ReadOffAddrOp_Int32 args = doIndexOffAddrOp (Just mo_s_32ToWord) b32 res args -emitPrimOp res ReadOffAddrOp_Int64 args = doIndexOffAddrOp Nothing b64 res args -emitPrimOp res ReadOffAddrOp_Word8 args = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args -emitPrimOp res ReadOffAddrOp_Word16 args = doIndexOffAddrOp (Just mo_u_16ToWord) b16 res args -emitPrimOp res ReadOffAddrOp_Word32 args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args -emitPrimOp res ReadOffAddrOp_Word64 args = doIndexOffAddrOp Nothing b64 res args +emitPrimOp dflags res ReadOffAddrOp_Char args = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadOffAddrOp_WideChar args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp dflags res ReadOffAddrOp_Int args = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res ReadOffAddrOp_Word args = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res ReadOffAddrOp_Addr args = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp _ res ReadOffAddrOp_Float args = doIndexOffAddrOp Nothing f32 res args +emitPrimOp _ res ReadOffAddrOp_Double args = doIndexOffAddrOp Nothing f64 res args +emitPrimOp dflags res ReadOffAddrOp_StablePtr args = doIndexOffAddrOp Nothing (bWord dflags) res args +emitPrimOp dflags res ReadOffAddrOp_Int8 args = doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadOffAddrOp_Int16 args = doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args +emitPrimOp dflags res ReadOffAddrOp_Int32 args = doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args +emitPrimOp _ res ReadOffAddrOp_Int64 args = doIndexOffAddrOp Nothing b64 res args +emitPrimOp dflags res ReadOffAddrOp_Word8 args = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadOffAddrOp_Word16 args = doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args +emitPrimOp dflags res ReadOffAddrOp_Word32 args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp _ res ReadOffAddrOp_Word64 args = doIndexOffAddrOp Nothing b64 res args -- IndexXXXArray -emitPrimOp res IndexByteArrayOp_Char args = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args -emitPrimOp res IndexByteArrayOp_WideChar args = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args -emitPrimOp res IndexByteArrayOp_Int args = doIndexByteArrayOp Nothing bWord res args -emitPrimOp res IndexByteArrayOp_Word args = doIndexByteArrayOp Nothing bWord res args -emitPrimOp res IndexByteArrayOp_Addr args = doIndexByteArrayOp Nothing bWord res args -emitPrimOp res IndexByteArrayOp_Float args = doIndexByteArrayOp Nothing f32 res args -emitPrimOp res IndexByteArrayOp_Double args = doIndexByteArrayOp Nothing f64 res args -emitPrimOp res IndexByteArrayOp_StablePtr args = doIndexByteArrayOp Nothing bWord res args -emitPrimOp res IndexByteArrayOp_Int8 args = doIndexByteArrayOp (Just mo_s_8ToWord) b8 res args -emitPrimOp res IndexByteArrayOp_Int16 args = doIndexByteArrayOp (Just mo_s_16ToWord) b16 res args -emitPrimOp res IndexByteArrayOp_Int32 args = doIndexByteArrayOp (Just mo_s_32ToWord) b32 res args -emitPrimOp res IndexByteArrayOp_Int64 args = doIndexByteArrayOp Nothing b64 res args -emitPrimOp res IndexByteArrayOp_Word8 args = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args -emitPrimOp res IndexByteArrayOp_Word16 args = doIndexByteArrayOp (Just mo_u_16ToWord) b16 res args -emitPrimOp res IndexByteArrayOp_Word32 args = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args -emitPrimOp res IndexByteArrayOp_Word64 args = doIndexByteArrayOp Nothing b64 res args +emitPrimOp dflags res IndexByteArrayOp_Char args = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexByteArrayOp_WideChar args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp dflags res IndexByteArrayOp_Int args = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res IndexByteArrayOp_Word args = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res IndexByteArrayOp_Addr args = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp _ res IndexByteArrayOp_Float args = doIndexByteArrayOp Nothing f32 res args +emitPrimOp _ res IndexByteArrayOp_Double args = doIndexByteArrayOp Nothing f64 res args +emitPrimOp dflags res IndexByteArrayOp_StablePtr args = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res IndexByteArrayOp_Int8 args = doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexByteArrayOp_Int16 args = doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16 res args +emitPrimOp dflags res IndexByteArrayOp_Int32 args = doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32 res args +emitPrimOp _ res IndexByteArrayOp_Int64 args = doIndexByteArrayOp Nothing b64 res args +emitPrimOp dflags res IndexByteArrayOp_Word8 args = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexByteArrayOp_Word16 args = doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16 res args +emitPrimOp dflags res IndexByteArrayOp_Word32 args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp _ res IndexByteArrayOp_Word64 args = doIndexByteArrayOp Nothing b64 res args -- ReadXXXArray, identical to IndexXXXArray. -emitPrimOp res ReadByteArrayOp_Char args = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args -emitPrimOp res ReadByteArrayOp_WideChar args = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args -emitPrimOp res ReadByteArrayOp_Int args = doIndexByteArrayOp Nothing bWord res args -emitPrimOp res ReadByteArrayOp_Word args = doIndexByteArrayOp Nothing bWord res args -emitPrimOp res ReadByteArrayOp_Addr args = doIndexByteArrayOp Nothing bWord res args -emitPrimOp res ReadByteArrayOp_Float args = doIndexByteArrayOp Nothing f32 res args -emitPrimOp res ReadByteArrayOp_Double args = doIndexByteArrayOp Nothing f64 res args -emitPrimOp res ReadByteArrayOp_StablePtr args = doIndexByteArrayOp Nothing bWord res args -emitPrimOp res ReadByteArrayOp_Int8 args = doIndexByteArrayOp (Just mo_s_8ToWord) b8 res args -emitPrimOp res ReadByteArrayOp_Int16 args = doIndexByteArrayOp (Just mo_s_16ToWord) b16 res args -emitPrimOp res ReadByteArrayOp_Int32 args = doIndexByteArrayOp (Just mo_s_32ToWord) b32 res args -emitPrimOp res ReadByteArrayOp_Int64 args = doIndexByteArrayOp Nothing b64 res args -emitPrimOp res ReadByteArrayOp_Word8 args = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args -emitPrimOp res ReadByteArrayOp_Word16 args = doIndexByteArrayOp (Just mo_u_16ToWord) b16 res args -emitPrimOp res ReadByteArrayOp_Word32 args = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args -emitPrimOp res ReadByteArrayOp_Word64 args = doIndexByteArrayOp Nothing b64 res args +emitPrimOp dflags res ReadByteArrayOp_Char args = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadByteArrayOp_WideChar args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp dflags res ReadByteArrayOp_Int args = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res ReadByteArrayOp_Word args = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res ReadByteArrayOp_Addr args = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp _ res ReadByteArrayOp_Float args = doIndexByteArrayOp Nothing f32 res args +emitPrimOp _ res ReadByteArrayOp_Double args = doIndexByteArrayOp Nothing f64 res args +emitPrimOp dflags res ReadByteArrayOp_StablePtr args = doIndexByteArrayOp Nothing (bWord dflags) res args +emitPrimOp dflags res ReadByteArrayOp_Int8 args = doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadByteArrayOp_Int16 args = doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16 res args +emitPrimOp dflags res ReadByteArrayOp_Int32 args = doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32 res args +emitPrimOp _ res ReadByteArrayOp_Int64 args = doIndexByteArrayOp Nothing b64 res args +emitPrimOp dflags res ReadByteArrayOp_Word8 args = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadByteArrayOp_Word16 args = doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16 res args +emitPrimOp dflags res ReadByteArrayOp_Word32 args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args +emitPrimOp _ res ReadByteArrayOp_Word64 args = doIndexByteArrayOp Nothing b64 res args -- WriteXXXoffAddr -emitPrimOp res WriteOffAddrOp_Char args = doWriteOffAddrOp (Just mo_WordTo8) res args -emitPrimOp res WriteOffAddrOp_WideChar args = doWriteOffAddrOp (Just mo_WordTo32) res args -emitPrimOp res WriteOffAddrOp_Int args = doWriteOffAddrOp Nothing res args -emitPrimOp res WriteOffAddrOp_Word args = doWriteOffAddrOp Nothing res args -emitPrimOp res WriteOffAddrOp_Addr args = doWriteOffAddrOp Nothing res args -emitPrimOp res WriteOffAddrOp_Float args = doWriteOffAddrOp Nothing res args -emitPrimOp res WriteOffAddrOp_Double args = doWriteOffAddrOp Nothing res args -emitPrimOp res WriteOffAddrOp_StablePtr args = doWriteOffAddrOp Nothing res args -emitPrimOp res WriteOffAddrOp_Int8 args = doWriteOffAddrOp (Just mo_WordTo8) res args -emitPrimOp res WriteOffAddrOp_Int16 args = doWriteOffAddrOp (Just mo_WordTo16) res args -emitPrimOp res WriteOffAddrOp_Int32 args = doWriteOffAddrOp (Just mo_WordTo32) res args -emitPrimOp res WriteOffAddrOp_Int64 args = doWriteOffAddrOp Nothing res args -emitPrimOp res WriteOffAddrOp_Word8 args = doWriteOffAddrOp (Just mo_WordTo8) res args -emitPrimOp res WriteOffAddrOp_Word16 args = doWriteOffAddrOp (Just mo_WordTo16) res args -emitPrimOp res WriteOffAddrOp_Word32 args = doWriteOffAddrOp (Just mo_WordTo32) res args -emitPrimOp res WriteOffAddrOp_Word64 args = doWriteOffAddrOp Nothing res args +emitPrimOp dflags res WriteOffAddrOp_Char args = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) res args +emitPrimOp dflags res WriteOffAddrOp_WideChar args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) res args +emitPrimOp _ res WriteOffAddrOp_Int args = doWriteOffAddrOp Nothing res args +emitPrimOp _ res WriteOffAddrOp_Word args = doWriteOffAddrOp Nothing res args +emitPrimOp _ res WriteOffAddrOp_Addr args = doWriteOffAddrOp Nothing res args +emitPrimOp _ res WriteOffAddrOp_Float args = doWriteOffAddrOp Nothing res args +emitPrimOp _ res WriteOffAddrOp_Double args = doWriteOffAddrOp Nothing res args +emitPrimOp _ res WriteOffAddrOp_StablePtr args = doWriteOffAddrOp Nothing res args +emitPrimOp dflags res WriteOffAddrOp_Int8 args = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) res args +emitPrimOp dflags res WriteOffAddrOp_Int16 args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) res args +emitPrimOp dflags res WriteOffAddrOp_Int32 args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) res args +emitPrimOp _ res WriteOffAddrOp_Int64 args = doWriteOffAddrOp Nothing res args +emitPrimOp dflags res WriteOffAddrOp_Word8 args = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) res args +emitPrimOp dflags res WriteOffAddrOp_Word16 args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) res args +emitPrimOp dflags res WriteOffAddrOp_Word32 args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) res args +emitPrimOp _ res WriteOffAddrOp_Word64 args = doWriteOffAddrOp Nothing res args -- WriteXXXArray -emitPrimOp res WriteByteArrayOp_Char args = doWriteByteArrayOp (Just mo_WordTo8) res args -emitPrimOp res WriteByteArrayOp_WideChar args = doWriteByteArrayOp (Just mo_WordTo32) res args -emitPrimOp res WriteByteArrayOp_Int args = doWriteByteArrayOp Nothing res args -emitPrimOp res WriteByteArrayOp_Word args = doWriteByteArrayOp Nothing res args -emitPrimOp res WriteByteArrayOp_Addr args = doWriteByteArrayOp Nothing res args -emitPrimOp res WriteByteArrayOp_Float args = doWriteByteArrayOp Nothing res args -emitPrimOp res WriteByteArrayOp_Double args = doWriteByteArrayOp Nothing res args -emitPrimOp res WriteByteArrayOp_StablePtr args = doWriteByteArrayOp Nothing res args -emitPrimOp res WriteByteArrayOp_Int8 args = doWriteByteArrayOp (Just mo_WordTo8) res args -emitPrimOp res WriteByteArrayOp_Int16 args = doWriteByteArrayOp (Just mo_WordTo16) res args -emitPrimOp res WriteByteArrayOp_Int32 args = doWriteByteArrayOp (Just mo_WordTo32) res args -emitPrimOp res WriteByteArrayOp_Int64 args = doWriteByteArrayOp Nothing res args -emitPrimOp res WriteByteArrayOp_Word8 args = doWriteByteArrayOp (Just mo_WordTo8) res args -emitPrimOp res WriteByteArrayOp_Word16 args = doWriteByteArrayOp (Just mo_WordTo16) res args -emitPrimOp res WriteByteArrayOp_Word32 args = doWriteByteArrayOp (Just mo_WordTo32) res args -emitPrimOp res WriteByteArrayOp_Word64 args = doWriteByteArrayOp Nothing res args +emitPrimOp dflags res WriteByteArrayOp_Char args = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) res args +emitPrimOp dflags res WriteByteArrayOp_WideChar args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) res args +emitPrimOp _ res WriteByteArrayOp_Int args = doWriteByteArrayOp Nothing res args +emitPrimOp _ res WriteByteArrayOp_Word args = doWriteByteArrayOp Nothing res args +emitPrimOp _ res WriteByteArrayOp_Addr args = doWriteByteArrayOp Nothing res args +emitPrimOp _ res WriteByteArrayOp_Float args = doWriteByteArrayOp Nothing res args +emitPrimOp _ res WriteByteArrayOp_Double args = doWriteByteArrayOp Nothing res args +emitPrimOp _ res WriteByteArrayOp_StablePtr args = doWriteByteArrayOp Nothing res args +emitPrimOp dflags res WriteByteArrayOp_Int8 args = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) res args +emitPrimOp dflags res WriteByteArrayOp_Int16 args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) res args +emitPrimOp dflags res WriteByteArrayOp_Int32 args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) res args +emitPrimOp _ res WriteByteArrayOp_Int64 args = doWriteByteArrayOp Nothing res args +emitPrimOp dflags res WriteByteArrayOp_Word8 args = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) res args +emitPrimOp dflags res WriteByteArrayOp_Word16 args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) res args +emitPrimOp dflags res WriteByteArrayOp_Word32 args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) res args +emitPrimOp _ res WriteByteArrayOp_Word64 args = doWriteByteArrayOp Nothing res args -- Copying and setting byte arrays -emitPrimOp [] CopyByteArrayOp [src,src_off,dst,dst_off,n] = +emitPrimOp _ [] CopyByteArrayOp [src,src_off,dst,dst_off,n] = doCopyByteArrayOp src src_off dst dst_off n -emitPrimOp [] CopyMutableByteArrayOp [src,src_off,dst,dst_off,n] = +emitPrimOp _ [] CopyMutableByteArrayOp [src,src_off,dst,dst_off,n] = doCopyMutableByteArrayOp src src_off dst dst_off n -emitPrimOp [] SetByteArrayOp [ba,off,len,c] = +emitPrimOp _ [] SetByteArrayOp [ba,off,len,c] = doSetByteArrayOp ba off len c -- Population count -emitPrimOp [res] PopCnt8Op [w] = emitPopCntCall res w W8 -emitPrimOp [res] PopCnt16Op [w] = emitPopCntCall res w W16 -emitPrimOp [res] PopCnt32Op [w] = emitPopCntCall res w W32 -emitPrimOp [res] PopCnt64Op [w] = emitPopCntCall res w W64 -emitPrimOp [res] PopCntOp [w] = emitPopCntCall res w wordWidth +emitPrimOp dflags [res] PopCnt8Op [w] = + emitPopCntCall res (CmmMachOp (mo_WordTo8 dflags) [w]) W8 +emitPrimOp dflags [res] PopCnt16Op [w] = + emitPopCntCall res (CmmMachOp (mo_WordTo16 dflags) [w]) W16 +emitPrimOp dflags [res] PopCnt32Op [w] = + 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 -emitPrimOp [res] op [arg] +emitPrimOp dflags [res] op [arg] | nopOp op = emitAssign (CmmLocal res) arg | Just (mop,rep) <- narrowOp op = emitAssign (CmmLocal res) $ - CmmMachOp (mop rep wordWidth) [CmmMachOp (mop wordWidth rep) [arg]] + CmmMachOp (mop rep (wordWidth dflags)) [CmmMachOp (mop (wordWidth dflags) rep) [arg]] -emitPrimOp r@[res] op args +emitPrimOp dflags r@[res] op args | Just prim <- callishOp op = do emitPrimCall r prim args - | Just mop <- translateOp op + | Just mop <- translateOp dflags op = let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args) in emit stmt -emitPrimOp results op args - = do dflags <- getDynFlags - case callishPrimOpSupported dflags op of +emitPrimOp dflags results op args + = case callishPrimOpSupported dflags op of Left op -> emit $ mkUnsafeCall (PrimTarget op) results args Right gen -> gen results args @@ -531,19 +530,19 @@ type GenericOp = [CmmFormal] -> [CmmActual] -> FCode () callishPrimOpSupported :: DynFlags -> PrimOp -> Either CallishMachOp GenericOp callishPrimOpSupported dflags op = case op of - IntQuotRemOp | ncg && x86ish -> Left (MO_S_QuotRem wordWidth) - | otherwise -> Right genericIntQuotRemOp + IntQuotRemOp | ncg && x86ish -> Left (MO_S_QuotRem (wordWidth dflags)) + | otherwise -> Right (genericIntQuotRemOp dflags) - WordQuotRemOp | ncg && x86ish -> Left (MO_U_QuotRem wordWidth) - | otherwise -> Right genericWordQuotRemOp + WordQuotRemOp | ncg && x86ish -> Left (MO_U_QuotRem (wordWidth dflags)) + | otherwise -> Right (genericWordQuotRemOp dflags) - WordQuotRem2Op | ncg && x86ish -> Left (MO_U_QuotRem2 wordWidth) - | otherwise -> Right genericWordQuotRem2Op + WordQuotRem2Op | ncg && x86ish -> Left (MO_U_QuotRem2 (wordWidth dflags)) + | otherwise -> Right (genericWordQuotRem2Op dflags) - WordAdd2Op | ncg && x86ish -> Left (MO_Add2 wordWidth) + WordAdd2Op | ncg && x86ish -> Left (MO_Add2 (wordWidth dflags)) | otherwise -> Right genericWordAdd2Op - WordMul2Op | ncg && x86ish -> Left (MO_U_Mul2 wordWidth) + WordMul2Op | ncg && x86ish -> Left (MO_U_Mul2 (wordWidth dflags)) | otherwise -> Right genericWordMul2Op _ -> panic "emitPrimOp: can't translate PrimOp" (ppr op) @@ -557,37 +556,37 @@ callishPrimOpSupported dflags op ArchX86_64 -> True _ -> False -genericIntQuotRemOp :: GenericOp -genericIntQuotRemOp [res_q, res_r] [arg_x, arg_y] +genericIntQuotRemOp :: DynFlags -> GenericOp +genericIntQuotRemOp dflags [res_q, res_r] [arg_x, arg_y] = emit $ mkAssign (CmmLocal res_q) - (CmmMachOp (MO_S_Quot wordWidth) [arg_x, arg_y]) <*> + (CmmMachOp (MO_S_Quot (wordWidth dflags)) [arg_x, arg_y]) <*> mkAssign (CmmLocal res_r) - (CmmMachOp (MO_S_Rem wordWidth) [arg_x, arg_y]) -genericIntQuotRemOp _ _ = panic "genericIntQuotRemOp" + (CmmMachOp (MO_S_Rem (wordWidth dflags)) [arg_x, arg_y]) +genericIntQuotRemOp _ _ _ = panic "genericIntQuotRemOp" -genericWordQuotRemOp :: GenericOp -genericWordQuotRemOp [res_q, res_r] [arg_x, arg_y] +genericWordQuotRemOp :: DynFlags -> GenericOp +genericWordQuotRemOp dflags [res_q, res_r] [arg_x, arg_y] = emit $ mkAssign (CmmLocal res_q) - (CmmMachOp (MO_U_Quot wordWidth) [arg_x, arg_y]) <*> + (CmmMachOp (MO_U_Quot (wordWidth dflags)) [arg_x, arg_y]) <*> mkAssign (CmmLocal res_r) - (CmmMachOp (MO_U_Rem wordWidth) [arg_x, arg_y]) -genericWordQuotRemOp _ _ = panic "genericWordQuotRemOp" - -genericWordQuotRem2Op :: GenericOp -genericWordQuotRem2Op [res_q, res_r] [arg_x_high, arg_x_low, arg_y] - = emit =<< f (widthInBits wordWidth) zero arg_x_high arg_x_low - where ty = cmmExprType arg_x_high - shl x i = CmmMachOp (MO_Shl wordWidth) [x, i] - shr x i = CmmMachOp (MO_U_Shr wordWidth) [x, i] - or x y = CmmMachOp (MO_Or wordWidth) [x, y] - ge x y = CmmMachOp (MO_U_Ge wordWidth) [x, y] - ne x y = CmmMachOp (MO_Ne wordWidth) [x, y] - minus x y = CmmMachOp (MO_Sub wordWidth) [x, y] - times x y = CmmMachOp (MO_Mul wordWidth) [x, y] + (CmmMachOp (MO_U_Rem (wordWidth dflags)) [arg_x, arg_y]) +genericWordQuotRemOp _ _ _ = panic "genericWordQuotRemOp" + +genericWordQuotRem2Op :: DynFlags -> GenericOp +genericWordQuotRem2Op dflags [res_q, res_r] [arg_x_high, arg_x_low, arg_y] + = emit =<< f (widthInBits (wordWidth dflags)) zero arg_x_high arg_x_low + where ty = cmmExprType dflags arg_x_high + shl x i = CmmMachOp (MO_Shl (wordWidth dflags)) [x, i] + shr x i = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, i] + or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y] + ge x y = CmmMachOp (MO_U_Ge (wordWidth dflags)) [x, y] + ne x y = CmmMachOp (MO_Ne (wordWidth dflags)) [x, y] + minus x y = CmmMachOp (MO_Sub (wordWidth dflags)) [x, y] + times x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y] zero = lit 0 one = lit 1 - negone = lit (fromIntegral (widthInBits wordWidth) - 1) - lit i = CmmLit (CmmInt i wordWidth) + negone = lit (fromIntegral (widthInBits (wordWidth dflags)) - 1) + lit i = CmmLit (CmmInt i (wordWidth dflags)) f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode CmmAGraph f 0 acc high _ = return (mkAssign (CmmLocal res_q) acc <*> @@ -620,12 +619,21 @@ genericWordQuotRem2Op [res_q, res_r] [arg_x_high, arg_x_low, arg_y] (CmmReg (CmmLocal rhigh'')) (CmmReg (CmmLocal rlow')) return (this <*> rest) -genericWordQuotRem2Op _ _ = panic "genericWordQuotRem2Op" +genericWordQuotRem2Op _ _ _ = panic "genericWordQuotRem2Op" genericWordAdd2Op :: GenericOp genericWordAdd2Op [res_h, res_l] [arg_x, arg_y] - = do r1 <- newTemp (cmmExprType arg_x) - r2 <- newTemp (cmmExprType arg_x) + = do dflags <- getDynFlags + r1 <- newTemp (cmmExprType dflags arg_x) + r2 <- newTemp (cmmExprType dflags arg_x) + let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww] + toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww] + bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm] + add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y] + or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y] + hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags))) + (wordWidth dflags)) + hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags)) emit $ catAGraphs [mkAssign (CmmLocal r1) (add (bottomHalf arg_x) (bottomHalf arg_y)), @@ -637,25 +645,28 @@ genericWordAdd2Op [res_h, res_l] [arg_x, arg_y] mkAssign (CmmLocal res_l) (or (toTopHalf (CmmReg (CmmLocal r2))) (bottomHalf (CmmReg (CmmLocal r1))))] - where topHalf x = CmmMachOp (MO_U_Shr wordWidth) [x, hww] - toTopHalf x = CmmMachOp (MO_Shl wordWidth) [x, hww] - bottomHalf x = CmmMachOp (MO_And wordWidth) [x, hwm] - add x y = CmmMachOp (MO_Add wordWidth) [x, y] - or x y = CmmMachOp (MO_Or wordWidth) [x, y] - hww = CmmLit (CmmInt (fromIntegral (widthInBits halfWordWidth)) - wordWidth) - hwm = CmmLit (CmmInt halfWordMask wordWidth) genericWordAdd2Op _ _ = panic "genericWordAdd2Op" genericWordMul2Op :: GenericOp genericWordMul2Op [res_h, res_l] [arg_x, arg_y] - = do let t = cmmExprType arg_x + = do dflags <- getDynFlags + let t = cmmExprType dflags arg_x xlyl <- liftM CmmLocal $ newTemp t xlyh <- liftM CmmLocal $ newTemp t xhyl <- liftM CmmLocal $ newTemp t r <- liftM CmmLocal $ newTemp t -- This generic implementation is very simple and slow. We might -- well be able to do better, but for now this at least works. + let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww] + toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww] + bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm] + add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y] + sum = foldl1 add + mul x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y] + or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y] + hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags))) + (wordWidth dflags)) + hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags)) emit $ catAGraphs [mkAssign xlyl (mul (bottomHalf arg_x) (bottomHalf arg_y)), @@ -675,16 +686,6 @@ genericWordMul2Op [res_h, res_l] [arg_x, arg_y] topHalf (CmmReg xhyl), topHalf (CmmReg xlyh), topHalf (CmmReg r)])] - where topHalf x = CmmMachOp (MO_U_Shr wordWidth) [x, hww] - toTopHalf x = CmmMachOp (MO_Shl wordWidth) [x, hww] - bottomHalf x = CmmMachOp (MO_And wordWidth) [x, hwm] - add x y = CmmMachOp (MO_Add wordWidth) [x, y] - sum = foldl1 add - mul x y = CmmMachOp (MO_Mul wordWidth) [x, y] - or x y = CmmMachOp (MO_Or wordWidth) [x, y] - hww = CmmLit (CmmInt (fromIntegral (widthInBits halfWordWidth)) - wordWidth) - hwm = CmmLit (CmmInt halfWordMask wordWidth) genericWordMul2Op _ _ = panic "genericWordMul2Op" -- These PrimOps are NOPs in Cmm @@ -711,125 +712,125 @@ narrowOp _ = Nothing -- Native word signless ops -translateOp :: PrimOp -> Maybe MachOp -translateOp IntAddOp = Just mo_wordAdd -translateOp IntSubOp = Just mo_wordSub -translateOp WordAddOp = Just mo_wordAdd -translateOp WordSubOp = Just mo_wordSub -translateOp AddrAddOp = Just mo_wordAdd -translateOp AddrSubOp = Just mo_wordSub - -translateOp IntEqOp = Just mo_wordEq -translateOp IntNeOp = Just mo_wordNe -translateOp WordEqOp = Just mo_wordEq -translateOp WordNeOp = Just mo_wordNe -translateOp AddrEqOp = Just mo_wordEq -translateOp AddrNeOp = Just mo_wordNe - -translateOp AndOp = Just mo_wordAnd -translateOp OrOp = Just mo_wordOr -translateOp XorOp = Just mo_wordXor -translateOp NotOp = Just mo_wordNot -translateOp SllOp = Just mo_wordShl -translateOp SrlOp = Just mo_wordUShr - -translateOp AddrRemOp = Just mo_wordURem +translateOp :: DynFlags -> PrimOp -> Maybe MachOp +translateOp dflags IntAddOp = Just (mo_wordAdd dflags) +translateOp dflags IntSubOp = Just (mo_wordSub dflags) +translateOp dflags WordAddOp = Just (mo_wordAdd dflags) +translateOp dflags WordSubOp = Just (mo_wordSub dflags) +translateOp dflags AddrAddOp = Just (mo_wordAdd dflags) +translateOp dflags AddrSubOp = Just (mo_wordSub dflags) + +translateOp dflags IntEqOp = Just (mo_wordEq dflags) +translateOp dflags IntNeOp = Just (mo_wordNe dflags) +translateOp dflags WordEqOp = Just (mo_wordEq dflags) +translateOp dflags WordNeOp = Just (mo_wordNe dflags) +translateOp dflags AddrEqOp = Just (mo_wordEq dflags) +translateOp dflags AddrNeOp = Just (mo_wordNe dflags) + +translateOp dflags AndOp = Just (mo_wordAnd dflags) +translateOp dflags OrOp = Just (mo_wordOr dflags) +translateOp dflags XorOp = Just (mo_wordXor dflags) +translateOp dflags NotOp = Just (mo_wordNot dflags) +translateOp dflags SllOp = Just (mo_wordShl dflags) +translateOp dflags SrlOp = Just (mo_wordUShr dflags) + +translateOp dflags AddrRemOp = Just (mo_wordURem dflags) -- Native word signed ops -translateOp IntMulOp = Just mo_wordMul -translateOp IntMulMayOfloOp = Just (MO_S_MulMayOflo wordWidth) -translateOp IntQuotOp = Just mo_wordSQuot -translateOp IntRemOp = Just mo_wordSRem -translateOp IntNegOp = Just mo_wordSNeg +translateOp dflags IntMulOp = Just (mo_wordMul dflags) +translateOp dflags IntMulMayOfloOp = Just (MO_S_MulMayOflo (wordWidth dflags)) +translateOp dflags IntQuotOp = Just (mo_wordSQuot dflags) +translateOp dflags IntRemOp = Just (mo_wordSRem dflags) +translateOp dflags IntNegOp = Just (mo_wordSNeg dflags) -translateOp IntGeOp = Just mo_wordSGe -translateOp IntLeOp = Just mo_wordSLe -translateOp IntGtOp = Just mo_wordSGt -translateOp IntLtOp = Just mo_wordSLt +translateOp dflags IntGeOp = Just (mo_wordSGe dflags) +translateOp dflags IntLeOp = Just (mo_wordSLe dflags) +translateOp dflags IntGtOp = Just (mo_wordSGt dflags) +translateOp dflags IntLtOp = Just (mo_wordSLt dflags) -translateOp ISllOp = Just mo_wordShl -translateOp ISraOp = Just mo_wordSShr -translateOp ISrlOp = Just mo_wordUShr +translateOp dflags ISllOp = Just (mo_wordShl dflags) +translateOp dflags ISraOp = Just (mo_wordSShr dflags) +translateOp dflags ISrlOp = Just (mo_wordUShr dflags) -- Native word unsigned ops -translateOp WordGeOp = Just mo_wordUGe -translateOp WordLeOp = Just mo_wordULe -translateOp WordGtOp = Just mo_wordUGt -translateOp WordLtOp = Just mo_wordULt +translateOp dflags WordGeOp = Just (mo_wordUGe dflags) +translateOp dflags WordLeOp = Just (mo_wordULe dflags) +translateOp dflags WordGtOp = Just (mo_wordUGt dflags) +translateOp dflags WordLtOp = Just (mo_wordULt dflags) -translateOp WordMulOp = Just mo_wordMul -translateOp WordQuotOp = Just mo_wordUQuot -translateOp WordRemOp = Just mo_wordURem +translateOp dflags WordMulOp = Just (mo_wordMul dflags) +translateOp dflags WordQuotOp = Just (mo_wordUQuot dflags) +translateOp dflags WordRemOp = Just (mo_wordURem dflags) -translateOp AddrGeOp = Just mo_wordUGe -translateOp AddrLeOp = Just mo_wordULe -translateOp AddrGtOp = Just mo_wordUGt -translateOp AddrLtOp = Just mo_wordULt +translateOp dflags AddrGeOp = Just (mo_wordUGe dflags) +translateOp dflags AddrLeOp = Just (mo_wordULe dflags) +translateOp dflags AddrGtOp = Just (mo_wordUGt dflags) +translateOp dflags AddrLtOp = Just (mo_wordULt dflags) -- Char# ops -translateOp CharEqOp = Just (MO_Eq wordWidth) -translateOp CharNeOp = Just (MO_Ne wordWidth) -translateOp CharGeOp = Just (MO_U_Ge wordWidth) -translateOp CharLeOp = Just (MO_U_Le wordWidth) -translateOp CharGtOp = Just (MO_U_Gt wordWidth) -translateOp CharLtOp = Just (MO_U_Lt wordWidth) +translateOp dflags CharEqOp = Just (MO_Eq (wordWidth dflags)) +translateOp dflags CharNeOp = Just (MO_Ne (wordWidth dflags)) +translateOp dflags CharGeOp = Just (MO_U_Ge (wordWidth dflags)) +translateOp dflags CharLeOp = Just (MO_U_Le (wordWidth dflags)) +translateOp dflags CharGtOp = Just (MO_U_Gt (wordWidth dflags)) +translateOp dflags CharLtOp = Just (MO_U_Lt (wordWidth dflags)) -- Double ops -translateOp DoubleEqOp = Just (MO_F_Eq W64) -translateOp DoubleNeOp = Just (MO_F_Ne W64) -translateOp DoubleGeOp = Just (MO_F_Ge W64) -translateOp DoubleLeOp = Just (MO_F_Le W64) -translateOp DoubleGtOp = Just (MO_F_Gt W64) -translateOp DoubleLtOp = Just (MO_F_Lt W64) +translateOp _ DoubleEqOp = Just (MO_F_Eq W64) +translateOp _ DoubleNeOp = Just (MO_F_Ne W64) +translateOp _ DoubleGeOp = Just (MO_F_Ge W64) +translateOp _ DoubleLeOp = Just (MO_F_Le W64) +translateOp _ DoubleGtOp = Just (MO_F_Gt W64) +translateOp _ DoubleLtOp = Just (MO_F_Lt W64) -translateOp DoubleAddOp = Just (MO_F_Add W64) -translateOp DoubleSubOp = Just (MO_F_Sub W64) -translateOp DoubleMulOp = Just (MO_F_Mul W64) -translateOp DoubleDivOp = Just (MO_F_Quot W64) -translateOp DoubleNegOp = Just (MO_F_Neg W64) +translateOp _ DoubleAddOp = Just (MO_F_Add W64) +translateOp _ DoubleSubOp = Just (MO_F_Sub W64) +translateOp _ DoubleMulOp = Just (MO_F_Mul W64) +translateOp _ DoubleDivOp = Just (MO_F_Quot W64) +translateOp _ DoubleNegOp = Just (MO_F_Neg W64) -- Float ops -translateOp FloatEqOp = Just (MO_F_Eq W32) -translateOp FloatNeOp = Just (MO_F_Ne W32) -translateOp FloatGeOp = Just (MO_F_Ge W32) -translateOp FloatLeOp = Just (MO_F_Le W32) -translateOp FloatGtOp = Just (MO_F_Gt W32) -translateOp FloatLtOp = Just (MO_F_Lt W32) +translateOp _ FloatEqOp = Just (MO_F_Eq W32) +translateOp _ FloatNeOp = Just (MO_F_Ne W32) +translateOp _ FloatGeOp = Just (MO_F_Ge W32) +translateOp _ FloatLeOp = Just (MO_F_Le W32) +translateOp _ FloatGtOp = Just (MO_F_Gt W32) +translateOp _ FloatLtOp = Just (MO_F_Lt W32) -translateOp FloatAddOp = Just (MO_F_Add W32) -translateOp FloatSubOp = Just (MO_F_Sub W32) -translateOp FloatMulOp = Just (MO_F_Mul W32) -translateOp FloatDivOp = Just (MO_F_Quot W32) -translateOp FloatNegOp = Just (MO_F_Neg W32) +translateOp _ FloatAddOp = Just (MO_F_Add W32) +translateOp _ FloatSubOp = Just (MO_F_Sub W32) +translateOp _ FloatMulOp = Just (MO_F_Mul W32) +translateOp _ FloatDivOp = Just (MO_F_Quot W32) +translateOp _ FloatNegOp = Just (MO_F_Neg W32) -- Conversions -translateOp Int2DoubleOp = Just (MO_SF_Conv wordWidth W64) -translateOp Double2IntOp = Just (MO_FS_Conv W64 wordWidth) +translateOp dflags Int2DoubleOp = Just (MO_SF_Conv (wordWidth dflags) W64) +translateOp dflags Double2IntOp = Just (MO_FS_Conv W64 (wordWidth dflags)) -translateOp Int2FloatOp = Just (MO_SF_Conv wordWidth W32) -translateOp Float2IntOp = Just (MO_FS_Conv W32 wordWidth) +translateOp dflags Int2FloatOp = Just (MO_SF_Conv (wordWidth dflags) W32) +translateOp dflags Float2IntOp = Just (MO_FS_Conv W32 (wordWidth dflags)) -translateOp Float2DoubleOp = Just (MO_FF_Conv W32 W64) -translateOp Double2FloatOp = Just (MO_FF_Conv W64 W32) +translateOp _ Float2DoubleOp = Just (MO_FF_Conv W32 W64) +translateOp _ Double2FloatOp = Just (MO_FF_Conv W64 W32) -- Word comparisons masquerading as more exotic things. -translateOp SameMutVarOp = Just mo_wordEq -translateOp SameMVarOp = Just mo_wordEq -translateOp SameMutableArrayOp = Just mo_wordEq -translateOp SameMutableByteArrayOp = Just mo_wordEq -translateOp SameMutableArrayArrayOp= Just mo_wordEq -translateOp SameTVarOp = Just mo_wordEq -translateOp EqStablePtrOp = Just mo_wordEq +translateOp dflags SameMutVarOp = Just (mo_wordEq dflags) +translateOp dflags SameMVarOp = Just (mo_wordEq dflags) +translateOp dflags SameMutableArrayOp = Just (mo_wordEq dflags) +translateOp dflags SameMutableByteArrayOp = Just (mo_wordEq dflags) +translateOp dflags SameMutableArrayArrayOp= Just (mo_wordEq dflags) +translateOp dflags SameTVarOp = Just (mo_wordEq dflags) +translateOp dflags EqStablePtrOp = Just (mo_wordEq dflags) -translateOp _ = Nothing +translateOp _ _ = Nothing -- These primops are implemented by CallishMachOps, because they sometimes -- turn into foreign calls depending on the backend. @@ -884,7 +885,7 @@ doIndexByteArrayOp _ _ _ _ doReadPtrArrayOp :: LocalReg -> CmmExpr -> CmmExpr -> FCode () doReadPtrArrayOp res addr idx = do dflags <- getDynFlags - mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing gcWord res addr idx + mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr idx doWriteOffAddrOp :: Maybe MachOp -> [LocalReg] -> [CmmExpr] -> FCode () @@ -908,42 +909,45 @@ doWritePtrArrayOp addr idx val -- the write barrier. We must write a byte into the mark table: -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N] emit $ mkStore ( - cmmOffsetExpr - (cmmOffsetExprW (cmmOffsetB addr (arrPtrsHdrSize dflags)) + cmmOffsetExpr dflags + (cmmOffsetExprW dflags (cmmOffsetB dflags addr (arrPtrsHdrSize dflags)) (loadArrPtrsSize dflags addr)) - (CmmMachOp mo_wordUShr [idx, - CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)]) + (CmmMachOp (mo_wordUShr dflags) [idx, + mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags)]) ) (CmmLit (CmmInt 1 W8)) loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr -loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB addr off) bWord - where off = fixedHdrSize dflags * wORD_SIZE + oFFSET_StgMutArrPtrs_ptrs +loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB dflags addr off) (bWord dflags) + where off = fixedHdrSize dflags * wORD_SIZE dflags + oFFSET_StgMutArrPtrs_ptrs dflags mkBasicIndexedRead :: ByteOff -> Maybe MachOp -> CmmType -> LocalReg -> CmmExpr -> CmmExpr -> FCode () mkBasicIndexedRead off Nothing read_rep res base idx - = emitAssign (CmmLocal res) (cmmLoadIndexOffExpr off read_rep base idx) + = do dflags <- getDynFlags + emitAssign (CmmLocal res) (cmmLoadIndexOffExpr dflags off read_rep base idx) mkBasicIndexedRead off (Just cast) read_rep res base idx - = emitAssign (CmmLocal res) (CmmMachOp cast [ - cmmLoadIndexOffExpr off read_rep base idx]) + = do dflags <- getDynFlags + emitAssign (CmmLocal res) (CmmMachOp cast [ + cmmLoadIndexOffExpr dflags off read_rep base idx]) mkBasicIndexedWrite :: ByteOff -> Maybe MachOp -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () mkBasicIndexedWrite off Nothing base idx val - = emitStore (cmmIndexOffExpr off (typeWidth (cmmExprType val)) base idx) val + = do dflags <- getDynFlags + emitStore (cmmIndexOffExpr dflags off (typeWidth (cmmExprType dflags val)) base idx) val mkBasicIndexedWrite off (Just cast) base idx val = mkBasicIndexedWrite off Nothing base idx (CmmMachOp cast [val]) -- ---------------------------------------------------------------------------- -- Misc utils -cmmIndexOffExpr :: ByteOff -> Width -> CmmExpr -> CmmExpr -> CmmExpr -cmmIndexOffExpr off width base idx - = cmmIndexExpr width (cmmOffsetB base off) idx +cmmIndexOffExpr :: DynFlags -> ByteOff -> Width -> CmmExpr -> CmmExpr -> CmmExpr +cmmIndexOffExpr dflags off width base idx + = cmmIndexExpr dflags width (cmmOffsetB dflags base off) idx -cmmLoadIndexOffExpr :: ByteOff -> CmmType -> CmmExpr -> CmmExpr -> CmmExpr -cmmLoadIndexOffExpr off ty base idx - = CmmLoad (cmmIndexOffExpr off (typeWidth ty) base idx) ty +cmmLoadIndexOffExpr :: DynFlags -> ByteOff -> CmmType -> CmmExpr -> CmmExpr -> CmmExpr +cmmLoadIndexOffExpr dflags off ty base idx + = CmmLoad (cmmIndexOffExpr dflags off (typeWidth ty) base idx) ty setInfo :: CmmExpr -> CmmExpr -> CmmAGraph setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr @@ -962,7 +966,8 @@ doCopyByteArrayOp = emitCopyByteArray copy -- Copy data (we assume the arrays aren't overlapping since -- they're of different types) copy _src _dst dst_p src_p bytes = - emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit 1)) + do dflags <- getDynFlags + emitMemcpyCall dst_p src_p bytes (mkIntExpr dflags 1) -- | Takes a source 'MutableByteArray#', an offset in the source -- array, a destination 'MutableByteArray#', an offset into the @@ -977,11 +982,12 @@ doCopyMutableByteArrayOp = emitCopyByteArray copy -- we were provided are the same array! -- TODO: Optimize branch for common case of no aliasing. copy src dst dst_p src_p bytes = do + dflags <- getDynFlags [moveCall, cpyCall] <- forkAlts [ - getCode $ emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit 1)), - getCode $ emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit 1)) + getCode $ emitMemmoveCall dst_p src_p bytes (mkIntExpr dflags 1), + getCode $ emitMemcpyCall dst_p src_p bytes (mkIntExpr dflags 1) ] - emit =<< mkCmmIfThenElse (cmmEqWord src dst) moveCall cpyCall + emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()) @@ -989,8 +995,8 @@ emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () emitCopyByteArray copy src src_off dst dst_off n = do dflags <- getDynFlags - dst_p <- assignTempE $ cmmOffsetExpr (cmmOffsetB dst (arrWordsHdrSize dflags)) dst_off - src_p <- assignTempE $ cmmOffsetExpr (cmmOffsetB src (arrWordsHdrSize dflags)) src_off + dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off + src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off copy src dst dst_p src_p n -- ---------------------------------------------------------------------------- @@ -1003,8 +1009,8 @@ doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () doSetByteArrayOp ba off len c = do dflags <- getDynFlags - p <- assignTempE $ cmmOffsetExpr (cmmOffsetB ba (arrWordsHdrSize dflags)) off - emitMemsetCall p c len (CmmLit (mkIntCLit 1)) + p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off + emitMemsetCall p c len (mkIntExpr dflags 1) -- ---------------------------------------------------------------------------- -- Copying pointer arrays @@ -1034,7 +1040,8 @@ doCopyArrayOp = emitCopyArray copy -- Copy data (we assume the arrays aren't overlapping since -- they're of different types) copy _src _dst dst_p src_p bytes = - emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)) + do dflags <- getDynFlags + emitMemcpyCall dst_p src_p bytes (mkIntExpr dflags (wORD_SIZE dflags)) -- | Takes a source 'MutableArray#', an offset in the source array, a @@ -1049,11 +1056,12 @@ doCopyMutableArrayOp = emitCopyArray copy -- we were provided are the same array! -- TODO: Optimize branch for common case of no aliasing. copy src dst dst_p src_p bytes = do + dflags <- getDynFlags [moveCall, cpyCall] <- forkAlts [ - getCode $ emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)), - getCode $ emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)) + getCode $ emitMemmoveCall dst_p src_p bytes (mkIntExpr dflags (wORD_SIZE dflags)), + getCode $ emitMemcpyCall dst_p src_p bytes (mkIntExpr dflags (wORD_SIZE dflags)) ] - emit =<< mkCmmIfThenElse (cmmEqWord src dst) moveCall cpyCall + emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()) @@ -1071,15 +1079,15 @@ emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 = do -- Set the dirty bit in the header. emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) - dst_elems_p <- assignTempE $ cmmOffsetB dst (arrPtrsHdrSize dflags) - dst_p <- assignTempE $ cmmOffsetExprW dst_elems_p dst_off - src_p <- assignTempE $ cmmOffsetExprW (cmmOffsetB src (arrPtrsHdrSize dflags)) src_off - bytes <- assignTempE $ cmmMulWord n (CmmLit (mkIntCLit wORD_SIZE)) + dst_elems_p <- assignTempE $ cmmOffsetB dflags dst (arrPtrsHdrSize dflags) + dst_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p dst_off + src_p <- assignTempE $ cmmOffsetExprW dflags (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off + bytes <- assignTempE $ cmmMulWord dflags n (mkIntExpr dflags (wORD_SIZE dflags)) copy src dst dst_p src_p bytes -- The base address of the destination card table - dst_cards_p <- assignTempE $ cmmOffsetExprW dst_elems_p (loadArrPtrsSize dflags dst) + dst_cards_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p (loadArrPtrsSize dflags dst) emitSetCards dst_off dst_cards_p n @@ -1090,62 +1098,69 @@ emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 = do emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () emitCloneArray info_p res_r src0 src_off0 n0 = do + dflags <- getDynFlags + let arrPtrsHdrSizeW dflags = mkIntExpr dflags (fixedHdrSize dflags + + (sIZEOF_StgMutArrPtrs_NoHdr dflags `div` wORD_SIZE dflags)) + myCapability = cmmSubWord dflags (CmmReg baseReg) (mkIntExpr dflags (oFFSET_Capability_r dflags)) -- Passed as arguments (be careful) src <- assignTempE src0 src_off <- assignTempE src_off0 n <- assignTempE n0 - card_words <- assignTempE $ (n `cmmUShrWord` - (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS))) - `cmmAddWord` CmmLit (mkIntCLit 1) - size <- assignTempE $ n `cmmAddWord` card_words - dflags <- getDynFlags - words <- assignTempE $ arrPtrsHdrSizeW dflags `cmmAddWord` size + card_bytes <- assignTempE $ cardRoundUp dflags n + size <- assignTempE $ cmmAddWord dflags n (bytesToWordsRoundUp dflags card_bytes) + words <- assignTempE $ cmmAddWord dflags (arrPtrsHdrSizeW dflags) size - arr_r <- newTemp bWord + arr_r <- newTemp (bWord dflags) emitAllocateCall arr_r myCapability words - tickyAllocPrim (CmmLit (mkIntCLit (arrPtrsHdrSize dflags))) (n `cmmMulWord` wordSize) - (CmmLit $ mkIntCLit 0) + tickyAllocPrim (mkIntExpr dflags (arrPtrsHdrSize dflags)) (cmmMulWord dflags n (wordSize dflags)) + (zeroExpr dflags) let arr = CmmReg (CmmLocal arr_r) emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCS - emit $ mkStore (cmmOffsetB arr (fixedHdrSize dflags * wORD_SIZE + - oFFSET_StgMutArrPtrs_ptrs)) n - emit $ mkStore (cmmOffsetB arr (fixedHdrSize dflags * wORD_SIZE + - oFFSET_StgMutArrPtrs_size)) size + emit $ mkStore (cmmOffsetB dflags arr (fixedHdrSize dflags * wORD_SIZE dflags + + oFFSET_StgMutArrPtrs_ptrs dflags)) n + emit $ mkStore (cmmOffsetB dflags arr (fixedHdrSize dflags * wORD_SIZE dflags + + oFFSET_StgMutArrPtrs_size dflags)) size - dst_p <- assignTempE $ cmmOffsetB arr (arrPtrsHdrSize dflags) - src_p <- assignTempE $ cmmOffsetExprW (cmmOffsetB src (arrPtrsHdrSize dflags)) + dst_p <- assignTempE $ cmmOffsetB dflags arr (arrPtrsHdrSize dflags) + src_p <- assignTempE $ cmmOffsetExprW dflags (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off - emitMemcpyCall dst_p src_p (n `cmmMulWord` wordSize) (CmmLit (mkIntCLit wORD_SIZE)) + emitMemcpyCall dst_p src_p (cmmMulWord dflags n (wordSize dflags)) (mkIntExpr dflags (wORD_SIZE dflags)) - emitMemsetCall (cmmOffsetExprW dst_p n) - (CmmLit (mkIntCLit 1)) - (card_words `cmmMulWord` wordSize) - (CmmLit (mkIntCLit wORD_SIZE)) + emitMemsetCall (cmmOffsetExprW dflags dst_p n) + (mkIntExpr dflags 1) + card_bytes + (mkIntExpr dflags (wORD_SIZE dflags)) emit $ mkAssign (CmmLocal res_r) arr - where - arrPtrsHdrSizeW dflags = CmmLit $ mkIntCLit $ fixedHdrSize dflags + - (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE) - wordSize = CmmLit (mkIntCLit wORD_SIZE) - myCapability = CmmReg baseReg `cmmSubWord` - CmmLit (mkIntCLit oFFSET_Capability_r) -- | Takes and offset in the destination array, the base address of -- the card table, and the number of elements affected (*not* the -- number of cards). Marks the relevant cards as dirty. emitSetCards :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () emitSetCards dst_start dst_cards_start n = do - start_card <- assignTempE $ card dst_start - emitMemsetCall (dst_cards_start `cmmAddWord` start_card) - (CmmLit (mkIntCLit 1)) - ((card (dst_start `cmmAddWord` n) `cmmSubWord` start_card) - `cmmAddWord` CmmLit (mkIntCLit 1)) - (CmmLit (mkIntCLit wORD_SIZE)) - where - -- Convert an element index to a card index - card i = i `cmmUShrWord` (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)) + dflags <- getDynFlags + start_card <- assignTempE $ card dflags dst_start + emitMemsetCall (cmmAddWord dflags dst_cards_start start_card) + (mkIntExpr dflags 1) + (cardRoundUp dflags n) + (mkIntExpr dflags 1) -- no alignment (1 byte) + +-- Convert an element index to a card index +card :: DynFlags -> CmmExpr -> CmmExpr +card dflags i = cmmUShrWord dflags i (mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags)) + +-- Convert a number of elements to a number of cards, rounding up +cardRoundUp :: DynFlags -> CmmExpr -> CmmExpr +cardRoundUp dflags i = card dflags (cmmAddWord dflags i (mkIntExpr dflags ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS dflags) - 1))) + +bytesToWordsRoundUp :: DynFlags -> CmmExpr -> CmmExpr +bytesToWordsRoundUp dflags e = cmmQuotWord dflags (cmmAddWord dflags e (mkIntExpr dflags (wORD_SIZE dflags - 1))) + (wordSize dflags) + +wordSize :: DynFlags -> CmmExpr +wordSize dflags = mkIntExpr dflags (wORD_SIZE dflags) -- | Emit a call to @memcpy@. emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index 56c02d040f..e6e9899040 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -54,7 +54,6 @@ import CostCentre import DynFlags import FastString import Module -import Constants -- Lots of field offsets import Outputable import Control.Monad @@ -67,10 +66,10 @@ import Data.Char (ord) ----------------------------------------------------------------------------- -- Expression representing the current cost centre stack -ccsType :: CmmType -- Type of a cost-centre stack +ccsType :: DynFlags -> CmmType -- Type of a cost-centre stack ccsType = bWord -ccType :: CmmType -- Type of a cost centre +ccType :: DynFlags -> CmmType -- Type of a cost centre ccType = bWord curCCS :: CmmExpr @@ -85,25 +84,28 @@ mkCCostCentre cc = CmmLabel (mkCCLabel cc) mkCCostCentreStack :: CostCentreStack -> CmmLit mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs) -costCentreFrom :: CmmExpr -- A closure pointer +costCentreFrom :: DynFlags + -> CmmExpr -- A closure pointer -> CmmExpr -- The cost centre from that closure -costCentreFrom cl = CmmLoad (cmmOffsetB cl oFFSET_StgHeader_ccs) ccsType +costCentreFrom dflags cl = CmmLoad (cmmOffsetB dflags cl (oFFSET_StgHeader_ccs dflags)) (ccsType dflags) staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit] -- The profiling header words in a static closure -- Was SET_STATIC_PROF_HDR staticProfHdr dflags ccs - = ifProfilingL dflags [mkCCostCentreStack ccs, staticLdvInit] + = ifProfilingL dflags [mkCCostCentreStack ccs, staticLdvInit dflags] dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr] -- Profiling header words in a dynamic closure -dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit] +dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags] initUpdFrameProf :: ByteOff -> FCode () -- Initialise the profiling field of an update frame initUpdFrameProf frame_off = ifProfiling $ -- frame->header.prof.ccs = CCCS - emitStore (CmmStackSlot Old (frame_off - oFFSET_StgHeader_ccs)) curCCS + do dflags <- getDynFlags + emitStore (CmmStackSlot Old (frame_off - oFFSET_StgHeader_ccs dflags)) + curCCS -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0) -- is unnecessary because it is not used anyhow. @@ -142,7 +144,7 @@ saveCurrentCostCentre = do dflags <- getDynFlags if not (dopt Opt_SccProfilingOn dflags) then return Nothing - else do local_cc <- newTemp ccType + else do local_cc <- newTemp (ccType dflags) emitAssign (CmmLocal local_cc) curCCS return (Just local_cc) @@ -163,7 +165,7 @@ profDynAlloc :: SMRep -> CmmExpr -> FCode () profDynAlloc rep ccs = ifProfiling $ do dflags <- getDynFlags - profAlloc (CmmLit (mkIntCLit (heapClosureSize dflags rep))) ccs + profAlloc (mkIntExpr dflags (heapClosureSize dflags rep)) ccs -- | Record the allocation of a closure (size is given by a CmmExpr) -- The size must be in words, because the allocation counter in a CCS counts @@ -173,10 +175,10 @@ profAlloc words ccs = ifProfiling $ do dflags <- getDynFlags emit (addToMemE alloc_rep - (cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc) - (CmmMachOp (MO_UU_Conv wordWidth (typeWidth alloc_rep)) $ - [CmmMachOp mo_wordSub [words, - CmmLit (mkIntCLit (profHdrSize dflags))]])) + (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_mem_alloc dflags)) + (CmmMachOp (MO_UU_Conv (wordWidth dflags) (typeWidth alloc_rep)) $ + [CmmMachOp (mo_wordSub dflags) [words, + mkIntExpr dflags (profHdrSize dflags)]])) -- subtract the "profiling overhead", which is the -- profiling header in a closure. where @@ -187,16 +189,18 @@ profAlloc words ccs enterCostCentreThunk :: CmmExpr -> FCode () enterCostCentreThunk closure = - ifProfiling $ do - emit $ storeCurCCS (costCentreFrom closure) + ifProfiling $ do + dflags <- getDynFlags + emit $ storeCurCCS (costCentreFrom dflags closure) enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode () enterCostCentreFun ccs closure = ifProfiling $ do if isCurrentCCS ccs - then emitRtsCall rtsPackageId (fsLit "enterFunCCS") - [(CmmReg (CmmGlobal BaseReg), AddrHint), - (costCentreFrom closure, AddrHint)] False + then do dflags <- getDynFlags + emitRtsCall rtsPackageId (fsLit "enterFunCCS") + [(CmmReg (CmmGlobal BaseReg), AddrHint), + (costCentreFrom dflags closure, AddrHint)] False else return () -- top-level function, nothing to do ifProfiling :: FCode () -> FCode () @@ -227,58 +231,58 @@ initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs) emitCostCentreDecl :: CostCentre -> FCode () emitCostCentreDecl cc = do + { dflags <- getDynFlags + ; let is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF + | otherwise = zero dflags -- NB. bytesFS: we want the UTF-8 bytes here (#5559) - { label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc) + ; label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc) ; modl <- newByteStringCLit (bytesFS $ Module.moduleNameFS $ Module.moduleName $ cc_mod cc) - ; dflags <- getDynFlags ; loc <- newByteStringCLit $ bytesFS $ mkFastString $ showPpr dflags (costCentreSrcSpan cc) -- XXX going via FastString to get UTF-8 encoding is silly ; let - lits = [ zero, -- StgInt ccID, + lits = [ zero dflags, -- StgInt ccID, label, -- char *label, modl, -- char *module, loc, -- char *srcloc, zero64, -- StgWord64 mem_alloc - zero, -- StgWord time_ticks + zero dflags, -- StgWord time_ticks is_caf, -- StgInt is_caf - zero -- struct _CostCentre *link + zero dflags -- struct _CostCentre *link ] ; emitDataLits (mkCCLabel cc) lits } - where - is_caf | isCafCC cc = mkIntCLit (ord 'c') -- 'c' == is a CAF - | otherwise = zero emitCostCentreStackDecl :: CostCentreStack -> FCode () emitCostCentreStackDecl ccs = case maybeSingletonCCS ccs of - Just cc -> emitDataLits (mkCCSLabel ccs) (mk_lits cc) - Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs) - where - mk_lits cc = zero : - mkCCostCentre cc : - replicate (sizeof_ccs_words - 2) zero - -- Note: to avoid making any assumptions about how the - -- C compiler (that compiles the RTS, in particular) does - -- layouts of structs containing long-longs, simply - -- pad out the struct with zero words until we hit the - -- size of the overall struct (which we get via DerivedConstants.h) - -zero :: CmmLit -zero = mkIntCLit 0 + Just cc -> + do dflags <- getDynFlags + let mk_lits cc = zero dflags : + mkCCostCentre cc : + replicate (sizeof_ccs_words dflags - 2) (zero dflags) + -- Note: to avoid making any assumptions about how the + -- C compiler (that compiles the RTS, in particular) does + -- layouts of structs containing long-longs, simply + -- pad out the struct with zero words until we hit the + -- size of the overall struct (which we get via DerivedConstants.h) + emitDataLits (mkCCSLabel ccs) (mk_lits cc) + Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs) + +zero :: DynFlags -> CmmLit +zero dflags = mkIntCLit dflags 0 zero64 :: CmmLit zero64 = CmmInt 0 W64 -sizeof_ccs_words :: Int -sizeof_ccs_words +sizeof_ccs_words :: DynFlags -> Int +sizeof_ccs_words dflags -- round up to the next word. | ms == 0 = ws | otherwise = ws + 1 where - (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE + (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE dflags -- --------------------------------------------------------------------------- -- Set the current cost centre stack @@ -288,9 +292,9 @@ emitSetCCC cc tick push = do dflags <- getDynFlags if not (dopt Opt_SccProfilingOn dflags) then nopC - else do tmp <- newTemp ccsType -- TODO FIXME NOW + else do tmp <- newTemp (ccsType dflags) -- TODO FIXME NOW pushCostCentre tmp curCCS cc - when tick $ emit (bumpSccCount (CmmReg (CmmLocal tmp))) + when tick $ emit (bumpSccCount dflags (CmmReg (CmmLocal tmp))) when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp))) pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode () @@ -301,10 +305,10 @@ pushCostCentre result ccs cc (CmmLit (mkCCostCentre cc), AddrHint)] False -bumpSccCount :: CmmExpr -> CmmAGraph -bumpSccCount ccs +bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph +bumpSccCount dflags ccs = addToMem REP_CostCentreStack_scc_count - (cmmOffsetB ccs oFFSET_CostCentreStack_scc_count) 1 + (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1 ----------------------------------------------------------------------------- -- @@ -315,24 +319,25 @@ bumpSccCount ccs -- -- Initial value for the LDV field in a static closure -- -staticLdvInit :: CmmLit +staticLdvInit :: DynFlags -> CmmLit staticLdvInit = zeroCLit -- -- Initial value of the LDV field in a dynamic closure -- -dynLdvInit :: CmmExpr -dynLdvInit = -- (era << LDV_SHIFT) | LDV_STATE_CREATE - CmmMachOp mo_wordOr [ - CmmMachOp mo_wordShl [loadEra, CmmLit (mkIntCLit lDV_SHIFT) ], - CmmLit (mkWordCLit lDV_STATE_CREATE) +dynLdvInit :: DynFlags -> CmmExpr +dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE + CmmMachOp (mo_wordOr dflags) [ + CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags lDV_SHIFT ], + CmmLit (mkWordCLit dflags lDV_STATE_CREATE) ] -- -- Initialise the LDV word of a new closure -- ldvRecordCreate :: CmmExpr -> FCode () -ldvRecordCreate closure = emit $ mkStore (ldvWord closure) dynLdvInit +ldvRecordCreate closure = do dflags <- getDynFlags + emit $ mkStore (ldvWord dflags closure) (dynLdvInit dflags) -- -- Called when a closure is entered, marks the closure as having been "used". @@ -341,35 +346,37 @@ ldvRecordCreate closure = emit $ mkStore (ldvWord closure) dynLdvInit -- profiling. -- ldvEnterClosure :: ClosureInfo -> FCode () -ldvEnterClosure closure_info = ldvEnter (cmmOffsetB (CmmReg nodeReg) (-tag)) - where tag = funTag closure_info +ldvEnterClosure closure_info = do dflags <- getDynFlags + let tag = funTag dflags closure_info + ldvEnter (cmmOffsetB dflags (CmmReg nodeReg) (-tag)) -- don't forget to substract node's tag ldvEnter :: CmmExpr -> FCode () -- Argument is a closure pointer -ldvEnter cl_ptr - = ifProfiling $ - -- if (era > 0) { - -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) | - -- era | LDV_STATE_USE } - emit =<< mkCmmIfThenElse (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit]) - (mkStore ldv_wd new_ldv_wd) - mkNop - where - -- don't forget to substract node's tag - ldv_wd = ldvWord cl_ptr - new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd bWord) - (CmmLit (mkWordCLit lDV_CREATE_MASK))) - (cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE))) - -loadEra :: CmmExpr -loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth) +ldvEnter cl_ptr = do + dflags <- getDynFlags + let -- don't forget to substract node's tag + ldv_wd = ldvWord dflags cl_ptr + new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags)) + (CmmLit (mkWordCLit dflags lDV_CREATE_MASK))) + (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags lDV_STATE_USE))) + ifProfiling $ + -- if (era > 0) { + -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) | + -- era | LDV_STATE_USE } + emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt dflags) [loadEra dflags, CmmLit (zeroCLit dflags)]) + (mkStore ldv_wd new_ldv_wd) + mkNop + +loadEra :: DynFlags -> CmmExpr +loadEra dflags = CmmMachOp (MO_UU_Conv cIntWidth (wordWidth dflags)) [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "era"))) cInt] -ldvWord :: CmmExpr -> CmmExpr +ldvWord :: DynFlags -> CmmExpr -> CmmExpr -- Takes the address of a closure, and returns -- the address of the LDV word in the closure -ldvWord closure_ptr = cmmOffsetB closure_ptr oFFSET_StgHeader_ldvw +ldvWord dflags closure_ptr + = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags) -- LDV constants, from ghc/includes/Constants.h lDV_SHIFT :: Int diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs index ec8f674555..137764db3d 100644 --- a/compiler/codeGen/StgCmmTicky.hs +++ b/compiler/codeGen/StgCmmTicky.hs @@ -65,7 +65,6 @@ import Name import Id import BasicTypes import FastString -import Constants import Outputable import DynFlags @@ -106,14 +105,14 @@ emitTickyCounter cl_info args -- krc: note that all the fields are I32 now; some were I16 before, -- but the code generator wasn't handling that properly and it led to chaos, -- panic and disorder. - [ mkIntCLit 0, - mkIntCLit (length args), -- Arity - mkIntCLit 0, -- XXX: we no longer know this! Words passed on stack + [ mkIntCLit dflags 0, + mkIntCLit dflags (length args), -- Arity + mkIntCLit dflags 0, -- XXX: we no longer know this! Words passed on stack fun_descr_lit, arg_descr_lit, - zeroCLit, -- Entry count - zeroCLit, -- Allocs - zeroCLit -- Link + zeroCLit dflags, -- Entry count + zeroCLit dflags, -- Allocs + zeroCLit dflags -- Link ] } -- When printing the name of a thing in a ticky file, we want to @@ -164,10 +163,11 @@ tickyUpdateBhCaf cl_info tickyEnterFun :: ClosureInfo -> FCode () tickyEnterFun cl_info = ifTicky $ - do { bumpTickyCounter ctr + do { dflags <- getDynFlags + ; bumpTickyCounter ctr ; fun_ctr_lbl <- getTickyCtrLabel ; registerTickyCtr fun_ctr_lbl - ; bumpTickyCounter' (cmmLabelOffB fun_ctr_lbl oFFSET_StgEntCounter_entry_count) + ; bumpTickyCounter' (cmmLabelOffB fun_ctr_lbl (oFFSET_StgEntCounter_entry_count dflags)) } where ctr | isStaticClosure cl_info = (fsLit "ENT_STATIC_FUN_DIRECT_ctr") @@ -179,22 +179,23 @@ registerTickyCtr :: CLabel -> FCode () -- f_ct.link = ticky_entry_ctrs; /* hook this one onto the front of the list */ -- ticky_entry_ctrs = & (f_ct); /* mark it as "registered" */ -- f_ct.registeredp = 1 } -registerTickyCtr ctr_lbl - = emit =<< mkCmmIfThen test (catAGraphs register_stmts) - where +registerTickyCtr ctr_lbl = do + dflags <- getDynFlags + let -- krc: code generator doesn't handle Not, so we test for Eq 0 instead - test = CmmMachOp (MO_Eq wordWidth) - [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl - oFFSET_StgEntCounter_registeredp)) bWord, - CmmLit (mkIntCLit 0)] + test = CmmMachOp (MO_Eq (wordWidth dflags)) + [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl + (oFFSET_StgEntCounter_registeredp dflags))) (bWord dflags), + zeroExpr dflags] register_stmts - = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl oFFSET_StgEntCounter_link)) - (CmmLoad ticky_entry_ctrs bWord) - , mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl) - , mkStore (CmmLit (cmmLabelOffB ctr_lbl - oFFSET_StgEntCounter_registeredp)) - (CmmLit (mkIntCLit 1)) ] + = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_link dflags))) + (CmmLoad ticky_entry_ctrs (bWord dflags)) + , mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl) + , mkStore (CmmLit (cmmLabelOffB ctr_lbl + (oFFSET_StgEntCounter_registeredp dflags))) + (mkIntExpr dflags 1) ] ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs")) + emit =<< mkCmmIfThen test (catAGraphs register_stmts) tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode () tickyReturnOldCon arity @@ -314,14 +315,15 @@ tickyAllocHeap :: VirtualHpOffset -> FCode () -- Must be lazy in the amount of allocation! tickyAllocHeap hp = ifTicky $ - do { ticky_ctr <- getTickyCtrLabel + do { dflags <- getDynFlags + ; ticky_ctr <- getTickyCtrLabel ; emit $ catAGraphs $ if hp == 0 then [] -- Inside the emitMiddle to avoid control else [ -- dependency on the argument -- Bump the allcoation count in the StgEntCounter addToMem REP_StgEntCounter_allocs (CmmLit (cmmLabelOffB ticky_ctr - oFFSET_StgEntCounter_allocs)) hp, + (oFFSET_StgEntCounter_allocs dflags))) hp, -- Bump ALLOC_HEAP_ctr addToMemLbl cLong (mkCmmDataLabel rtsPackageId (fsLit "ALLOC_HEAP_ctr")) 1, -- Bump ALLOC_HEAP_tot @@ -332,8 +334,8 @@ tickyAllocHeap hp ifTicky :: FCode () -> FCode () ifTicky code = do dflags <- getDynFlags - if doingTickyProfiling dflags then code - else nopC + if dopt Opt_Ticky dflags then code + else nopC -- All the ticky-ticky counters are declared "unsigned long" in C bumpTickyCounter :: FastString -> FCode () diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 100d821cb0..4471b78151 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -57,7 +57,6 @@ import ForeignCall import IdInfo import Type import TyCon -import Constants import SMRep import Module import Literal @@ -68,7 +67,6 @@ import Unique import DynFlags import FastString import Outputable -import Platform import Data.Char import Data.List @@ -86,31 +84,32 @@ import Data.Maybe cgLit :: Literal -> FCode CmmLit cgLit (MachStr s) = newByteStringCLit (bytesFB s) -- not unpackFS; we want the UTF-8 byte stream. -cgLit other_lit = return (mkSimpleLit other_lit) +cgLit other_lit = do dflags <- getDynFlags + return (mkSimpleLit dflags other_lit) -mkLtOp :: Literal -> MachOp +mkLtOp :: DynFlags -> Literal -> MachOp -- On signed literals we must do a signed comparison -mkLtOp (MachInt _) = MO_S_Lt wordWidth -mkLtOp (MachFloat _) = MO_F_Lt W32 -mkLtOp (MachDouble _) = MO_F_Lt W64 -mkLtOp lit = MO_U_Lt (typeWidth (cmmLitType (mkSimpleLit lit))) +mkLtOp dflags (MachInt _) = MO_S_Lt (wordWidth dflags) +mkLtOp _ (MachFloat _) = MO_F_Lt W32 +mkLtOp _ (MachDouble _) = MO_F_Lt W64 +mkLtOp dflags lit = MO_U_Lt (typeWidth (cmmLitType dflags (mkSimpleLit dflags lit))) -- ToDo: seems terribly indirect! -mkSimpleLit :: Literal -> CmmLit -mkSimpleLit (MachChar c) = CmmInt (fromIntegral (ord c)) wordWidth -mkSimpleLit MachNullAddr = zeroCLit -mkSimpleLit (MachInt i) = CmmInt i wordWidth -mkSimpleLit (MachInt64 i) = CmmInt i W64 -mkSimpleLit (MachWord i) = CmmInt i wordWidth -mkSimpleLit (MachWord64 i) = CmmInt i W64 -mkSimpleLit (MachFloat r) = CmmFloat r W32 -mkSimpleLit (MachDouble r) = CmmFloat r W64 -mkSimpleLit (MachLabel fs ms fod) +mkSimpleLit :: DynFlags -> Literal -> CmmLit +mkSimpleLit dflags (MachChar c) = CmmInt (fromIntegral (ord c)) (wordWidth dflags) +mkSimpleLit dflags MachNullAddr = zeroCLit dflags +mkSimpleLit dflags (MachInt i) = CmmInt i (wordWidth dflags) +mkSimpleLit _ (MachInt64 i) = CmmInt i W64 +mkSimpleLit dflags (MachWord i) = CmmInt i (wordWidth dflags) +mkSimpleLit _ (MachWord64 i) = CmmInt i W64 +mkSimpleLit _ (MachFloat r) = CmmFloat r W32 +mkSimpleLit _ (MachDouble r) = CmmFloat r W64 +mkSimpleLit _ (MachLabel fs ms fod) = CmmLabel (mkForeignLabel fs ms labelSrc fod) where -- TODO: Literal labels might not actually be in the current package... labelSrc = ForeignLabelInThisPackage -mkSimpleLit other = pprPanic "mkSimpleLit" (ppr other) +mkSimpleLit _ other = pprPanic "mkSimpleLit" (ppr other) -------------------------------------------------------------------------- -- @@ -142,14 +141,15 @@ addToMemE rep ptr n -- ------------------------------------------------------------------------- -mkTaggedObjectLoad :: LocalReg -> LocalReg -> WordOff -> DynTag -> CmmAGraph +mkTaggedObjectLoad :: DynFlags -> LocalReg -> LocalReg -> WordOff -> DynTag -> CmmAGraph -- (loadTaggedObjectField reg base off tag) generates assignment -- reg = bitsK[ base + off - tag ] -- where K is fixed by 'reg' -mkTaggedObjectLoad reg base offset tag +mkTaggedObjectLoad dflags reg base offset tag = mkAssign (CmmLocal reg) - (CmmLoad (cmmOffsetB (CmmReg (CmmLocal base)) - (wORD_SIZE*offset - tag)) + (CmmLoad (cmmOffsetB dflags + (CmmReg (CmmLocal base)) + (wORD_SIZE dflags * offset - tag)) (localRegType reg)) ------------------------------------------------------------------------- @@ -159,9 +159,9 @@ mkTaggedObjectLoad reg base offset tag -- ------------------------------------------------------------------------- -tagToClosure :: TyCon -> CmmExpr -> CmmExpr -tagToClosure tycon tag - = CmmLoad (cmmOffsetExprW closure_tbl tag) bWord +tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr +tagToClosure dflags tycon tag + = CmmLoad (cmmOffsetExprW dflags closure_tbl tag) (bWord dflags) where closure_tbl = CmmLit (CmmLabel lbl) lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs @@ -251,11 +251,11 @@ callerSaveVolatileRegs dflags = (caller_save, caller_load) regs_to_save = filter (callerSaves platform) system_regs callerSaveGlobalReg reg - = mkStore (get_GlobalReg_addr platform reg) (CmmReg (CmmGlobal reg)) + = mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg)) callerRestoreGlobalReg reg = mkAssign (CmmGlobal reg) - (CmmLoad (get_GlobalReg_addr platform reg) (globalRegType reg)) + (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType dflags reg)) -- ----------------------------------------------------------------------------- -- Global registers @@ -266,42 +266,42 @@ callerSaveVolatileRegs dflags = (caller_save, caller_load) -- register table address for it. -- (See also get_GlobalReg_reg_or_addr in MachRegs) -get_GlobalReg_addr :: Platform -> GlobalReg -> CmmExpr -get_GlobalReg_addr _ BaseReg = regTableOffset 0 -get_GlobalReg_addr platform mid - = get_Regtable_addr_from_offset platform - (globalRegType mid) (baseRegOffset mid) +get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr +get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0 +get_GlobalReg_addr dflags mid + = get_Regtable_addr_from_offset dflags + (globalRegType dflags mid) (baseRegOffset dflags mid) -- Calculate a literal representing an offset into the register table. -- Used when we don't have an actual BaseReg to offset from. -regTableOffset :: Int -> CmmExpr -regTableOffset n = - CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n)) +regTableOffset :: DynFlags -> Int -> CmmExpr +regTableOffset dflags n = + CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n)) -get_Regtable_addr_from_offset :: Platform -> CmmType -> Int -> CmmExpr -get_Regtable_addr_from_offset platform _rep offset = - if haveRegBase platform +get_Regtable_addr_from_offset :: DynFlags -> CmmType -> Int -> CmmExpr +get_Regtable_addr_from_offset dflags _rep offset = + if haveRegBase (targetPlatform dflags) then CmmRegOff (CmmGlobal BaseReg) offset - else regTableOffset offset + else regTableOffset dflags offset -- ----------------------------------------------------------------------------- -- Information about global registers -baseRegOffset :: GlobalReg -> Int - -baseRegOffset Sp = oFFSET_StgRegTable_rSp -baseRegOffset SpLim = oFFSET_StgRegTable_rSpLim -baseRegOffset (LongReg 1) = oFFSET_StgRegTable_rL1 -baseRegOffset Hp = oFFSET_StgRegTable_rHp -baseRegOffset HpLim = oFFSET_StgRegTable_rHpLim -baseRegOffset CCCS = oFFSET_StgRegTable_rCCCS -baseRegOffset CurrentTSO = oFFSET_StgRegTable_rCurrentTSO -baseRegOffset CurrentNursery = oFFSET_StgRegTable_rCurrentNursery -baseRegOffset HpAlloc = oFFSET_StgRegTable_rHpAlloc -baseRegOffset GCEnter1 = oFFSET_stgGCEnter1 -baseRegOffset GCFun = oFFSET_stgGCFun -baseRegOffset reg = pprPanic "baseRegOffset:" (ppr reg) +baseRegOffset :: DynFlags -> GlobalReg -> Int + +baseRegOffset dflags Sp = oFFSET_StgRegTable_rSp dflags +baseRegOffset dflags SpLim = oFFSET_StgRegTable_rSpLim dflags +baseRegOffset dflags (LongReg 1) = oFFSET_StgRegTable_rL1 dflags +baseRegOffset dflags Hp = oFFSET_StgRegTable_rHp dflags +baseRegOffset dflags HpLim = oFFSET_StgRegTable_rHpLim dflags +baseRegOffset dflags CCCS = oFFSET_StgRegTable_rCCCS dflags +baseRegOffset dflags CurrentTSO = oFFSET_StgRegTable_rCurrentTSO dflags +baseRegOffset dflags CurrentNursery = oFFSET_StgRegTable_rCurrentNursery dflags +baseRegOffset dflags HpAlloc = oFFSET_StgRegTable_rHpAlloc dflags +baseRegOffset dflags GCEnter1 = oFFSET_stgGCEnter1 dflags +baseRegOffset dflags GCFun = oFFSET_stgGCFun dflags +baseRegOffset _ reg = pprPanic "baseRegOffset:" (ppr reg) ------------------------------------------------------------------------- -- @@ -344,8 +344,9 @@ assignTemp :: CmmExpr -> FCode LocalReg -- due to them being trashed on foreign calls--though it means -- the optimization pass doesn't have to do as much work) assignTemp (CmmReg (CmmLocal reg)) = return reg -assignTemp e = do { uniq <- newUnique - ; let reg = LocalReg uniq (cmmExprType e) +assignTemp e = do { dflags <- getDynFlags + ; uniq <- newUnique + ; let reg = LocalReg uniq (cmmExprType dflags e) ; emitAssign (CmmLocal reg) e ; return reg } @@ -360,8 +361,9 @@ newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint]) -- regs it wants will save later assignments. newUnboxedTupleRegs res_ty = ASSERT( isUnboxedTupleType res_ty ) - do { sequel <- getSequel - ; regs <- choose_regs sequel + do { dflags <- getDynFlags + ; sequel <- getSequel + ; regs <- choose_regs dflags sequel ; ASSERT( regs `equalLength` reps ) return (regs, map primRepForeignHint reps) } where @@ -370,8 +372,8 @@ newUnboxedTupleRegs res_ty | ty <- ty_args , let rep = typePrimRep ty , not (isVoidRep rep) ] - choose_regs (AssignTo regs _) = return regs - choose_regs _other = mapM (newTemp . primRepCmmType) reps + choose_regs _ (AssignTo regs _) = return regs + choose_regs dflags _ = mapM (newTemp . primRepCmmType dflags) reps @@ -423,17 +425,18 @@ unscramble vertices = mapM_ do_component components -- Cyclic? Then go via temporaries. Pick one to -- break the loop and try again with the rest. do_component (CyclicSCC ((_,first_stmt) : rest)) = do + dflags <- getDynFlags u <- newUnique - let (to_tmp, from_tmp) = split u first_stmt + let (to_tmp, from_tmp) = split dflags u first_stmt mk_graph to_tmp unscramble rest mk_graph from_tmp - split :: Unique -> Stmt -> (Stmt, Stmt) - split uniq (reg, rhs) + split :: DynFlags -> Unique -> Stmt -> (Stmt, Stmt) + split dflags uniq (reg, rhs) = ((tmp, rhs), (reg, CmmReg (CmmLocal tmp))) where - rep = cmmExprType rhs + rep = cmmExprType dflags rhs tmp = LocalReg uniq rep mk_graph :: Stmt -> FCode () @@ -510,11 +513,11 @@ mk_switch _tag_expr [(_tag,lbl)] Nothing _ _ _ -- SINGLETON BRANCH: one equality check to do mk_switch tag_expr [(tag,lbl)] (Just deflt) _ _ _ - = return (mkCbranch cond deflt lbl) - where - cond = cmmNeWord tag_expr (CmmLit (mkIntCLit tag)) - -- We have lo_tag < hi_tag, but there's only one branch, - -- so there must be a default + = do dflags <- getDynFlags + let cond = cmmNeWord dflags tag_expr (mkIntExpr dflags tag) + -- We have lo_tag < hi_tag, but there's only one branch, + -- so there must be a default + return (mkCbranch cond deflt lbl) -- ToDo: we might want to check for the two branch case, where one of -- the branches is the tag 0, because comparing '== 0' is likely to be @@ -531,7 +534,7 @@ mk_switch tag_expr [(tag,lbl)] (Just deflt) _ _ _ -- mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C | use_switch -- Use a switch - = let + = do let find_branch :: ConTagZ -> Maybe BlockId find_branch i = case (assocMaybe branches i) of Just lbl -> Just lbl @@ -542,33 +545,36 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C -- tag of a real branch is real_lo_tag (not lo_tag). arms :: [Maybe BlockId] arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]] - in - return (mkSwitch (cmmOffset tag_expr (- real_lo_tag)) arms) + dflags <- getDynFlags + return (mkSwitch (cmmOffset dflags tag_expr (- real_lo_tag)) arms) -- if we can knock off a bunch of default cases with one if, then do so | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches - = do stmts <- mk_switch tag_expr branches mb_deflt + = do dflags <- getDynFlags + stmts <- mk_switch tag_expr branches mb_deflt lowest_branch hi_tag via_C mkCmmIfThenElse - (cmmULtWord tag_expr (CmmLit (mkIntCLit lowest_branch))) + (cmmULtWord dflags tag_expr (mkIntExpr dflags lowest_branch)) (mkBranch deflt) stmts | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches - = do stmts <- mk_switch tag_expr branches mb_deflt + = do dflags <- getDynFlags + stmts <- mk_switch tag_expr branches mb_deflt lo_tag highest_branch via_C mkCmmIfThenElse - (cmmUGtWord tag_expr (CmmLit (mkIntCLit highest_branch))) + (cmmUGtWord dflags tag_expr (mkIntExpr dflags highest_branch)) (mkBranch deflt) stmts | otherwise -- Use an if-tree - = do lo_stmts <- mk_switch tag_expr lo_branches mb_deflt + = do dflags <- getDynFlags + lo_stmts <- mk_switch tag_expr lo_branches mb_deflt lo_tag (mid_tag-1) via_C hi_stmts <- mk_switch tag_expr hi_branches mb_deflt mid_tag hi_tag via_C mkCmmIfThenElse - (cmmUGeWord tag_expr (CmmLit (mkIntCLit mid_tag))) + (cmmUGeWord dflags tag_expr (mkIntExpr dflags mid_tag)) hi_stmts lo_stmts -- we test (e >= mid_tag) rather than (e < mid_tag), because @@ -649,17 +655,20 @@ mk_lit_switch :: CmmExpr -> BlockId -> [(Literal,BlockId)] -> FCode CmmAGraph mk_lit_switch scrut deflt [(lit,blk)] - = return (mkCbranch (CmmMachOp ne [scrut, CmmLit cmm_lit]) deflt blk) - where - cmm_lit = mkSimpleLit lit - cmm_ty = cmmLitType cmm_lit + = do + dflags <- getDynFlags + let + cmm_lit = mkSimpleLit dflags lit + cmm_ty = cmmLitType dflags cmm_lit rep = typeWidth cmm_ty ne = if isFloatType cmm_ty then MO_F_Ne rep else MO_Ne rep + return (mkCbranch (CmmMachOp ne [scrut, CmmLit cmm_lit]) deflt blk) mk_lit_switch scrut deflt_blk_id branches - = do lo_blk <- mk_lit_switch scrut deflt_blk_id lo_branches + = do dflags <- getDynFlags + lo_blk <- mk_lit_switch scrut deflt_blk_id lo_branches hi_blk <- mk_lit_switch scrut deflt_blk_id hi_branches - mkCmmIfThenElse cond lo_blk hi_blk + mkCmmIfThenElse (cond dflags) lo_blk hi_blk where n_branches = length branches (mid_lit,_) = branches !! (n_branches `div` 2) @@ -668,8 +677,8 @@ mk_lit_switch scrut deflt_blk_id branches (lo_branches, hi_branches) = span is_lo branches is_lo (t,_) = t < mid_lit - cond = CmmMachOp (mkLtOp mid_lit) - [scrut, CmmLit (mkSimpleLit mid_lit)] + cond dflags = CmmMachOp (mkLtOp dflags mid_lit) + [scrut, CmmLit (mkSimpleLit dflags mid_lit)] -------------- @@ -705,7 +714,8 @@ assignTemp' :: CmmExpr -> FCode CmmExpr assignTemp' e | isTrivialCmmExpr e = return e | otherwise = do - lreg <- newTemp (cmmExprType e) + dflags <- getDynFlags + lreg <- newTemp (cmmExprType dflags e) let reg = CmmLocal lreg emitAssign reg e return (CmmReg reg) |