diff options
| author | Ian Lynagh <ian@well-typed.com> | 2012-09-12 11:31:11 +0100 |
|---|---|---|
| committer | Ian Lynagh <ian@well-typed.com> | 2012-09-12 11:31:11 +0100 |
| commit | f611396a581e733c41cee41750c95675bdb64961 (patch) | |
| tree | 5ac98a36e98a6a58e97de9d1a7605386a41cd688 | |
| parent | 6986eb91102b42ed61953500b60724c385dd658c (diff) | |
| download | haskell-f611396a581e733c41cee41750c95675bdb64961.tar.gz | |
Pass DynFlags down to bWord
I've switched to passing DynFlags rather than Platform, as (a) it's
simpler to not have to extract targetPlatform in so many places, and
(b) it may be useful to have DynFlags around in future.
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: |