diff options
64 files changed, 1478 insertions, 1354 deletions
diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs index 186b6bfdc2..3387b3f470 100644 --- a/compiler/cmm/CmmExpr.hs +++ b/compiler/cmm/CmmExpr.hs @@ -23,6 +23,7 @@ import CmmType import CmmMachOp import BlockId import CLabel +import DynFlags import Unique import Data.Set (Set) @@ -111,31 +112,32 @@ data CmmLit | CmmHighStackMark -- stands for the max stack space used during a procedure deriving Eq -cmmExprType :: CmmExpr -> CmmType -cmmExprType (CmmLit lit) = cmmLitType lit -cmmExprType (CmmLoad _ rep) = rep -cmmExprType (CmmReg reg) = cmmRegType reg -cmmExprType (CmmMachOp op args) = machOpResultType op (map cmmExprType args) -cmmExprType (CmmRegOff reg _) = cmmRegType reg -cmmExprType (CmmStackSlot _ _) = bWord -- an address +cmmExprType :: DynFlags -> CmmExpr -> CmmType +cmmExprType dflags (CmmLit lit) = cmmLitType dflags lit +cmmExprType _ (CmmLoad _ rep) = rep +cmmExprType dflags (CmmReg reg) = cmmRegType dflags reg +cmmExprType dflags (CmmMachOp op args) = machOpResultType dflags op (map (cmmExprType dflags) args) +cmmExprType dflags (CmmRegOff reg _) = cmmRegType dflags reg +cmmExprType dflags (CmmStackSlot _ _) = bWord dflags -- an address -- Careful though: what is stored at the stack slot may be bigger than -- an address -cmmLitType :: CmmLit -> CmmType -cmmLitType (CmmInt _ width) = cmmBits width -cmmLitType (CmmFloat _ width) = cmmFloat width -cmmLitType (CmmLabel lbl) = cmmLabelType lbl -cmmLitType (CmmLabelOff lbl _) = cmmLabelType lbl -cmmLitType (CmmLabelDiffOff {}) = bWord -cmmLitType (CmmBlock _) = bWord -cmmLitType (CmmHighStackMark) = bWord +cmmLitType :: DynFlags -> CmmLit -> CmmType +cmmLitType _ (CmmInt _ width) = cmmBits width +cmmLitType _ (CmmFloat _ width) = cmmFloat width +cmmLitType dflags (CmmLabel lbl) = cmmLabelType dflags lbl +cmmLitType dflags (CmmLabelOff lbl _) = cmmLabelType dflags lbl +cmmLitType dflags (CmmLabelDiffOff {}) = bWord dflags +cmmLitType dflags (CmmBlock _) = bWord dflags +cmmLitType dflags (CmmHighStackMark) = bWord dflags -cmmLabelType :: CLabel -> CmmType -cmmLabelType lbl | isGcPtrLabel lbl = gcWord - | otherwise = bWord +cmmLabelType :: DynFlags -> CLabel -> CmmType +cmmLabelType dflags lbl + | isGcPtrLabel lbl = gcWord + | otherwise = bWord dflags -cmmExprWidth :: CmmExpr -> Width -cmmExprWidth e = typeWidth (cmmExprType e) +cmmExprWidth :: DynFlags -> CmmExpr -> Width +cmmExprWidth dflags e = typeWidth (cmmExprType dflags e) -------- --- Negation for conditional branches @@ -164,9 +166,9 @@ instance Ord LocalReg where instance Uniquable LocalReg where getUnique (LocalReg uniq _) = uniq -cmmRegType :: CmmReg -> CmmType -cmmRegType (CmmLocal reg) = localRegType reg -cmmRegType (CmmGlobal reg) = globalRegType reg +cmmRegType :: DynFlags -> CmmReg -> CmmType +cmmRegType _ (CmmLocal reg) = localRegType reg +cmmRegType dflags (CmmGlobal reg) = globalRegType dflags reg localRegType :: LocalReg -> CmmType localRegType (LocalReg _ rep) = rep @@ -412,12 +414,12 @@ nodeReg = CmmGlobal node node :: GlobalReg node = VanillaReg 1 VGcPtr -globalRegType :: GlobalReg -> CmmType -globalRegType (VanillaReg _ VGcPtr) = gcWord -globalRegType (VanillaReg _ VNonGcPtr) = bWord -globalRegType (FloatReg _) = cmmFloat W32 -globalRegType (DoubleReg _) = cmmFloat W64 -globalRegType (LongReg _) = cmmBits W64 -globalRegType Hp = gcWord -- The initialiser for all +globalRegType :: DynFlags -> GlobalReg -> CmmType +globalRegType _ (VanillaReg _ VGcPtr) = gcWord +globalRegType dflags (VanillaReg _ VNonGcPtr) = bWord dflags +globalRegType _ (FloatReg _) = cmmFloat W32 +globalRegType _ (DoubleReg _) = cmmFloat W64 +globalRegType _ (LongReg _) = cmmBits W64 +globalRegType _ Hp = gcWord -- The initialiser for all -- dynamically allocated closures -globalRegType _ = bWord +globalRegType dflags _ = bWord dflags diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs index 49a0176b45..27054bb8b3 100644 --- a/compiler/cmm/CmmLayoutStack.hs +++ b/compiler/cmm/CmmLayoutStack.hs @@ -120,7 +120,7 @@ cmmLayoutStack dflags procpoints entry_args (final_stackmaps, _final_high_sp, new_blocks) <- mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) -> - layout procpoints liveness entry entry_args + layout dflags procpoints liveness entry entry_args rec_stackmaps rec_high_sp blocks new_blocks' <- mapM (lowerSafeForeignCall dflags) new_blocks @@ -130,7 +130,8 @@ cmmLayoutStack dflags procpoints entry_args -layout :: BlockSet -- proc points +layout :: DynFlags + -> BlockSet -- proc points -> BlockEnv CmmLive -- liveness -> BlockId -- entry -> ByteOff -- stack args on entry @@ -146,7 +147,7 @@ layout :: BlockSet -- proc points , [CmmBlock] -- [out] new blocks ) -layout procpoints liveness entry entry_args final_stackmaps final_hwm blocks +layout dflags procpoints liveness entry entry_args final_stackmaps final_hwm blocks = go blocks init_stackmap entry_args [] where (updfr, cont_info) = collectContInfo blocks @@ -187,7 +188,7 @@ layout procpoints liveness entry entry_args final_stackmaps final_hwm blocks -- each of the successor blocks. See handleLastNode for -- details. (middle2, sp_off, last1, fixup_blocks, out) - <- handleLastNode procpoints liveness cont_info + <- handleLastNode dflags procpoints liveness cont_info acc_stackmaps stack1 middle0 last0 -- pprTrace "layout(out)" (ppr out) $ return () @@ -210,7 +211,7 @@ layout procpoints liveness entry entry_args final_stackmaps final_hwm blocks -- beginning of a proc, and we don't modify Sp before the -- check. - final_blocks = manifestSp final_stackmaps stack0 sp0 sp_high entry0 + final_blocks = manifestSp dflags final_stackmaps stack0 sp0 sp_high entry0 middle_pre sp_off last1 fixup_blocks acc_stackmaps' = mapUnion acc_stackmaps out @@ -317,7 +318,7 @@ getStackLoc (Young l) n stackmaps = -- extra code that goes *after* the Sp adjustment. handleLastNode - :: ProcPointSet -> BlockEnv CmmLive -> BlockEnv ByteOff + :: DynFlags -> ProcPointSet -> BlockEnv CmmLive -> BlockEnv ByteOff -> BlockEnv StackMap -> StackMap -> Block CmmNode O O -> CmmNode O C @@ -329,7 +330,7 @@ handleLastNode , BlockEnv StackMap -- stackmaps for the continuations ) -handleLastNode procpoints liveness cont_info stackmaps +handleLastNode dflags procpoints liveness cont_info stackmaps stack0@StackMap { sm_sp = sp0 } middle last = case last of -- At each return / tail call, @@ -428,7 +429,7 @@ handleLastNode procpoints liveness cont_info stackmaps | Just stack2 <- mapLookup l stackmaps = do let assigs = fixupStack stack0 stack2 - (tmp_lbl, block) <- makeFixupBlock sp0 l stack2 assigs + (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 assigs return (l, tmp_lbl, stack2, block) -- (b) if the successor is a proc point, save everything @@ -442,7 +443,7 @@ handleLastNode procpoints liveness cont_info stackmaps setupStackFrame l liveness (sm_ret_off stack0) cont_args stack0 -- - (tmp_lbl, block) <- makeFixupBlock sp0 l stack2 assigs + (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 assigs return (l, tmp_lbl, stack2, block) -- (c) otherwise, the current StackMap is the StackMap for @@ -456,14 +457,15 @@ handleLastNode procpoints liveness cont_info stackmaps is_live (r,_) = r `elemRegSet` live -makeFixupBlock :: ByteOff -> Label -> StackMap -> [CmmNode O O] -> UniqSM (Label, [CmmBlock]) -makeFixupBlock sp0 l stack assigs +makeFixupBlock :: DynFlags -> ByteOff -> Label -> StackMap -> [CmmNode O O] + -> UniqSM (Label, [CmmBlock]) +makeFixupBlock dflags sp0 l stack assigs | null assigs && sp0 == sm_sp stack = return (l, []) | otherwise = do tmp_lbl <- liftM mkBlockId $ getUniqueM let sp_off = sp0 - sm_sp stack block = blockJoin (CmmEntry tmp_lbl) - (maybeAddSpAdj sp_off (blockFromList assigs)) + (maybeAddSpAdj dflags sp_off (blockFromList assigs)) (CmmBranch l) return (tmp_lbl, [block]) @@ -705,7 +707,8 @@ allocate ret_off live stackmap@StackMap{ sm_sp = sp0 -- middle_post, because the Sp adjustment intervenes. -- manifestSp - :: BlockEnv StackMap -- StackMaps for other blocks + :: DynFlags + -> BlockEnv StackMap -- StackMaps for other blocks -> StackMap -- StackMap for this block -> ByteOff -- Sp on entry to the block -> ByteOff -- SpHigh @@ -716,17 +719,17 @@ manifestSp -> [CmmBlock] -- new blocks -> [CmmBlock] -- final blocks with Sp manifest -manifestSp stackmaps stack0 sp0 sp_high +manifestSp dflags stackmaps stack0 sp0 sp_high first middle_pre sp_off last fixup_blocks = final_block : fixup_blocks' where area_off = getAreaOff stackmaps adj_pre_sp, adj_post_sp :: CmmNode e x -> CmmNode e x - adj_pre_sp = mapExpDeep (areaToSp sp0 sp_high area_off) - adj_post_sp = mapExpDeep (areaToSp (sp0 - sp_off) sp_high area_off) + adj_pre_sp = mapExpDeep (areaToSp dflags sp0 sp_high area_off) + adj_post_sp = mapExpDeep (areaToSp dflags (sp0 - sp_off) sp_high area_off) - final_middle = maybeAddSpAdj sp_off $ + final_middle = maybeAddSpAdj dflags sp_off $ blockFromList $ map adj_pre_sp $ elimStackStores stack0 stackmaps area_off $ @@ -747,10 +750,10 @@ getAreaOff stackmaps (Young l) = Nothing -> pprPanic "getAreaOff" (ppr l) -maybeAddSpAdj :: ByteOff -> Block CmmNode O O -> Block CmmNode O O -maybeAddSpAdj 0 block = block -maybeAddSpAdj sp_off block - = block `blockSnoc` CmmAssign spReg (cmmOffset (CmmReg spReg) sp_off) +maybeAddSpAdj :: DynFlags -> ByteOff -> Block CmmNode O O -> Block CmmNode O O +maybeAddSpAdj _ 0 block = block +maybeAddSpAdj dflags sp_off block + = block `blockSnoc` CmmAssign spReg (cmmOffset dflags (CmmReg spReg) sp_off) {- @@ -770,16 +773,16 @@ arguments. to be Sp + Sp(L) - Sp(L') -} -areaToSp :: ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr -areaToSp sp_old _sp_hwm area_off (CmmStackSlot area n) = - cmmOffset (CmmReg spReg) (sp_old - area_off area - n) -areaToSp _ sp_hwm _ (CmmLit CmmHighStackMark) = mkIntExpr sp_hwm -areaToSp _ _ _ (CmmMachOp (MO_U_Lt _) -- Note [null stack check] +areaToSp :: DynFlags -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr +areaToSp dflags sp_old _sp_hwm area_off (CmmStackSlot area n) = + cmmOffset dflags (CmmReg spReg) (sp_old - area_off area - n) +areaToSp _ _ sp_hwm _ (CmmLit CmmHighStackMark) = mkIntExpr sp_hwm +areaToSp _ _ _ _ (CmmMachOp (MO_U_Lt _) -- Note [null stack check] [CmmMachOp (MO_Sub _) [ CmmReg (CmmGlobal Sp) , CmmLit (CmmInt 0 _)], CmmReg (CmmGlobal SpLim)]) = zeroExpr -areaToSp _ _ _ other = other +areaToSp _ _ _ _ other = other -- ----------------------------------------------------------------------------- -- Note [null stack check] @@ -910,8 +913,8 @@ lowerSafeForeignCall dflags block = do -- Both 'id' and 'new_base' are KindNonPtr 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)) let (caller_save, caller_load) = callerSaveVolatileRegs dflags load_tso <- newTemp gcWord load_stack <- newTemp gcWord @@ -935,7 +938,7 @@ lowerSafeForeignCall dflags block -- received an exception during the call, then the stack might be -- different. Hence we continue by jumping to the top stack frame, -- not by jumping to succ. - jump = CmmCall { cml_target = CmmLoad (CmmReg spReg) bWord + jump = CmmCall { cml_target = CmmLoad (CmmReg spReg) (bWord dflags) , cml_cont = Just succ , cml_args_regs = regs , cml_args = widthInBytes wordWidth diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index 47c30b1a0f..53238edf94 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -19,6 +19,7 @@ import BlockId import FastString import Outputable import Constants +import DynFlags import Data.Maybe @@ -31,15 +32,15 @@ import Data.Maybe -- Exported entry points: cmmLint :: (Outputable d, Outputable h) - => GenCmmGroup d h CmmGraph -> Maybe SDoc -cmmLint tops = runCmmLint (mapM_ lintCmmDecl) tops + => DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc +cmmLint dflags tops = runCmmLint dflags (mapM_ lintCmmDecl) tops -cmmLintGraph :: CmmGraph -> Maybe SDoc -cmmLintGraph g = runCmmLint lintCmmGraph g +cmmLintGraph :: DynFlags -> CmmGraph -> Maybe SDoc +cmmLintGraph dflags g = runCmmLint dflags lintCmmGraph g -runCmmLint :: Outputable a => (a -> CmmLint b) -> a -> Maybe SDoc -runCmmLint l p = - case unCL (l p) of +runCmmLint :: Outputable a => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc +runCmmLint dflags l p = + case unCL (l p) dflags of Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"), nest 2 err, ptext $ sLit ("Program was:"), @@ -85,23 +86,27 @@ lintCmmExpr (CmmLoad expr rep) = do -- cmmCheckWordAddress expr return rep lintCmmExpr expr@(CmmMachOp op args) = do + dflags <- getDynFlags tys <- mapM lintCmmExpr args - if map (typeWidth . cmmExprType) args == machOpArgReps op + if map (typeWidth . cmmExprType dflags) args == machOpArgReps op then cmmCheckMachOp op args tys - else cmmLintMachOpErr expr (map cmmExprType args) (machOpArgReps op) + else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps op) lintCmmExpr (CmmRegOff reg offset) - = lintCmmExpr (CmmMachOp (MO_Add rep) + = do dflags <- getDynFlags + let rep = typeWidth (cmmRegType dflags reg) + lintCmmExpr (CmmMachOp (MO_Add rep) [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)]) - where rep = typeWidth (cmmRegType reg) lintCmmExpr expr = - return (cmmExprType expr) + do dflags <- getDynFlags + return (cmmExprType dflags expr) -- Check for some common byte/word mismatches (eg. Sp + 1) cmmCheckMachOp :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys = cmmCheckMachOp op [reg, lit] tys cmmCheckMachOp op _ tys - = return (machOpResultType op tys) + = do dflags <- getDynFlags + return (machOpResultType dflags op tys) isOffsetOp :: MachOp -> Bool isOffsetOp (MO_Add _) = True @@ -131,8 +136,9 @@ lintCmmMiddle node = case node of CmmComment _ -> return () CmmAssign reg expr -> do + dflags <- getDynFlags erep <- lintCmmExpr expr - let reg_ty = cmmRegType reg + let reg_ty = cmmRegType dflags reg if (erep `cmmEqType_ignoring_ptrhood` reg_ty) then return () else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty @@ -157,9 +163,10 @@ lintCmmLast labels node = case node of checkCond e CmmSwitch e branches -> do + dflags <- getDynFlags mapM_ checkTarget $ catMaybes branches erep <- lintCmmExpr e - if (erep `cmmEqType_ignoring_ptrhood` bWord) + if (erep `cmmEqType_ignoring_ptrhood` bWord dflags) then return () else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e <> text " :: " <> ppr erep) @@ -195,20 +202,24 @@ checkCond expr -- just a basic error monad: -newtype CmmLint a = CmmLint { unCL :: Either SDoc a } +newtype CmmLint a = CmmLint { unCL :: DynFlags -> Either SDoc a } instance Monad CmmLint where - CmmLint m >>= k = CmmLint $ case m of + CmmLint m >>= k = CmmLint $ \dflags -> + case m dflags of Left e -> Left e - Right a -> unCL (k a) - return a = CmmLint (Right a) + Right a -> unCL (k a) dflags + return a = CmmLint (\_ -> Right a) + +instance HasDynFlags CmmLint where + getDynFlags = CmmLint (\dflags -> Right dflags) cmmLintErr :: SDoc -> CmmLint a -cmmLintErr msg = CmmLint (Left msg) +cmmLintErr msg = CmmLint (\_ -> Left msg) addLintInfo :: SDoc -> CmmLint a -> CmmLint a -addLintInfo info thing = CmmLint $ - case unCL thing of +addLintInfo info thing = CmmLint $ \dflags -> + case unCL thing dflags of Left err -> Left (hang info 2 err) Right a -> Right a diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs index d53f4855da..6e152c5f04 100644 --- a/compiler/cmm/CmmMachOp.hs +++ b/compiler/cmm/CmmMachOp.hs @@ -25,6 +25,7 @@ where import CmmType import Outputable +import DynFlags ----------------------------------------------------------------------------- -- MachOp @@ -283,8 +284,8 @@ maybeInvertComparison op {- | Returns the MachRep of the result of a MachOp. -} -machOpResultType :: MachOp -> [CmmType] -> CmmType -machOpResultType mop tys = +machOpResultType :: DynFlags -> MachOp -> [CmmType] -> CmmType +machOpResultType dflags mop tys = case mop of MO_Add {} -> ty1 -- Preserve GC-ptr-hood MO_Sub {} -> ty1 -- of first arg @@ -297,29 +298,29 @@ machOpResultType mop tys = MO_U_Quot r -> cmmBits r MO_U_Rem r -> cmmBits r - MO_Eq {} -> comparisonResultRep - MO_Ne {} -> comparisonResultRep - MO_S_Ge {} -> comparisonResultRep - MO_S_Le {} -> comparisonResultRep - MO_S_Gt {} -> comparisonResultRep - MO_S_Lt {} -> comparisonResultRep + MO_Eq {} -> comparisonResultRep dflags + MO_Ne {} -> comparisonResultRep dflags + MO_S_Ge {} -> comparisonResultRep dflags + MO_S_Le {} -> comparisonResultRep dflags + MO_S_Gt {} -> comparisonResultRep dflags + MO_S_Lt {} -> comparisonResultRep dflags - MO_U_Ge {} -> comparisonResultRep - MO_U_Le {} -> comparisonResultRep - MO_U_Gt {} -> comparisonResultRep - MO_U_Lt {} -> comparisonResultRep + MO_U_Ge {} -> comparisonResultRep dflags + MO_U_Le {} -> comparisonResultRep dflags + MO_U_Gt {} -> comparisonResultRep dflags + MO_U_Lt {} -> comparisonResultRep dflags MO_F_Add r -> cmmFloat r MO_F_Sub r -> cmmFloat r MO_F_Mul r -> cmmFloat r MO_F_Quot r -> cmmFloat r MO_F_Neg r -> cmmFloat r - MO_F_Eq {} -> comparisonResultRep - MO_F_Ne {} -> comparisonResultRep - MO_F_Ge {} -> comparisonResultRep - MO_F_Le {} -> comparisonResultRep - MO_F_Gt {} -> comparisonResultRep - MO_F_Lt {} -> comparisonResultRep + MO_F_Eq {} -> comparisonResultRep dflags + MO_F_Ne {} -> comparisonResultRep dflags + MO_F_Ge {} -> comparisonResultRep dflags + MO_F_Le {} -> comparisonResultRep dflags + MO_F_Gt {} -> comparisonResultRep dflags + MO_F_Lt {} -> comparisonResultRep dflags MO_And {} -> ty1 -- Used for pointer masking MO_Or {} -> ty1 @@ -337,7 +338,7 @@ machOpResultType mop tys = where (ty1:_) = tys -comparisonResultRep :: CmmType +comparisonResultRep :: DynFlags -> CmmType comparisonResultRep = bWord -- is it? diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 8a10724524..d7df52a566 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -522,7 +522,7 @@ expr0 :: { ExtFCode CmmExpr } -- leaving out the type of a literal gives you the native word size in C-- maybe_ty :: { CmmType } - : {- empty -} { bWord } + : {- empty -} {% do dflags <- getDynFlags; return $ bWord dflags } | '::' type { $2 } maybe_actuals :: { [ExtFCode HintedCmmActual] } @@ -630,8 +630,9 @@ mkString s = CmmString (map (fromIntegral.ord) s) -- the op. mkMachOp :: (Width -> MachOp) -> [ExtFCode CmmExpr] -> ExtFCode CmmExpr mkMachOp fn args = do + dflags <- getDynFlags arg_exprs <- sequence args - return (CmmMachOp (fn (typeWidth (cmmExprType (head arg_exprs)))) arg_exprs) + return (CmmMachOp (fn (typeWidth (cmmExprType dflags (head arg_exprs)))) arg_exprs) getLit :: CmmExpr -> CmmLit getLit (CmmLit l) = l @@ -658,12 +659,12 @@ exprOp name args_code = do exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr) exprMacros dflags = listToUFM [ ( fsLit "ENTRY_CODE", \ [x] -> entryCode dflags x ), - ( fsLit "INFO_PTR", \ [x] -> closureInfoPtr x ), + ( fsLit "INFO_PTR", \ [x] -> closureInfoPtr dflags x ), ( fsLit "STD_INFO", \ [x] -> infoTable dflags x ), ( fsLit "FUN_INFO", \ [x] -> funInfoTable dflags x ), - ( fsLit "GET_ENTRY", \ [x] -> entryCode dflags (closureInfoPtr x) ), - ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr x) ), - ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr x) ), + ( fsLit "GET_ENTRY", \ [x] -> entryCode dflags (closureInfoPtr dflags x) ), + ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr dflags x) ), + ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr dflags x) ), ( fsLit "INFO_TYPE", \ [x] -> infoTableClosureType dflags x ), ( fsLit "INFO_PTRS", \ [x] -> infoTablePtrs dflags x ), ( fsLit "INFO_NPTRS", \ [x] -> infoTableNonPtrs dflags x ) @@ -868,7 +869,7 @@ foreignCall conv_string results_code expr_code args_code vols safety ret -- Temporary hack so at least some functions are CmmSafe CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args ret)) _ -> - let expr' = adjCallTarget platform convention expr args in + let expr' = adjCallTarget dflags convention expr args in case safety of CmmUnsafe -> code (emitForeignCall' PlayRisky results @@ -880,13 +881,14 @@ foreignCall conv_string results_code expr_code args_code vols safety ret code (emitForeignCall' PlayInterruptible results (CmmCallee expr' convention) args vols NoC_SRT ret) -adjCallTarget :: Platform -> CCallConv -> CmmExpr -> [CmmHinted CmmExpr] +adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [CmmHinted CmmExpr] -> CmmExpr -- On Windows, we have to add the '@N' suffix to the label when making -- a call with the stdcall calling convention. -adjCallTarget (Platform { platformOS = OSMinGW32 }) StdCallConv (CmmLit (CmmLabel lbl)) args +adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args + | platformOS (targetPlatform dflags) == OSMinGW32 = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args)))) - where size (CmmHinted e _) = max wORD_SIZE (widthInBytes (typeWidth (cmmExprType e))) + where size (CmmHinted e _) = max wORD_SIZE (widthInBytes (typeWidth (cmmExprType dflags e))) -- c.f. CgForeignCall.emitForeignCall adjCallTarget _ _ expr _ = expr @@ -917,14 +919,15 @@ primCall results_code name args_code vols safety doStore :: CmmType -> ExtFCode CmmExpr -> ExtFCode CmmExpr -> ExtCode doStore rep addr_code val_code - = do addr <- addr_code + = do dflags <- getDynFlags + addr <- addr_code val <- val_code -- if the specified store type does not match the type of the expr -- on the rhs, then we insert a coercion that will cause the type -- mismatch to be flagged by cmm-lint. If we don't do this, then -- the store will happen at the wrong type, and the error will not -- be noticed. - let val_width = typeWidth (cmmExprType val) + let val_width = typeWidth (cmmExprType dflags val) rep_width = typeWidth rep let coerce_val | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val] @@ -941,7 +944,7 @@ emitRetUT args = do -- or regs that we assign to, so better use -- simultaneous assignments here (#3546) when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp))) - stmtC $ CmmJump (entryCode dflags (CmmLoad (cmmRegOffW spReg sp) bWord)) (Just live) + stmtC $ CmmJump (entryCode dflags (CmmLoad (cmmRegOffW spReg sp) (bWord dflags))) (Just live) -- ----------------------------------------------------------------------------- -- If-then-else and boolean expressions diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs index 0c075b8476..e87502b5a0 100644 --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -183,7 +183,7 @@ dumpGraph dflags flag name g = do when (dopt Opt_DoCmmLinting dflags) $ do_lint g dumpWith dflags flag name g where - do_lint g = case cmmLintGraph g of + do_lint g = case cmmLintGraph dflags g of Just err -> do { fatalErrorMsg dflags err ; ghcExit dflags 1 } diff --git a/compiler/cmm/CmmRewriteAssignments.hs b/compiler/cmm/CmmRewriteAssignments.hs index a5b7602078..824883654c 100644 --- a/compiler/cmm/CmmRewriteAssignments.hs +++ b/compiler/cmm/CmmRewriteAssignments.hs @@ -20,6 +20,7 @@ import CmmUtils import CmmOpt import StgCmmUtils +import DynFlags import UniqSupply import Platform import UniqFM @@ -35,8 +36,9 @@ import Prelude hiding (succ, zip) ---------------------------------------------------------------- --- Main function -rewriteAssignments :: Platform -> CmmGraph -> UniqSM CmmGraph -rewriteAssignments platform g = do +rewriteAssignments :: DynFlags -> CmmGraph -> UniqSM CmmGraph +rewriteAssignments dflags g = do + let platform = targetPlatform dflags -- Because we need to act on forwards and backwards information, we -- first perform usage analysis and bake this information into the -- graph (backwards transform), and then do a forwards transform @@ -44,7 +46,7 @@ rewriteAssignments platform g = do g' <- annotateUsage g g'' <- liftM fst $ dataflowPassFwd g' [(g_entry g, fact_bot assignmentLattice)] $ analRewFwd assignmentLattice - (assignmentTransfer platform) + (assignmentTransfer dflags) (assignmentRewrite `thenFwdRw` machOpFoldRewrite platform) return (modifyGraph eraseRegUsage g'') @@ -309,7 +311,7 @@ invalidateUsersOf reg = mapUFM (invalidateUsers' reg) -- optimize; we need an algorithmic change to prevent us from having to -- traverse the /entire/ map continually. -middleAssignment :: Platform -> WithRegUsage CmmNode O O -> AssignmentMap +middleAssignment :: DynFlags -> WithRegUsage CmmNode O O -> AssignmentMap -> AssignmentMap -- Algorithm for annotated assignments: @@ -349,10 +351,10 @@ middleAssignment _ (Plain (CmmAssign (CmmLocal _) _)) assign = assign -- 1. Delete any sinking assignments that were used by this instruction -- 2. Look for all assignments that load from memory locations that -- were clobbered by this store and invalidate them. -middleAssignment _ (Plain n@(CmmStore lhs rhs)) assign +middleAssignment dflags (Plain n@(CmmStore lhs rhs)) assign = let m = deleteSinks n assign in foldUFM_Directly f m m -- [foldUFM performance] - where f u (xassign -> Just x) m | (lhs, rhs) `clobbers` (u, x) = addToUFM_Directly m u NeverOptimize + where f u (xassign -> Just x) m | clobbers dflags (lhs, rhs) (u, x) = addToUFM_Directly m u NeverOptimize f _ _ m = m {- Also leaky = mapUFM_Directly p . deleteSinks n $ assign @@ -371,7 +373,7 @@ middleAssignment _ (Plain n@(CmmStore lhs rhs)) assign -- This is kind of expensive. (One way to optimize this might be to -- store extra information about expressions that allow this and other -- checks to be done cheaply.) -middleAssignment platform (Plain n@(CmmUnsafeForeignCall{})) assign +middleAssignment dflags (Plain n@(CmmUnsafeForeignCall{})) assign = deleteCallerSaves (foldRegsDefd (\m r -> addToUFM m r NeverOptimize) (deleteSinks n assign) n) where deleteCallerSaves m = foldUFM_Directly f m m f u (xassign -> Just x) m | wrapRecExpf g x False = addToUFM_Directly m u NeverOptimize @@ -379,6 +381,7 @@ middleAssignment platform (Plain n@(CmmUnsafeForeignCall{})) assign g (CmmReg (CmmGlobal r)) _ | callerSaves platform r = True g (CmmRegOff (CmmGlobal r) _) _ | callerSaves platform r = True g _ b = b + platform = targetPlatform dflags middleAssignment _ (Plain (CmmComment {})) assign = assign @@ -398,17 +401,18 @@ middleAssignment _ (Plain (CmmComment {})) assign -- the next spill.) -- * Non stack-slot stores always conflict with each other. (This is -- not always the case; we could probably do something special for Hp) -clobbers :: (CmmExpr, CmmExpr) -- (lhs, rhs) of clobbering CmmStore +clobbers :: DynFlags + -> (CmmExpr, CmmExpr) -- (lhs, rhs) of clobbering CmmStore -> (Unique, CmmExpr) -- (register, expression) that may be clobbered -> Bool -clobbers (CmmRegOff (CmmGlobal Hp) _, _) (_, _) = False -clobbers (CmmReg (CmmGlobal Hp), _) (_, _) = False +clobbers _ (CmmRegOff (CmmGlobal Hp) _, _) (_, _) = False +clobbers _ (CmmReg (CmmGlobal Hp), _) (_, _) = False -- ToDo: Also catch MachOp case -clobbers (ss@CmmStackSlot{}, CmmReg (CmmLocal r)) (u, CmmLoad (ss'@CmmStackSlot{}) _) +clobbers _ (ss@CmmStackSlot{}, CmmReg (CmmLocal r)) (u, CmmLoad (ss'@CmmStackSlot{}) _) | getUnique r == u, ss == ss' = False -- No-op on the stack slot (XXX: Do we need this special case?) -clobbers (CmmStackSlot a o, rhs) (_, expr) = f expr +clobbers dflags (CmmStackSlot a o, rhs) (_, expr) = f expr where f (CmmLoad (CmmStackSlot a' o') t) - = (a, o, widthInBytes (cmmExprWidth rhs)) `overlaps` (a', o', widthInBytes (typeWidth t)) + = (a, o, widthInBytes (cmmExprWidth dflags rhs)) `overlaps` (a', o', widthInBytes (typeWidth t)) f (CmmLoad e _) = containsStackSlot e f (CmmMachOp _ es) = or (map f es) f _ = False @@ -418,7 +422,7 @@ clobbers (CmmStackSlot a o, rhs) (_, expr) = f expr containsStackSlot (CmmMachOp _ es) = or (map containsStackSlot es) containsStackSlot (CmmStackSlot{}) = True containsStackSlot _ = False -clobbers _ (_, e) = f e +clobbers _ _ (_, e) = f e where f (CmmLoad (CmmStackSlot _ _) _) = False f (CmmLoad{}) = True -- conservative f (CmmMachOp _ es) = or (map f es) @@ -463,11 +467,11 @@ invalidateVolatile k m = mapUFM p m exp _ = False p _ = NeverOptimize -- probably shouldn't happen with AlwaysSink -assignmentTransfer :: Platform +assignmentTransfer :: DynFlags -> FwdTransfer (WithRegUsage CmmNode) AssignmentMap -assignmentTransfer platform +assignmentTransfer dflags = mkFTransfer3 (flip const) - (middleAssignment platform) + (middleAssignment dflags) ((mkFactBase assignmentLattice .) . lastAssignment) -- Note [Soundness of inlining] diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs index 71ed4f09f8..8c5c99d469 100644 --- a/compiler/cmm/CmmSink.hs +++ b/compiler/cmm/CmmSink.hs @@ -237,8 +237,8 @@ walk dflags nodes assigs = go nodes emptyBlock assigs go [] block as = (block, as) go ((live,node):ns) block as | shouldDiscard node live = go ns block as - | Just a <- shouldSink node1 = go ns block (a : as1) - | otherwise = go ns block' as' + | Just a <- shouldSink dflags node1 = go ns block (a : as1) + | otherwise = go ns block' as' where (node1, as1) = tryToInline dflags live node as @@ -251,10 +251,10 @@ walk dflags nodes assigs = go nodes emptyBlock assigs -- be profitable to sink assignments to global regs too, but the -- liveness analysis doesn't track those (yet) so we can't. -- -shouldSink :: CmmNode e x -> Maybe Assignment -shouldSink (CmmAssign (CmmLocal r) e) | no_local_regs = Just (r, e, exprMem e) +shouldSink :: DynFlags -> CmmNode e x -> Maybe Assignment +shouldSink dflags (CmmAssign (CmmLocal r) e) | no_local_regs = Just (r, e, exprMem dflags e) where no_local_regs = True -- foldRegsUsed (\_ _ -> False) True e -shouldSink _other = Nothing +shouldSink _ _other = Nothing -- -- discard dead assignments. This doesn't do as good a job as @@ -342,7 +342,7 @@ tryToInline dflags live node assigs = go usages node [] assigs node' = mapExpDeep inline node where inline (CmmReg (CmmLocal l')) | l == l' = rhs inline (CmmRegOff (CmmLocal l') off) | l == l' - = cmmOffset rhs off + = cmmOffset dflags rhs off inline other = other go usages node skipped (assig@(l,rhs,_) : rest) @@ -407,7 +407,7 @@ conflicts dflags (r, rhs, addr) node | foldRegsUsed (\b r' -> r == r' || b) False node = True -- (2) a store to an address conflicts with a read of the same memory - | CmmStore addr' e <- node, memConflicts addr (loadAddr addr' (cmmExprWidth e)) = True + | CmmStore addr' e <- node, memConflicts addr (loadAddr dflags addr' (cmmExprWidth dflags e)) = True -- (3) an assignment to Hp/Sp conflicts with a heap/stack read respectively | HeapMem <- addr, CmmAssign (CmmGlobal Hp) _ <- node = True @@ -480,21 +480,21 @@ memConflicts (SpMem o1 w1) (SpMem o2 w2) | otherwise = o2 + w2 > o1 memConflicts _ _ = True -exprMem :: CmmExpr -> AbsMem -exprMem (CmmLoad addr w) = bothMems (loadAddr addr (typeWidth w)) (exprMem addr) -exprMem (CmmMachOp _ es) = foldr bothMems NoMem (map exprMem es) -exprMem _ = NoMem +exprMem :: DynFlags -> CmmExpr -> AbsMem +exprMem dflags (CmmLoad addr w) = bothMems (loadAddr dflags addr (typeWidth w)) (exprMem dflags addr) +exprMem dflags (CmmMachOp _ es) = foldr bothMems NoMem (map (exprMem dflags) es) +exprMem _ _ = NoMem -loadAddr :: CmmExpr -> Width -> AbsMem -loadAddr e w = +loadAddr :: DynFlags -> CmmExpr -> Width -> AbsMem +loadAddr dflags e w = case e of - CmmReg r -> regAddr r 0 w - CmmRegOff r i -> regAddr r i w + CmmReg r -> regAddr dflags r 0 w + CmmRegOff r i -> regAddr dflags r i w _other | CmmGlobal Sp `regUsedIn` e -> StackMem | otherwise -> AnyMem -regAddr :: CmmReg -> Int -> Width -> AbsMem -regAddr (CmmGlobal Sp) i w = SpMem i (widthInBytes w) -regAddr (CmmGlobal Hp) _ _ = HeapMem -regAddr r _ _ | isGcPtrType (cmmRegType r) = HeapMem -- yay! GCPtr pays for itself -regAddr _ _ _ = AnyMem +regAddr :: DynFlags -> CmmReg -> Int -> Width -> AbsMem +regAddr _ (CmmGlobal Sp) i w = SpMem i (widthInBytes w) +regAddr _ (CmmGlobal Hp) _ _ = HeapMem +regAddr dflags r _ _ | isGcPtrType (cmmRegType dflags r) = HeapMem -- yay! GCPtr pays for itself +regAddr _ _ _ _ = AnyMem diff --git a/compiler/cmm/CmmType.hs b/compiler/cmm/CmmType.hs index 63b42f83bb..db5db9bf96 100644 --- a/compiler/cmm/CmmType.hs +++ b/compiler/cmm/CmmType.hs @@ -18,9 +18,9 @@ where #include "HsVersions.h" import Constants +import DynFlags import FastString import Outputable -import Platform import Data.Word import Data.Int @@ -96,11 +96,11 @@ f32 = cmmFloat W32 f64 = cmmFloat W64 -- CmmTypes of native word widths -bWord :: CmmType -bWord = cmmBits wordWidth +bWord :: DynFlags -> CmmType +bWord _ = cmmBits wordWidth -bHalfWord :: Platform -> CmmType -bHalfWord platform = cmmBits (halfWordWidth platform) +bHalfWord :: DynFlags -> CmmType +bHalfWord dflags = cmmBits (halfWordWidth dflags) gcWord :: CmmType gcWord = CmmType GcPtrCat wordWidth @@ -165,13 +165,13 @@ wordWidth | wORD_SIZE == 4 = W32 | wORD_SIZE == 8 = W64 | otherwise = panic "MachOp.wordRep: Unknown word size" -halfWordWidth :: Platform -> Width +halfWordWidth :: DynFlags -> Width halfWordWidth _ | wORD_SIZE == 4 = W16 | wORD_SIZE == 8 = W32 | otherwise = panic "MachOp.halfWordRep: Unknown word size" -halfWordMask :: Platform -> Integer +halfWordMask :: DynFlags -> Integer halfWordMask _ | wORD_SIZE == 4 = 0xFFFF | wORD_SIZE == 8 = 0xFFFFFFFF diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs index 6607aec33c..bc092177b1 100644 --- a/compiler/cmm/CmmUtils.hs +++ b/compiler/cmm/CmmUtils.hs @@ -73,6 +73,7 @@ import Outputable import Unique import UniqSupply import Constants( wORD_SIZE, tAG_MASK ) +import DynFlags import Util import Data.Word @@ -86,19 +87,19 @@ import Hoopl -- --------------------------------------------------- -primRepCmmType :: PrimRep -> CmmType -primRepCmmType VoidRep = panic "primRepCmmType:VoidRep" -primRepCmmType PtrRep = gcWord -primRepCmmType IntRep = bWord -primRepCmmType WordRep = bWord -primRepCmmType Int64Rep = b64 -primRepCmmType Word64Rep = b64 -primRepCmmType AddrRep = bWord -primRepCmmType FloatRep = f32 -primRepCmmType DoubleRep = f64 +primRepCmmType :: DynFlags -> PrimRep -> CmmType +primRepCmmType _ VoidRep = panic "primRepCmmType:VoidRep" +primRepCmmType _ PtrRep = gcWord +primRepCmmType dflags IntRep = bWord dflags +primRepCmmType dflags WordRep = bWord dflags +primRepCmmType _ Int64Rep = b64 +primRepCmmType _ Word64Rep = b64 +primRepCmmType dflags AddrRep = bWord dflags +primRepCmmType _ FloatRep = f32 +primRepCmmType _ DoubleRep = f64 -typeCmmType :: UnaryType -> CmmType -typeCmmType ty = primRepCmmType (typePrimRep ty) +typeCmmType :: DynFlags -> UnaryType -> CmmType +typeCmmType dflags ty = primRepCmmType dflags (typePrimRep ty) primRepForeignHint :: PrimRep -> ForeignHint primRepForeignHint VoidRep = panic "primRepForeignHint:VoidRep" @@ -182,10 +183,10 @@ packHalfWordsCLit lower_half_word upper_half_word mkLblExpr :: CLabel -> CmmExpr mkLblExpr lbl = CmmLit (CmmLabel lbl) -cmmOffsetExpr :: CmmExpr -> CmmExpr -> CmmExpr +cmmOffsetExpr :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr -- assumes base and offset have the same CmmType -cmmOffsetExpr e (CmmLit (CmmInt n _)) = cmmOffset e (fromInteger n) -cmmOffsetExpr e byte_off = CmmMachOp (MO_Add (cmmExprWidth e)) [e, byte_off] +cmmOffsetExpr dflags e (CmmLit (CmmInt n _)) = cmmOffset dflags e (fromInteger n) +cmmOffsetExpr dflags e byte_off = CmmMachOp (MO_Add (cmmExprWidth dflags e)) [e, byte_off] -- NB. Do *not* inspect the value of the offset in these smart constructors!!! -- because the offset is sometimes involved in a loop in the code generator @@ -194,18 +195,18 @@ cmmOffsetExpr e byte_off = CmmMachOp (MO_Add (cmmExprWidth e)) [e, byte_off] -- stage; they're eliminated later instead (either during printing or -- a later optimisation step on Cmm). -- -cmmOffset :: CmmExpr -> Int -> CmmExpr -cmmOffset e 0 = e -cmmOffset (CmmReg reg) byte_off = cmmRegOff reg byte_off -cmmOffset (CmmRegOff reg m) byte_off = cmmRegOff reg (m+byte_off) -cmmOffset (CmmLit lit) byte_off = CmmLit (cmmOffsetLit lit byte_off) -cmmOffset (CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]) byte_off2 +cmmOffset :: DynFlags -> CmmExpr -> Int -> CmmExpr +cmmOffset _ e 0 = e +cmmOffset _ (CmmReg reg) byte_off = cmmRegOff reg byte_off +cmmOffset _ (CmmRegOff reg m) byte_off = cmmRegOff reg (m+byte_off) +cmmOffset _ (CmmLit lit) byte_off = CmmLit (cmmOffsetLit lit byte_off) +cmmOffset _ (CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]) byte_off2 = CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off2) rep)] -cmmOffset expr byte_off +cmmOffset dflags expr byte_off = CmmMachOp (MO_Add width) [expr, CmmLit (CmmInt (toInteger byte_off) width)] where - width = cmmExprWidth expr + width = cmmExprWidth dflags expr -- Smart constructor for CmmRegOff. Same caveats as cmmOffset above. cmmRegOff :: CmmReg -> Int -> CmmExpr @@ -224,35 +225,37 @@ cmmLabelOff lbl byte_off = CmmLabelOff lbl byte_off -- | Useful for creating an index into an array, with a staticaly known offset. -- The type is the element type; used for making the multiplier -cmmIndex :: Width -- Width w +cmmIndex :: DynFlags + -> Width -- Width w -> CmmExpr -- Address of vector of items of width w -> Int -- Which element of the vector (0 based) -> CmmExpr -- Address of i'th element -cmmIndex width base idx = cmmOffset base (idx * widthInBytes width) +cmmIndex dflags width base idx = cmmOffset dflags base (idx * widthInBytes width) -- | Useful for creating an index into an array, with an unknown offset. -cmmIndexExpr :: Width -- Width w +cmmIndexExpr :: DynFlags + -> Width -- Width w -> CmmExpr -- Address of vector of items of width w -> CmmExpr -- Which element of the vector (0 based) -> CmmExpr -- Address of i'th element -cmmIndexExpr width base (CmmLit (CmmInt n _)) = cmmIndex width base (fromInteger n) -cmmIndexExpr width base idx = - cmmOffsetExpr base byte_off +cmmIndexExpr dflags width base (CmmLit (CmmInt n _)) = cmmIndex dflags width base (fromInteger n) +cmmIndexExpr dflags width base idx = + cmmOffsetExpr dflags base byte_off where - idx_w = cmmExprWidth idx + idx_w = cmmExprWidth dflags idx byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr (widthInLog width)] -cmmLoadIndex :: CmmType -> CmmExpr -> Int -> CmmExpr -cmmLoadIndex ty expr ix = CmmLoad (cmmIndex (typeWidth ty) expr ix) ty +cmmLoadIndex :: DynFlags -> CmmType -> CmmExpr -> Int -> CmmExpr +cmmLoadIndex dflags ty expr ix = CmmLoad (cmmIndex dflags (typeWidth ty) expr ix) ty -- The "B" variants take byte offsets cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr cmmRegOffB = cmmRegOff -cmmOffsetB :: CmmExpr -> ByteOff -> CmmExpr +cmmOffsetB :: DynFlags -> CmmExpr -> ByteOff -> CmmExpr cmmOffsetB = cmmOffset -cmmOffsetExprB :: CmmExpr -> CmmExpr -> CmmExpr +cmmOffsetExprB :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr cmmOffsetExprB = cmmOffsetExpr cmmLabelOffB :: CLabel -> ByteOff -> CmmLit @@ -263,13 +266,13 @@ cmmOffsetLitB = cmmOffsetLit ----------------------- -- The "W" variants take word offsets -cmmOffsetExprW :: CmmExpr -> CmmExpr -> CmmExpr +cmmOffsetExprW :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr -- The second arg is a *word* offset; need to change it to bytes -cmmOffsetExprW e (CmmLit (CmmInt n _)) = cmmOffsetW e (fromInteger n) -cmmOffsetExprW e wd_off = cmmIndexExpr wordWidth e wd_off +cmmOffsetExprW dflags e (CmmLit (CmmInt n _)) = cmmOffsetW dflags e (fromInteger n) +cmmOffsetExprW dflags e wd_off = cmmIndexExpr dflags wordWidth e wd_off -cmmOffsetW :: CmmExpr -> WordOff -> CmmExpr -cmmOffsetW e n = cmmOffsetB e (wORD_SIZE * n) +cmmOffsetW :: DynFlags -> CmmExpr -> WordOff -> CmmExpr +cmmOffsetW dflags e n = cmmOffsetB dflags e (wORD_SIZE * n) cmmRegOffW :: CmmReg -> WordOff -> CmmExpr cmmRegOffW reg wd_off = cmmRegOffB reg (wd_off * wORD_SIZE) @@ -280,8 +283,8 @@ cmmOffsetLitW lit wd_off = cmmOffsetLitB lit (wORD_SIZE * wd_off) cmmLabelOffW :: CLabel -> WordOff -> CmmLit cmmLabelOffW lbl wd_off = cmmLabelOffB lbl (wORD_SIZE * wd_off) -cmmLoadIndexW :: CmmExpr -> Int -> CmmType -> CmmExpr -cmmLoadIndexW base off ty = CmmLoad (cmmOffsetW base off) ty +cmmLoadIndexW :: DynFlags -> CmmExpr -> Int -> CmmType -> CmmExpr +cmmLoadIndexW dflags base off ty = CmmLoad (cmmOffsetW dflags base off) ty ----------------------- cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord, @@ -302,9 +305,9 @@ cmmSubWord e1 e2 = CmmMachOp mo_wordSub [e1, e2] cmmMulWord e1 e2 = CmmMachOp mo_wordMul [e1, e2] cmmQuotWord e1 e2 = CmmMachOp mo_wordUQuot [e1, e2] -cmmNegate :: CmmExpr -> CmmExpr -cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep) -cmmNegate e = CmmMachOp (MO_S_Neg (cmmExprWidth e)) [e] +cmmNegate :: DynFlags -> CmmExpr -> CmmExpr +cmmNegate _ (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep) +cmmNegate dflags e = CmmMachOp (MO_S_Neg (cmmExprWidth dflags e)) [e] blankWord :: CmmStatic blankWord = CmmUninitialised wORD_SIZE diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs index 8952ba1803..6bcdcaa966 100644 --- a/compiler/cmm/MkGraph.hs +++ b/compiler/cmm/MkGraph.hs @@ -367,7 +367,7 @@ copyOutOflow dflags conv transfer area actuals updfr_off arg_offset = init_offset + extra_stack_off args :: [(CmmExpr, ParamLocation)] -- The argument and where to put it - args = assignArgumentsPos dflags conv cmmExprType actuals + args = assignArgumentsPos dflags conv (cmmExprType dflags) actuals args' = foldl adjust setRA args where adjust rst (v, StackParam off) = (v, StackParam (off + arg_offset)) : rst diff --git a/compiler/cmm/OldCmmLint.hs b/compiler/cmm/OldCmmLint.hs index 72e40ce4f8..009a7841f1 100644 --- a/compiler/cmm/OldCmmLint.hs +++ b/compiler/cmm/OldCmmLint.hs @@ -24,7 +24,7 @@ import Outputable import OldPprCmm() import Constants import FastString -import Platform +import DynFlags import Data.Maybe @@ -32,15 +32,15 @@ import Data.Maybe -- Exported entry points: cmmLint :: (Outputable d, Outputable h) - => Platform -> GenCmmGroup d h (ListGraph CmmStmt) -> Maybe SDoc -cmmLint platform tops = runCmmLint platform (mapM_ (lintCmmDecl platform)) tops + => DynFlags -> GenCmmGroup d h (ListGraph CmmStmt) -> Maybe SDoc +cmmLint dflags tops = runCmmLint dflags (mapM_ (lintCmmDecl dflags)) tops cmmLintTop :: (Outputable d, Outputable h) - => Platform -> GenCmmDecl d h (ListGraph CmmStmt) -> Maybe SDoc -cmmLintTop platform top = runCmmLint platform (lintCmmDecl platform) top + => DynFlags -> GenCmmDecl d h (ListGraph CmmStmt) -> Maybe SDoc +cmmLintTop dflags top = runCmmLint dflags (lintCmmDecl dflags) top runCmmLint :: Outputable a - => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc + => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc runCmmLint _ l p = case unCL (l p) of Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"), @@ -49,19 +49,20 @@ runCmmLint _ l p = nest 2 (ppr p)]) Right _ -> Nothing -lintCmmDecl :: Platform -> (GenCmmDecl h i (ListGraph CmmStmt)) -> CmmLint () -lintCmmDecl platform (CmmProc _ lbl (ListGraph blocks)) +lintCmmDecl :: DynFlags -> (GenCmmDecl h i (ListGraph CmmStmt)) -> CmmLint () +lintCmmDecl dflags (CmmProc _ lbl (ListGraph blocks)) = addLintInfo (text "in proc " <> pprCLabel platform lbl) $ let labels = foldl (\s b -> setInsert (blockId b) s) setEmpty blocks - in mapM_ (lintCmmBlock platform labels) blocks + in mapM_ (lintCmmBlock dflags labels) blocks + where platform = targetPlatform dflags lintCmmDecl _ (CmmData {}) = return () -lintCmmBlock :: Platform -> BlockSet -> GenBasicBlock CmmStmt -> CmmLint () -lintCmmBlock platform labels (BasicBlock id stmts) +lintCmmBlock :: DynFlags -> BlockSet -> GenBasicBlock CmmStmt -> CmmLint () +lintCmmBlock dflags labels (BasicBlock id stmts) = addLintInfo (text "in basic block " <> ppr id) $ - mapM_ (lintCmmStmt platform labels) stmts + mapM_ (lintCmmStmt dflags labels) stmts -- ----------------------------------------------------------------------------- -- lintCmmExpr @@ -69,32 +70,32 @@ lintCmmBlock platform labels (BasicBlock id stmts) -- Checks whether a CmmExpr is "type-correct", and check for obvious-looking -- byte/word mismatches. -lintCmmExpr :: Platform -> CmmExpr -> CmmLint CmmType -lintCmmExpr platform (CmmLoad expr rep) = do - _ <- lintCmmExpr platform expr +lintCmmExpr :: DynFlags -> CmmExpr -> CmmLint CmmType +lintCmmExpr dflags (CmmLoad expr rep) = do + _ <- lintCmmExpr dflags expr -- Disabled, if we have the inlining phase before the lint phase, -- we can have funny offsets due to pointer tagging. -- EZY -- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $ -- cmmCheckWordAddress expr return rep -lintCmmExpr platform expr@(CmmMachOp op args) = do - tys <- mapM (lintCmmExpr platform) args - if map (typeWidth . cmmExprType) args == machOpArgReps op - then cmmCheckMachOp op args tys - else cmmLintMachOpErr expr (map cmmExprType args) (machOpArgReps op) -lintCmmExpr platform (CmmRegOff reg offset) - = lintCmmExpr platform (CmmMachOp (MO_Add rep) +lintCmmExpr dflags expr@(CmmMachOp op args) = do + tys <- mapM (lintCmmExpr dflags) args + if map (typeWidth . cmmExprType dflags) args == machOpArgReps op + then cmmCheckMachOp dflags op args tys + else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps op) +lintCmmExpr dflags (CmmRegOff reg offset) + = lintCmmExpr dflags (CmmMachOp (MO_Add rep) [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)]) - where rep = typeWidth (cmmRegType reg) -lintCmmExpr _ expr = - return (cmmExprType expr) + where rep = typeWidth (cmmRegType dflags reg) +lintCmmExpr dflags expr = + return (cmmExprType dflags expr) -- Check for some common byte/word mismatches (eg. Sp + 1) -cmmCheckMachOp :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType -cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys - = cmmCheckMachOp op [reg, lit] tys -cmmCheckMachOp op _ tys - = return (machOpResultType op tys) +cmmCheckMachOp :: DynFlags -> MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType +cmmCheckMachOp dflags op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys + = cmmCheckMachOp dflags op [reg, lit] tys +cmmCheckMachOp dflags op _ tys + = return (machOpResultType dflags op tys) isOffsetOp :: MachOp -> Bool isOffsetOp (MO_Add _) = True @@ -119,43 +120,43 @@ notNodeReg :: CmmExpr -> Bool notNodeReg (CmmReg reg) | reg == nodeReg = False notNodeReg _ = True -lintCmmStmt :: Platform -> BlockSet -> CmmStmt -> CmmLint () -lintCmmStmt platform labels = lint +lintCmmStmt :: DynFlags -> BlockSet -> CmmStmt -> CmmLint () +lintCmmStmt dflags labels = lint where lint (CmmNop) = return () lint (CmmComment {}) = return () lint stmt@(CmmAssign reg expr) = do - erep <- lintCmmExpr platform expr - let reg_ty = cmmRegType reg + erep <- lintCmmExpr dflags expr + let reg_ty = cmmRegType dflags reg if (erep `cmmEqType_ignoring_ptrhood` reg_ty) then return () else cmmLintAssignErr stmt erep reg_ty lint (CmmStore l r) = do - _ <- lintCmmExpr platform l - _ <- lintCmmExpr platform r + _ <- lintCmmExpr dflags l + _ <- lintCmmExpr dflags r return () lint (CmmCall target _res args _) = - do lintTarget platform labels target - mapM_ (lintCmmExpr platform . hintlessCmm) args - lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr platform e >> checkCond e + do lintTarget dflags labels target + mapM_ (lintCmmExpr dflags . hintlessCmm) args + lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr dflags e >> checkCond e lint (CmmSwitch e branches) = do mapM_ checkTarget $ catMaybes branches - erep <- lintCmmExpr platform e - if (erep `cmmEqType_ignoring_ptrhood` bWord) + erep <- lintCmmExpr dflags e + if (erep `cmmEqType_ignoring_ptrhood` bWord dflags) then return () else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e <> text " :: " <> ppr erep) - lint (CmmJump e _) = lintCmmExpr platform e >> return () + lint (CmmJump e _) = lintCmmExpr dflags e >> return () lint (CmmReturn) = return () lint (CmmBranch id) = checkTarget id checkTarget id = if setMember id labels then return () else cmmLintErr (text "Branch to nonexistent id" <+> ppr id) -lintTarget :: Platform -> BlockSet -> CmmCallTarget -> CmmLint () -lintTarget platform _ (CmmCallee e _) = do _ <- lintCmmExpr platform e - return () -lintTarget _ _ (CmmPrim _ Nothing) = return () -lintTarget platform labels (CmmPrim _ (Just stmts)) - = mapM_ (lintCmmStmt platform labels) stmts +lintTarget :: DynFlags -> BlockSet -> CmmCallTarget -> CmmLint () +lintTarget dflags _ (CmmCallee e _) = do _ <- lintCmmExpr dflags e + return () +lintTarget _ _ (CmmPrim _ Nothing) = return () +lintTarget dflags labels (CmmPrim _ (Just stmts)) + = mapM_ (lintCmmStmt dflags labels) stmts checkCond :: CmmExpr -> CmmLint () diff --git a/compiler/cmm/OldCmmUtils.hs b/compiler/cmm/OldCmmUtils.hs index 0ec7a25f15..fe6ccee642 100644 --- a/compiler/cmm/OldCmmUtils.hs +++ b/compiler/cmm/OldCmmUtils.hs @@ -20,6 +20,7 @@ module OldCmmUtils( import OldCmm import CmmUtils import OrdList +import DynFlags import Unique --------------------------------------------------- @@ -77,23 +78,23 @@ cheapEqReg _ _ = False -- --------------------------------------------------- -loadArgsIntoTemps :: [Unique] +loadArgsIntoTemps :: DynFlags -> [Unique] -> [HintedCmmActual] -> ([Unique], [CmmStmt], [HintedCmmActual]) -loadArgsIntoTemps uniques [] = (uniques, [], []) -loadArgsIntoTemps uniques ((CmmHinted e hint):args) = +loadArgsIntoTemps _ uniques [] = (uniques, [], []) +loadArgsIntoTemps dflags uniques ((CmmHinted e hint):args) = (uniques'', new_stmts ++ remaining_stmts, (CmmHinted new_e hint) : remaining_e) where - (uniques', new_stmts, new_e) = maybeAssignTemp uniques e + (uniques', new_stmts, new_e) = maybeAssignTemp dflags uniques e (uniques'', remaining_stmts, remaining_e) = - loadArgsIntoTemps uniques' args + loadArgsIntoTemps dflags uniques' args -maybeAssignTemp :: [Unique] -> CmmExpr -> ([Unique], [CmmStmt], CmmExpr) -maybeAssignTemp uniques e +maybeAssignTemp :: DynFlags -> [Unique] -> CmmExpr -> ([Unique], [CmmStmt], CmmExpr) +maybeAssignTemp dflags uniques e | hasNoGlobalRegs e = (uniques, [], e) | otherwise = (tail uniques, [CmmAssign local e], CmmReg local) - where local = CmmLocal (LocalReg (head uniques) (cmmExprType e)) + where local = CmmLocal (LocalReg (head uniques) (cmmExprType dflags e)) diff --git a/compiler/cmm/OldPprCmm.hs b/compiler/cmm/OldPprCmm.hs index 9605cb9bdf..a3857d4e47 100644 --- a/compiler/cmm/OldPprCmm.hs +++ b/compiler/cmm/OldPprCmm.hs @@ -93,9 +93,10 @@ pprStmt stmt = case stmt of CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi -- rep[lv] = expr; - CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi - where - rep = ppr ( cmmExprType expr ) + CmmStore lv expr -> + sdocWithDynFlags $ \dflags -> + let rep = ppr ( cmmExprType dflags expr ) + in rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi -- call "ccall" foo(x, y)[r1, r2]; -- ToDo ppr volatile diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index dd71ac655e..01c64dae60 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -167,7 +167,9 @@ pprLocalness lbl | not $ externallyVisibleCLabel lbl = ptext (sLit "static ") pprStmt :: CmmStmt -> SDoc -pprStmt stmt = case stmt of +pprStmt stmt = + sdocWithDynFlags $ \dflags -> + case stmt of CmmReturn -> panic "pprStmt: return statement should have been cps'd away" CmmNop -> empty CmmComment _ -> empty -- (hang (ptext (sLit "/*")) 3 (ftext s)) $$ ptext (sLit "*/") @@ -187,7 +189,7 @@ pprStmt stmt = case stmt of | otherwise -> hsep [ pprExpr (CmmLoad dest rep), equals, pprExpr src <> semi ] where - rep = cmmExprType src + rep = cmmExprType dflags src CmmCall (CmmCallee fn cconv) results args ret -> maybe_proto $$ @@ -262,15 +264,15 @@ pprForeignCall fn cconv results args = (proto, fn_call) pprCFunType :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> SDoc pprCFunType ppr_fn cconv ress args - = res_type ress <+> - parens (ccallConvAttribute cconv <> ppr_fn) <> - parens (commafy (map arg_type args)) - where - res_type [] = ptext (sLit "void") + = sdocWithDynFlags $ \dflags -> + let res_type [] = ptext (sLit "void") res_type [CmmHinted one hint] = machRepHintCType (localRegType one) hint res_type _ = panic "pprCFunType: only void or 1 return value supported" - arg_type (CmmHinted expr hint) = machRepHintCType (cmmExprType expr) hint + arg_type (CmmHinted expr hint) = machRepHintCType (cmmExprType dflags expr) hint + in res_type ress <+> + parens (ccallConvAttribute cconv <> ppr_fn) <> + parens (commafy (map arg_type args)) -- --------------------------------------------------------------------- -- unconditional branches @@ -423,8 +425,10 @@ pprMachOpApp' mop args where -- Cast needed for signed integer ops - pprArg e | signedOp mop = cCast (machRep_S_CType (typeWidth (cmmExprType e))) e - | needsFCasts mop = cCast (machRep_F_CType (typeWidth (cmmExprType e))) e + pprArg e | signedOp mop = sdocWithDynFlags $ \dflags -> + cCast (machRep_S_CType (typeWidth (cmmExprType dflags e))) e + | needsFCasts mop = sdocWithDynFlags $ \dflags -> + cCast (machRep_F_CType (typeWidth (cmmExprType dflags e))) e | otherwise = pprExpr1 e needsFCasts (MO_F_Eq _) = False needsFCasts (MO_F_Ne _) = False @@ -480,7 +484,8 @@ pprStatics (CmmStaticLit (CmmFloat f W32) : rest) = pprLit1 (floatToWord f) : pprStatics rest | otherwise = pprPanic "pprStatics: float" (vcat (map ppr' rest)) - where ppr' (CmmStaticLit l) = ppr (cmmLitType l) + where ppr' (CmmStaticLit l) = sdocWithDynFlags $ \dflags -> + ppr (cmmLitType dflags l) ppr' _other = ptext (sLit "bad static!") pprStatics (CmmStaticLit (CmmFloat f W64) : rest) = map pprLit1 (doubleToWords f) ++ pprStatics rest @@ -846,7 +851,8 @@ pprCall ppr_fn cconv results args = cCast (ptext (sLit "void *")) expr -- see comment by machRepHintCType below pprArg (CmmHinted expr SignedHint) - = cCast (machRep_S_CType $ typeWidth $ cmmExprType expr) expr + = sdocWithDynFlags $ \dflags -> + cCast (machRep_S_CType $ typeWidth $ cmmExprType dflags expr) expr pprArg (CmmHinted expr _other) = pprExpr expr diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index 58866979f8..423bcd5504 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -185,7 +185,8 @@ pprNode node = pp_node <+> pp_debug -- rep[lv] = expr; CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi where - rep = ppr ( cmmExprType expr ) + rep = sdocWithDynFlags $ \dflags -> + ppr ( cmmExprType dflags expr ) -- call "ccall" foo(x, y)[r1, r2]; -- ToDo ppr volatile diff --git a/compiler/cmm/PprCmmExpr.hs b/compiler/cmm/PprCmmExpr.hs index 2f25b028d1..2c481c38a2 100644 --- a/compiler/cmm/PprCmmExpr.hs +++ b/compiler/cmm/PprCmmExpr.hs @@ -73,11 +73,12 @@ instance Outputable GlobalReg where pprExpr :: CmmExpr -> SDoc pprExpr e - = case e of + = sdocWithDynFlags $ \dflags -> + case e of CmmRegOff reg i -> pprExpr (CmmMachOp (MO_Add rep) [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)]) - where rep = typeWidth (cmmRegType reg) + where rep = typeWidth (cmmRegType dflags reg) CmmLit lit -> pprLit lit _other -> pprExpr1 e diff --git a/compiler/codeGen/CgBindery.lhs b/compiler/codeGen/CgBindery.lhs index 0efc99d370..7fe79804fa 100644 --- a/compiler/codeGen/CgBindery.lhs +++ b/compiler/codeGen/CgBindery.lhs @@ -205,10 +205,17 @@ untagNodeIdInfo id offset lf_info tag 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 +235,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 @@ -451,13 +451,13 @@ bindNewToUntagNode id offset lf_info tag -- 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 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 diff --git a/compiler/codeGen/CgCallConv.hs b/compiler/codeGen/CgCallConv.hs index 9443e0e936..9b3fcecd36 100644 --- a/compiler/codeGen/CgCallConv.hs +++ b/compiler/codeGen/CgCallConv.hs @@ -226,8 +226,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)) } 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 ede235a00a..f8062cfbf5 100644 --- a/compiler/codeGen/CgClosure.lhs +++ b/compiler/codeGen/CgClosure.lhs @@ -371,11 +371,11 @@ mkSlowEntryCode dflags cl_info reg_args 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)) + (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 spReg offset) (CmmReg (CmmGlobal reg)) stk_adj_pop = CmmAssign spReg (cmmRegOffW spReg final_stk_offset) @@ -490,7 +490,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 +576,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 +589,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, @@ -602,7 +602,7 @@ link_caf cl_info _is_upd = do -- 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..146f28461f 100644 --- a/compiler/codeGen/CgCon.lhs +++ b/compiler/codeGen/CgCon.lhs @@ -356,7 +356,7 @@ cgReturnDataCon con amodes = do node_live = Just [node] enter_it dflags = stmtsC [ CmmAssign nodeReg (cmmUntag (CmmReg nodeReg)), - CmmJump (entryCode dflags $ closureInfoPtr $ CmmReg nodeReg) + CmmJump (entryCode dflags $ closureInfoPtr dflags $ CmmReg nodeReg) node_live ] jump_to lbl = stmtC $ CmmJump (CmmLit lbl) node_live @@ -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..d57dec14e4 100644 --- a/compiler/codeGen/CgExpr.lhs +++ b/compiler/codeGen/CgExpr.lhs @@ -146,10 +146,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 +178,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 +190,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]) @@ -481,14 +484,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 801d8a31c6..48f674a09a 100644 --- a/compiler/codeGen/CgForeignCall.hs +++ b/compiler/codeGen/CgForeignCall.hs @@ -70,13 +70,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 +99,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 + 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 +137,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 @@ -194,10 +194,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,32 +212,33 @@ 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)) + CmmAssign spLim (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags)) rESERVED_STACK_WORDS), -- HpAlloc = 0; -- HpAlloc is assumed to be set to non-zero only by a failed @@ -247,33 +249,35 @@ emitLoadThreadState = do -- 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) (-1)), -- HpLim = CurrentNursery->start + -- CurrentNursery->blocks*BLOCK_SIZE_W - 1; CmmAssign hpLim - (cmmOffsetExpr - (CmmLoad nursery_bdescr_start bWord) - (cmmOffset + (cmmOffsetExpr dflags + (CmmLoad (nursery_bdescr_start dflags) (bWord dflags)) + (cmmOffset dflags (CmmMachOp mo_wordMul [ CmmMachOp (MO_SS_Conv W32 wordWidth) - [CmmLoad nursery_bdescr_blocks b32], + [CmmLoad (nursery_bdescr_blocks dflags) b32], mkIntExpr bLOCK_SIZE ]) (-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 +nursery_bdescr_start dflags = cmmOffset dflags stgCurrentNursery oFFSET_bdescr_start +nursery_bdescr_blocks dflags = cmmOffset dflags stgCurrentNursery oFFSET_bdescr_blocks tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: DynFlags -> ByteOff tso_stackobj dflags = closureField dflags oFFSET_StgTSO_stackobj @@ -307,10 +311,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 98d08f9ea1..daca30c25a 100644 --- a/compiler/codeGen/CgHeapery.lhs +++ b/compiler/codeGen/CgHeapery.lhs @@ -230,7 +230,7 @@ mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [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,9 +241,9 @@ 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) +padLitToWord :: DynFlags -> CmmLit -> [CmmLit] +padLitToWord dflags lit = lit : padding pad_length + where width = typeWidth (cmmLitType dflags lit) pad_length = wORD_SIZE - widthInBytes width :: Int padding n | n <= 0 = [] @@ -470,7 +470,9 @@ do_checks stk hp reg_save_code rts_lbl live 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 + + ; doGranAllocate hp_expr -- The failure block: this saves the registers and jumps to -- the appropriate RTS stub. @@ -496,7 +498,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 @@ -528,11 +530,10 @@ hpChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code hpChkGen bytes liveness reentry = do dflags <- getDynFlags let platform = targetPlatform dflags + assigns = mkStmts [ mk_vanilla_assignment dflags 9 liveness, + mk_vanilla_assignment dflags 10 reentry ] do_checks' zeroExpr 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). @@ -546,15 +547,14 @@ stkChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code stkChkGen bytes liveness reentry = do dflags <- getDynFlags let platform = targetPlatform dflags + assigns = mkStmts [ mk_vanilla_assignment dflags 9 liveness, + mk_vanilla_assignment dflags 10 reentry ] do_checks' bytes zeroExpr 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 @@ -630,8 +630,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 ceccec2415..68cbe0f0da 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -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) 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 @@ -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,27 +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 platform) wordWidth) [infoTableConstrTag dflags info_table] + = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) wordWidth) [infoTableConstrTag dflags info_table] where - platform = targetPlatform dflags - 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 platform) wordWidth) [infoTableClosureType dflags info_table] + = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) wordWidth) [infoTableClosureType dflags info_table] where - platform = targetPlatform dflags - 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 @@ -325,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 (targetPlatform dflags)) + = 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 (targetPlatform dflags)) + = CmmLoad (cmmOffsetB dflags info_tbl (stdClosureTypeOffset dflags)) (bHalfWord dflags) infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr infoTablePtrs dflags info_tbl - = CmmLoad (cmmOffsetB info_tbl (stdPtrsOffset dflags)) (bHalfWord (targetPlatform dflags)) + = CmmLoad (cmmOffsetB dflags info_tbl (stdPtrsOffset dflags)) (bHalfWord dflags) infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr infoTableNonPtrs dflags info_tbl - = CmmLoad (cmmOffsetB info_tbl (stdNonPtrsOffset dflags)) (bHalfWord (targetPlatform dflags)) + = CmmLoad (cmmOffsetB dflags info_tbl (stdNonPtrsOffset dflags)) (bHalfWord dflags) funInfoTable :: DynFlags -> CmmExpr -> CmmExpr -- Takes the info pointer of a function, @@ -347,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) | otherwise - = cmmOffsetW info_ptr (1 + stdInfoTableSizeW dflags) + = cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags) -- Past the entry code pointer ------------------------------------------------------------------------- diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs index c2b7a11c33..92ff418049 100644 --- a/compiler/codeGen/CgPrimOp.hs +++ b/compiler/codeGen/CgPrimOp.hs @@ -46,12 +46,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 @@ -60,7 +62,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 _ [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 @@ -94,7 +96,7 @@ emitPrimOp [res_r,res_c] IntAddCOp [aa,bb] _ ] -emitPrimOp [res_r,res_c] IntSubCOp [aa,bb] _ +emitPrimOp _ [res_r,res_c] IntSubCOp [aa,bb] _ {- Similarly: #define subIntCzh(r,c,a,b) \ { r = ((I_)(a)) - ((I_)(b)); \ @@ -117,7 +119,7 @@ emitPrimOp [res_r,res_c] IntSubCOp [aa,bb] _ ] -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. @@ -133,15 +135,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) @@ -154,24 +156,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) + val + | dopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag arg) | otherwise = CmmLit zeroCLit -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)) -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-}] @@ -185,54 +184,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 [ + cmmLoadIndexW dflags arg1 (fixedHdrSize dflags) (bWord dflags), + cmmLoadIndexW dflags arg2 (fixedHdrSize dflags) (bWord dflags) + ])) -emitPrimOp [res] ReallyUnsafePtrEqualityOp [arg1,arg2] _ +emitPrimOp _ [res] ReallyUnsafePtrEqualityOp [arg1,arg2] _ = stmtC (CmmAssign (CmmLocal res) (CmmMachOp mo_wordEq [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 arg))) {- Freezing arrays-of-ptrs requires changing an info table, for the benefit of the generational collector. It needs to scavenge mutable @@ -244,184 +238,183 @@ 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) (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 _ 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 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 _ 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 -- 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 _ 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 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 _ 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 -- 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 _ 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 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 _ 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 -- 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 _ 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 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 _ 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 -- 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 _ res WriteOffAddrOp_Char args _ = doWriteOffAddrOp (Just mo_WordTo8) b8 res args +emitPrimOp _ res WriteOffAddrOp_WideChar args _ = doWriteOffAddrOp (Just mo_WordTo32) 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 _ 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 -- 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 _ res WriteByteArrayOp_Char args _ = doWriteByteArrayOp (Just mo_WordTo8) b8 res args +emitPrimOp _ res WriteByteArrayOp_WideChar args _ = doWriteByteArrayOp (Just mo_WordTo32) 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 _ 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 -- 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. @@ -429,19 +422,19 @@ emitPrimOp [] SetByteArrayOp [ba,off,len,c] live = -- 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 [res] PopCnt8Op [w] live = +emitPrimOp _ [res] PopCnt8Op [w] live = emitPopCntCall res (CmmMachOp mo_WordTo8 [w]) W8 live -emitPrimOp [res] PopCnt16Op [w] live = +emitPrimOp _ [res] PopCnt16Op [w] live = emitPopCntCall res (CmmMachOp mo_WordTo16 [w]) W16 live -emitPrimOp [res] PopCnt32Op [w] live = +emitPrimOp _ [res] PopCnt32Op [w] live = emitPopCntCall res (CmmMachOp mo_WordTo32 [w]) W32 live -emitPrimOp [res] PopCnt64Op [w] live = +emitPrimOp _ [res] PopCnt64Op [w] live = emitPopCntCall res (CmmMachOp mo_WordTo64 [w]) W64 live -emitPrimOp [res] PopCntOp [w] live = +emitPrimOp _ [res] PopCntOp [w] live = emitPopCntCall res w wordWidth live -- The rest just translate straightforwardly -emitPrimOp [res] op [arg] _ +emitPrimOp _ [res] op [arg] _ | nopOp op = stmtC (CmmAssign (CmmLocal res) arg) @@ -449,7 +442,7 @@ emitPrimOp [res] op [arg] _ = stmtC (CmmAssign (CmmLocal res) $ CmmMachOp (mop rep wordWidth) [CmmMachOp (mop wordWidth rep) [arg]]) -emitPrimOp [res] op args live +emitPrimOp _ [res] op args live | Just prim <- callishOp op = do vols <- getVolatileRegs live emitForeignCall' PlayRisky @@ -464,7 +457,7 @@ emitPrimOp [res] op args live = let stmt = CmmAssign (CmmLocal res) (CmmMachOp mop args) in stmtC stmt -emitPrimOp [res_q, res_r] IntQuotRemOp [arg_x, arg_y] _ +emitPrimOp _ [res_q, res_r] IntQuotRemOp [arg_x, arg_y] _ = let genericImpl = [CmmAssign (CmmLocal res_q) (CmmMachOp (MO_S_Quot wordWidth) [arg_x, arg_y]), @@ -477,7 +470,7 @@ emitPrimOp [res_q, res_r] IntQuotRemOp [arg_x, arg_y] _ CmmHinted arg_y NoHint] CmmMayReturn in stmtC stmt -emitPrimOp [res_q, res_r] WordQuotRemOp [arg_x, arg_y] _ +emitPrimOp _ [res_q, res_r] WordQuotRemOp [arg_x, arg_y] _ = let genericImpl = [CmmAssign (CmmLocal res_q) (CmmMachOp (MO_U_Quot wordWidth) [arg_x, arg_y]), @@ -490,8 +483,8 @@ emitPrimOp [res_q, res_r] WordQuotRemOp [arg_x, arg_y] _ 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 +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) [x, i] shr x i = CmmMachOp (MO_U_Shr wordWidth) [x, i] or x y = CmmMachOp (MO_Or wordWidth) [x, y] @@ -543,11 +536,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 dflags <- getDynFlags - let platform = targetPlatform dflags - 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 @@ -566,9 +557,9 @@ emitPrimOp [res_h, res_l] WordAdd2Op [arg_x, arg_y] _ 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 platform))) + hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags))) wordWidth) - hwm = CmmLit (CmmInt (halfWordMask platform) wordWidth) + hwm = CmmLit (CmmInt (halfWordMask dflags) wordWidth) stmt = CmmCall (CmmPrim (MO_Add2 wordWidth) (Just genericImpl)) [CmmHinted res_h NoHint, CmmHinted res_l NoHint] @@ -576,10 +567,8 @@ emitPrimOp [res_h, res_l] WordAdd2Op [arg_x, arg_y] _ CmmHinted arg_y NoHint] CmmMayReturn stmtC stmt -emitPrimOp [res_h, res_l] WordMul2Op [arg_x, arg_y] _ - = do dflags <- getDynFlags - let platform = targetPlatform dflags - 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 @@ -612,9 +601,9 @@ emitPrimOp [res_h, res_l] WordMul2Op [arg_x, arg_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 platform))) + hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags))) wordWidth) - hwm = CmmLit (CmmInt (halfWordMask platform) wordWidth) + hwm = CmmLit (CmmInt (halfWordMask dflags) wordWidth) stmt = CmmCall (CmmPrim (MO_U_Mul2 wordWidth) (Just genericImpl)) [CmmHinted res_h NoHint, CmmHinted res_l NoHint] @@ -623,7 +612,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 @@ -849,46 +838,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)) (card idx) ) (CmmLit (CmmInt 1 W8)) loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr -loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB addr off) bWord +loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB dflags addr off) (bWord dflags) where off = fixedHdrSize dflags * wORD_SIZE + oFFSET_StgMutArrPtrs_ptrs 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 @@ -933,8 +926,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 -- ---------------------------------------------------------------------------- @@ -947,7 +940,7 @@ doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code doSetByteArrayOp ba off len c live = do dflags <- getDynFlags - p <- assignTemp $ cmmOffsetExpr (cmmOffsetB ba (arrWordsHdrSize dflags)) off + p <- assignTemp $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off emitMemsetCall p c len (CmmLit (mkIntCLit 1)) live -- ---------------------------------------------------------------------------- @@ -1007,15 +1000,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 + 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 n (CmmLit (mkIntCLit wORD_SIZE)) 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 @@ -1037,26 +1030,26 @@ emitCloneArray info_p res_r src0 src_off0 n0 live = do size <- assignTemp $ n `cmmAddWord` bytesToWordsRoundUp card_bytes words <- assignTemp $ arrPtrsHdrSizeW dflags `cmmAddWord` 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) 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 + + oFFSET_StgMutArrPtrs_ptrs)) n + stmtC $ CmmStore (cmmOffsetB dflags arr (fixedHdrSize dflags * wORD_SIZE + + oFFSET_StgMutArrPtrs_size)) 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 - emitMemsetCall (cmmOffsetExprW dst_p n) + emitMemsetCall (cmmOffsetExprW dflags dst_p n) (CmmLit (mkIntCLit 1)) card_bytes (CmmLit (mkIntCLit wORD_SIZE)) diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs index 751f45db52..975787e492 100644 --- a/compiler/codeGen/CgProf.hs +++ b/compiler/codeGen/CgProf.hs @@ -70,9 +70,11 @@ 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) bWord +costCentreFrom dflags cl + = CmmLoad (cmmOffsetB dflags cl oFFSET_StgHeader_ccs) (bWord dflags) staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit] -- The profiling header words in a static closure @@ -88,7 +90,8 @@ 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) + do dflags <- getDynFlags + stmtC (CmmStore (cmmOffsetB dflags 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. @@ -114,7 +117,7 @@ profAlloc words ccs = ifProfiling $ do dflags <- getDynFlags stmtC (addToMemE alloc_rep - (cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc) + (cmmOffsetB dflags ccs oFFSET_CostCentreStack_mem_alloc) (CmmMachOp (MO_UU_Conv wordWidth alloc_rep) $ [CmmMachOp mo_wordSub [words, mkIntExpr (profHdrSize dflags)]])) @@ -129,15 +132,17 @@ profAlloc words ccs enterCostCentreThunk :: CmmExpr -> Code enterCostCentreThunk closure = ifProfiling $ do - stmtC $ storeCurCCS (costCentreFrom closure) + 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 @@ -223,9 +228,9 @@ 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 @@ -236,10 +241,10 @@ pushCostCentre result ccs cc (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) 1 ----------------------------------------------------------------------------- -- @@ -267,7 +272,8 @@ dynLdvInit = -- (era << LDV_SHIFT) | 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 -- -- Called when a closure is entered, marks the closure as having been "used". @@ -276,34 +282,37 @@ ldvRecordCreate closure = stmtC $ CmmStore (ldvWord closure) dynLdvInit -- profiling. -- ldvEnterClosure :: ClosureInfo -> Code -ldvEnterClosure closure_info = ldvEnter (cmmOffsetB (CmmReg nodeReg) (-tag)) +ldvEnterClosure closure_info + = do dflags <- getDynFlags + ldvEnter (cmmOffsetB dflags (CmmReg nodeReg) (-tag)) where tag = funTag closure_info -- 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 (cmmAndWord (CmmLoad ldv_wd (bWord dflags)) + (CmmLit (mkWordCLit lDV_CREATE_MASK))) + (cmmOrWord loadEra (CmmLit (mkWordCLit 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))) loadEra :: CmmExpr loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth) [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 -- LDV constants, from ghc/includes/Constants.h lDV_SHIFT :: Int diff --git a/compiler/codeGen/CgStackery.lhs b/compiler/codeGen/CgStackery.lhs index 217586a9d1..04fce86f2f 100644 --- a/compiler/codeGen/CgStackery.lhs +++ b/compiler/codeGen/CgStackery.lhs @@ -317,7 +317,7 @@ 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 diff --git a/compiler/codeGen/CgTailCall.lhs b/compiler/codeGen/CgTailCall.lhs index 6db1b46d77..b82e3080f3 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 diff --git a/compiler/codeGen/CgTicky.hs b/compiler/codeGen/CgTicky.hs index bc3e26fb47..bc9a94c8bd 100644 --- a/compiler/codeGen/CgTicky.hs +++ b/compiler/codeGen/CgTicky.hs @@ -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) + [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl + oFFSET_StgEntCounter_registeredp)) (bWord dflags), + CmmLit (mkIntCLit 0)] + register_stmts + = [ CmmStore (CmmLit (cmmLabelOffB ctr_lbl oFFSET_StgEntCounter_link)) + (CmmLoad ticky_entry_ctrs (bWord dflags)) + , 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")) + emitIf test (stmtsC register_stmts) tickyReturnOldCon, tickyReturnNewCon :: Arity -> Code tickyReturnOldCon arity diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 298143bd08..29554c8f14 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -69,7 +69,6 @@ import Util import DynFlags import FastString import Outputable -import Platform import Data.Char import Data.Word @@ -115,12 +114,12 @@ mkSimpleLit (MachStr _) = panic "mkSimpleLit: MachStr" -- should have converted them all to a real core representation. 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 _ (MachInt _) = MO_S_Lt wordWidth +mkLtOp _ (MachFloat _) = MO_F_Lt W32 +mkLtOp _ (MachDouble _) = MO_F_Lt W64 +mkLtOp dflags lit = MO_U_Lt (typeWidth (cmmLitType dflags (mkSimpleLit lit))) --------------------------------------------------- @@ -154,8 +153,8 @@ tagForCon con = tag | 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 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 where closure_tbl = CmmLit (CmmLabel lbl) lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs @@ -307,15 +306,15 @@ callerSaveVolatileRegs dflags vols = (caller_save, caller_load) 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 @@ -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)) @@ -499,7 +500,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 +513,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) @@ -604,8 +606,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 +631,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 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 +654,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 mid_lit)] ------------------------------------------------------------------------- -- @@ -687,13 +691,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 +717,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 @@ -810,11 +816,11 @@ 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 _ BaseReg = regTableOffset 0 +get_GlobalReg_addr dflags mid + = get_Regtable_addr_from_offset dflags + (globalRegType dflags mid) (baseRegOffset mid) -- Calculate a literal representing an offset into the register table. -- Used when we don't have an actual BaseReg to offset from. @@ -822,68 +828,69 @@ regTableOffset :: Int -> CmmExpr regTableOffset n = CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + 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 -- | 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 +902,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 +914,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) [ CmmReg (CmmGlobal reg), CmmLit (CmmInt (fromIntegral offset) wordWidth)]) -- CmmLit, CmmReg (CmmLocal), CmmStackSlot _other -> expr + where platform = targetPlatform dflags diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs index ae05bffbb8..88174b9f8c 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 _ PtrArg = gcWord +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 diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index d74533d76e..65e0103099 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -235,7 +235,7 @@ cgDataCon data_con do { _ <- ticky_code ; ldvEnter (CmmReg nodeReg) ; tickyReturnOldCon (length arg_things) - ; void $ emitReturn [cmmOffsetB (CmmReg nodeReg) + ; void $ emitReturn [cmmOffsetB dflags (CmmReg nodeReg) (tagForCon data_con)] } -- The case continuation code expects a tagged pointer diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 04799a7f0b..b3a3fc8de8 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -65,9 +65,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 @@ -340,7 +341,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 +382,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 @@ -481,7 +482,8 @@ 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) + do dflags <- getDynFlags + emit $ mkTaggedObjectLoad dflags reg node off tag) where tag = lfDynTag lf_info ----------------------------------------- @@ -580,7 +582,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)) @@ -686,7 +688,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 +705,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), @@ -718,7 +720,7 @@ link_caf node _is_upd = do -- 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/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index 083e615b78..15686a8c9a 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -56,14 +56,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 +149,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) @@ -191,7 +191,7 @@ buildDynCon' dflags platform binder _cc con [arg] offsetW = (val_int - mIN_INTLIKE) * (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 + ; return ( litIdInfo dflags binder (mkConLFInfo con) intlike_amode , return mkNop) } buildDynCon' dflags platform binder _cc con [arg] @@ -205,7 +205,7 @@ buildDynCon' dflags platform binder _cc con [arg] offsetW = (val_int - mIN_CHARLIKE) * (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 + ; return ( litIdInfo dflags binder (mkConLFInfo con) charlike_amode , return mkNop) } -------- buildDynCon': the general case ----------- @@ -225,7 +225,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 @@ -255,7 +255,8 @@ bindConArgs (DataAlt con) base args -- when accessing the constructor field. bind_arg :: (NonVoid Id, VirtualHpOffset) -> FCode LocalReg bind_arg (arg, offset) - = do { emit $ mkTaggedObjectLoad (idToReg arg) base offset tag + = do { dflags <- getDynFlags + ; emit $ mkTaggedObjectLoad dflags (idToReg dflags arg) base offset tag ; bindArgToReg arg } bindConArgs _other_con _base args diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs index e4611237cc..10fc2029a9 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 @@ -81,18 +82,18 @@ mkCgIdInfo id lf expr , cg_loc = CmmLoc expr, cg_tag = lfDynTag 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 -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_loc = LneLoc blk_id (map (idToReg dflags) regs) , cg_tag = lfDynTag lf } where lf = mkLFLetNoEscape @@ -104,9 +105,9 @@ rhsIdInfo id lf_info = do { reg <- newTemp gcWord ; return (mkCgIdInfo 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 lf_info)) idInfoToAmode :: CgIdInfo -> CmmExpr -- Returns a CmmExpr for the *tagged* pointer @@ -114,9 +115,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 +171,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 @@ -212,9 +214,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 id lf_info (CmmReg (CmmLocal reg))) + return reg rebindToReg :: NonVoid Id -> FCode LocalReg -- Like bindToReg, but the Id is already in scope, so @@ -229,7 +232,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 -- @@ -237,8 +240,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 bc29c68c37..a87bef110c 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,10 +504,12 @@ 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 @@ -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 @@ -673,7 +686,7 @@ 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 ; return AssignedDirectly @@ -715,7 +728,7 @@ 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 <*> diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index cdedd1243c..eb5850f10f 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -55,7 +55,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 + ; cmm_args <- getFCallArgs stg_args ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty ; let ((call_args, arg_hints), cmm_target) = case target of @@ -98,18 +110,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] @@ -262,10 +262,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 +279,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,16 +291,16 @@ emitSaveThreadState bid = do dflags <- getDynFlags -- CurrentTSO->stackobj->sp = Sp; - emitStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO (tso_stackobj dflags)) bWord) (stack_SP dflags)) + emitStore (cmmOffset dflags (CmmLoad (cmmOffset dflags stgCurrentTSO (tso_stackobj dflags)) (bWord dflags)) (stack_SP dflags)) (CmmStackSlot (Young bid) (widthInBytes (typeWidth gcWord))) - emit closeNursery + 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 @@ -309,36 +310,36 @@ loadThreadState dflags tso stack = do -- 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)) + mkAssign spLim (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags)) rESERVED_STACK_WORDS), - openNursery, + 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 + (cmmOffsetExpr dflags + (CmmLoad (nursery_bdescr_start dflags) (bWord dflags)) + (cmmOffset dflags (CmmMachOp mo_wordMul [ CmmMachOp (MO_SS_Conv W32 wordWidth) - [CmmLoad nursery_bdescr_blocks b32], + [CmmLoad (nursery_bdescr_blocks dflags) b32], mkIntExpr bLOCK_SIZE ]) (-1) @@ -346,12 +347,13 @@ openNursery = catAGraphs [ ) ] 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 +nursery_bdescr_start dflags = cmmOffset dflags stgCurrentNursery oFFSET_bdescr_start +nursery_bdescr_blocks dflags = cmmOffset dflags stgCurrentNursery oFFSET_bdescr_blocks tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: DynFlags -> ByteOff tso_stackobj dflags = closureField dflags oFFSET_StgTSO_stackobj @@ -405,10 +407,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 b82064e0ec..27d4244e35 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -140,9 +140,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)) ----------------------------------------------------------- @@ -206,7 +206,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,9 +219,9 @@ 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) +padLitToWord :: DynFlags -> CmmLit -> [CmmLit] +padLitToWord dflags lit = lit : padding pad_length + where width = typeWidth (cmmLitType dflags lit) pad_length = wORD_SIZE - widthInBytes width :: Int padding n | n <= 0 = [] @@ -542,11 +542,13 @@ do_checks :: Bool -- Should we check the stack? do_checks checkStack alloc do_gc = do gc_id <- newLabelC - when checkStack $ - emit =<< mkCmmIfGoto sp_oflo gc_id + when checkStack $ do + dflags <- getDynFlags + emit =<< mkCmmIfGoto (sp_oflo dflags) gc_id when (alloc /= 0) $ do - emitAssign hpReg bump_hp + dflags <- getDynFlags + emitAssign hpReg (bump_hp dflags) emit =<< mkCmmIfThen hp_oflo (alloc_n <*> mkBranch gc_id) emitOutOfLine gc_id $ @@ -560,11 +562,12 @@ do_checks checkStack alloc do_gc = do -- confuse the LDV profiler. where alloc_lit = mkIntExpr (alloc*wORD_SIZE) -- Bytes - bump_hp = cmmOffsetExprB (CmmReg hpReg) alloc_lit + bump_hp dflags = cmmOffsetExprB dflags (CmmReg hpReg) alloc_lit -- Sp overflow if (Sp - CmmHighStack < SpLim) - sp_oflo = CmmMachOp mo_wordULt - [CmmMachOp (MO_Sub (typeWidth (cmmRegType spReg))) + sp_oflo dflags + = CmmMachOp mo_wordULt + [CmmMachOp (MO_Sub (typeWidth (cmmRegType dflags spReg))) [CmmReg spReg, CmmLit CmmHighStackMark], CmmReg spLimReg] diff --git a/compiler/codeGen/StgCmmHpc.hs b/compiler/codeGen/StgCmmHpc.hs index 8f4c8d9223..cb60e9dd71 100644 --- a/compiler/codeGen/StgCmmHpc.hs +++ b/compiler/codeGen/StgCmmHpc.hs @@ -19,14 +19,14 @@ import StgCmmUtils import HscTypes 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 diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 3f29bf67ec..b670b2401e 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -527,13 +527,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 @@ -592,16 +591,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,27 +608,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 platform) wordWidth) [infoTableConstrTag dflags info_table] + = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) wordWidth) [infoTableConstrTag dflags info_table] where - platform = targetPlatform dflags - 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 platform) wordWidth) [infoTableClosureType dflags info_table] + = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) wordWidth) [infoTableClosureType dflags info_table] where - platform = targetPlatform dflags - 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 @@ -640,21 +637,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 (targetPlatform dflags)) + = 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 (targetPlatform dflags)) + = CmmLoad (cmmOffsetB dflags info_tbl (stdClosureTypeOffset dflags)) (bHalfWord dflags) infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr infoTablePtrs dflags info_tbl - = CmmLoad (cmmOffsetB info_tbl (stdPtrsOffset dflags)) (bHalfWord (targetPlatform dflags)) + = CmmLoad (cmmOffsetB dflags info_tbl (stdPtrsOffset dflags)) (bHalfWord dflags) infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr infoTableNonPtrs dflags info_tbl - = CmmLoad (cmmOffsetB info_tbl (stdNonPtrsOffset dflags)) (bHalfWord (targetPlatform dflags)) + = CmmLoad (cmmOffsetB dflags info_tbl (stdNonPtrsOffset dflags)) (bHalfWord dflags) funInfoTable :: DynFlags -> CmmExpr -> CmmExpr -- Takes the info pointer of a function, @@ -662,8 +659,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) | otherwise - = cmmOffsetW info_ptr (1 + stdInfoTableSizeW dflags) + = cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags) -- Past the entry code pointer diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 29d99943be..aa803e026a 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -81,10 +81,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 @@ -104,7 +105,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)] @@ -116,10 +118,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 @@ -137,15 +140,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 () @@ -153,7 +158,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 _ [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 @@ -187,7 +192,7 @@ emitPrimOp [res_r,res_c] IntAddCOp [aa,bb] ] -emitPrimOp [res_r,res_c] IntSubCOp [aa,bb] +emitPrimOp _ [res_r,res_c] IntSubCOp [aa,bb] {- Similarly: #define subIntCzh(r,c,a,b) \ { r = ((I_)(a)) - ((I_)(b)); \ @@ -210,7 +215,7 @@ emitPrimOp [res_r,res_c] IntSubCOp [aa,bb] ] -emitPrimOp [res] ParOp [arg] +emitPrimOp _ [res] ParOp [arg] = -- for now, just implement this in a C function -- later, we might want to inline it. @@ -219,37 +224,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) + val + | dopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag arg) | otherwise = CmmLit zeroCLit -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) -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)) @@ -257,53 +259,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 [ + cmmLoadIndexW dflags arg1 (fixedHdrSize dflags) (bWord dflags), + cmmLoadIndexW dflags arg2 (fixedHdrSize dflags) (bWord dflags) ]) -emitPrimOp [res] ReallyUnsafePtrEqualityOp [arg1,arg2] +emitPrimOp _ [res] ReallyUnsafePtrEqualityOp [arg1,arg2] = emitAssign (CmmLocal res) (CmmMachOp mo_wordEq [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 arg)) {- Freezing arrays-of-ptrs requires changing an info table, for the benefit of the generational collector. It needs to scavenge mutable @@ -315,202 +311,201 @@ 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) (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 _ 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 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 _ 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 -- 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 _ 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 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 _ 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 -- 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 _ 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 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 _ 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 -- 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 _ 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 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 _ 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 -- 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 _ 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 -- 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 _ 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 -- 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] = +emitPrimOp _ [res] PopCnt8Op [w] = emitPopCntCall res (CmmMachOp mo_WordTo8 [w]) W8 -emitPrimOp [res] PopCnt16Op [w] = +emitPrimOp _ [res] PopCnt16Op [w] = emitPopCntCall res (CmmMachOp mo_WordTo16 [w]) W16 -emitPrimOp [res] PopCnt32Op [w] = +emitPrimOp _ [res] PopCnt32Op [w] = emitPopCntCall res (CmmMachOp mo_WordTo32 [w]) W32 -emitPrimOp [res] PopCnt64Op [w] = +emitPrimOp _ [res] PopCnt64Op [w] = emitPopCntCall res w W64 -- arg always has type W64, no need to narrow -emitPrimOp [res] PopCntOp [w] = +emitPrimOp _ [res] PopCntOp [w] = emitPopCntCall res w wordWidth -- The rest just translate straightforwardly -emitPrimOp [res] op [arg] +emitPrimOp _s [res] op [arg] | nopOp op = emitAssign (CmmLocal res) arg @@ -518,7 +513,7 @@ emitPrimOp [res] op [arg] = emitAssign (CmmLocal res) $ CmmMachOp (mop rep wordWidth) [CmmMachOp (mop wordWidth rep) [arg]] -emitPrimOp r@[res] op args +emitPrimOp _ r@[res] op args | Just prim <- callishOp op = do emitPrimCall r prim args @@ -526,9 +521,8 @@ emitPrimOp r@[res] op args = 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 @@ -544,7 +538,7 @@ callishPrimOpSupported dflags op | otherwise -> Right genericWordQuotRemOp WordQuotRem2Op | ncg && x86ish -> Left (MO_U_QuotRem2 wordWidth) - | otherwise -> Right genericWordQuotRem2Op + | otherwise -> Right (genericWordQuotRem2Op dflags) WordAdd2Op | ncg && x86ish -> Left (MO_Add2 wordWidth) | otherwise -> Right genericWordAdd2Op @@ -579,10 +573,10 @@ genericWordQuotRemOp [res_q, res_r] [arg_x, arg_y] (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] +genericWordQuotRem2Op :: DynFlags -> GenericOp +genericWordQuotRem2Op dflags [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 + where ty = cmmExprType dflags 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] @@ -626,22 +620,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 dflags <- getDynFlags - let platform = targetPlatform dflags - r1 <- newTemp (cmmExprType arg_x) - r2 <- newTemp (cmmExprType arg_x) + r1 <- newTemp (cmmExprType dflags arg_x) + r2 <- newTemp (cmmExprType dflags arg_x) let 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 platform))) + hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags))) wordWidth) - hwm = CmmLit (CmmInt (halfWordMask platform) wordWidth) + hwm = CmmLit (CmmInt (halfWordMask dflags) wordWidth) emit $ catAGraphs [mkAssign (CmmLocal r1) (add (bottomHalf arg_x) (bottomHalf arg_y)), @@ -658,8 +651,7 @@ genericWordAdd2Op _ _ = panic "genericWordAdd2Op" genericWordMul2Op :: GenericOp genericWordMul2Op [res_h, res_l] [arg_x, arg_y] = do dflags <- getDynFlags - let platform = targetPlatform dflags - t = cmmExprType arg_x + let t = cmmExprType dflags arg_x xlyl <- liftM CmmLocal $ newTemp t xlyh <- liftM CmmLocal $ newTemp t xhyl <- liftM CmmLocal $ newTemp t @@ -673,9 +665,9 @@ genericWordMul2Op [res_h, res_l] [arg_x, arg_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 platform))) + hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags))) wordWidth) - hwm = CmmLit (CmmInt (halfWordMask platform) wordWidth) + hwm = CmmLit (CmmInt (halfWordMask dflags) wordWidth) emit $ catAGraphs [mkAssign xlyl (mul (bottomHalf arg_x) (bottomHalf arg_y)), @@ -918,42 +910,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, mkIntExpr mUT_ARR_PTRS_CARD_BITS]) ) (CmmLit (CmmInt 1 W8)) loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr -loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB addr off) bWord +loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB dflags addr off) (bWord dflags) where off = fixedHdrSize dflags * wORD_SIZE + oFFSET_StgMutArrPtrs_ptrs 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 @@ -999,8 +994,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 -- ---------------------------------------------------------------------------- @@ -1013,7 +1008,7 @@ doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () doSetByteArrayOp ba off len c = do dflags <- getDynFlags - p <- assignTempE $ cmmOffsetExpr (cmmOffsetB ba (arrWordsHdrSize dflags)) off + p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off emitMemsetCall p c len (mkIntExpr 1) -- ---------------------------------------------------------------------------- @@ -1081,15 +1076,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 + 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 n (mkIntExpr wORD_SIZE) 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 @@ -1110,25 +1105,25 @@ emitCloneArray info_p res_r src0 src_off0 n0 = do dflags <- getDynFlags words <- assignTempE $ arrPtrsHdrSizeW dflags `cmmAddWord` size - arr_r <- newTemp bWord + arr_r <- newTemp (bWord dflags) emitAllocateCall arr_r myCapability words tickyAllocPrim (mkIntExpr (arrPtrsHdrSize dflags)) (n `cmmMulWord` wordSize) zeroExpr 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 + + oFFSET_StgMutArrPtrs_ptrs)) n + emit $ mkStore (cmmOffsetB dflags arr (fixedHdrSize dflags * wORD_SIZE + + oFFSET_StgMutArrPtrs_size)) 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) (mkIntExpr wORD_SIZE) - emitMemsetCall (cmmOffsetExprW dst_p n) + emitMemsetCall (cmmOffsetExprW dflags dst_p n) (mkIntExpr 1) card_bytes (mkIntExpr wORD_SIZE) diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index 7f677d5969..c980493de1 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -67,10 +67,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,9 +85,10 @@ 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) (ccsType dflags) staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit] -- The profiling header words in a static closure @@ -142,7 +143,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) @@ -173,7 +174,7 @@ profAlloc words ccs = ifProfiling $ do dflags <- getDynFlags emit (addToMemE alloc_rep - (cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc) + (cmmOffsetB dflags ccs oFFSET_CostCentreStack_mem_alloc) (CmmMachOp (MO_UU_Conv wordWidth (typeWidth alloc_rep)) $ [CmmMachOp mo_wordSub [words, mkIntExpr (profHdrSize dflags)]])) @@ -187,16 +188,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 () @@ -288,9 +291,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 +304,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) 1 ----------------------------------------------------------------------------- -- @@ -332,7 +335,8 @@ dynLdvInit = -- (era << LDV_SHIFT) | 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 -- -- Called when a closure is entered, marks the closure as having been "used". @@ -341,35 +345,36 @@ ldvRecordCreate closure = emit $ mkStore (ldvWord closure) dynLdvInit -- profiling. -- ldvEnterClosure :: ClosureInfo -> FCode () -ldvEnterClosure closure_info = ldvEnter (cmmOffsetB (CmmReg nodeReg) (-tag)) +ldvEnterClosure closure_info = do dflags <- getDynFlags + ldvEnter (cmmOffsetB dflags (CmmReg nodeReg) (-tag)) where tag = funTag closure_info -- 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))) +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 (cmmAndWord (CmmLoad ldv_wd (bWord dflags)) + (CmmLit (mkWordCLit lDV_CREATE_MASK))) + (cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE))) + 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 loadEra :: CmmExpr loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth) [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 -- LDV constants, from ghc/includes/Constants.h lDV_SHIFT :: Int diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs index bb1c4cf788..e6cb6ed84b 100644 --- a/compiler/codeGen/StgCmmTicky.hs +++ b/compiler/codeGen/StgCmmTicky.hs @@ -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, + [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl + oFFSET_StgEntCounter_registeredp)) (bWord dflags), zeroExpr] 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)) + = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl oFFSET_StgEntCounter_link)) + (CmmLoad ticky_entry_ctrs (bWord dflags)) + , mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl) + , mkStore (CmmLit (cmmLabelOffB ctr_lbl + oFFSET_StgEntCounter_registeredp)) (mkIntExpr 1) ] ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs")) + emit =<< mkCmmIfThen test (catAGraphs register_stmts) tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode () tickyReturnOldCon arity diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 8cb0ee89be..b402199ac4 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -88,12 +88,12 @@ cgLit (MachStr s) = newByteStringCLit (bytesFB s) -- not unpackFS; we want the UTF-8 byte stream. cgLit other_lit = return (mkSimpleLit 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 _ (MachInt _) = MO_S_Lt wordWidth +mkLtOp _ (MachFloat _) = MO_F_Lt W32 +mkLtOp _ (MachDouble _) = MO_F_Lt W64 +mkLtOp dflags lit = MO_U_Lt (typeWidth (cmmLitType dflags (mkSimpleLit lit))) -- ToDo: seems terribly indirect! mkSimpleLit :: Literal -> CmmLit @@ -142,13 +142,14 @@ 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)) + (CmmLoad (cmmOffsetB dflags + (CmmReg (CmmLocal base)) (wORD_SIZE*offset - tag)) (localRegType reg)) @@ -159,9 +160,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 +252,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,11 +267,11 @@ 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 _ BaseReg = regTableOffset 0 +get_GlobalReg_addr dflags mid + = get_Regtable_addr_from_offset (targetPlatform dflags) + (globalRegType dflags mid) (baseRegOffset mid) -- Calculate a literal representing an offset into the register table. -- Used when we don't have an actual BaseReg to offset from. @@ -344,8 +345,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 +362,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 +373,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 +426,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 () @@ -531,7 +535,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,8 +546,8 @@ 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 @@ -649,17 +653,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 + = do + dflags <- getDynFlags + let cmm_lit = mkSimpleLit lit - cmm_ty = cmmLitType cmm_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 +675,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 mid_lit)] -------------- @@ -705,7 +712,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) diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index e1c0e30a58..478c5985c8 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -141,6 +141,7 @@ dsCImport :: Id -> Maybe Header -> DsM ([Binding], SDoc, SDoc) dsCImport id co (CLabel cid) cconv _ _ = do + dflags <- getDynFlags let ty = pFst $ coercionKind co fod = case tyConAppTyCon_maybe (dropForAlls ty) of Just tycon @@ -152,7 +153,7 @@ dsCImport id co (CLabel cid) cconv _ _ = do let rhs = foRhs (Lit (MachLabel cid stdcall_info fod)) rhs' = Cast rhs co - stdcall_info = fun_type_arg_stdcall_info cconv ty + stdcall_info = fun_type_arg_stdcall_info dflags cconv ty in return ([(id, rhs')], empty, empty) @@ -166,15 +167,15 @@ dsCImport id co CWrapper cconv _ _ -- For stdcall labels, if the type was a FunPtr or newtype thereof, -- then we need to calculate the size of the arguments in order to add -- the @n suffix to the label. -fun_type_arg_stdcall_info :: CCallConv -> Type -> Maybe Int -fun_type_arg_stdcall_info StdCallConv ty +fun_type_arg_stdcall_info :: DynFlags -> CCallConv -> Type -> Maybe Int +fun_type_arg_stdcall_info dflags StdCallConv ty | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty, tyConUnique tc == funPtrTyConKey = let (_tvs,sans_foralls) = tcSplitForAllTys arg_ty (fe_arg_tys, _orig_res_ty) = tcSplitFunTys sans_foralls - in Just $ sum (map (widthInBytes . typeWidth . typeCmmType . getPrimTyOf) fe_arg_tys) -fun_type_arg_stdcall_info _other_conv _ + in Just $ sum (map (widthInBytes . typeWidth . typeCmmType dflags . getPrimTyOf) fe_arg_tys) +fun_type_arg_stdcall_info _ _other_conv _ = Nothing \end{code} @@ -519,7 +520,7 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc (arg_cname n stg_type, stg_type, ty, - typeCmmType (getPrimTyOf ty)) + typeCmmType dflags (getPrimTyOf ty)) | (ty,n) <- zip arg_htys [1::Int ..] ] arg_cname n stg_ty @@ -546,7 +547,7 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc stable_ptr_arg = (text "the_stableptr", text "StgStablePtr", undefined, - typeCmmType (mkStablePtrPrimTy alphaTy)) + typeCmmType dflags (mkStablePtrPrimTy alphaTy)) -- stuff to do with the return type of the C function res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes @@ -735,7 +736,7 @@ insertRetAddr dflags CCallConv args -- (See rts/Adjustor.c for details). let go :: Int -> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)] - go 4 args = ret_addr_arg : args + go 4 args = ret_addr_arg dflags : args go n (arg:args) = arg : go (n+1) args go _ [] = [] in go 0 args @@ -746,20 +747,20 @@ insertRetAddr dflags CCallConv args -- (See rts/Adjustor.c for details). let go :: Int -> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)] - go 6 args = ret_addr_arg : args + go 6 args = ret_addr_arg dflags : args go n (arg@(_,_,_,rep):args) | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args | otherwise = arg : go n args go _ [] = [] in go 0 args _ -> - ret_addr_arg : args + ret_addr_arg dflags : args where platform = targetPlatform dflags insertRetAddr _ _ args = args -ret_addr_arg :: (SDoc, SDoc, Type, CmmType) -ret_addr_arg = (text "original_return_addr", text "void*", undefined, - typeCmmType addrPrimTy) +ret_addr_arg :: DynFlags -> (SDoc, SDoc, Type, CmmType) +ret_addr_arg dflags = (text "original_return_addr", text "void*", undefined, + typeCmmType dflags addrPrimTy) -- This function returns the primitive type associated with the boxed -- type argument to a foreign export (eg. Int ==> Int#). diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index 2ff1ed9829..211620ac42 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -146,7 +146,7 @@ cmmLlvmGen :: DynFlags -> UniqSupply -> LlvmEnv -> RawCmmDecl cmmLlvmGen dflags us env cmm = do -- rewrite assignments to global regs let fixed_cmm = {-# SCC "llvm_fix_regs" #-} - fixStgRegisters (targetPlatform dflags) cmm + fixStgRegisters dflags cmm dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmmGroup [fixed_cmm]) diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 7f80cab617..a4b7652f8a 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -243,10 +243,12 @@ genCall env (CmmPrim _ (Just stmts)) _ _ _ -- Handle all other foreign calls and prim ops. genCall env target res args ret = do + let dflags = getDflags env + -- parameter types let arg_type (CmmHinted _ AddrHint) = i8Ptr -- cast pointers to i8*. Llvm equivalent of void* - arg_type (CmmHinted expr _ ) = cmmToLlvmType $ cmmExprType expr + arg_type (CmmHinted expr _ ) = cmmToLlvmType $ cmmExprType dflags expr -- ret type let ret_type ([]) = LMVoid @@ -755,11 +757,12 @@ exprToVarOpt env opt e = case e of -> genMachOp env opt op exprs CmmRegOff r i - -> exprToVar env $ expandCmmReg (r, i) + -> exprToVar env $ expandCmmReg dflags (r, i) CmmStackSlot _ _ -> panic "exprToVar: CmmStackSlot not supported!" + where dflags = getDflags env -- | Handle CmmMachOp expressions genMachOp :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData @@ -1171,9 +1174,10 @@ genLit env (CmmFloat r w) nilOL, []) genLit env cmm@(CmmLabel l) - = let label = strCLabel_llvm env l + = let dflags = getDflags env + label = strCLabel_llvm env l ty = funLookup label env - lmty = cmmToLlvmType $ cmmLitType cmm + lmty = cmmToLlvmType $ cmmLitType dflags cmm in case ty of -- Make generic external label definition and then pointer to it Nothing -> do @@ -1340,9 +1344,9 @@ doExpr ty expr = do -- | Expand CmmRegOff -expandCmmReg :: (CmmReg, Int) -> CmmExpr -expandCmmReg (reg, off) - = let width = typeWidth (cmmRegType reg) +expandCmmReg :: DynFlags -> (CmmReg, Int) -> CmmExpr +expandCmmReg dflags (reg, off) + = let width = typeWidth (cmmRegType dflags reg) voff = CmmLit $ CmmInt (fromIntegral off) width in CmmMachOp (MO_Add width) [CmmReg reg, voff] diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs index 8e42149dce..eae8246138 100644 --- a/compiler/llvmGen/LlvmCodeGen/Data.hs +++ b/compiler/llvmGen/LlvmCodeGen/Data.hs @@ -38,11 +38,12 @@ structStr = fsLit "_struct" -- done by 'resolveLlvmData'. genLlvmData :: LlvmEnv -> (Section, CmmStatics) -> LlvmUnresData genLlvmData env (sec, Statics lbl xs) = - let static = map genData xs + let dflags = getDflags env + static = map genData xs label = strCLabel_llvm env lbl types = map getStatTypes static - getStatTypes (Left x) = cmmToLlvmType $ cmmLitType x + getStatTypes (Left x) = cmmToLlvmType $ cmmLitType dflags x getStatTypes (Right x) = getStatType x strucTy = LMStruct types @@ -106,9 +107,10 @@ resData :: LlvmEnv -> UnresStatic -> (LlvmEnv, LlvmStatic, [LMGlobal]) resData env (Right stat) = (env, stat, []) resData env (Left cmm@(CmmLabel l)) = - let label = strCLabel_llvm env l + let dflags = getDflags env + label = strCLabel_llvm env l ty = funLookup label env - lmty = cmmToLlvmType $ cmmLitType cmm + lmty = cmmToLlvmType $ cmmLitType dflags cmm in case ty of -- Make generic external label defenition and then pointer to it Nothing -> diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index e92eb4f34c..fc20ef4988 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -62,7 +62,7 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps cmm_stream do_lint cmm = do { showPass dflags "CmmLint" - ; case cmmLint (targetPlatform dflags) cmm of + ; case cmmLint dflags cmm of Just err -> do { log_action dflags dflags SevDump noSrcSpan defaultDumpStyle err ; ghcExit dflags 1 } diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 6b1e93f271..1490360057 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -378,7 +378,7 @@ cmmNativeGen dflags ncgImpl us cmm count -- rewrite assignments to global regs let fixed_cmm = {-# SCC "fixStgRegisters" #-} - fixStgRegisters platform cmm + fixStgRegisters dflags cmm -- cmm to cmm optimisations let (opt_cmm, imports) = diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs index 0b5ffcd0d1..2135020097 100644 --- a/compiler/nativeGen/PIC.hs +++ b/compiler/nativeGen/PIC.hs @@ -133,7 +133,7 @@ cmmMakeDynamicReference' dflags addImport referenceKind lbl AccessViaSymbolPtr -> do let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl addImport symbolPtr - return $ CmmLoad (cmmMakePicReference dflags symbolPtr) bWord + return $ CmmLoad (cmmMakePicReference dflags symbolPtr) (bWord dflags) AccessDirectly -> case referenceKind of -- for data, we might have to make some calculations: diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index 6581375382..307c65b441 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -124,7 +124,7 @@ stmtToInstrs stmt = do | target32Bit (targetPlatform dflags) && isWord64 ty -> assignReg_I64Code reg src | otherwise -> assignReg_IntCode size reg src - where ty = cmmRegType reg + where ty = cmmRegType dflags reg size = cmmTypeSize ty CmmStore addr src @@ -132,7 +132,7 @@ stmtToInstrs stmt = do | target32Bit (targetPlatform dflags) && isWord64 ty -> assignMem_I64Code addr src | otherwise -> assignMem_IntCode size addr src - where ty = cmmExprType src + where ty = cmmExprType dflags src size = cmmTypeSize ty CmmCall target result_regs args _ @@ -218,12 +218,12 @@ jumpTableEntry (Just blockid) = CmmStaticLit (CmmLabel blockLabel) -- Expand CmmRegOff. ToDo: should we do it this way around, or convert -- CmmExprs into CmmRegOff? -mangleIndexTree :: CmmExpr -> CmmExpr -mangleIndexTree (CmmRegOff reg off) +mangleIndexTree :: DynFlags -> CmmExpr -> CmmExpr +mangleIndexTree dflags (CmmRegOff reg off) = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] - where width = typeWidth (cmmRegType reg) + where width = typeWidth (cmmRegType dflags reg) -mangleIndexTree _ +mangleIndexTree _ _ = panic "PPC.CodeGen.mangleIndexTree: no match" -- ----------------------------------------------------------------------------- @@ -370,11 +370,11 @@ getRegister' _ (CmmReg (CmmGlobal PicBaseReg)) return (Fixed archWordSize reg nilOL) getRegister' dflags (CmmReg reg) - = return (Fixed (cmmTypeSize (cmmRegType reg)) + = return (Fixed (cmmTypeSize (cmmRegType dflags reg)) (getRegisterReg (targetPlatform dflags) reg) nilOL) getRegister' dflags tree@(CmmRegOff _ _) - = getRegister' dflags (mangleIndexTree tree) + = getRegister' dflags (mangleIndexTree dflags tree) -- for 32-bit architectuers, support some 64 -> 32 bit conversions: -- TO_W_(x), TO_W_(x >> 32) @@ -561,8 +561,8 @@ getRegister' _ (CmmLit (CmmFloat f frep)) = do `consOL` (addr_code `snocOL` LD size dst addr) return (Any size code) -getRegister' _ (CmmLit lit) - = let rep = cmmLitType lit +getRegister' dflags (CmmLit lit) + = let rep = cmmLitType dflags lit imm = litToImm lit code dst = toOL [ LIS dst (HA imm), @@ -607,7 +607,8 @@ temporary, then do the other computation, and then use the temporary: -} getAmode :: CmmExpr -> NatM Amode -getAmode tree@(CmmRegOff _ _) = getAmode (mangleIndexTree tree) +getAmode tree@(CmmRegOff _ _) = do dflags <- getDynFlags + getAmode (mangleIndexTree dflags tree) getAmode (CmmMachOp (MO_Sub W32) [x, CmmLit (CmmInt i _)]) | Just off <- makeImmediate W32 True (-i) @@ -844,14 +845,14 @@ genCCall target dest_regs argsAndHints = do dflags <- getDynFlags let platform = targetPlatform dflags case platformOS platform of - OSLinux -> genCCall' platform GCPLinux target dest_regs argsAndHints - OSDarwin -> genCCall' platform GCPDarwin target dest_regs argsAndHints + OSLinux -> genCCall' dflags GCPLinux target dest_regs argsAndHints + OSDarwin -> genCCall' dflags GCPDarwin target dest_regs argsAndHints _ -> panic "PPC.CodeGen.genCCall: not defined for this os" data GenCCallPlatform = GCPLinux | GCPDarwin genCCall' - :: Platform + :: DynFlags -> GenCCallPlatform -> CmmCallTarget -- function to call -> [HintedCmmFormal] -- where to put the result @@ -902,7 +903,7 @@ genCCall' _ _ (CmmPrim MO_WriteBarrier _) _ _ genCCall' _ _ (CmmPrim _ (Just stmts)) _ _ = stmtsToInstrs stmts -genCCall' platform gcp target dest_regs argsAndHints +genCCall' dflags gcp target dest_regs argsAndHints = ASSERT (not $ any (`elem` [II16]) $ map cmmTypeSize argReps) -- we rely on argument promotion in the codeGen do @@ -934,6 +935,8 @@ genCCall' platform gcp target dest_regs argsAndHints `snocOL` BCTRL usedRegs `appOL` codeAfter) where + platform = targetPlatform dflags + initialStackOffset = case gcp of GCPDarwin -> 24 GCPLinux -> 8 @@ -955,7 +958,7 @@ genCCall' platform gcp target dest_regs argsAndHints = argsAndHints args = map hintlessCmm argsAndHints' - argReps = map cmmExprType args + argReps = map (cmmExprType dflags) args roundTo a x | x `mod` a == 0 = x | otherwise = x + a - (x `mod` a) @@ -1089,7 +1092,7 @@ genCCall' platform gcp target dest_regs argsAndHints | isWord64 rep -> toOL [MR (getHiVRegFromLo r_dest) r3, MR r_dest r4] | otherwise -> unitOL (MR r_dest r3) - where rep = cmmRegType (CmmLocal dest) + where rep = cmmRegType dflags (CmmLocal dest) r_dest = getRegisterReg platform (CmmLocal dest) _ -> panic "genCCall' moveResult: Bad dest_regs" diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs index 681b31d3eb..576e19db1a 100644 --- a/compiler/nativeGen/PPC/Ppr.hs +++ b/compiler/nativeGen/PPC/Ppr.hs @@ -297,7 +297,8 @@ pprSectionHeader seg pprDataItem :: CmmLit -> SDoc pprDataItem lit - = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit) + = sdocWithDynFlags $ \dflags -> + vcat (ppr_item (cmmTypeSize $ cmmLitType dflags lit) lit) where imm = litToImm lit diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index a3409dd28b..27dafb7d42 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -111,7 +111,9 @@ stmtsToInstrs stmts stmtToInstrs :: CmmStmt -> NatM InstrBlock -stmtToInstrs stmt = case stmt of +stmtToInstrs stmt = do + dflags <- getDynFlags + case stmt of CmmNop -> return nilOL CmmComment s -> return (unitOL (COMMENT s)) @@ -119,14 +121,14 @@ stmtToInstrs stmt = case stmt of | isFloatType ty -> assignReg_FltCode size reg src | isWord64 ty -> assignReg_I64Code reg src | otherwise -> assignReg_IntCode size reg src - where ty = cmmRegType reg + where ty = cmmRegType dflags reg size = cmmTypeSize ty CmmStore addr src | isFloatType ty -> assignMem_FltCode size addr src | isWord64 ty -> assignMem_I64Code addr src | otherwise -> assignMem_IntCode size addr src - where ty = cmmExprType src + where ty = cmmExprType dflags src size = cmmTypeSize ty CmmCall target result_regs args _ @@ -203,11 +205,12 @@ assignReg_IntCode _ reg src = do -- Floating point assignment to memory assignMem_FltCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock assignMem_FltCode pk addr src = do + dflags <- getDynFlags Amode dst__2 code1 <- getAmode addr (src__2, code2) <- getSomeReg src tmp1 <- getNewRegNat pk let - pk__2 = cmmExprType src + pk__2 = cmmExprType dflags src code__2 = code1 `appOL` code2 `appOL` if sizeToWidth pk == typeWidth pk__2 then unitOL (ST pk src__2 dst__2) @@ -458,17 +461,21 @@ genCCall target dest_regs argsAndHints -- | Generate code to calculate an argument, and move it into one -- or two integer vregs. arg_to_int_vregs :: CmmExpr -> NatM (OrdList Instr, [Reg]) -arg_to_int_vregs arg +arg_to_int_vregs arg = do dflags <- getDynFlags + arg_to_int_vregs' dflags arg + +arg_to_int_vregs' :: DynFlags -> CmmExpr -> NatM (OrdList Instr, [Reg]) +arg_to_int_vregs' dflags arg -- If the expr produces a 64 bit int, then we can just use iselExpr64 - | isWord64 (cmmExprType arg) + | isWord64 (cmmExprType dflags arg) = do (ChildCode64 code r_lo) <- iselExpr64 arg let r_hi = getHiVRegFromLo r_lo return (code, [r_hi, r_lo]) | otherwise = do (src, code) <- getSomeReg arg - let pk = cmmExprType arg + let pk = cmmExprType dflags arg case cmmTypeSize pk of diff --git a/compiler/nativeGen/SPARC/CodeGen/Amode.hs b/compiler/nativeGen/SPARC/CodeGen/Amode.hs index 92e70eb4dc..139064ccbd 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Amode.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Amode.hs @@ -33,7 +33,8 @@ getAmode -> NatM Amode getAmode tree@(CmmRegOff _ _) - = getAmode (mangleIndexTree tree) + = do dflags <- getDynFlags + getAmode (mangleIndexTree dflags tree) getAmode (CmmMachOp (MO_Sub _) [x, CmmLit (CmmInt i _)]) | fits13Bits (-i) diff --git a/compiler/nativeGen/SPARC/CodeGen/Base.hs b/compiler/nativeGen/SPARC/CodeGen/Base.hs index 469361139b..367d9230ba 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Base.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Base.hs @@ -29,6 +29,7 @@ import Size import Reg import CodeGen.Platform +import DynFlags import OldCmm import OldPprCmm () import Platform @@ -114,13 +115,13 @@ getRegisterReg platform (CmmGlobal mid) -- Expand CmmRegOff. ToDo: should we do it this way around, or convert -- CmmExprs into CmmRegOff? -mangleIndexTree :: CmmExpr -> CmmExpr +mangleIndexTree :: DynFlags -> CmmExpr -> CmmExpr -mangleIndexTree (CmmRegOff reg off) +mangleIndexTree dflags (CmmRegOff reg off) = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] - where width = typeWidth (cmmRegType reg) + where width = typeWidth (cmmRegType dflags reg) -mangleIndexTree _ +mangleIndexTree _ _ = panic "SPARC.CodeGen.Base.mangleIndexTree: no match" diff --git a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs index 74f20196df..d459d98212 100644 --- a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs +++ b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs @@ -93,14 +93,15 @@ condIntCode cond x y = do condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode condFltCode cond x y = do + dflags <- getDynFlags (src1, code1) <- getSomeReg x (src2, code2) <- getSomeReg y tmp <- getNewRegNat FF64 let promote x = FxTOy FF32 FF64 x tmp - pk1 = cmmExprType x - pk2 = cmmExprType y + pk1 = cmmExprType dflags x + pk2 = cmmExprType dflags y code__2 = if pk1 `cmmEqType` pk2 then diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs index c2c47e99aa..f7c7419e15 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs @@ -57,11 +57,12 @@ getRegister :: CmmExpr -> NatM Register getRegister (CmmReg reg) = do dflags <- getDynFlags let platform = targetPlatform dflags - return (Fixed (cmmTypeSize (cmmRegType reg)) - (getRegisterReg platform reg) nilOL) + return (Fixed (cmmTypeSize (cmmRegType dflags reg)) + (getRegisterReg platform reg) nilOL) getRegister tree@(CmmRegOff _ _) - = getRegister (mangleIndexTree tree) + = do dflags <- getDynFlags + getRegister (mangleIndexTree dflags tree) getRegister (CmmMachOp (MO_UU_Conv W64 W32) [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do @@ -490,14 +491,15 @@ trivialFCode -> NatM Register trivialFCode pk instr x y = do + dflags <- getDynFlags (src1, code1) <- getSomeReg x (src2, code2) <- getSomeReg y tmp <- getNewRegNat FF64 let promote x = FxTOy FF32 FF64 x tmp - pk1 = cmmExprType x - pk2 = cmmExprType y + pk1 = cmmExprType dflags x + pk2 = cmmExprType dflags y code__2 dst = if pk1 `cmmEqType` pk2 then diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs index 8ae3b4b744..55afac0ee2 100644 --- a/compiler/nativeGen/SPARC/Ppr.hs +++ b/compiler/nativeGen/SPARC/Ppr.hs @@ -338,7 +338,8 @@ pprSectionHeader seg -- | Pretty print a data item. pprDataItem :: CmmLit -> SDoc pprDataItem lit - = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit) + = sdocWithDynFlags $ \dflags -> + vcat (ppr_item (cmmTypeSize $ cmmLitType dflags lit) lit) where imm = litToImm lit diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index e8f2eccd6b..9e4dd24dd2 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -141,6 +141,7 @@ stmtsToInstrs stmts stmtToInstrs :: CmmStmt -> NatM InstrBlock stmtToInstrs stmt = do + dflags <- getDynFlags is32Bit <- is32BitPlatform case stmt of CmmNop -> return nilOL @@ -150,14 +151,14 @@ stmtToInstrs stmt = do | isFloatType ty -> assignReg_FltCode size reg src | is32Bit && isWord64 ty -> assignReg_I64Code reg src | otherwise -> assignReg_IntCode size reg src - where ty = cmmRegType reg + where ty = cmmRegType dflags reg size = cmmTypeSize ty CmmStore addr src | isFloatType ty -> assignMem_FltCode size addr src | is32Bit && isWord64 ty -> assignMem_I64Code addr src | otherwise -> assignMem_IntCode size addr src - where ty = cmmExprType src + where ty = cmmExprType dflags src size = cmmTypeSize ty CmmCall target result_regs args _ @@ -285,10 +286,10 @@ jumpTableEntry (Just blockid) = CmmStaticLit (CmmLabel blockLabel) -- Expand CmmRegOff. ToDo: should we do it this way around, or convert -- CmmExprs into CmmRegOff? -mangleIndexTree :: CmmReg -> Int -> CmmExpr -mangleIndexTree reg off +mangleIndexTree :: DynFlags -> CmmReg -> Int -> CmmExpr +mangleIndexTree dflags reg off = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] - where width = typeWidth (cmmRegType reg) + where width = typeWidth (cmmRegType dflags reg) -- | The dual to getAnyReg: compute an expression into a register, but -- we don't mind which one it is. @@ -406,12 +407,13 @@ iselExpr64 expr -------------------------------------------------------------------------------- getRegister :: CmmExpr -> NatM Register -getRegister e = do is32Bit <- is32BitPlatform - getRegister' is32Bit e +getRegister e = do dflags <- getDynFlags + is32Bit <- is32BitPlatform + getRegister' dflags is32Bit e -getRegister' :: Bool -> CmmExpr -> NatM Register +getRegister' :: DynFlags -> Bool -> CmmExpr -> NatM Register -getRegister' is32Bit (CmmReg reg) +getRegister' dflags is32Bit (CmmReg reg) = case reg of CmmGlobal PicBaseReg | is32Bit -> @@ -423,44 +425,43 @@ getRegister' is32Bit (CmmReg reg) _ -> do use_sse2 <- sse2Enabled let - sz = cmmTypeSize (cmmRegType reg) + sz = cmmTypeSize (cmmRegType dflags reg) size | not use_sse2 && isFloatSize sz = FF80 | otherwise = sz -- - dflags <- getDynFlags let platform = targetPlatform dflags return (Fixed size (getRegisterReg platform use_sse2 reg) nilOL) -getRegister' is32Bit (CmmRegOff r n) - = getRegister' is32Bit $ mangleIndexTree r n +getRegister' dflags is32Bit (CmmRegOff r n) + = getRegister' dflags is32Bit $ mangleIndexTree dflags r n -- for 32-bit architectuers, support some 64 -> 32 bit conversions: -- TO_W_(x), TO_W_(x >> 32) -getRegister' is32Bit (CmmMachOp (MO_UU_Conv W64 W32) +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32) [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) | is32Bit = do ChildCode64 code rlo <- iselExpr64 x return $ Fixed II32 (getHiVRegFromLo rlo) code -getRegister' is32Bit (CmmMachOp (MO_SS_Conv W64 W32) +getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32) [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) | is32Bit = do ChildCode64 code rlo <- iselExpr64 x return $ Fixed II32 (getHiVRegFromLo rlo) code -getRegister' is32Bit (CmmMachOp (MO_UU_Conv W64 W32) [x]) +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32) [x]) | is32Bit = do ChildCode64 code rlo <- iselExpr64 x return $ Fixed II32 rlo code -getRegister' is32Bit (CmmMachOp (MO_SS_Conv W64 W32) [x]) +getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32) [x]) | is32Bit = do ChildCode64 code rlo <- iselExpr64 x return $ Fixed II32 rlo code -getRegister' _ (CmmLit lit@(CmmFloat f w)) = +getRegister' _ _ (CmmLit lit@(CmmFloat f w)) = if_sse2 float_const_sse2 float_const_x87 where float_const_sse2 @@ -491,60 +492,60 @@ getRegister' _ (CmmLit lit@(CmmFloat f w)) = loadFloatAmode False w addr code -- catch simple cases of zero- or sign-extended load -getRegister' _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _]) = do +getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _]) = do code <- intLoadCode (MOVZxL II8) addr return (Any II32 code) -getRegister' _ (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _]) = do +getRegister' _ _ (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _]) = do code <- intLoadCode (MOVSxL II8) addr return (Any II32 code) -getRegister' _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _]) = do +getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _]) = do code <- intLoadCode (MOVZxL II16) addr return (Any II32 code) -getRegister' _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _]) = do +getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _]) = do code <- intLoadCode (MOVSxL II16) addr return (Any II32 code) -- catch simple cases of zero- or sign-extended load -getRegister' is32Bit (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _]) +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _]) | not is32Bit = do code <- intLoadCode (MOVZxL II8) addr return (Any II64 code) -getRegister' is32Bit (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _]) +getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _]) | not is32Bit = do code <- intLoadCode (MOVSxL II8) addr return (Any II64 code) -getRegister' is32Bit (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _]) +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _]) | not is32Bit = do code <- intLoadCode (MOVZxL II16) addr return (Any II64 code) -getRegister' is32Bit (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _]) +getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _]) | not is32Bit = do code <- intLoadCode (MOVSxL II16) addr return (Any II64 code) -getRegister' is32Bit (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _]) +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _]) | not is32Bit = do code <- intLoadCode (MOV II32) addr -- 32-bit loads zero-extend return (Any II64 code) -getRegister' is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _]) +getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _]) | not is32Bit = do code <- intLoadCode (MOVSxL II32) addr return (Any II64 code) -getRegister' is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), +getRegister' _ is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), CmmLit displacement]) | not is32Bit = do return $ Any II64 (\dst -> unitOL $ LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst)) -getRegister' is32Bit (CmmMachOp mop [x]) = do -- unary MachOps +getRegister' dflags is32Bit (CmmMachOp mop [x]) = do -- unary MachOps sse2 <- sse2Enabled case mop of MO_F_Neg w @@ -634,11 +635,11 @@ getRegister' is32Bit (CmmMachOp mop [x]) = do -- unary MachOps conversionNop :: Size -> CmmExpr -> NatM Register conversionNop new_size expr - = do e_code <- getRegister' is32Bit expr + = do e_code <- getRegister' dflags is32Bit expr return (swizzleRegisterRep e_code new_size) -getRegister' is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps +getRegister' _ is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps sse2 <- sse2Enabled case mop of MO_F_Eq _ -> condFltReg is32Bit EQQ x y @@ -812,14 +813,14 @@ getRegister' is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps return (Fixed size result code) -getRegister' _ (CmmLoad mem pk) +getRegister' _ _ (CmmLoad mem pk) | isFloatType pk = do Amode addr mem_code <- getAmode mem use_sse2 <- sse2Enabled loadFloatAmode use_sse2 (typeWidth pk) addr mem_code -getRegister' is32Bit (CmmLoad mem pk) +getRegister' _ is32Bit (CmmLoad mem pk) | is32Bit && not (isWord64 pk) = do code <- intLoadCode instr mem @@ -837,14 +838,14 @@ getRegister' is32Bit (CmmLoad mem pk) -- simpler we do our 8-bit arithmetic with full 32-bit registers. -- Simpler memory load code on x86_64 -getRegister' is32Bit (CmmLoad mem pk) +getRegister' _ is32Bit (CmmLoad mem pk) | not is32Bit = do code <- intLoadCode (MOV size) mem return (Any size code) where size = intSize $ typeWidth pk -getRegister' is32Bit (CmmLit (CmmInt 0 width)) +getRegister' _ is32Bit (CmmLit (CmmInt 0 width)) = let size = intSize width @@ -861,8 +862,8 @@ getRegister' is32Bit (CmmLit (CmmInt 0 width)) -- optimisation for loading small literals on x86_64: take advantage -- of the automatic zero-extension from 32 to 64 bits, because the 32-bit -- instruction forms are shorter. -getRegister' is32Bit (CmmLit lit) - | not is32Bit, isWord64 (cmmLitType lit), not (isBigLit lit) +getRegister' dflags is32Bit (CmmLit lit) + | not is32Bit, isWord64 (cmmLitType dflags lit), not (isBigLit lit) = let imm = litToImm lit code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst)) @@ -877,15 +878,13 @@ getRegister' is32Bit (CmmLit lit) -- note2: all labels are small, because we're assuming the -- small memory model (see gcc docs, -mcmodel=small). -getRegister' _ (CmmLit lit) - = let - size = cmmTypeSize (cmmLitType lit) - imm = litToImm lit - code dst = unitOL (MOV size (OpImm imm) (OpReg dst)) - in - return (Any size code) +getRegister' dflags _ (CmmLit lit) + = do let size = cmmTypeSize (cmmLitType dflags lit) + imm = litToImm lit + code dst = unitOL (MOV size (OpImm imm) (OpReg dst)) + return (Any size code) -getRegister' _ other = pprPanic "getRegister(x86)" (ppr other) +getRegister' _ _ other = pprPanic "getRegister(x86)" (ppr other) intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr @@ -958,7 +957,8 @@ getAmode e = do is32Bit <- is32BitPlatform getAmode' is32Bit e getAmode' :: Bool -> CmmExpr -> NatM Amode -getAmode' _ (CmmRegOff r n) = getAmode $ mangleIndexTree r n +getAmode' _ (CmmRegOff r n) = do dflags <- getDynFlags + getAmode $ mangleIndexTree dflags r n getAmode' is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), CmmLit displacement]) @@ -1047,7 +1047,8 @@ getNonClobberedOperand (CmmLit lit) = do else do is32Bit <- is32BitPlatform - if is32BitLit is32Bit lit && not (isFloatType (cmmLitType lit)) + dflags <- getDynFlags + if is32BitLit is32Bit lit && not (isFloatType (cmmLitType dflags lit)) then return (OpImm (litToImm lit), nilOL) else getNonClobberedOperand_generic (CmmLit lit) @@ -1100,7 +1101,8 @@ getOperand (CmmLit lit) = do else do is32Bit <- is32BitPlatform - if is32BitLit is32Bit lit && not (isFloatType (cmmLitType lit)) + dflags <- getDynFlags + if is32BitLit is32Bit lit && not (isFloatType (cmmLitType dflags lit)) then return (OpImm (litToImm lit), nilOL) else getOperand_generic (CmmLit lit) @@ -1276,21 +1278,23 @@ condIntCode' _ cond x (CmmLit (CmmInt 0 pk)) = do -- anything vs operand condIntCode' is32Bit cond x y | isOperand is32Bit y = do + dflags <- getDynFlags (x_reg, x_code) <- getNonClobberedReg x (y_op, y_code) <- getOperand y let code = x_code `appOL` y_code `snocOL` - CMP (cmmTypeSize (cmmExprType x)) y_op (OpReg x_reg) + CMP (cmmTypeSize (cmmExprType dflags x)) y_op (OpReg x_reg) return (CondCode False cond code) -- anything vs anything condIntCode' _ cond x y = do + dflags <- getDynFlags (y_reg, y_code) <- getNonClobberedReg y (x_op, x_code) <- getRegOrMem x let code = y_code `appOL` x_code `snocOL` - CMP (cmmTypeSize (cmmExprType x)) (OpReg y_reg) x_op + CMP (cmmTypeSize (cmmExprType dflags x)) (OpReg y_reg) x_op return (CondCode False cond code) @@ -1317,12 +1321,13 @@ condFltCode cond x y -- an operand, but the right must be a reg. We can probably do better -- than this general case... condFltCode_sse2 = do + dflags <- getDynFlags (x_reg, x_code) <- getNonClobberedReg x (y_op, y_code) <- getOperand y let code = x_code `appOL` y_code `snocOL` - CMP (floatSize $ cmmExprWidth x) y_op (OpReg x_reg) + CMP (floatSize $ cmmExprWidth dflags x) y_op (OpReg x_reg) -- NB(1): we need to use the unsigned comparison operators on the -- result of this comparison. return (CondCode True (condToUnsigned cond) code) @@ -1713,7 +1718,7 @@ genCCall32 target dest_regs args = do (CmmPrim _ (Just stmts), _) -> stmtsToInstrs stmts - _ -> genCCall32' target dest_regs args + _ -> genCCall32' dflags target dest_regs args where divOp1 platform signed width results [CmmHinted arg_x _, CmmHinted arg_y _] = divOp platform signed width results Nothing arg_x arg_y @@ -1750,16 +1755,17 @@ genCCall32 target dest_regs args = do divOp _ _ _ _ _ _ _ = panic "genCCall32: Wrong number of results for divOp" -genCCall32' :: CmmCallTarget -- function to call +genCCall32' :: DynFlags + -> CmmCallTarget -- function to call -> [HintedCmmFormal] -- where to put the result -> [HintedCmmActual] -- arguments (of mixed type) -> NatM InstrBlock -genCCall32' target dest_regs args = do +genCCall32' dflags target dest_regs args = do let -- Align stack to 16n for calls, assuming a starting stack -- alignment of 16n - word_size on procedure entry. Which we -- maintiain. See Note [rts/StgCRun.c : Stack Alignment on X86] - sizes = map (arg_size . cmmExprType . hintlessCmm) (reverse args) + sizes = map (arg_size . cmmExprType dflags . hintlessCmm) (reverse args) raw_arg_size = sum sizes + wORD_SIZE arg_pad_size = (roundTo 16 $ raw_arg_size) - raw_arg_size tot_arg_size = raw_arg_size + arg_pad_size - wORD_SIZE @@ -1780,7 +1786,7 @@ genCCall32' target dest_regs args = do where fn_imm = ImmCLbl lbl CmmCallee expr conv -> do { (dyn_r, dyn_c) <- getSomeReg expr - ; ASSERT( isWord32 (cmmExprType expr) ) + ; ASSERT( isWord32 (cmmExprType dflags expr) ) return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) } CmmPrim _ _ -> panic $ "genCCall: Can't handle CmmPrim call type here, error " @@ -1896,7 +1902,7 @@ genCCall32' target dest_regs args = do DELTA (delta-size)) where - arg_ty = cmmExprType arg + arg_ty = cmmExprType dflags arg size = arg_size arg_ty -- Byte size genCCall64 :: CmmCallTarget -- function to call @@ -1953,8 +1959,7 @@ genCCall64 target dest_regs args = do _ -> do dflags <- getDynFlags - let platform = targetPlatform dflags - genCCall64' platform target dest_regs args + genCCall64' dflags target dest_regs args where divOp1 platform signed width results [CmmHinted arg_x _, CmmHinted arg_y _] = divOp platform signed width results Nothing arg_x arg_y @@ -1989,12 +1994,12 @@ genCCall64 target dest_regs args = do divOp _ _ _ _ _ _ _ = panic "genCCall64: Wrong number of results for divOp" -genCCall64' :: Platform +genCCall64' :: DynFlags -> CmmCallTarget -- function to call -> [HintedCmmFormal] -- where to put the result -> [HintedCmmActual] -- arguments (of mixed type) -> NatM InstrBlock -genCCall64' platform target dest_regs args = do +genCCall64' dflags target dest_regs args = do -- load up the register arguments (stack_args, int_regs_used, fp_regs_used, load_args_code) <- @@ -2097,7 +2102,8 @@ genCCall64' platform target dest_regs args = do call `appOL` assign_code dest_regs) - where arg_size = 8 -- always, at the mo + where platform = targetPlatform dflags + arg_size = 8 -- always, at the mo load_args :: [CmmHinted CmmExpr] -> [Reg] -- int regs avail for args @@ -2122,7 +2128,7 @@ genCCall64' platform target dest_regs args = do arg_code <- getAnyReg arg load_args rest rs fregs (code `appOL` arg_code r) where - arg_rep = cmmExprType arg + arg_rep = cmmExprType dflags arg push_this_arg = do (args',ars,frs,code') <- load_args rest aregs fregs code @@ -2156,7 +2162,7 @@ genCCall64' platform target dest_regs args = do load_args_win rest (ireg : usedInt) usedFP regs (code `appOL` arg_code ireg) where - arg_rep = cmmExprType arg + arg_rep = cmmExprType dflags arg push_args [] code = return code push_args ((CmmHinted arg _):rest) code @@ -2183,7 +2189,7 @@ genCCall64' platform target dest_regs args = do DELTA (delta-arg_size)] push_args rest code' where - arg_rep = cmmExprType arg + arg_rep = cmmExprType dflags arg width = typeWidth arg_rep leaveStackSpace n = do diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index 6411fb94b1..420da7cc3d 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -34,6 +34,7 @@ import PprBase import BlockId import BasicTypes (Alignment) +import DynFlags import OldCmm import CLabel import Unique ( pprUnique, Uniquable(..) ) @@ -419,12 +420,13 @@ pprSectionHeader seg pprDataItem :: CmmLit -> SDoc -pprDataItem lit = sdocWithPlatform $ \platform -> pprDataItem' platform lit +pprDataItem lit = sdocWithDynFlags $ \dflags -> pprDataItem' dflags lit -pprDataItem' :: Platform -> CmmLit -> SDoc -pprDataItem' platform lit - = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit) +pprDataItem' :: DynFlags -> CmmLit -> SDoc +pprDataItem' dflags lit + = vcat (ppr_item (cmmTypeSize $ cmmLitType dflags lit) lit) where + platform = targetPlatform dflags imm = litToImm lit -- These seem to be common: |