diff options
Diffstat (limited to 'compiler')
41 files changed, 1123 insertions, 1083 deletions
diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index 0cfcc0d5be..7d243615fe 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -33,6 +33,7 @@ import CLabel import Cmm import CmmUtils import Data.List +import DynFlags import Maybes import Module import Outputable @@ -166,17 +167,17 @@ srtToData srt = [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)] -- in the SRT. Then, if the number of CAFs is small enough to fit in a bitmap, -- we make sure they're all close enough to the bottom of the table that the -- bitmap will be able to cover all of them. -buildSRT :: TopSRT -> CAFSet -> UniqSM (TopSRT, Maybe CmmDecl, C_SRT) -buildSRT topSRT cafs = +buildSRT :: DynFlags -> TopSRT -> CAFSet -> UniqSM (TopSRT, Maybe CmmDecl, C_SRT) +buildSRT dflags topSRT cafs = do let -- For each label referring to a function f without a static closure, -- replace it with the CAFs that are reachable from f. sub_srt topSRT localCafs = let cafs = Set.elems localCafs mkSRT topSRT = - do localSRTs <- procpointSRT (lbl topSRT) (elt_map topSRT) cafs + do localSRTs <- procpointSRT dflags (lbl topSRT) (elt_map topSRT) cafs return (topSRT, localSRTs) - in if length cafs > maxBmpSize then + in if length cafs > maxBmpSize dflags then mkSRT (foldl add_if_missing topSRT cafs) else -- make sure all the cafs are near the bottom of the srt mkSRT (add_if_too_far topSRT cafs) @@ -196,7 +197,7 @@ buildSRT topSRT cafs = add srt [] = srt add srt@(TopSRT {next_elt = next}) (caf : rst) = case cafOffset srt caf of - Just ix -> if next - ix > maxBmpSize then + Just ix -> if next - ix > maxBmpSize dflags then add (addCAF caf srt) rst else srt Nothing -> add (addCAF caf srt) rst @@ -206,12 +207,12 @@ buildSRT topSRT cafs = -- Construct an SRT bitmap. -- Adapted from simpleStg/SRT.lhs, which expects Id's. -procpointSRT :: CLabel -> Map CLabel Int -> [CLabel] -> +procpointSRT :: DynFlags -> CLabel -> Map CLabel Int -> [CLabel] -> UniqSM (Maybe CmmDecl, C_SRT) -procpointSRT _ _ [] = +procpointSRT _ _ _ [] = return (Nothing, NoC_SRT) -procpointSRT top_srt top_table entries = - do (top, srt) <- bitmap `seq` to_SRT top_srt offset len bitmap +procpointSRT dflags top_srt top_table entries = + do (top, srt) <- bitmap `seq` to_SRT dflags top_srt offset len bitmap return (top, srt) where ints = map (expectJust "constructSRT" . flip Map.lookup top_table) entries @@ -221,20 +222,20 @@ procpointSRT top_srt top_table entries = len = P.last bitmap_entries + 1 bitmap = intsToBitmap len bitmap_entries -maxBmpSize :: Int -maxBmpSize = widthInBits wordWidth `div` 2 +maxBmpSize :: DynFlags -> Int +maxBmpSize dflags = widthInBits (wordWidth dflags) `div` 2 -- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT. -to_SRT :: CLabel -> Int -> Int -> Bitmap -> UniqSM (Maybe CmmDecl, C_SRT) -to_SRT top_srt off len bmp - | len > maxBmpSize || bmp == [fromIntegral srt_escape] +to_SRT :: DynFlags -> CLabel -> Int -> Int -> Bitmap -> UniqSM (Maybe CmmDecl, C_SRT) +to_SRT dflags top_srt off len bmp + | len > maxBmpSize dflags || bmp == [fromIntegral srt_escape] = do id <- getUniqueM let srt_desc_lbl = mkLargeSRTLabel id tbl = CmmData RelocatableReadOnlyData $ Statics srt_desc_lbl $ map CmmStaticLit ( cmmLabelOffW top_srt off - : mkWordCLit (fromIntegral len) - : map mkWordCLit bmp) + : mkWordCLit dflags (fromIntegral len) + : map (mkWordCLit dflags) bmp) return (Just tbl, C_SRT srt_desc_lbl 0 srt_escape) | otherwise = return (Nothing, C_SRT top_srt off (fromIntegral (head bmp))) @@ -318,11 +319,12 @@ flattenCAFSets cpsdecls = zipWith (bundle flatmap) zipped localCAFs localCAFs = unzipWith localCAFInfo zipped flatmap = mkTopCAFInfo localCAFs -- transitive closure of localCAFs -doSRTs :: TopSRT +doSRTs :: DynFlags + -> TopSRT -> [(CAFEnv, [CmmDecl])] -> IO (TopSRT, [CmmDecl]) -doSRTs topSRT tops +doSRTs dflags topSRT tops = do let caf_decls = flattenCAFSets tops us <- mkSplitUniqSupply 'u' @@ -330,19 +332,19 @@ doSRTs topSRT tops return (topSRT', reverse gs' {- Note [reverse gs] -}) where setSRT (topSRT, rst) (caf_map, decl@(CmmProc{})) = do - (topSRT, srt_tables, srt_env) <- buildSRTs topSRT caf_map + (topSRT, srt_tables, srt_env) <- buildSRTs dflags topSRT caf_map let decl' = updInfoSRTs srt_env decl return (topSRT, decl': srt_tables ++ rst) setSRT (topSRT, rst) (_, decl) = return (topSRT, decl : rst) -buildSRTs :: TopSRT -> BlockEnv CAFSet +buildSRTs :: DynFlags -> TopSRT -> BlockEnv CAFSet -> UniqSM (TopSRT, [CmmDecl], BlockEnv C_SRT) -buildSRTs top_srt caf_map +buildSRTs dflags top_srt caf_map = foldM doOne (top_srt, [], mapEmpty) (mapToList caf_map) where doOne (top_srt, decls, srt_env) (l, cafs) - = do (top_srt, mb_decl, srt) <- buildSRT top_srt cafs + = do (top_srt, mb_decl, srt) <- buildSRT dflags top_srt cafs return ( top_srt, maybeToList mb_decl ++ decls , mapInsert l srt srt_env ) diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs index dd1b6af643..5e75e6134f 100644 --- a/compiler/cmm/CmmCallConv.hs +++ b/compiler/cmm/CmmCallConv.hs @@ -78,9 +78,9 @@ assignArgumentsPos dflags conv arg_ty reps = assignments _ -> (assts, (r:rs)) int = case (w, regs) of (W128, _) -> panic "W128 unsupported register type" - (_, (v:vs, fs, ds, ls)) | widthInBits w <= widthInBits wordWidth + (_, (v:vs, fs, ds, ls)) | widthInBits w <= widthInBits (wordWidth dflags) -> k (RegisterParam (v gcp), (vs, fs, ds, ls)) - (_, (vs, fs, ds, l:ls)) | widthInBits w > widthInBits wordWidth + (_, (vs, fs, ds, l:ls)) | widthInBits w > widthInBits (wordWidth dflags) -> k (RegisterParam l, (vs, fs, ds, ls)) _ -> (assts, (r:rs)) k (asst, regs') = assign_regs ((r, asst) : assts) rs regs' diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index 29affaef0b..3bbbb5e1d8 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -114,8 +114,8 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks) -- Use a zero place-holder in place of the -- entry-label in the info table return (top_decls ++ - [mkRODataLits info_lbl (zeroCLit : rel_std_info ++ - rel_extra_bits)]) + [mkRODataLits info_lbl (zeroCLit dflags : rel_std_info ++ + rel_extra_bits)]) _nonempty -> -- Separately emit info table (with the function entry -- point as first entry) and the entry code @@ -172,9 +172,9 @@ mkInfoTableContents dflags -- (which in turn came from a handwritten .cmm file) | StackRep frame <- smrep - = do { (prof_lits, prof_data) <- mkProfLits prof + = do { (prof_lits, prof_data) <- mkProfLits dflags prof ; let (srt_label, srt_bitmap) = mkSRTLit srt - ; (liveness_lit, liveness_data) <- mkLivenessBits frame + ; (liveness_lit, liveness_data) <- mkLivenessBits dflags frame ; let std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit rts_tag | Just tag <- mb_rts_tag = tag @@ -184,8 +184,8 @@ mkInfoTableContents dflags ; return (prof_data ++ liveness_data, (std_info, srt_label)) } | HeapRep _ ptrs nonptrs closure_type <- smrep - = do { let layout = packHalfWordsCLit ptrs nonptrs - ; (prof_lits, prof_data) <- mkProfLits prof + = do { let layout = packHalfWordsCLit dflags ptrs nonptrs + ; (prof_lits, prof_data) <- mkProfLits dflags prof ; let (srt_label, srt_bitmap) = mkSRTLit srt ; (mb_srt_field, mb_layout, extra_bits, ct_data) <- mk_pieces closure_type srt_label @@ -208,24 +208,24 @@ mkInfoTableContents dflags = return (Nothing, Nothing, srt_label, []) mk_pieces (ThunkSelector offset) _no_srt - = return (Just 0, Just (mkWordCLit offset), [], []) + = return (Just 0, Just (mkWordCLit dflags offset), [], []) -- Layout known (one free var); we use the layout field for offset mk_pieces (Fun arity (ArgSpec fun_type)) srt_label - = do { let extra_bits = packHalfWordsCLit fun_type arity : srt_label + = do { let extra_bits = packHalfWordsCLit dflags fun_type arity : srt_label ; return (Nothing, Nothing, extra_bits, []) } mk_pieces (Fun arity (ArgGen arg_bits)) srt_label - = do { (liveness_lit, liveness_data) <- mkLivenessBits arg_bits + = do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits ; let fun_type | null liveness_data = aRG_GEN | otherwise = aRG_GEN_BIG - extra_bits = [ packHalfWordsCLit fun_type arity + extra_bits = [ packHalfWordsCLit dflags fun_type arity , srt_lit, liveness_lit, slow_entry ] ; return (Nothing, Nothing, extra_bits, liveness_data) } where slow_entry = CmmLabel (toSlowEntryLbl info_lbl) srt_lit = case srt_label of - [] -> mkIntCLit 0 + [] -> mkIntCLit dflags 0 (lit:_rest) -> ASSERT( null _rest ) lit mk_pieces BlackHole _ = panic "mk_pieces: BlackHole" @@ -297,12 +297,12 @@ makeRelativeRefTo _ _ lit = lit -- The head of the stack layout is the top of the stack and -- the least-significant bit. -mkLivenessBits :: Liveness -> UniqSM (CmmLit, [RawCmmDecl]) +mkLivenessBits :: DynFlags -> Liveness -> UniqSM (CmmLit, [RawCmmDecl]) -- ^ Returns: -- 1. The bitmap (literal value or label) -- 2. Large bitmap CmmData if needed -mkLivenessBits liveness +mkLivenessBits dflags liveness | n_bits > mAX_SMALL_BITMAP_SIZE -- does not fit in one word = do { uniq <- getUniqueUs ; let bitmap_lbl = mkBitmapLabel uniq @@ -310,7 +310,7 @@ mkLivenessBits liveness [mkRODataLits bitmap_lbl lits]) } | otherwise -- Fits in one word - = return (mkWordCLit bitmap_word, []) + = return (mkWordCLit dflags bitmap_word, []) where n_bits = length liveness @@ -324,7 +324,7 @@ mkLivenessBits liveness bitmap_word = fromIntegral n_bits .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT) - lits = mkWordCLit (fromIntegral n_bits) : map mkWordCLit bitmap + lits = mkWordCLit dflags (fromIntegral n_bits) : map (mkWordCLit dflags) bitmap -- The first word is the size. The structure must match -- StgLargeBitmap in includes/rts/storage/InfoTable.h @@ -361,7 +361,7 @@ mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt_len layout_lit | dopt Opt_SccProfilingOn dflags = [type_descr, closure_descr] | otherwise = [] - type_lit = packHalfWordsCLit cl_type srt_len + type_lit = packHalfWordsCLit dflags cl_type srt_len ------------------------------------------------------------------------- -- @@ -369,9 +369,9 @@ mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt_len layout_lit -- ------------------------------------------------------------------------- -mkProfLits :: ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl]) -mkProfLits NoProfilingInfo = return ((zeroCLit, zeroCLit), []) -mkProfLits (ProfilingInfo td cd) +mkProfLits :: DynFlags -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl]) +mkProfLits dflags NoProfilingInfo = return ((zeroCLit dflags, zeroCLit dflags), []) +mkProfLits _ (ProfilingInfo td cd) = do { (td_lit, td_decl) <- newStringLit td ; (cd_lit, cd_decl) <- newStringLit cd ; return ((td_lit,cd_lit), [td_decl,cd_decl]) } diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs index 0ddbfb6227..ea9a4bb7ba 100644 --- a/compiler/cmm/CmmLayoutStack.hs +++ b/compiler/cmm/CmmLayoutStack.hs @@ -776,12 +776,12 @@ arguments. 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 dflags _ sp_hwm _ (CmmLit CmmHighStackMark) = mkIntExpr dflags sp_hwm +areaToSp dflags _ _ _ (CmmMachOp (MO_U_Lt _) -- Note [null stack check] + [CmmMachOp (MO_Sub _) + [ CmmReg (CmmGlobal Sp) + , CmmLit (CmmInt 0 _)], + CmmReg (CmmGlobal SpLim)]) = zeroExpr dflags areaToSp _ _ _ _ other = other -- ----------------------------------------------------------------------------- @@ -920,7 +920,7 @@ lowerSafeForeignCall dflags block load_stack <- newTemp (gcWord dflags) let suspend = saveThreadState dflags <*> caller_save <*> - mkMiddle (callSuspendThread id intrbl) + mkMiddle (callSuspendThread dflags id intrbl) midCall = mkUnsafeCall tgt res args resume = mkMiddle (callResumeThread new_base id) <*> -- Assign the result to BaseReg: we @@ -941,7 +941,7 @@ lowerSafeForeignCall dflags block jump = CmmCall { cml_target = CmmLoad (CmmReg spReg) (bWord dflags) , cml_cont = Just succ , cml_args_regs = regs - , cml_args = widthInBytes wordWidth + , cml_args = widthInBytes (wordWidth dflags) , cml_ret_args = ret_args , cml_ret_off = updfr } @@ -966,12 +966,12 @@ foreignLbl name = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId name)) newTemp :: CmmType -> UniqSM LocalReg newTemp rep = getUniqueM >>= \u -> return (LocalReg u rep) -callSuspendThread :: LocalReg -> Bool -> CmmNode O O -callSuspendThread id intrbl = +callSuspendThread :: DynFlags -> LocalReg -> Bool -> CmmNode O O +callSuspendThread dflags id intrbl = CmmUnsafeForeignCall (ForeignTarget (foreignLbl (fsLit "suspendThread")) (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint])) - [id] [CmmReg (CmmGlobal BaseReg), mkIntExpr (fromEnum intrbl)] + [id] [CmmReg (CmmGlobal BaseReg), mkIntExpr dflags (fromEnum intrbl)] callResumeThread :: LocalReg -> LocalReg -> CmmNode O O callResumeThread new_base id = diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index 53238edf94..0afe2a3b50 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -88,9 +88,9 @@ lintCmmExpr (CmmLoad expr rep) = do lintCmmExpr expr@(CmmMachOp op args) = do dflags <- getDynFlags tys <- mapM lintCmmExpr args - if map (typeWidth . cmmExprType dflags) args == machOpArgReps op + if map (typeWidth . cmmExprType dflags) args == machOpArgReps dflags op then cmmCheckMachOp op args tys - else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps op) + else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps dflags op) lintCmmExpr (CmmRegOff reg offset) = do dflags <- getDynFlags let rep = typeWidth (cmmRegType dflags reg) @@ -158,9 +158,10 @@ lintCmmLast labels node = case node of CmmBranch id -> checkTarget id CmmCondBranch e t f -> do + dflags <- getDynFlags mapM_ checkTarget [t,f] _ <- lintCmmExpr e - checkCond e + checkCond dflags e CmmSwitch e branches -> do dflags <- getDynFlags @@ -190,10 +191,10 @@ lintTarget (ForeignTarget e _) = lintCmmExpr e >> return () lintTarget (PrimTarget {}) = return () -checkCond :: CmmExpr -> CmmLint () -checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return () -checkCond (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values -checkCond expr +checkCond :: DynFlags -> CmmExpr -> CmmLint () +checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return () +checkCond dflags (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth dflags = return () -- constant values +checkCond _ expr = cmmLintErr (hang (text "expression is not a conditional:") 2 (ppr expr)) diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs index 6e152c5f04..520c7e7a7d 100644 --- a/compiler/cmm/CmmMachOp.hs +++ b/compiler/cmm/CmmMachOp.hs @@ -123,59 +123,62 @@ mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe , mo_wordULe, mo_wordUGt, mo_wordULt , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr - , mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32 , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord - , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64 + , mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64 + :: DynFlags -> MachOp + +mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32 + , mo_32To8, mo_32To16 :: MachOp -mo_wordAdd = MO_Add wordWidth -mo_wordSub = MO_Sub wordWidth -mo_wordEq = MO_Eq wordWidth -mo_wordNe = MO_Ne wordWidth -mo_wordMul = MO_Mul wordWidth -mo_wordSQuot = MO_S_Quot wordWidth -mo_wordSRem = MO_S_Rem wordWidth -mo_wordSNeg = MO_S_Neg wordWidth -mo_wordUQuot = MO_U_Quot wordWidth -mo_wordURem = MO_U_Rem wordWidth - -mo_wordSGe = MO_S_Ge wordWidth -mo_wordSLe = MO_S_Le wordWidth -mo_wordSGt = MO_S_Gt wordWidth -mo_wordSLt = MO_S_Lt wordWidth - -mo_wordUGe = MO_U_Ge wordWidth -mo_wordULe = MO_U_Le wordWidth -mo_wordUGt = MO_U_Gt wordWidth -mo_wordULt = MO_U_Lt wordWidth - -mo_wordAnd = MO_And wordWidth -mo_wordOr = MO_Or wordWidth -mo_wordXor = MO_Xor wordWidth -mo_wordNot = MO_Not wordWidth -mo_wordShl = MO_Shl wordWidth -mo_wordSShr = MO_S_Shr wordWidth -mo_wordUShr = MO_U_Shr wordWidth - -mo_u_8To32 = MO_UU_Conv W8 W32 -mo_s_8To32 = MO_SS_Conv W8 W32 -mo_u_16To32 = MO_UU_Conv W16 W32 -mo_s_16To32 = MO_SS_Conv W16 W32 - -mo_u_8ToWord = MO_UU_Conv W8 wordWidth -mo_s_8ToWord = MO_SS_Conv W8 wordWidth -mo_u_16ToWord = MO_UU_Conv W16 wordWidth -mo_s_16ToWord = MO_SS_Conv W16 wordWidth -mo_s_32ToWord = MO_SS_Conv W32 wordWidth -mo_u_32ToWord = MO_UU_Conv W32 wordWidth - -mo_WordTo8 = MO_UU_Conv wordWidth W8 -mo_WordTo16 = MO_UU_Conv wordWidth W16 -mo_WordTo32 = MO_UU_Conv wordWidth W32 -mo_WordTo64 = MO_UU_Conv wordWidth W64 - -mo_32To8 = MO_UU_Conv W32 W8 -mo_32To16 = MO_UU_Conv W32 W16 +mo_wordAdd dflags = MO_Add (wordWidth dflags) +mo_wordSub dflags = MO_Sub (wordWidth dflags) +mo_wordEq dflags = MO_Eq (wordWidth dflags) +mo_wordNe dflags = MO_Ne (wordWidth dflags) +mo_wordMul dflags = MO_Mul (wordWidth dflags) +mo_wordSQuot dflags = MO_S_Quot (wordWidth dflags) +mo_wordSRem dflags = MO_S_Rem (wordWidth dflags) +mo_wordSNeg dflags = MO_S_Neg (wordWidth dflags) +mo_wordUQuot dflags = MO_U_Quot (wordWidth dflags) +mo_wordURem dflags = MO_U_Rem (wordWidth dflags) + +mo_wordSGe dflags = MO_S_Ge (wordWidth dflags) +mo_wordSLe dflags = MO_S_Le (wordWidth dflags) +mo_wordSGt dflags = MO_S_Gt (wordWidth dflags) +mo_wordSLt dflags = MO_S_Lt (wordWidth dflags) + +mo_wordUGe dflags = MO_U_Ge (wordWidth dflags) +mo_wordULe dflags = MO_U_Le (wordWidth dflags) +mo_wordUGt dflags = MO_U_Gt (wordWidth dflags) +mo_wordULt dflags = MO_U_Lt (wordWidth dflags) + +mo_wordAnd dflags = MO_And (wordWidth dflags) +mo_wordOr dflags = MO_Or (wordWidth dflags) +mo_wordXor dflags = MO_Xor (wordWidth dflags) +mo_wordNot dflags = MO_Not (wordWidth dflags) +mo_wordShl dflags = MO_Shl (wordWidth dflags) +mo_wordSShr dflags = MO_S_Shr (wordWidth dflags) +mo_wordUShr dflags = MO_U_Shr (wordWidth dflags) + +mo_u_8To32 = MO_UU_Conv W8 W32 +mo_s_8To32 = MO_SS_Conv W8 W32 +mo_u_16To32 = MO_UU_Conv W16 W32 +mo_s_16To32 = MO_SS_Conv W16 W32 + +mo_u_8ToWord dflags = MO_UU_Conv W8 (wordWidth dflags) +mo_s_8ToWord dflags = MO_SS_Conv W8 (wordWidth dflags) +mo_u_16ToWord dflags = MO_UU_Conv W16 (wordWidth dflags) +mo_s_16ToWord dflags = MO_SS_Conv W16 (wordWidth dflags) +mo_s_32ToWord dflags = MO_SS_Conv W32 (wordWidth dflags) +mo_u_32ToWord dflags = MO_UU_Conv W32 (wordWidth dflags) + +mo_WordTo8 dflags = MO_UU_Conv (wordWidth dflags) W8 +mo_WordTo16 dflags = MO_UU_Conv (wordWidth dflags) W16 +mo_WordTo32 dflags = MO_UU_Conv (wordWidth dflags) W32 +mo_WordTo64 dflags = MO_UU_Conv (wordWidth dflags) W64 + +mo_32To8 = MO_UU_Conv W32 W8 +mo_32To16 = MO_UU_Conv W32 W16 -- ---------------------------------------------------------------------------- @@ -350,8 +353,8 @@ comparisonResultRep = bWord -- is it? -- its arguments are the same as the MachOp expects. This is used when -- linting a CmmExpr. -machOpArgReps :: MachOp -> [Width] -machOpArgReps op = +machOpArgReps :: DynFlags -> MachOp -> [Width] +machOpArgReps dflags op = case op of MO_Add r -> [r,r] MO_Sub r -> [r,r] @@ -392,9 +395,9 @@ machOpArgReps op = MO_Or r -> [r,r] MO_Xor r -> [r,r] MO_Not r -> [r] - MO_Shl r -> [r,wordWidth] - MO_U_Shr r -> [r,wordWidth] - MO_S_Shr r -> [r,wordWidth] + MO_Shl r -> [r, wordWidth dflags] + MO_U_Shr r -> [r, wordWidth dflags] + MO_S_Shr r -> [r, wordWidth dflags] MO_SS_Conv from _ -> [from] MO_UU_Conv from _ -> [from] diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index 5f208244f8..0df24a6a66 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -183,8 +183,7 @@ cmmMiniInlineStmts dflags uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) -- not CmmLocal: that might invalidate the usage analysis results isTiny _ = False - platform = targetPlatform dflags - foldExp (CmmMachOp op args) = cmmMachOpFold platform op args + foldExp (CmmMachOp op args) = cmmMachOpFold dflags op args foldExp e = e ncgDebugTrace str x = if ncgDebugIsOn then trace str x else x @@ -302,17 +301,17 @@ inlineExpr _ _ other_expr = other_expr -- been optimized and folded. cmmMachOpFold - :: Platform + :: DynFlags -> MachOp -- The operation from an CmmMachOp -> [CmmExpr] -- The optimized arguments -> CmmExpr -cmmMachOpFold platform op args = fromMaybe (CmmMachOp op args) (cmmMachOpFoldM platform op args) +cmmMachOpFold dflags op args = fromMaybe (CmmMachOp op args) (cmmMachOpFoldM dflags op args) -- Returns Nothing if no changes, useful for Hoopl, also reduces -- allocation! cmmMachOpFoldM - :: Platform + :: DynFlags -> MachOp -> [CmmExpr] -> Maybe CmmExpr @@ -338,7 +337,7 @@ cmmMachOpFoldM _ (MO_SS_Conv rep1 rep2) [x] | rep1 == rep2 = Just x cmmMachOpFoldM _ (MO_UU_Conv rep1 rep2) [x] | rep1 == rep2 = Just x -- Eliminate nested conversions where possible -cmmMachOpFoldM platform conv_outer [CmmMachOp conv_inner [x]] +cmmMachOpFoldM dflags conv_outer [CmmMachOp conv_inner [x]] | Just (rep1,rep2,signed1) <- isIntConversion conv_inner, Just (_, rep3,signed2) <- isIntConversion conv_outer = case () of @@ -348,13 +347,13 @@ cmmMachOpFoldM platform conv_outer [CmmMachOp conv_inner [x]] -- but remember to use the signedness from the widening, just in case -- the final conversion is a widen. | rep1 < rep2 && rep2 > rep3 -> - Just $ cmmMachOpFold platform (intconv signed1 rep1 rep3) [x] + Just $ cmmMachOpFold dflags (intconv signed1 rep1 rep3) [x] -- Nested widenings: collapse if the signedness is the same | rep1 < rep2 && rep2 < rep3 && signed1 == signed2 -> - Just $ cmmMachOpFold platform (intconv signed1 rep1 rep3) [x] + Just $ cmmMachOpFold dflags (intconv signed1 rep1 rep3) [x] -- Nested narrowings: collapse | rep1 > rep2 && rep2 > rep3 -> - Just $ cmmMachOpFold platform (MO_UU_Conv rep1 rep3) [x] + Just $ cmmMachOpFold dflags (MO_UU_Conv rep1 rep3) [x] | otherwise -> Nothing where @@ -371,22 +370,22 @@ cmmMachOpFoldM platform conv_outer [CmmMachOp conv_inner [x]] -- but what if the architecture only supports word-sized loads, should -- we do the transformation anyway? -cmmMachOpFoldM _ mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)] +cmmMachOpFoldM dflags mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)] = case mop of -- for comparisons: don't forget to narrow the arguments before -- comparing, since they might be out of range. - MO_Eq _ -> Just $ CmmLit (CmmInt (if x_u == y_u then 1 else 0) wordWidth) - MO_Ne _ -> Just $ CmmLit (CmmInt (if x_u /= y_u then 1 else 0) wordWidth) + MO_Eq _ -> Just $ CmmLit (CmmInt (if x_u == y_u then 1 else 0) (wordWidth dflags)) + MO_Ne _ -> Just $ CmmLit (CmmInt (if x_u /= y_u then 1 else 0) (wordWidth dflags)) - MO_U_Gt _ -> Just $ CmmLit (CmmInt (if x_u > y_u then 1 else 0) wordWidth) - MO_U_Ge _ -> Just $ CmmLit (CmmInt (if x_u >= y_u then 1 else 0) wordWidth) - MO_U_Lt _ -> Just $ CmmLit (CmmInt (if x_u < y_u then 1 else 0) wordWidth) - MO_U_Le _ -> Just $ CmmLit (CmmInt (if x_u <= y_u then 1 else 0) wordWidth) + MO_U_Gt _ -> Just $ CmmLit (CmmInt (if x_u > y_u then 1 else 0) (wordWidth dflags)) + MO_U_Ge _ -> Just $ CmmLit (CmmInt (if x_u >= y_u then 1 else 0) (wordWidth dflags)) + MO_U_Lt _ -> Just $ CmmLit (CmmInt (if x_u < y_u then 1 else 0) (wordWidth dflags)) + MO_U_Le _ -> Just $ CmmLit (CmmInt (if x_u <= y_u then 1 else 0) (wordWidth dflags)) - MO_S_Gt _ -> Just $ CmmLit (CmmInt (if x_s > y_s then 1 else 0) wordWidth) - MO_S_Ge _ -> Just $ CmmLit (CmmInt (if x_s >= y_s then 1 else 0) wordWidth) - MO_S_Lt _ -> Just $ CmmLit (CmmInt (if x_s < y_s then 1 else 0) wordWidth) - MO_S_Le _ -> Just $ CmmLit (CmmInt (if x_s <= y_s then 1 else 0) wordWidth) + MO_S_Gt _ -> Just $ CmmLit (CmmInt (if x_s > y_s then 1 else 0) (wordWidth dflags)) + MO_S_Ge _ -> Just $ CmmLit (CmmInt (if x_s >= y_s then 1 else 0) (wordWidth dflags)) + MO_S_Lt _ -> Just $ CmmLit (CmmInt (if x_s < y_s then 1 else 0) (wordWidth dflags)) + MO_S_Le _ -> Just $ CmmLit (CmmInt (if x_s <= y_s then 1 else 0) (wordWidth dflags)) MO_Add r -> Just $ CmmLit (CmmInt (x + y) r) MO_Sub r -> Just $ CmmLit (CmmInt (x - y) r) @@ -418,9 +417,9 @@ cmmMachOpFoldM _ mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)] -- also assume that constants have been shifted to the right when -- possible. -cmmMachOpFoldM platform op [x@(CmmLit _), y] +cmmMachOpFoldM dflags op [x@(CmmLit _), y] | not (isLit y) && isCommutableMachOp op - = Just (cmmMachOpFold platform op [y, x]) + = Just (cmmMachOpFold dflags op [y, x]) -- Turn (a+b)+c into a+(b+c) where possible. Because literals are -- moved to the right, it is more likely that we will find @@ -438,19 +437,19 @@ cmmMachOpFoldM platform op [x@(CmmLit _), y] -- Also don't do it if arg1 is PicBaseReg, so that we don't separate the -- PicBaseReg from the corresponding label (or label difference). -- -cmmMachOpFoldM platform mop1 [CmmMachOp mop2 [arg1,arg2], arg3] +cmmMachOpFoldM dflags mop1 [CmmMachOp mop2 [arg1,arg2], arg3] | mop2 `associates_with` mop1 && not (isLit arg1) && not (isPicReg arg1) - = Just (cmmMachOpFold platform mop2 [arg1, cmmMachOpFold platform mop1 [arg2,arg3]]) + = Just (cmmMachOpFold dflags mop2 [arg1, cmmMachOpFold dflags mop1 [arg2,arg3]]) where MO_Add{} `associates_with` MO_Sub{} = True mop1 `associates_with` mop2 = mop1 == mop2 && isAssociativeMachOp mop1 -- special case: (a - b) + c ==> a + (c - b) -cmmMachOpFoldM platform mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3] +cmmMachOpFoldM dflags mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3] | not (isLit arg1) && not (isPicReg arg1) - = Just (cmmMachOpFold platform mop1 [arg1, cmmMachOpFold platform mop2 [arg3,arg2]]) + = Just (cmmMachOpFold dflags mop1 [arg1, cmmMachOpFold dflags mop2 [arg3,arg2]]) -- Make a RegOff if we can cmmMachOpFoldM _ (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)] @@ -479,9 +478,9 @@ cmmMachOpFoldM _ (MO_Sub _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)] -- narrowing throws away bits from the operand, there's no way to do -- the same comparison at the larger size. -cmmMachOpFoldM platform cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)] +cmmMachOpFoldM dflags cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)] | -- powerPC NCG has a TODO for I8/I16 comparisons, so don't try - platformArch platform `elem` [ArchX86, ArchX86_64], + platformArch (targetPlatform dflags) `elem` [ArchX86, ArchX86_64], -- if the operand is widened: Just (rep, signed, narrow_fn) <- maybe_conversion conv, -- and this is a comparison operation: @@ -489,7 +488,7 @@ cmmMachOpFoldM platform cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)] -- and the literal fits in the smaller size: i == narrow_fn rep i -- then we can do the comparison at the smaller size - = Just (cmmMachOpFold platform narrow_cmp [x, CmmLit (CmmInt i rep)]) + = Just (cmmMachOpFold dflags narrow_cmp [x, CmmLit (CmmInt i rep)]) where maybe_conversion (MO_UU_Conv from to) | to > from @@ -522,7 +521,7 @@ cmmMachOpFoldM platform cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)] -- We can often do something with constants of 0 and 1 ... -cmmMachOpFoldM _ mop [x, y@(CmmLit (CmmInt 0 _))] +cmmMachOpFoldM dflags mop [x, y@(CmmLit (CmmInt 0 _))] = case mop of MO_Add _ -> Just x MO_Sub _ -> Just x @@ -537,15 +536,15 @@ cmmMachOpFoldM _ mop [x, y@(CmmLit (CmmInt 0 _))] MO_Eq _ | Just x' <- maybeInvertCmmExpr x -> Just x' MO_U_Gt _ | isComparisonExpr x -> Just x MO_S_Gt _ | isComparisonExpr x -> Just x - MO_U_Lt _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 wordWidth) - MO_S_Lt _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 wordWidth) - MO_U_Ge _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 wordWidth) - MO_S_Ge _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 wordWidth) + MO_U_Lt _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 (wordWidth dflags)) + MO_S_Lt _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 (wordWidth dflags)) + MO_U_Ge _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 (wordWidth dflags)) + MO_S_Ge _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 (wordWidth dflags)) MO_U_Le _ | Just x' <- maybeInvertCmmExpr x -> Just x' MO_S_Le _ | Just x' <- maybeInvertCmmExpr x -> Just x' _ -> Nothing -cmmMachOpFoldM _ mop [x, (CmmLit (CmmInt 1 rep))] +cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt 1 rep))] = case mop of MO_Mul _ -> Just x MO_S_Quot _ -> Just x @@ -556,24 +555,24 @@ cmmMachOpFoldM _ mop [x, (CmmLit (CmmInt 1 rep))] MO_Eq _ | isComparisonExpr x -> Just x MO_U_Lt _ | Just x' <- maybeInvertCmmExpr x -> Just x' MO_S_Lt _ | Just x' <- maybeInvertCmmExpr x -> Just x' - MO_U_Gt _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 wordWidth) - MO_S_Gt _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 wordWidth) - MO_U_Le _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 wordWidth) - MO_S_Le _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 wordWidth) + MO_U_Gt _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 (wordWidth dflags)) + MO_S_Gt _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 (wordWidth dflags)) + MO_U_Le _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 (wordWidth dflags)) + MO_S_Le _ | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 (wordWidth dflags)) MO_U_Ge _ | isComparisonExpr x -> Just x MO_S_Ge _ | isComparisonExpr x -> Just x _ -> Nothing -- Now look for multiplication/division by powers of 2 (integers). -cmmMachOpFoldM platform mop [x, (CmmLit (CmmInt n _))] +cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt n _))] = case mop of MO_Mul rep | Just p <- exactLog2 n -> - Just (cmmMachOpFold platform (MO_Shl rep) [x, CmmLit (CmmInt p rep)]) + Just (cmmMachOpFold dflags (MO_Shl rep) [x, CmmLit (CmmInt p rep)]) MO_U_Quot rep | Just p <- exactLog2 n -> - Just (cmmMachOpFold platform (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)]) + Just (cmmMachOpFold dflags (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)]) MO_S_Quot rep | Just p <- exactLog2 n, CmmReg _ <- x -> -- We duplicate x below, hence require @@ -601,7 +600,7 @@ cmmMachOpFoldM platform mop [x, (CmmLit (CmmInt n _))] CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)] x3 = CmmMachOp (MO_Add rep) [x, x2] in - Just (cmmMachOpFold platform (MO_S_Shr rep) [x3, CmmLit (CmmInt p rep)]) + Just (cmmMachOpFold dflags (MO_S_Shr rep) [x3, CmmLit (CmmInt p rep)]) _ -> Nothing -- ToDo (#7116): optimise floating-point multiplication, e.g. x*2.0 -> x+x diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index bfde123fd5..7937b88ea3 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -1053,9 +1053,9 @@ doSwitch mb_range scrut arms deflt initEnv :: DynFlags -> Env initEnv dflags = listToUFM [ ( fsLit "SIZEOF_StgHeader", - VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags * wORD_SIZE)) wordWidth) )), + VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags * wORD_SIZE)) (wordWidth dflags)) )), ( fsLit "SIZEOF_StgInfoTable", - VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) wordWidth) )) + VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth dflags)) )) ] parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup) diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs index e87502b5a0..6ee40d9a74 100644 --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -43,7 +43,7 @@ cmmPipeline hsc_env topSRT prog = tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog - (topSRT, cmms) <- {-# SCC "doSRTs" #-} doSRTs topSRT tops + (topSRT, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags topSRT tops dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms) return (topSRT, cmms) diff --git a/compiler/cmm/CmmRewriteAssignments.hs b/compiler/cmm/CmmRewriteAssignments.hs index 824883654c..585d78e95b 100644 --- a/compiler/cmm/CmmRewriteAssignments.hs +++ b/compiler/cmm/CmmRewriteAssignments.hs @@ -22,7 +22,6 @@ import StgCmmUtils import DynFlags import UniqSupply -import Platform import UniqFM import Unique import BlockId @@ -38,7 +37,6 @@ import Prelude hiding (succ, zip) 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 @@ -47,7 +45,7 @@ rewriteAssignments dflags g = do g'' <- liftM fst $ dataflowPassFwd g' [(g_entry g, fact_bot assignmentLattice)] $ analRewFwd assignmentLattice (assignmentTransfer dflags) - (assignmentRewrite `thenFwdRw` machOpFoldRewrite platform) + (assignmentRewrite `thenFwdRw` machOpFoldRewrite dflags) return (modifyGraph eraseRegUsage g'') ---------------------------------------------------------------- @@ -615,8 +613,8 @@ assignmentRewrite = mkFRewrite3 first middle last -- in literals, which we can inline more aggressively, and inlining -- gives us opportunities for more folding. However, we don't need any -- facts to do MachOp folding. -machOpFoldRewrite :: Platform -> FwdRewrite UniqSM (WithRegUsage CmmNode) a -machOpFoldRewrite platform = mkFRewrite3 first middle last +machOpFoldRewrite :: DynFlags -> FwdRewrite UniqSM (WithRegUsage CmmNode) a +machOpFoldRewrite dflags = mkFRewrite3 first middle last where first _ _ = return Nothing middle :: WithRegUsage CmmNode O O -> a -> GenCmmReplGraph (WithRegUsage CmmNode) O O middle (Plain m) _ = return (fmap (mkMiddle . Plain) (foldNode m)) @@ -626,7 +624,7 @@ machOpFoldRewrite platform = mkFRewrite3 first middle last last (Plain l) _ = return (fmap (mkLast . Plain) (foldNode l)) foldNode :: CmmNode e x -> Maybe (CmmNode e x) foldNode n = mapExpDeepM foldExp n - foldExp (CmmMachOp op args) = cmmMachOpFoldM platform op args + foldExp (CmmMachOp op args) = cmmMachOpFoldM dflags op args foldExp _ = Nothing -- ToDo: Outputable instance for UsageMap and AssignmentMap diff --git a/compiler/cmm/CmmType.hs b/compiler/cmm/CmmType.hs index 4c5d6b1138..66b4c8302b 100644 --- a/compiler/cmm/CmmType.hs +++ b/compiler/cmm/CmmType.hs @@ -97,13 +97,13 @@ f64 = cmmFloat W64 -- CmmTypes of native word widths bWord :: DynFlags -> CmmType -bWord _ = cmmBits wordWidth +bWord dflags = cmmBits (wordWidth dflags) bHalfWord :: DynFlags -> CmmType bHalfWord dflags = cmmBits (halfWordWidth dflags) gcWord :: DynFlags -> CmmType -gcWord _ = CmmType GcPtrCat wordWidth +gcWord dflags = CmmType GcPtrCat (wordWidth dflags) cInt, cLong :: CmmType cInt = cmmBits cIntWidth @@ -160,10 +160,11 @@ mrStr W80 = sLit("W80") -------- Common Widths ------------ -wordWidth :: Width -wordWidth | wORD_SIZE == 4 = W32 - | wORD_SIZE == 8 = W64 - | otherwise = panic "MachOp.wordRep: Unknown word size" +wordWidth :: DynFlags -> Width +wordWidth _ + | wORD_SIZE == 4 = W32 + | wORD_SIZE == 8 = W64 + | otherwise = panic "MachOp.wordRep: Unknown word size" halfWordWidth :: DynFlags -> Width halfWordWidth _ diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs index 07130f336b..75bdf61ee4 100644 --- a/compiler/cmm/CmmUtils.hs +++ b/compiler/cmm/CmmUtils.hs @@ -121,17 +121,17 @@ typeForeignHint = primRepForeignHint . typePrimRep -- --------------------------------------------------- -mkIntCLit :: Int -> CmmLit -mkIntCLit i = CmmInt (toInteger i) wordWidth +mkIntCLit :: DynFlags -> Int -> CmmLit +mkIntCLit dflags i = CmmInt (toInteger i) (wordWidth dflags) -mkIntExpr :: Int -> CmmExpr -mkIntExpr i = CmmLit $! mkIntCLit i +mkIntExpr :: DynFlags -> Int -> CmmExpr +mkIntExpr dflags i = CmmLit $! mkIntCLit dflags i -zeroCLit :: CmmLit -zeroCLit = CmmInt 0 wordWidth +zeroCLit :: DynFlags -> CmmLit +zeroCLit dflags = CmmInt 0 (wordWidth dflags) -zeroExpr :: CmmExpr -zeroExpr = CmmLit zeroCLit +zeroExpr :: DynFlags -> CmmExpr +zeroExpr dflags = CmmLit (zeroCLit dflags) mkByteStringCLit :: Unique -> [Word8] -> (CmmLit, GenCmmDecl CmmStatics info stmt) -- We have to make a top-level decl for the string, @@ -156,21 +156,21 @@ mkRODataLits lbl lits needsRelocation (CmmLabelOff _ _) = True needsRelocation _ = False -mkWordCLit :: StgWord -> CmmLit -mkWordCLit wd = CmmInt (fromIntegral wd) wordWidth +mkWordCLit :: DynFlags -> StgWord -> CmmLit +mkWordCLit dflags wd = CmmInt (fromIntegral wd) (wordWidth dflags) -packHalfWordsCLit :: (Integral a, Integral b) => a -> b -> CmmLit +packHalfWordsCLit :: (Integral a, Integral b) => DynFlags -> a -> b -> CmmLit -- Make a single word literal in which the lower_half_word is -- at the lower address, and the upper_half_word is at the -- higher address -- ToDo: consider using half-word lits instead -- but be careful: that's vulnerable when reversed -packHalfWordsCLit lower_half_word upper_half_word +packHalfWordsCLit dflags lower_half_word upper_half_word #ifdef WORDS_BIGENDIAN - = mkWordCLit ((fromIntegral lower_half_word `shiftL` hALF_WORD_SIZE_IN_BITS) + = mkWordCLit dflags ((fromIntegral lower_half_word `shiftL` hALF_WORD_SIZE_IN_BITS) .|. fromIntegral upper_half_word) #else - = mkWordCLit ((fromIntegral lower_half_word) + = mkWordCLit dflags ((fromIntegral lower_half_word) .|. (fromIntegral upper_half_word `shiftL` hALF_WORD_SIZE_IN_BITS)) #endif @@ -243,7 +243,7 @@ cmmIndexExpr dflags width base idx = cmmOffsetExpr dflags base byte_off where idx_w = cmmExprWidth dflags idx - byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr (widthInLog width)] + byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr dflags (widthInLog width)] cmmLoadIndex :: DynFlags -> CmmType -> CmmExpr -> Int -> CmmExpr cmmLoadIndex dflags ty expr ix = CmmLoad (cmmIndex dflags (typeWidth ty) expr ix) ty @@ -269,7 +269,7 @@ cmmOffsetLitB = cmmOffsetLit cmmOffsetExprW :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr -- The second arg is a *word* offset; need to change it to bytes cmmOffsetExprW dflags e (CmmLit (CmmInt n _)) = cmmOffsetW dflags e (fromInteger n) -cmmOffsetExprW dflags e wd_off = cmmIndexExpr dflags wordWidth e wd_off +cmmOffsetExprW dflags e wd_off = cmmIndexExpr dflags (wordWidth dflags) e wd_off cmmOffsetW :: DynFlags -> CmmExpr -> WordOff -> CmmExpr cmmOffsetW dflags e n = cmmOffsetB dflags e (wORD_SIZE * n) @@ -290,20 +290,20 @@ cmmLoadIndexW dflags base off ty = CmmLoad (cmmOffsetW dflags base off) ty cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord, cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord, cmmUShrWord, cmmAddWord, cmmMulWord, cmmQuotWord - :: CmmExpr -> CmmExpr -> CmmExpr -cmmOrWord e1 e2 = CmmMachOp mo_wordOr [e1, e2] -cmmAndWord e1 e2 = CmmMachOp mo_wordAnd [e1, e2] -cmmNeWord e1 e2 = CmmMachOp mo_wordNe [e1, e2] -cmmEqWord e1 e2 = CmmMachOp mo_wordEq [e1, e2] -cmmULtWord e1 e2 = CmmMachOp mo_wordULt [e1, e2] -cmmUGeWord e1 e2 = CmmMachOp mo_wordUGe [e1, e2] -cmmUGtWord e1 e2 = CmmMachOp mo_wordUGt [e1, e2] ---cmmShlWord e1 e2 = CmmMachOp mo_wordShl [e1, e2] -cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2] -cmmAddWord e1 e2 = CmmMachOp mo_wordAdd [e1, e2] -cmmSubWord e1 e2 = CmmMachOp mo_wordSub [e1, e2] -cmmMulWord e1 e2 = CmmMachOp mo_wordMul [e1, e2] -cmmQuotWord e1 e2 = CmmMachOp mo_wordUQuot [e1, e2] + :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr +cmmOrWord dflags e1 e2 = CmmMachOp (mo_wordOr dflags) [e1, e2] +cmmAndWord dflags e1 e2 = CmmMachOp (mo_wordAnd dflags) [e1, e2] +cmmNeWord dflags e1 e2 = CmmMachOp (mo_wordNe dflags) [e1, e2] +cmmEqWord dflags e1 e2 = CmmMachOp (mo_wordEq dflags) [e1, e2] +cmmULtWord dflags e1 e2 = CmmMachOp (mo_wordULt dflags) [e1, e2] +cmmUGeWord dflags e1 e2 = CmmMachOp (mo_wordUGe dflags) [e1, e2] +cmmUGtWord dflags e1 e2 = CmmMachOp (mo_wordUGt dflags) [e1, e2] +--cmmShlWord dflags e1 e2 = CmmMachOp (mo_wordShl dflags) [e1, e2] +cmmUShrWord dflags e1 e2 = CmmMachOp (mo_wordUShr dflags) [e1, e2] +cmmAddWord dflags e1 e2 = CmmMachOp (mo_wordAdd dflags) [e1, e2] +cmmSubWord dflags e1 e2 = CmmMachOp (mo_wordSub dflags) [e1, e2] +cmmMulWord dflags e1 e2 = CmmMachOp (mo_wordMul dflags) [e1, e2] +cmmQuotWord dflags e1 e2 = CmmMachOp (mo_wordUQuot dflags) [e1, e2] cmmNegate :: DynFlags -> CmmExpr -> CmmExpr cmmNegate _ (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep) @@ -342,28 +342,27 @@ hasNoGlobalRegs _ = False -- Tag bits mask --cmmTagBits = CmmLit (mkIntCLit tAG_BITS) -cmmTagMask, cmmPointerMask :: CmmExpr -cmmTagMask = mkIntExpr tAG_MASK -cmmPointerMask = mkIntExpr (complement tAG_MASK) +cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr +cmmTagMask dflags = mkIntExpr dflags tAG_MASK +cmmPointerMask dflags = mkIntExpr dflags (complement tAG_MASK) -- Used to untag a possibly tagged pointer -- A static label need not be untagged -cmmUntag, cmmGetTag :: CmmExpr -> CmmExpr -cmmUntag e@(CmmLit (CmmLabel _)) = e +cmmUntag, cmmGetTag :: DynFlags -> CmmExpr -> CmmExpr +cmmUntag _ e@(CmmLit (CmmLabel _)) = e -- Default case -cmmUntag e = (e `cmmAndWord` cmmPointerMask) +cmmUntag dflags e = cmmAndWord dflags e (cmmPointerMask dflags) -cmmGetTag e = (e `cmmAndWord` cmmTagMask) +cmmGetTag dflags e = cmmAndWord dflags e (cmmTagMask dflags) -- Test if a closure pointer is untagged -cmmIsTagged :: CmmExpr -> CmmExpr -cmmIsTagged e = (e `cmmAndWord` cmmTagMask) - `cmmNeWord` zeroExpr +cmmIsTagged :: DynFlags -> CmmExpr -> CmmExpr +cmmIsTagged dflags e = cmmNeWord dflags (cmmAndWord dflags e (cmmTagMask dflags)) (zeroExpr dflags) -cmmConstrTag, cmmConstrTag1 :: CmmExpr -> CmmExpr -cmmConstrTag e = (e `cmmAndWord` cmmTagMask) `cmmSubWord` mkIntExpr 1 +cmmConstrTag, cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr +cmmConstrTag dflags e = cmmSubWord dflags (cmmAndWord dflags e (cmmTagMask dflags)) (mkIntExpr dflags 1) -- Get constructor tag, but one based. -cmmConstrTag1 e = e `cmmAndWord` cmmTagMask +cmmConstrTag1 dflags e = cmmAndWord dflags e (cmmTagMask dflags) -------------------------------------------- diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs index d9dfb42cbe..3233dbed8c 100644 --- a/compiler/cmm/MkGraph.hs +++ b/compiler/cmm/MkGraph.hs @@ -306,7 +306,7 @@ copyIn dflags oflow conv area formals = where ci (reg, RegisterParam r) (n, ms) = (n, CmmAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) : ms) ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms) - init_offset = widthInBytes wordWidth -- infotable + init_offset = widthInBytes (wordWidth dflags) -- infotable args = assignArgumentsPos dflags conv localRegType formals args' = foldl adjust [] args where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst @@ -356,10 +356,10 @@ copyOutOflow dflags conv transfer area actuals updfr_off case transfer of Call -> ([(CmmLit (CmmBlock id), StackParam init_offset)], - widthInBytes wordWidth) + widthInBytes (wordWidth dflags)) JumpRet -> ([], - widthInBytes wordWidth) + widthInBytes (wordWidth dflags)) _other -> ([], 0) Old -> ([], updfr_off) diff --git a/compiler/cmm/OldCmmLint.hs b/compiler/cmm/OldCmmLint.hs index 009a7841f1..9146aa74a3 100644 --- a/compiler/cmm/OldCmmLint.hs +++ b/compiler/cmm/OldCmmLint.hs @@ -80,9 +80,9 @@ lintCmmExpr dflags (CmmLoad expr rep) = do return rep lintCmmExpr dflags expr@(CmmMachOp op args) = do tys <- mapM (lintCmmExpr dflags) args - if map (typeWidth . cmmExprType dflags) args == machOpArgReps op + if map (typeWidth . cmmExprType dflags) args == machOpArgReps dflags op then cmmCheckMachOp dflags op args tys - else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps op) + else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps dflags op) lintCmmExpr dflags (CmmRegOff reg offset) = lintCmmExpr dflags (CmmMachOp (MO_Add rep) [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)]) @@ -137,7 +137,7 @@ lintCmmStmt dflags labels = lint lint (CmmCall target _res args _) = do lintTarget dflags labels target mapM_ (lintCmmExpr dflags . hintlessCmm) args - lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr dflags e >> checkCond e + lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr dflags e >> checkCond dflags e lint (CmmSwitch e branches) = do mapM_ checkTarget $ catMaybes branches erep <- lintCmmExpr dflags e @@ -159,10 +159,10 @@ lintTarget dflags labels (CmmPrim _ (Just stmts)) = mapM_ (lintCmmStmt dflags labels) stmts -checkCond :: CmmExpr -> CmmLint () -checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return () -checkCond (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values -checkCond expr +checkCond :: DynFlags -> CmmExpr -> CmmLint () +checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return () +checkCond dflags (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth dflags = return () -- constant values +checkCond _ expr = cmmLintErr (hang (text "expression is not a conditional:") 2 (ppr expr)) diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 01c64dae60..b40b34aaa5 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -149,9 +149,10 @@ pprBBlock (BasicBlock lbl stmts) = pprWordArray :: CLabel -> [CmmStatic] -> SDoc pprWordArray lbl ds - = hcat [ pprLocalness lbl, ptext (sLit "StgWord") + = sdocWithDynFlags $ \dflags -> + hcat [ pprLocalness lbl, ptext (sLit "StgWord") , space, ppr lbl, ptext (sLit "[] = {") ] - $$ nest 8 (commafy (pprStatics ds)) + $$ nest 8 (commafy (pprStatics dflags ds)) $$ ptext (sLit "};") -- @@ -178,10 +179,10 @@ pprStmt stmt = -- some debugging option is on. They can get quite -- large. - CmmAssign dest src -> pprAssign dest src + CmmAssign dest src -> pprAssign dflags dest src CmmStore dest src - | typeWidth rep == W64 && wordWidth /= W64 + | typeWidth rep == W64 && wordWidth dflags /= W64 -> (if isFloatType rep then ptext (sLit "ASSIGN_DBL") else ptext (sLit ("ASSIGN_Word64"))) <> parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi @@ -248,7 +249,8 @@ pprStmt stmt = CmmBranch ident -> pprBranch ident CmmCondBranch expr ident -> pprCondBranch expr ident CmmJump lbl _ -> mkJMP_(pprExpr lbl) <> semi - CmmSwitch arg ids -> pprSwitch arg ids + CmmSwitch arg ids -> sdocWithDynFlags $ \dflags -> + pprSwitch dflags arg ids pprForeignCall :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> (SDoc, SDoc) @@ -297,8 +299,8 @@ pprCondBranch expr ident -- 'undefined'. However, they may be defined one day, so we better -- document this behaviour. -- -pprSwitch :: CmmExpr -> [ Maybe BlockId ] -> SDoc -pprSwitch e maybe_ids +pprSwitch :: DynFlags -> CmmExpr -> [ Maybe BlockId ] -> SDoc +pprSwitch dflags e maybe_ids = let pairs = [ (ix, ident) | (ix,Just ident) <- zip [0..] maybe_ids ] pairs2 = [ (map fst as, snd (head as)) | as <- groupBy sndEq pairs ] in @@ -313,11 +315,11 @@ pprSwitch e maybe_ids caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix where do_fallthrough ix = - hsep [ ptext (sLit "case") , pprHexVal ix wordWidth <> colon , + hsep [ ptext (sLit "case") , pprHexVal ix (wordWidth dflags) <> colon , ptext (sLit "/* fall through */") ] final_branch ix = - hsep [ ptext (sLit "case") , pprHexVal ix wordWidth <> colon , + hsep [ ptext (sLit "case") , pprHexVal ix (wordWidth dflags) <> colon , ptext (sLit "goto") , (pprBlockId ident) <> semi ] caseify (_ , _ ) = panic "pprSwtich: swtich with no cases!" @@ -341,7 +343,7 @@ pprExpr e = case e of CmmLit lit -> pprLit lit - CmmLoad e ty -> pprLoad e ty + CmmLoad e ty -> sdocWithDynFlags $ \dflags -> pprLoad dflags e ty CmmReg reg -> pprCastReg reg CmmRegOff reg 0 -> pprCastReg reg @@ -356,26 +358,26 @@ pprExpr e = case e of CmmStackSlot _ _ -> panic "pprExpr: CmmStackSlot not supported!" -pprLoad :: CmmExpr -> CmmType -> SDoc -pprLoad e ty - | width == W64, wordWidth /= W64 +pprLoad :: DynFlags -> CmmExpr -> CmmType -> SDoc +pprLoad dflags e ty + | width == W64, wordWidth dflags /= W64 = (if isFloatType ty then ptext (sLit "PK_DBL") else ptext (sLit "PK_Word64")) <> parens (mkP_ <> pprExpr1 e) | otherwise = case e of - CmmReg r | isPtrReg r && width == wordWidth && not (isFloatType ty) + CmmReg r | isPtrReg r && width == wordWidth dflags && not (isFloatType ty) -> char '*' <> pprAsPtrReg r - CmmRegOff r 0 | isPtrReg r && width == wordWidth && not (isFloatType ty) + CmmRegOff r 0 | isPtrReg r && width == wordWidth dflags && not (isFloatType ty) -> char '*' <> pprAsPtrReg r - CmmRegOff r off | isPtrReg r && width == wordWidth + CmmRegOff r off | isPtrReg r && width == wordWidth dflags , off `rem` wORD_SIZE == 0 && not (isFloatType ty) -- ToDo: check that the offset is a word multiple? -- (For tagging to work, I had to avoid unaligned loads. --ARY) - -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift)) + -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift dflags)) _other -> cLoad e ty where @@ -474,38 +476,38 @@ pprLit1 other = pprLit other -- --------------------------------------------------------------------------- -- Static data -pprStatics :: [CmmStatic] -> [SDoc] -pprStatics [] = [] -pprStatics (CmmStaticLit (CmmFloat f W32) : rest) +pprStatics :: DynFlags -> [CmmStatic] -> [SDoc] +pprStatics _ [] = [] +pprStatics dflags (CmmStaticLit (CmmFloat f W32) : rest) -- floats are padded to a word, see #1852 | wORD_SIZE == 8, CmmStaticLit (CmmInt 0 W32) : rest' <- rest - = pprLit1 (floatToWord f) : pprStatics rest' + = pprLit1 (floatToWord dflags f) : pprStatics dflags rest' | wORD_SIZE == 4 - = pprLit1 (floatToWord f) : pprStatics rest + = pprLit1 (floatToWord dflags f) : pprStatics dflags rest | otherwise = pprPanic "pprStatics: float" (vcat (map ppr' rest)) 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 -pprStatics (CmmStaticLit (CmmInt i W64) : rest) - | wordWidth == W32 +pprStatics dflags (CmmStaticLit (CmmFloat f W64) : rest) + = map pprLit1 (doubleToWords dflags f) ++ pprStatics dflags rest +pprStatics dflags (CmmStaticLit (CmmInt i W64) : rest) + | wordWidth dflags == W32 #ifdef WORDS_BIGENDIAN - = pprStatics (CmmStaticLit (CmmInt q W32) : - CmmStaticLit (CmmInt r W32) : rest) + = pprStatics dflags (CmmStaticLit (CmmInt q W32) : + CmmStaticLit (CmmInt r W32) : rest) #else - = pprStatics (CmmStaticLit (CmmInt r W32) : - CmmStaticLit (CmmInt q W32) : rest) + = pprStatics dflags (CmmStaticLit (CmmInt r W32) : + CmmStaticLit (CmmInt q W32) : rest) #endif where r = i .&. 0xffffffff q = i `shiftR` 32 -pprStatics (CmmStaticLit (CmmInt _ w) : _) - | w /= wordWidth +pprStatics dflags (CmmStaticLit (CmmInt _ w) : _) + | w /= wordWidth dflags = panic "pprStatics: cannot emit a non-word-sized static literal" -pprStatics (CmmStaticLit lit : rest) - = pprLit1 lit : pprStatics rest -pprStatics (other : _) +pprStatics dflags (CmmStaticLit lit : rest) + = pprLit1 lit : pprStatics dflags rest +pprStatics _ (other : _) = pprPanic "pprWord" (pprStatic other) pprStatic :: CmmStatic -> SDoc @@ -710,19 +712,19 @@ mkP_ = ptext (sLit "(P_)") -- StgWord* -- -- Generating assignments is what we're all about, here -- -pprAssign :: CmmReg -> CmmExpr -> SDoc +pprAssign :: DynFlags -> CmmReg -> CmmExpr -> SDoc -- dest is a reg, rhs is a reg -pprAssign r1 (CmmReg r2) +pprAssign _ r1 (CmmReg r2) | isPtrReg r1 && isPtrReg r2 = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ] -- dest is a reg, rhs is a CmmRegOff -pprAssign r1 (CmmRegOff r2 off) +pprAssign dflags r1 (CmmRegOff r2 off) | isPtrReg r1 && isPtrReg r2 && (off `rem` wORD_SIZE == 0) = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ] where - off1 = off `shiftR` wordShift + off1 = off `shiftR` wordShift dflags (op,off') | off >= 0 = (char '+', off1) | otherwise = (char '-', -off1) @@ -730,7 +732,7 @@ pprAssign r1 (CmmRegOff r2 off) -- dest is a reg, rhs is anything. -- We can't cast the lvalue, so we have to cast the rhs if necessary. Casting -- the lvalue elicits a warning from new GCC versions (3.4+). -pprAssign r1 r2 +pprAssign _ r1 r2 | isFixedPtrReg r1 = mkAssign (mkP_ <> pprExpr1 r2) | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 r2) | otherwise = mkAssign (pprExpr r2) @@ -907,9 +909,9 @@ pprExternDecl _in_srt lbl -- If the label we want to refer to is a stdcall function (on Windows) then -- we must generate an appropriate prototype for it, so that the C compiler will -- add the @n suffix to the label (#2276) - stdcall_decl sz = + stdcall_decl sz = sdocWithDynFlags $ \dflags -> ptext (sLit "extern __attribute__((stdcall)) void ") <> ppr lbl - <> parens (commafy (replicate (sz `quot` wORD_SIZE) (machRep_U_CType wordWidth))) + <> parens (commafy (replicate (sz `quot` wORD_SIZE) (machRep_U_CType (wordWidth dflags)))) <> semi type TEState = (UniqSet LocalReg, Map CLabel ()) @@ -990,10 +992,10 @@ cLoad expr rep bewareLoadStoreAlignment (ArchARM {}) = True bewareLoadStoreAlignment _ = False -isCmmWordType :: CmmType -> Bool +isCmmWordType :: DynFlags -> CmmType -> Bool -- True of GcPtrReg/NonGcReg of native word size -isCmmWordType ty = not (isFloatType ty) - && typeWidth ty == wordWidth +isCmmWordType dflags ty = not (isFloatType ty) + && typeWidth ty == wordWidth dflags -- This is for finding the types of foreign call arguments. For a pointer -- argument, we always cast the argument to (void *), to avoid warnings from @@ -1004,8 +1006,10 @@ machRepHintCType rep SignedHint = machRep_S_CType (typeWidth rep) machRepHintCType rep _other = machRepCType rep machRepPtrCType :: CmmType -> SDoc -machRepPtrCType r | isCmmWordType r = ptext (sLit "P_") - | otherwise = machRepCType r <> char '*' +machRepPtrCType r + = sdocWithDynFlags $ \dflags -> + if isCmmWordType dflags r then ptext (sLit "P_") + else machRepCType r <> char '*' machRepCType :: CmmType -> SDoc machRepCType ty | isFloatType ty = machRep_F_CType w @@ -1019,20 +1023,26 @@ machRep_F_CType W64 = ptext (sLit "StgDouble") machRep_F_CType _ = panic "machRep_F_CType" machRep_U_CType :: Width -> SDoc -machRep_U_CType w | w == wordWidth = ptext (sLit "W_") -machRep_U_CType W8 = ptext (sLit "StgWord8") -machRep_U_CType W16 = ptext (sLit "StgWord16") -machRep_U_CType W32 = ptext (sLit "StgWord32") -machRep_U_CType W64 = ptext (sLit "StgWord64") -machRep_U_CType _ = panic "machRep_U_CType" +machRep_U_CType w + = sdocWithDynFlags $ \dflags -> + case w of + _ | w == wordWidth dflags -> ptext (sLit "W_") + W8 -> ptext (sLit "StgWord8") + W16 -> ptext (sLit "StgWord16") + W32 -> ptext (sLit "StgWord32") + W64 -> ptext (sLit "StgWord64") + _ -> panic "machRep_U_CType" machRep_S_CType :: Width -> SDoc -machRep_S_CType w | w == wordWidth = ptext (sLit "I_") -machRep_S_CType W8 = ptext (sLit "StgInt8") -machRep_S_CType W16 = ptext (sLit "StgInt16") -machRep_S_CType W32 = ptext (sLit "StgInt32") -machRep_S_CType W64 = ptext (sLit "StgInt64") -machRep_S_CType _ = panic "machRep_S_CType" +machRep_S_CType w + = sdocWithDynFlags $ \dflags -> + case w of + _ | w == wordWidth dflags -> ptext (sLit "I_") + W8 -> ptext (sLit "StgInt8") + W16 -> ptext (sLit "StgInt16") + W32 -> ptext (sLit "StgInt32") + W64 -> ptext (sLit "StgInt64") + _ -> panic "machRep_S_CType" -- --------------------------------------------------------------------- @@ -1062,18 +1072,18 @@ castDoubleToIntArray :: STUArray s Int Double -> ST s (STUArray s Int Int) castDoubleToIntArray = castSTUArray -- floats are always 1 word -floatToWord :: Rational -> CmmLit -floatToWord r +floatToWord :: DynFlags -> Rational -> CmmLit +floatToWord dflags r = runST (do arr <- newArray_ ((0::Int),0) writeArray arr 0 (fromRational r) arr' <- castFloatToIntArray arr i <- readArray arr' 0 - return (CmmInt (toInteger i) wordWidth) + return (CmmInt (toInteger i) (wordWidth dflags)) ) -doubleToWords :: Rational -> [CmmLit] -doubleToWords r +doubleToWords :: DynFlags -> Rational -> [CmmLit] +doubleToWords dflags r | big_doubles -- doubles are 2 words = runST (do arr <- newArray_ ((0::Int),1) @@ -1081,8 +1091,8 @@ doubleToWords r arr' <- castDoubleToIntArray arr i1 <- readArray arr' 0 i2 <- readArray arr' 1 - return [ CmmInt (toInteger i1) wordWidth - , CmmInt (toInteger i2) wordWidth + return [ CmmInt (toInteger i1) (wordWidth dflags) + , CmmInt (toInteger i2) (wordWidth dflags) ] ) | otherwise -- doubles are 1 word @@ -1091,14 +1101,14 @@ doubleToWords r writeArray arr 0 (fromRational r) arr' <- castDoubleToIntArray arr i <- readArray arr' 0 - return [ CmmInt (toInteger i) wordWidth ] + return [ CmmInt (toInteger i) (wordWidth dflags) ] ) -- --------------------------------------------------------------------------- -- Utils -wordShift :: Int -wordShift = widthInLog wordWidth +wordShift :: DynFlags -> Int +wordShift dflags = widthInLog (wordWidth dflags) commafy :: [SDoc] -> SDoc commafy xs = hsep $ punctuate comma xs diff --git a/compiler/cmm/PprCmmExpr.hs b/compiler/cmm/PprCmmExpr.hs index 2c481c38a2..7d2f4824ef 100644 --- a/compiler/cmm/PprCmmExpr.hs +++ b/compiler/cmm/PprCmmExpr.hs @@ -187,10 +187,11 @@ infixMachOp mop -- has the natural machine word size, we do not append the type -- pprLit :: CmmLit -> SDoc -pprLit lit = case lit of +pprLit lit = sdocWithDynFlags $ \dflags -> + case lit of CmmInt i rep -> hcat [ (if i < 0 then parens else id)(integer i) - , ppUnless (rep == wordWidth) $ + , ppUnless (rep == wordWidth dflags) $ space <> dcolon <+> ppr rep ] CmmFloat f rep -> hsep [ double (fromRat f), dcolon, ppr rep ] diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs index f8062cfbf5..fce910489e 100644 --- a/compiler/codeGen/CgClosure.lhs +++ b/compiler/codeGen/CgClosure.lhs @@ -320,10 +320,11 @@ mkFunEntryCode cl_info cc reg_args stk_args sp_top reg_save_code body = do -- Do the business ; funWrapper cl_info reg_args reg_save_code $ do - { tickyEnterFun cl_info + { dflags <- getDynFlags + ; tickyEnterFun cl_info ; enterCostCentreFun cc - (CmmMachOp mo_wordSub [ CmmReg nodeReg - , mkIntExpr (funTag cl_info) ]) + (CmmMachOp (mo_wordSub dflags) [ CmmReg nodeReg + , mkIntExpr dflags (funTag cl_info) ]) (node : map snd reg_args) -- live regs ; cgExpr body } @@ -429,7 +430,7 @@ funWrapper closure_info arg_regs reg_save_code fun_body = do ; whenC (tag /= 0 && node_points) $ do l <- newLabelC stmtC (CmmCondBranch (CmmMachOp mo_wordEq [cmmGetTag (CmmReg nodeReg), - mkIntExpr tag)]) l) + mkIntExpr dflags tag)]) l) stmtC (CmmStore (CmmLit (mkWordCLit 0)) (mkWordExpr 0)) labelC l -} @@ -598,7 +599,7 @@ link_caf cl_info _is_upd = do -- node is live, so save it. -- see Note [atomic CAF entry] in rts/sm/Storage.c - ; emitIf (CmmMachOp mo_wordEq [ CmmReg (CmmLocal ret), zeroExpr]) $ + ; emitIf (CmmMachOp (mo_wordEq dflags) [ CmmReg (CmmLocal ret), zeroExpr dflags]) $ -- re-enter R1. Doing this directly is slightly dodgy; we're -- assuming lots of things, like the stack pointer hasn't -- moved since we entered the CAF. diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs index 146f28461f..57fd10d4e4 100644 --- a/compiler/codeGen/CgCon.lhs +++ b/compiler/codeGen/CgCon.lhs @@ -355,7 +355,7 @@ cgReturnDataCon con amodes = do where node_live = Just [node] enter_it dflags - = stmtsC [ CmmAssign nodeReg (cmmUntag (CmmReg nodeReg)), + = stmtsC [ CmmAssign nodeReg (cmmUntag dflags (CmmReg nodeReg)), CmmJump (entryCode dflags $ closureInfoPtr dflags $ CmmReg nodeReg) node_live ] diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs index 213745d59d..b835e784e1 100644 --- a/compiler/codeGen/CgForeignCall.hs +++ b/compiler/codeGen/CgForeignCall.hs @@ -152,7 +152,7 @@ emitForeignCall' safety results target args vols _srt ret stmtC (CmmCall (CmmCallee suspendThread CCallConv) [ CmmHinted id AddrHint ] [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint - , CmmHinted (CmmLit (CmmInt (fromIntegral (fromEnum (playInterruptible safety))) wordWidth)) NoHint] + , CmmHinted (CmmLit (CmmInt (fromIntegral (fromEnum (playInterruptible safety))) (wordWidth dflags))) NoHint] ret) stmtC (CmmCall temp_target results temp_args ret) stmtC (CmmCall (CmmCallee resumeThread CCallConv) @@ -243,7 +243,7 @@ emitLoadThreadState = do -- HpAlloc = 0; -- HpAlloc is assumed to be set to non-zero only by a failed -- a heap check, see HeapStackCheck.cmm:GC_GENERIC - CmmAssign hpAlloc (CmmLit zeroCLit) + CmmAssign hpAlloc (CmmLit (zeroCLit dflags)) ] emitOpenNursery -- and load the current cost centre stack from the TSO when profiling: @@ -264,10 +264,10 @@ emitOpenNursery = (cmmOffsetExpr dflags (CmmLoad (nursery_bdescr_start dflags) (bWord dflags)) (cmmOffset dflags - (CmmMachOp mo_wordMul [ - CmmMachOp (MO_SS_Conv W32 wordWidth) + (CmmMachOp (mo_wordMul dflags) [ + CmmMachOp (MO_SS_Conv W32 (wordWidth dflags)) [CmmLoad (nursery_bdescr_blocks dflags) b32], - mkIntExpr bLOCK_SIZE + mkIntExpr dflags bLOCK_SIZE ]) (-1) ) diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs index daca30c25a..e37783cf11 100644 --- a/compiler/codeGen/CgHeapery.lhs +++ b/compiler/codeGen/CgHeapery.lhs @@ -208,22 +208,22 @@ mkStaticClosureFields dflags cl_info ccs caf_refs payload padding_wds | not is_caf = [] - | otherwise = ASSERT(null payload) [mkIntCLit 0] + | otherwise = ASSERT(null payload) [mkIntCLit dflags 0] static_link_field | is_caf || staticClosureNeedsLink cl_info = [static_link_value] | otherwise = [] saved_info_field - | is_caf = [mkIntCLit 0] + | is_caf = [mkIntCLit dflags 0] | otherwise = [] -- for a static constructor which has NoCafRefs, we set the -- static link field to a non-zero value so the garbage -- collector will ignore it. static_link_value - | caf_refs = mkIntCLit 0 - | otherwise = mkIntCLit 1 + | caf_refs = mkIntCLit dflags 0 + | otherwise = mkIntCLit dflags 1 mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] @@ -412,18 +412,18 @@ unbxTupleHeapCheck regs ptrs nptrs fail_code code | ptrs > 255 || nptrs > 255 = panic "altHeapCheck" | otherwise = initHeapUsage $ \ hpHw -> do - { codeOnly $ do { do_checks 0 {- no stack check -} hpHw + { dflags <- getDynFlags + ; let full_fail_code = fail_code `plusStmts` oneStmt assign_liveness + assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9 VNonGcPtr)) -- Ho ho ho! + (CmmLit (mkWordCLit dflags liveness)) + liveness = mkRegLiveness regs ptrs nptrs + live = Just $ map snd regs + rts_label = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_ut"))) + ; codeOnly $ do { do_checks 0 {- no stack check -} hpHw full_fail_code rts_label live ; tickyAllocHeap hpHw } ; setRealHp hpHw ; code } - where - full_fail_code = fail_code `plusStmts` oneStmt assign_liveness - assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9 VNonGcPtr)) -- Ho ho ho! - (CmmLit (mkWordCLit liveness)) - liveness = mkRegLiveness regs ptrs nptrs - live = Just $ map snd regs - rts_label = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_ut"))) \end{code} @@ -462,15 +462,27 @@ do_checks _ hp _ _ _ "structures in the code."]) do_checks stk hp reg_save_code rts_lbl live - = do_checks' (mkIntExpr (stk*wORD_SIZE)) - (mkIntExpr (hp*wORD_SIZE)) - (stk /= 0) (hp /= 0) reg_save_code rts_lbl live + = do dflags <- getDynFlags + do_checks' (mkIntExpr dflags (stk*wORD_SIZE)) + (mkIntExpr dflags (hp*wORD_SIZE)) + (stk /= 0) (hp /= 0) reg_save_code rts_lbl live -- The offsets are now in *bytes* do_checks' :: CmmExpr -> CmmExpr -> Bool -> Bool -> CmmStmts -> CmmExpr -> Maybe [GlobalReg] -> Code do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl live = do { dflags <- getDynFlags + + -- Stk overflow if (Sp - stk_bytes < SpLim) + ; let stk_oflo = CmmMachOp (mo_wordULt dflags) + [CmmMachOp (mo_wordSub dflags) [CmmReg spReg, stk_expr], + CmmReg (CmmGlobal SpLim)] + + -- Hp overflow if (Hp > HpLim) + -- (Hp has been incremented by now) + -- HpLim points to the LAST WORD of valid allocation space. + hp_oflo = CmmMachOp (mo_wordUGt dflags) + [CmmReg hpReg, CmmReg (CmmGlobal HpLim)] ; doGranAllocate hp_expr @@ -506,17 +518,6 @@ do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl live -- with slop at the end of the current block, which can -- confuse the LDV profiler. } - where - -- Stk overflow if (Sp - stk_bytes < SpLim) - stk_oflo = CmmMachOp mo_wordULt - [CmmMachOp mo_wordSub [CmmReg spReg, stk_expr], - CmmReg (CmmGlobal SpLim)] - - -- Hp overflow if (Hp > HpLim) - -- (Hp has been incremented by now) - -- HpLim points to the LAST WORD of valid allocation space. - hp_oflo = CmmMachOp mo_wordUGt - [CmmReg hpReg, CmmReg (CmmGlobal HpLim)] \end{code} %************************************************************************ @@ -532,15 +533,16 @@ hpChkGen bytes liveness reentry 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 + do_checks' (zeroExpr dflags) bytes False True assigns stg_gc_gen (Just (activeStgRegs platform)) -- a heap check where R1 points to the closure to enter on return, and -- we want to assign to Sp[0] on failure (used in AutoApply.cmm:BUILD_PAP). hpChkNodePointsAssignSp0 :: CmmExpr -> CmmExpr -> Code hpChkNodePointsAssignSp0 bytes sp0 - = do_checks' zeroExpr bytes False True assign - stg_gc_enter1 (Just [node]) + = do dflags <- getDynFlags + do_checks' (zeroExpr dflags) bytes False True assign + stg_gc_enter1 (Just [node]) where assign = oneStmt (CmmStore (CmmReg spReg) sp0) stkChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code @@ -549,7 +551,7 @@ stkChkGen bytes liveness reentry 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 + do_checks' bytes (zeroExpr dflags) True False assigns stg_gc_gen (Just (activeStgRegs platform)) mk_vanilla_assignment :: DynFlags -> Int -> CmmExpr -> CmmStmt @@ -558,8 +560,9 @@ mk_vanilla_assignment dflags n e stkChkNodePoints :: CmmExpr -> Code stkChkNodePoints bytes - = do_checks' bytes zeroExpr True False noStmts - stg_gc_enter1 (Just [node]) + = do dflags <- getDynFlags + do_checks' bytes (zeroExpr dflags) True False noStmts + stg_gc_enter1 (Just [node]) stg_gc_gen :: CmmExpr stg_gc_gen = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_gen"))) diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs index 68cbe0f0da..18e3532db9 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -214,15 +214,15 @@ emitAlgReturnTarget -> FCode (CLabel, SemiTaggingStuff) emitAlgReturnTarget name branches mb_deflt fam_sz - = do { blks <- getCgStmts $ + = do { blks <- getCgStmts $ do -- is the constructor tag in the node reg? + dflags <- getDynFlags if isSmallFamily fam_sz then do -- yes, node has constr. tag - let tag_expr = cmmConstrTag1 (CmmReg nodeReg) + let tag_expr = cmmConstrTag1 dflags (CmmReg nodeReg) branches' = [(tag+1,branch)|(tag,branch)<-branches] emitSwitch tag_expr branches' mb_deflt 1 fam_sz else do -- no, get tag from info table - dflags <- getDynFlags let -- Note that ptr _always_ has tag 1 -- when the family size is big enough untagged_ptr = cmmRegOffB nodeReg (-1) @@ -296,7 +296,7 @@ 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 dflags) wordWidth) [infoTableConstrTag dflags info_table] + = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableConstrTag dflags info_table] where info_table = infoTable dflags (closureInfoPtr dflags closure_ptr) @@ -304,7 +304,7 @@ 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 dflags) wordWidth) [infoTableClosureType dflags info_table] + = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableClosureType dflags info_table] where info_table = infoTable dflags (closureInfoPtr dflags closure_ptr) diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs index aaa97a2132..1accdbe213 100644 --- a/compiler/codeGen/CgPrimOp.hs +++ b/compiler/codeGen/CgPrimOp.hs @@ -62,7 +62,7 @@ emitPrimOp :: DynFlags -- First we handle various awkward cases specially. The remaining -- easy cases are then handled by translateOp, defined below. -emitPrimOp _ [res_r,res_c] IntAddCOp [aa,bb] _ +emitPrimOp dflags [res_r,res_c] IntAddCOp [aa,bb] _ {- With some bit-twiddling, we can define int{Add,Sub}Czh portably in C, and without needing any comparisons. This may not be the @@ -84,19 +84,19 @@ emitPrimOp _ [res_r,res_c] IntAddCOp [aa,bb] _ -} = stmtsC [ - CmmAssign (CmmLocal res_r) (CmmMachOp mo_wordAdd [aa,bb]), + CmmAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]), CmmAssign (CmmLocal res_c) $ - CmmMachOp mo_wordUShr [ - CmmMachOp mo_wordAnd [ - CmmMachOp mo_wordNot [CmmMachOp mo_wordXor [aa,bb]], - CmmMachOp mo_wordXor [aa, CmmReg (CmmLocal res_r)] + CmmMachOp (mo_wordUShr dflags) [ + CmmMachOp (mo_wordAnd dflags) [ + CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]], + CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] ], - mkIntExpr (wORD_SIZE_IN_BITS - 1) + mkIntExpr dflags (wORD_SIZE_IN_BITS - 1) ] ] -emitPrimOp _ [res_r,res_c] IntSubCOp [aa,bb] _ +emitPrimOp dflags [res_r,res_c] IntSubCOp [aa,bb] _ {- Similarly: #define subIntCzh(r,c,a,b) \ { r = ((I_)(a)) - ((I_)(b)); \ @@ -107,14 +107,14 @@ emitPrimOp _ [res_r,res_c] IntSubCOp [aa,bb] _ c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1) -} = stmtsC [ - CmmAssign (CmmLocal res_r) (CmmMachOp mo_wordSub [aa,bb]), + CmmAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]), CmmAssign (CmmLocal res_c) $ - CmmMachOp mo_wordUShr [ - CmmMachOp mo_wordAnd [ - CmmMachOp mo_wordXor [aa,bb], - CmmMachOp mo_wordXor [aa, CmmReg (CmmLocal res_r)] + CmmMachOp (mo_wordUShr dflags) [ + CmmMachOp (mo_wordAnd dflags) [ + CmmMachOp (mo_wordXor dflags) [aa,bb], + CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] ], - mkIntExpr (wORD_SIZE_IN_BITS - 1) + mkIntExpr dflags (wORD_SIZE_IN_BITS - 1) ] ] @@ -160,8 +160,8 @@ emitPrimOp dflags [res] GetCCSOfOp [arg] _live = stmtC (CmmAssign (CmmLocal res) val) where val - | dopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag arg) - | otherwise = CmmLit zeroCLit + | dopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag dflags arg) + | otherwise = CmmLit (zeroCLit dflags) emitPrimOp _ [res] GetCurrentCCSOp [_dummy_arg] _live = stmtC (CmmAssign (CmmLocal res) curCCS) @@ -210,14 +210,14 @@ emitPrimOp dflags [res] StableNameToIntOp [arg] _ -- #define eqStableNamezh(r,sn1,sn2) \ -- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn)) emitPrimOp dflags [res] EqStableNameOp [arg1,arg2] _ - = stmtC (CmmAssign (CmmLocal res) (CmmMachOp mo_wordEq [ + = stmtC (CmmAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [ cmmLoadIndexW dflags arg1 (fixedHdrSize dflags) (bWord dflags), cmmLoadIndexW dflags arg2 (fixedHdrSize dflags) (bWord dflags) ])) -emitPrimOp _ [res] ReallyUnsafePtrEqualityOp [arg1,arg2] _ - = stmtC (CmmAssign (CmmLocal res) (CmmMachOp mo_wordEq [arg1,arg2])) +emitPrimOp dflags [res] ReallyUnsafePtrEqualityOp [arg1,arg2] _ + = stmtC (CmmAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2])) -- #define addrToHValuezh(r,a) r=(P_)a emitPrimOp _ [res] AddrToAnyOp [arg] _ @@ -226,7 +226,7 @@ emitPrimOp _ [res] AddrToAnyOp [arg] _ -- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info)) -- Note: argument may be tagged! emitPrimOp dflags [res] DataToTagOp [arg] _ - = stmtC (CmmAssign (CmmLocal res) (getConstrTag dflags (cmmUntag arg))) + = stmtC (CmmAssign (CmmLocal res) (getConstrTag dflags (cmmUntag dflags arg))) {- Freezing arrays-of-ptrs requires changing an info table, for the benefit of the generational collector. It needs to scavenge mutable @@ -296,116 +296,116 @@ emitPrimOp dflags [res] SizeofMutableArrayArrayOp [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 dflags res IndexOffAddrOp_Char args _ = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexOffAddrOp_WideChar args _ = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args emitPrimOp dflags res IndexOffAddrOp_Int args _ = doIndexOffAddrOp Nothing (bWord dflags) res args emitPrimOp dflags res IndexOffAddrOp_Word args _ = doIndexOffAddrOp Nothing (bWord dflags) res args emitPrimOp dflags res IndexOffAddrOp_Addr args _ = doIndexOffAddrOp Nothing (bWord dflags) res args emitPrimOp _ res IndexOffAddrOp_Float args _ = doIndexOffAddrOp Nothing f32 res args emitPrimOp _ res IndexOffAddrOp_Double args _ = doIndexOffAddrOp Nothing f64 res args emitPrimOp dflags res IndexOffAddrOp_StablePtr args _ = doIndexOffAddrOp Nothing (bWord dflags) res args -emitPrimOp _ 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 dflags res IndexOffAddrOp_Int8 args _ = doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexOffAddrOp_Int16 args _ = doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args +emitPrimOp dflags res IndexOffAddrOp_Int32 args _ = doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args emitPrimOp _ res IndexOffAddrOp_Int64 args _ = doIndexOffAddrOp Nothing b64 res args -emitPrimOp _ 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 dflags res IndexOffAddrOp_Word8 args _ = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexOffAddrOp_Word16 args _ = doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args +emitPrimOp dflags res IndexOffAddrOp_Word32 args _ = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args emitPrimOp _ res IndexOffAddrOp_Word64 args _ = doIndexOffAddrOp Nothing b64 res args -- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr. -emitPrimOp _ res ReadOffAddrOp_Char args _ = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args -emitPrimOp _ res ReadOffAddrOp_WideChar args _ = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args +emitPrimOp dflags res ReadOffAddrOp_Char args _ = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadOffAddrOp_WideChar args _ = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args emitPrimOp dflags res ReadOffAddrOp_Int args _ = doIndexOffAddrOp Nothing (bWord dflags) res args emitPrimOp dflags res ReadOffAddrOp_Word args _ = doIndexOffAddrOp Nothing (bWord dflags) res args emitPrimOp dflags res ReadOffAddrOp_Addr args _ = doIndexOffAddrOp Nothing (bWord dflags) res args emitPrimOp _ res ReadOffAddrOp_Float args _ = doIndexOffAddrOp Nothing f32 res args emitPrimOp _ res ReadOffAddrOp_Double args _ = doIndexOffAddrOp Nothing f64 res args emitPrimOp dflags res ReadOffAddrOp_StablePtr args _ = doIndexOffAddrOp Nothing (bWord dflags) res args -emitPrimOp _ 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 dflags res ReadOffAddrOp_Int8 args _ = doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadOffAddrOp_Int16 args _ = doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args +emitPrimOp dflags res ReadOffAddrOp_Int32 args _ = doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args emitPrimOp _ res ReadOffAddrOp_Int64 args _ = doIndexOffAddrOp Nothing b64 res args -emitPrimOp _ 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 dflags res ReadOffAddrOp_Word8 args _ = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadOffAddrOp_Word16 args _ = doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args +emitPrimOp dflags res ReadOffAddrOp_Word32 args _ = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args emitPrimOp _ res ReadOffAddrOp_Word64 args _ = doIndexOffAddrOp Nothing b64 res args -- IndexXXXArray -emitPrimOp _ res IndexByteArrayOp_Char args _ = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args -emitPrimOp _ res IndexByteArrayOp_WideChar args _ = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args +emitPrimOp dflags res IndexByteArrayOp_Char args _ = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexByteArrayOp_WideChar args _ = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args emitPrimOp dflags res IndexByteArrayOp_Int args _ = doIndexByteArrayOp Nothing (bWord dflags) res args emitPrimOp dflags res IndexByteArrayOp_Word args _ = doIndexByteArrayOp Nothing (bWord dflags) res args emitPrimOp dflags res IndexByteArrayOp_Addr args _ = doIndexByteArrayOp Nothing (bWord dflags) res args emitPrimOp _ res IndexByteArrayOp_Float args _ = doIndexByteArrayOp Nothing f32 res args emitPrimOp _ res IndexByteArrayOp_Double args _ = doIndexByteArrayOp Nothing f64 res args emitPrimOp dflags res IndexByteArrayOp_StablePtr args _ = doIndexByteArrayOp Nothing (bWord dflags) res args -emitPrimOp _ 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 dflags res IndexByteArrayOp_Int8 args _ = doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexByteArrayOp_Int16 args _ = doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16 res args +emitPrimOp dflags res IndexByteArrayOp_Int32 args _ = doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32 res args emitPrimOp _ res IndexByteArrayOp_Int64 args _ = doIndexByteArrayOp Nothing b64 res args -emitPrimOp _ 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 dflags res IndexByteArrayOp_Word8 args _ = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexByteArrayOp_Word16 args _ = doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16 res args +emitPrimOp dflags res IndexByteArrayOp_Word32 args _ = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args emitPrimOp _ res IndexByteArrayOp_Word64 args _ = doIndexByteArrayOp Nothing b64 res args -- ReadXXXArray, identical to IndexXXXArray. -emitPrimOp _ res ReadByteArrayOp_Char args _ = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args -emitPrimOp _ res ReadByteArrayOp_WideChar args _ = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args +emitPrimOp dflags res ReadByteArrayOp_Char args _ = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadByteArrayOp_WideChar args _ = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args emitPrimOp dflags res ReadByteArrayOp_Int args _ = doIndexByteArrayOp Nothing (bWord dflags) res args emitPrimOp dflags res ReadByteArrayOp_Word args _ = doIndexByteArrayOp Nothing (bWord dflags) res args emitPrimOp dflags res ReadByteArrayOp_Addr args _ = doIndexByteArrayOp Nothing (bWord dflags) res args emitPrimOp _ res ReadByteArrayOp_Float args _ = doIndexByteArrayOp Nothing f32 res args emitPrimOp _ res ReadByteArrayOp_Double args _ = doIndexByteArrayOp Nothing f64 res args emitPrimOp dflags res ReadByteArrayOp_StablePtr args _ = doIndexByteArrayOp Nothing (bWord dflags) res args -emitPrimOp _ 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 dflags res ReadByteArrayOp_Int8 args _ = doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadByteArrayOp_Int16 args _ = doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16 res args +emitPrimOp dflags res ReadByteArrayOp_Int32 args _ = doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32 res args emitPrimOp _ res ReadByteArrayOp_Int64 args _ = doIndexByteArrayOp Nothing b64 res args -emitPrimOp _ 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 dflags res ReadByteArrayOp_Word8 args _ = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadByteArrayOp_Word16 args _ = doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16 res args +emitPrimOp dflags res ReadByteArrayOp_Word32 args _ = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args emitPrimOp _ res ReadByteArrayOp_Word64 args _ = doIndexByteArrayOp Nothing b64 res args -- WriteXXXoffAddr -emitPrimOp _ res WriteOffAddrOp_Char args _ = doWriteOffAddrOp (Just mo_WordTo8) b8 res args -emitPrimOp _ res WriteOffAddrOp_WideChar args _ = doWriteOffAddrOp (Just mo_WordTo32) b32 res args +emitPrimOp dflags res WriteOffAddrOp_Char args _ = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8 res args +emitPrimOp dflags res WriteOffAddrOp_WideChar args _ = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args emitPrimOp dflags res WriteOffAddrOp_Int args _ = doWriteOffAddrOp Nothing (bWord dflags) res args emitPrimOp dflags res WriteOffAddrOp_Word args _ = doWriteOffAddrOp Nothing (bWord dflags) res args emitPrimOp dflags res WriteOffAddrOp_Addr args _ = doWriteOffAddrOp Nothing (bWord dflags) res args emitPrimOp _ res WriteOffAddrOp_Float args _ = doWriteOffAddrOp Nothing f32 res args emitPrimOp _ res WriteOffAddrOp_Double args _ = doWriteOffAddrOp Nothing f64 res args emitPrimOp dflags res WriteOffAddrOp_StablePtr args _ = doWriteOffAddrOp Nothing (bWord dflags) res args -emitPrimOp _ 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 dflags res WriteOffAddrOp_Int8 args _ = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8 res args +emitPrimOp dflags res WriteOffAddrOp_Int16 args _ = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args +emitPrimOp dflags res WriteOffAddrOp_Int32 args _ = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args emitPrimOp _ res WriteOffAddrOp_Int64 args _ = doWriteOffAddrOp Nothing b64 res args -emitPrimOp _ 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 dflags res WriteOffAddrOp_Word8 args _ = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8 res args +emitPrimOp dflags res WriteOffAddrOp_Word16 args _ = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args +emitPrimOp dflags res WriteOffAddrOp_Word32 args _ = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args emitPrimOp _ res WriteOffAddrOp_Word64 args _ = doWriteOffAddrOp Nothing b64 res args -- WriteXXXArray -emitPrimOp _ res WriteByteArrayOp_Char args _ = doWriteByteArrayOp (Just mo_WordTo8) b8 res args -emitPrimOp _ res WriteByteArrayOp_WideChar args _ = doWriteByteArrayOp (Just mo_WordTo32) b32 res args +emitPrimOp dflags res WriteByteArrayOp_Char args _ = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args +emitPrimOp dflags res WriteByteArrayOp_WideChar args _ = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args emitPrimOp dflags res WriteByteArrayOp_Int args _ = doWriteByteArrayOp Nothing (bWord dflags) res args emitPrimOp dflags res WriteByteArrayOp_Word args _ = doWriteByteArrayOp Nothing (bWord dflags) res args emitPrimOp dflags res WriteByteArrayOp_Addr args _ = doWriteByteArrayOp Nothing (bWord dflags) res args emitPrimOp _ res WriteByteArrayOp_Float args _ = doWriteByteArrayOp Nothing f32 res args emitPrimOp _ res WriteByteArrayOp_Double args _ = doWriteByteArrayOp Nothing f64 res args emitPrimOp dflags res WriteByteArrayOp_StablePtr args _ = doWriteByteArrayOp Nothing (bWord dflags) res args -emitPrimOp _ 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 dflags res WriteByteArrayOp_Int8 args _ = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args +emitPrimOp dflags res WriteByteArrayOp_Int16 args _ = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args +emitPrimOp dflags res WriteByteArrayOp_Int32 args _ = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args emitPrimOp _ res WriteByteArrayOp_Int64 args _ = doWriteByteArrayOp Nothing b64 res args -emitPrimOp _ 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 dflags res WriteByteArrayOp_Word8 args _ = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args +emitPrimOp dflags res WriteByteArrayOp_Word16 args _ = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args +emitPrimOp dflags res WriteByteArrayOp_Word32 args _ = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args emitPrimOp _ res WriteByteArrayOp_Word64 args _ = doWriteByteArrayOp Nothing b64 res args -- Copying and setting byte arrays @@ -422,27 +422,27 @@ 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 = - emitPopCntCall res (CmmMachOp mo_WordTo8 [w]) W8 live -emitPrimOp _ [res] PopCnt16Op [w] live = - emitPopCntCall res (CmmMachOp mo_WordTo16 [w]) W16 live -emitPrimOp _ [res] PopCnt32Op [w] live = - emitPopCntCall res (CmmMachOp mo_WordTo32 [w]) W32 live -emitPrimOp _ [res] PopCnt64Op [w] live = - emitPopCntCall res (CmmMachOp mo_WordTo64 [w]) W64 live -emitPrimOp _ [res] PopCntOp [w] live = - emitPopCntCall res w wordWidth live +emitPrimOp dflags [res] PopCnt8Op [w] live = + emitPopCntCall res (CmmMachOp (mo_WordTo8 dflags) [w]) W8 live +emitPrimOp dflags [res] PopCnt16Op [w] live = + emitPopCntCall res (CmmMachOp (mo_WordTo16 dflags) [w]) W16 live +emitPrimOp dflags [res] PopCnt32Op [w] live = + emitPopCntCall res (CmmMachOp (mo_WordTo32 dflags) [w]) W32 live +emitPrimOp dflags [res] PopCnt64Op [w] live = + emitPopCntCall res (CmmMachOp (mo_WordTo64 dflags) [w]) W64 live +emitPrimOp dflags [res] PopCntOp [w] live = + emitPopCntCall res w (wordWidth dflags) live -- The rest just translate straightforwardly -emitPrimOp _ [res] op [arg] _ +emitPrimOp dflags [res] op [arg] _ | nopOp op = stmtC (CmmAssign (CmmLocal res) arg) | Just (mop,rep) <- narrowOp op = stmtC (CmmAssign (CmmLocal res) $ - CmmMachOp (mop rep wordWidth) [CmmMachOp (mop wordWidth rep) [arg]]) + CmmMachOp (mop rep (wordWidth dflags)) [CmmMachOp (mop (wordWidth dflags) rep) [arg]]) -emitPrimOp _ [res] op args live +emitPrimOp dflags [res] op args live | Just prim <- callishOp op = do vols <- getVolatileRegs live emitForeignCall' PlayRisky @@ -453,30 +453,30 @@ emitPrimOp _ [res] op args live NoC_SRT -- No SRT b/c we do PlayRisky CmmMayReturn - | Just mop <- translateOp op + | Just mop <- translateOp dflags op = let stmt = CmmAssign (CmmLocal res) (CmmMachOp mop args) in stmtC stmt -emitPrimOp _ [res_q, res_r] IntQuotRemOp [arg_x, arg_y] _ +emitPrimOp dflags [res_q, res_r] IntQuotRemOp [arg_x, arg_y] _ = let genericImpl = [CmmAssign (CmmLocal res_q) - (CmmMachOp (MO_S_Quot wordWidth) [arg_x, arg_y]), + (CmmMachOp (MO_S_Quot (wordWidth dflags)) [arg_x, arg_y]), CmmAssign (CmmLocal res_r) - (CmmMachOp (MO_S_Rem wordWidth) [arg_x, arg_y])] - stmt = CmmCall (CmmPrim (MO_S_QuotRem wordWidth) (Just genericImpl)) + (CmmMachOp (MO_S_Rem (wordWidth dflags)) [arg_x, arg_y])] + stmt = CmmCall (CmmPrim (MO_S_QuotRem (wordWidth dflags)) (Just genericImpl)) [CmmHinted res_q NoHint, CmmHinted res_r NoHint] [CmmHinted arg_x NoHint, CmmHinted arg_y NoHint] CmmMayReturn in stmtC stmt -emitPrimOp _ [res_q, res_r] WordQuotRemOp [arg_x, arg_y] _ +emitPrimOp dflags [res_q, res_r] WordQuotRemOp [arg_x, arg_y] _ = let genericImpl = [CmmAssign (CmmLocal res_q) - (CmmMachOp (MO_U_Quot wordWidth) [arg_x, arg_y]), + (CmmMachOp (MO_U_Quot (wordWidth dflags)) [arg_x, arg_y]), CmmAssign (CmmLocal res_r) - (CmmMachOp (MO_U_Rem wordWidth) [arg_x, arg_y])] - stmt = CmmCall (CmmPrim (MO_U_QuotRem wordWidth) (Just genericImpl)) + (CmmMachOp (MO_U_Rem (wordWidth dflags)) [arg_x, arg_y])] + stmt = CmmCall (CmmPrim (MO_U_QuotRem (wordWidth dflags)) (Just genericImpl)) [CmmHinted res_q NoHint, CmmHinted res_r NoHint] [CmmHinted arg_x NoHint, @@ -485,17 +485,17 @@ emitPrimOp _ [res_q, res_r] WordQuotRemOp [arg_x, arg_y] _ in stmtC stmt 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] - ge x y = CmmMachOp (MO_U_Ge wordWidth) [x, y] - ne x y = CmmMachOp (MO_Ne wordWidth) [x, y] - minus x y = CmmMachOp (MO_Sub wordWidth) [x, y] - times x y = CmmMachOp (MO_Mul wordWidth) [x, y] + shl x i = CmmMachOp (MO_Shl (wordWidth dflags)) [x, i] + shr x i = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, i] + or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y] + ge x y = CmmMachOp (MO_U_Ge (wordWidth dflags)) [x, y] + ne x y = CmmMachOp (MO_Ne (wordWidth dflags)) [x, y] + minus x y = CmmMachOp (MO_Sub (wordWidth dflags)) [x, y] + times x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y] zero = lit 0 one = lit 1 - negone = lit (fromIntegral (widthInBits wordWidth) - 1) - lit i = CmmLit (CmmInt i wordWidth) + negone = lit (fromIntegral (widthInBits (wordWidth dflags)) - 1) + lit i = CmmLit (CmmInt i (wordWidth dflags)) f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode [CmmStmt] f 0 acc high _ = return [CmmAssign (CmmLocal res_q) acc, CmmAssign (CmmLocal res_r) high] @@ -526,8 +526,8 @@ emitPrimOp dflags [res_q, res_r] WordQuotRem2Op [arg_x_high, arg_x_low, arg_y] _ (CmmReg (CmmLocal rhigh'')) (CmmReg (CmmLocal rlow')) return (this ++ rest) - genericImpl <- f (widthInBits wordWidth) zero arg_x_high arg_x_low - let stmt = CmmCall (CmmPrim (MO_U_QuotRem2 wordWidth) (Just genericImpl)) + genericImpl <- f (widthInBits (wordWidth dflags)) zero arg_x_high arg_x_low + let stmt = CmmCall (CmmPrim (MO_U_QuotRem2 (wordWidth dflags)) (Just genericImpl)) [CmmHinted res_q NoHint, CmmHinted res_r NoHint] [CmmHinted arg_x_high NoHint, @@ -552,15 +552,15 @@ emitPrimOp dflags [res_h, res_l] WordAdd2Op [arg_x, arg_y] _ CmmAssign (CmmLocal res_l) (or (toTopHalf (CmmReg (CmmLocal r2))) (bottomHalf (CmmReg (CmmLocal r1))))] - where topHalf x = CmmMachOp (MO_U_Shr wordWidth) [x, hww] - toTopHalf x = CmmMachOp (MO_Shl wordWidth) [x, hww] - bottomHalf x = CmmMachOp (MO_And wordWidth) [x, hwm] - add x y = CmmMachOp (MO_Add wordWidth) [x, y] - or x y = CmmMachOp (MO_Or wordWidth) [x, y] + where topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww] + toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww] + bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm] + add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y] + or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y] hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags))) - wordWidth) - hwm = CmmLit (CmmInt (halfWordMask dflags) wordWidth) - stmt = CmmCall (CmmPrim (MO_Add2 wordWidth) (Just genericImpl)) + (wordWidth dflags)) + hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags)) + stmt = CmmCall (CmmPrim (MO_Add2 (wordWidth dflags)) (Just genericImpl)) [CmmHinted res_h NoHint, CmmHinted res_l NoHint] [CmmHinted arg_x NoHint, @@ -594,17 +594,17 @@ emitPrimOp dflags [res_h, res_l] WordMul2Op [arg_x, arg_y] _ topHalf (CmmReg xhyl), topHalf (CmmReg xlyh), topHalf (CmmReg r)])] - where topHalf x = CmmMachOp (MO_U_Shr wordWidth) [x, hww] - toTopHalf x = CmmMachOp (MO_Shl wordWidth) [x, hww] - bottomHalf x = CmmMachOp (MO_And wordWidth) [x, hwm] - add x y = CmmMachOp (MO_Add wordWidth) [x, y] + where topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww] + toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww] + bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm] + add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y] sum = foldl1 add - mul x y = CmmMachOp (MO_Mul wordWidth) [x, y] - or x y = CmmMachOp (MO_Or wordWidth) [x, y] + mul x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y] + or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y] hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags))) - wordWidth) - hwm = CmmLit (CmmInt (halfWordMask dflags) wordWidth) - stmt = CmmCall (CmmPrim (MO_U_Mul2 wordWidth) (Just genericImpl)) + (wordWidth dflags)) + hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags)) + stmt = CmmCall (CmmPrim (MO_U_Mul2 (wordWidth dflags)) (Just genericImpl)) [CmmHinted res_h NoHint, CmmHinted res_l NoHint] [CmmHinted arg_x NoHint, @@ -643,125 +643,125 @@ narrowOp _ = Nothing -- Native word signless ops -translateOp :: PrimOp -> Maybe MachOp -translateOp IntAddOp = Just mo_wordAdd -translateOp IntSubOp = Just mo_wordSub -translateOp WordAddOp = Just mo_wordAdd -translateOp WordSubOp = Just mo_wordSub -translateOp AddrAddOp = Just mo_wordAdd -translateOp AddrSubOp = Just mo_wordSub - -translateOp IntEqOp = Just mo_wordEq -translateOp IntNeOp = Just mo_wordNe -translateOp WordEqOp = Just mo_wordEq -translateOp WordNeOp = Just mo_wordNe -translateOp AddrEqOp = Just mo_wordEq -translateOp AddrNeOp = Just mo_wordNe - -translateOp AndOp = Just mo_wordAnd -translateOp OrOp = Just mo_wordOr -translateOp XorOp = Just mo_wordXor -translateOp NotOp = Just mo_wordNot -translateOp SllOp = Just mo_wordShl -translateOp SrlOp = Just mo_wordUShr - -translateOp AddrRemOp = Just mo_wordURem +translateOp :: DynFlags -> PrimOp -> Maybe MachOp +translateOp dflags IntAddOp = Just (mo_wordAdd dflags) +translateOp dflags IntSubOp = Just (mo_wordSub dflags) +translateOp dflags WordAddOp = Just (mo_wordAdd dflags) +translateOp dflags WordSubOp = Just (mo_wordSub dflags) +translateOp dflags AddrAddOp = Just (mo_wordAdd dflags) +translateOp dflags AddrSubOp = Just (mo_wordSub dflags) + +translateOp dflags IntEqOp = Just (mo_wordEq dflags) +translateOp dflags IntNeOp = Just (mo_wordNe dflags) +translateOp dflags WordEqOp = Just (mo_wordEq dflags) +translateOp dflags WordNeOp = Just (mo_wordNe dflags) +translateOp dflags AddrEqOp = Just (mo_wordEq dflags) +translateOp dflags AddrNeOp = Just (mo_wordNe dflags) + +translateOp dflags AndOp = Just (mo_wordAnd dflags) +translateOp dflags OrOp = Just (mo_wordOr dflags) +translateOp dflags XorOp = Just (mo_wordXor dflags) +translateOp dflags NotOp = Just (mo_wordNot dflags) +translateOp dflags SllOp = Just (mo_wordShl dflags) +translateOp dflags SrlOp = Just (mo_wordUShr dflags) + +translateOp dflags AddrRemOp = Just (mo_wordURem dflags) -- Native word signed ops -translateOp IntMulOp = Just mo_wordMul -translateOp IntMulMayOfloOp = Just (MO_S_MulMayOflo wordWidth) -translateOp IntQuotOp = Just mo_wordSQuot -translateOp IntRemOp = Just mo_wordSRem -translateOp IntNegOp = Just mo_wordSNeg +translateOp dflags IntMulOp = Just (mo_wordMul dflags) +translateOp dflags IntMulMayOfloOp = Just (MO_S_MulMayOflo (wordWidth dflags)) +translateOp dflags IntQuotOp = Just (mo_wordSQuot dflags) +translateOp dflags IntRemOp = Just (mo_wordSRem dflags) +translateOp dflags IntNegOp = Just (mo_wordSNeg dflags) -translateOp IntGeOp = Just mo_wordSGe -translateOp IntLeOp = Just mo_wordSLe -translateOp IntGtOp = Just mo_wordSGt -translateOp IntLtOp = Just mo_wordSLt +translateOp dflags IntGeOp = Just (mo_wordSGe dflags) +translateOp dflags IntLeOp = Just (mo_wordSLe dflags) +translateOp dflags IntGtOp = Just (mo_wordSGt dflags) +translateOp dflags IntLtOp = Just (mo_wordSLt dflags) -translateOp ISllOp = Just mo_wordShl -translateOp ISraOp = Just mo_wordSShr -translateOp ISrlOp = Just mo_wordUShr +translateOp dflags ISllOp = Just (mo_wordShl dflags) +translateOp dflags ISraOp = Just (mo_wordSShr dflags) +translateOp dflags ISrlOp = Just (mo_wordUShr dflags) -- Native word unsigned ops -translateOp WordGeOp = Just mo_wordUGe -translateOp WordLeOp = Just mo_wordULe -translateOp WordGtOp = Just mo_wordUGt -translateOp WordLtOp = Just mo_wordULt +translateOp dflags WordGeOp = Just (mo_wordUGe dflags) +translateOp dflags WordLeOp = Just (mo_wordULe dflags) +translateOp dflags WordGtOp = Just (mo_wordUGt dflags) +translateOp dflags WordLtOp = Just (mo_wordULt dflags) -translateOp WordMulOp = Just mo_wordMul -translateOp WordQuotOp = Just mo_wordUQuot -translateOp WordRemOp = Just mo_wordURem +translateOp dflags WordMulOp = Just (mo_wordMul dflags) +translateOp dflags WordQuotOp = Just (mo_wordUQuot dflags) +translateOp dflags WordRemOp = Just (mo_wordURem dflags) -translateOp AddrGeOp = Just mo_wordUGe -translateOp AddrLeOp = Just mo_wordULe -translateOp AddrGtOp = Just mo_wordUGt -translateOp AddrLtOp = Just mo_wordULt +translateOp dflags AddrGeOp = Just (mo_wordUGe dflags) +translateOp dflags AddrLeOp = Just (mo_wordULe dflags) +translateOp dflags AddrGtOp = Just (mo_wordUGt dflags) +translateOp dflags AddrLtOp = Just (mo_wordULt dflags) -- Char# ops -translateOp CharEqOp = Just (MO_Eq wordWidth) -translateOp CharNeOp = Just (MO_Ne wordWidth) -translateOp CharGeOp = Just (MO_U_Ge wordWidth) -translateOp CharLeOp = Just (MO_U_Le wordWidth) -translateOp CharGtOp = Just (MO_U_Gt wordWidth) -translateOp CharLtOp = Just (MO_U_Lt wordWidth) +translateOp dflags CharEqOp = Just (MO_Eq (wordWidth dflags)) +translateOp dflags CharNeOp = Just (MO_Ne (wordWidth dflags)) +translateOp dflags CharGeOp = Just (MO_U_Ge (wordWidth dflags)) +translateOp dflags CharLeOp = Just (MO_U_Le (wordWidth dflags)) +translateOp dflags CharGtOp = Just (MO_U_Gt (wordWidth dflags)) +translateOp dflags CharLtOp = Just (MO_U_Lt (wordWidth dflags)) -- Double ops -translateOp DoubleEqOp = Just (MO_F_Eq W64) -translateOp DoubleNeOp = Just (MO_F_Ne W64) -translateOp DoubleGeOp = Just (MO_F_Ge W64) -translateOp DoubleLeOp = Just (MO_F_Le W64) -translateOp DoubleGtOp = Just (MO_F_Gt W64) -translateOp DoubleLtOp = Just (MO_F_Lt W64) +translateOp _ DoubleEqOp = Just (MO_F_Eq W64) +translateOp _ DoubleNeOp = Just (MO_F_Ne W64) +translateOp _ DoubleGeOp = Just (MO_F_Ge W64) +translateOp _ DoubleLeOp = Just (MO_F_Le W64) +translateOp _ DoubleGtOp = Just (MO_F_Gt W64) +translateOp _ DoubleLtOp = Just (MO_F_Lt W64) -translateOp DoubleAddOp = Just (MO_F_Add W64) -translateOp DoubleSubOp = Just (MO_F_Sub W64) -translateOp DoubleMulOp = Just (MO_F_Mul W64) -translateOp DoubleDivOp = Just (MO_F_Quot W64) -translateOp DoubleNegOp = Just (MO_F_Neg W64) +translateOp _ DoubleAddOp = Just (MO_F_Add W64) +translateOp _ DoubleSubOp = Just (MO_F_Sub W64) +translateOp _ DoubleMulOp = Just (MO_F_Mul W64) +translateOp _ DoubleDivOp = Just (MO_F_Quot W64) +translateOp _ DoubleNegOp = Just (MO_F_Neg W64) -- Float ops -translateOp FloatEqOp = Just (MO_F_Eq W32) -translateOp FloatNeOp = Just (MO_F_Ne W32) -translateOp FloatGeOp = Just (MO_F_Ge W32) -translateOp FloatLeOp = Just (MO_F_Le W32) -translateOp FloatGtOp = Just (MO_F_Gt W32) -translateOp FloatLtOp = Just (MO_F_Lt W32) +translateOp _ FloatEqOp = Just (MO_F_Eq W32) +translateOp _ FloatNeOp = Just (MO_F_Ne W32) +translateOp _ FloatGeOp = Just (MO_F_Ge W32) +translateOp _ FloatLeOp = Just (MO_F_Le W32) +translateOp _ FloatGtOp = Just (MO_F_Gt W32) +translateOp _ FloatLtOp = Just (MO_F_Lt W32) -translateOp FloatAddOp = Just (MO_F_Add W32) -translateOp FloatSubOp = Just (MO_F_Sub W32) -translateOp FloatMulOp = Just (MO_F_Mul W32) -translateOp FloatDivOp = Just (MO_F_Quot W32) -translateOp FloatNegOp = Just (MO_F_Neg W32) +translateOp _ FloatAddOp = Just (MO_F_Add W32) +translateOp _ FloatSubOp = Just (MO_F_Sub W32) +translateOp _ FloatMulOp = Just (MO_F_Mul W32) +translateOp _ FloatDivOp = Just (MO_F_Quot W32) +translateOp _ FloatNegOp = Just (MO_F_Neg W32) -- Conversions -translateOp Int2DoubleOp = Just (MO_SF_Conv wordWidth W64) -translateOp Double2IntOp = Just (MO_FS_Conv W64 wordWidth) +translateOp dflags Int2DoubleOp = Just (MO_SF_Conv (wordWidth dflags) W64) +translateOp dflags Double2IntOp = Just (MO_FS_Conv W64 (wordWidth dflags)) -translateOp Int2FloatOp = Just (MO_SF_Conv wordWidth W32) -translateOp Float2IntOp = Just (MO_FS_Conv W32 wordWidth) +translateOp dflags Int2FloatOp = Just (MO_SF_Conv (wordWidth dflags) W32) +translateOp dflags Float2IntOp = Just (MO_FS_Conv W32 (wordWidth dflags)) -translateOp Float2DoubleOp = Just (MO_FF_Conv W32 W64) -translateOp Double2FloatOp = Just (MO_FF_Conv W64 W32) +translateOp _ Float2DoubleOp = Just (MO_FF_Conv W32 W64) +translateOp _ Double2FloatOp = Just (MO_FF_Conv W64 W32) -- Word comparisons masquerading as more exotic things. -translateOp SameMutVarOp = Just mo_wordEq -translateOp SameMVarOp = Just mo_wordEq -translateOp SameMutableArrayOp = Just mo_wordEq -translateOp SameMutableByteArrayOp = Just mo_wordEq -translateOp SameMutableArrayArrayOp= Just mo_wordEq -translateOp SameTVarOp = Just mo_wordEq -translateOp EqStablePtrOp = Just mo_wordEq +translateOp dflags SameMutVarOp = Just (mo_wordEq dflags) +translateOp dflags SameMVarOp = Just (mo_wordEq dflags) +translateOp dflags SameMutableArrayOp = Just (mo_wordEq dflags) +translateOp dflags SameMutableByteArrayOp = Just (mo_wordEq dflags) +translateOp dflags SameMutableArrayArrayOp= Just (mo_wordEq dflags) +translateOp dflags SameTVarOp = Just (mo_wordEq dflags) +translateOp dflags EqStablePtrOp = Just (mo_wordEq dflags) -translateOp _ = Nothing +translateOp _ _ = Nothing -- These primops are implemented by CallishMachOps, because they sometimes -- turn into foreign calls depending on the backend. @@ -846,7 +846,7 @@ doWritePtrArrayOp addr idx val cmmOffsetExpr dflags (cmmOffsetExprW dflags (cmmOffsetB dflags addr (arrPtrsHdrSize dflags)) (loadArrPtrsSize dflags addr)) - (card idx) + (card dflags idx) ) (CmmLit (CmmInt 1 W8)) loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr @@ -900,7 +900,8 @@ doCopyByteArrayOp = emitCopyByteArray copy -- Copy data (we assume the arrays aren't overlapping since -- they're of different types) copy _src _dst dst_p src_p bytes live = - emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit 1)) live + do dflags <- getDynFlags + emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit dflags 1)) live -- | Takes a source 'MutableByteArray#', an offset in the source -- array, a destination 'MutableByteArray#', an offset into the @@ -915,9 +916,10 @@ doCopyMutableByteArrayOp = emitCopyByteArray copy -- we were provided are the same array! -- TODO: Optimize branch for common case of no aliasing. copy src dst dst_p src_p bytes live = - emitIfThenElse (cmmEqWord src dst) - (emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit 1)) live) - (emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit 1)) live) + do dflags <- getDynFlags + emitIfThenElse (cmmEqWord dflags src dst) + (emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit dflags 1)) live) + (emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit dflags 1)) live) emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code) @@ -941,7 +943,7 @@ doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr doSetByteArrayOp ba off len c live = do dflags <- getDynFlags p <- assignTemp $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off - emitMemsetCall p c len (CmmLit (mkIntCLit 1)) live + emitMemsetCall p c len (CmmLit (mkIntCLit dflags 1)) live -- ---------------------------------------------------------------------------- -- Copying pointer arrays @@ -964,7 +966,8 @@ doCopyArrayOp = emitCopyArray copy -- Copy data (we assume the arrays aren't overlapping since -- they're of different types) copy _src _dst dst_p src_p bytes live = - emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)) live + do dflags <- getDynFlags + emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit dflags wORD_SIZE)) live -- | Takes a source 'MutableArray#', an offset in the source array, a -- destination 'MutableArray#', an offset into the destination array, @@ -978,9 +981,10 @@ doCopyMutableArrayOp = emitCopyArray copy -- we were provided are the same array! -- TODO: Optimize branch for common case of no aliasing. copy src dst dst_p src_p bytes live = - emitIfThenElse (cmmEqWord src dst) - (emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)) live) - (emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)) live) + do dflags <- getDynFlags + emitIfThenElse (cmmEqWord dflags src dst) + (emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit dflags wORD_SIZE)) live) + (emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit dflags wORD_SIZE)) live) emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code) @@ -1003,7 +1007,7 @@ emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 live = do 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)) + bytes <- assignTemp $ cmmMulWord dflags n (CmmLit (mkIntCLit dflags wORD_SIZE)) copy src dst dst_p src_p bytes live @@ -1020,20 +1024,24 @@ emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code emitCloneArray info_p res_r src0 src_off0 n0 live = do dflags <- getDynFlags + let arrPtrsHdrSizeW dflags = CmmLit $ mkIntCLit dflags $ fixedHdrSize dflags + + (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE) + myCapability = cmmSubWord dflags (CmmReg baseReg) + (CmmLit (mkIntCLit dflags oFFSET_Capability_r)) -- Assign the arguments to temporaries so the code generator can -- calculate liveness for us. src <- assignTemp_ src0 src_off <- assignTemp_ src_off0 n <- assignTemp_ n0 - card_bytes <- assignTemp $ cardRoundUp n - size <- assignTemp $ n `cmmAddWord` bytesToWordsRoundUp card_bytes - words <- assignTemp $ arrPtrsHdrSizeW dflags `cmmAddWord` size + card_bytes <- assignTemp $ cardRoundUp dflags n + size <- assignTemp $ cmmAddWord dflags n (bytesToWordsRoundUp dflags card_bytes) + words <- assignTemp $ cmmAddWord dflags (arrPtrsHdrSizeW dflags) size arr_r <- newTemp (bWord dflags) emitAllocateCall arr_r myCapability words live - tickyAllocPrim (CmmLit (mkIntCLit (arrPtrsHdrSize dflags))) (n `cmmMulWord` wordSize) - (CmmLit $ mkIntCLit 0) + tickyAllocPrim (CmmLit (mkIntCLit dflags (arrPtrsHdrSize dflags))) (cmmMulWord dflags n (wordSize dflags)) + (CmmLit $ mkIntCLit dflags 0) let arr = CmmReg (CmmLocal arr_r) emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCS @@ -1046,47 +1054,45 @@ emitCloneArray info_p res_r src0 src_off0 n0 live = do src_p <- assignTemp $ cmmOffsetExprW dflags (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off - emitMemcpyCall dst_p src_p (n `cmmMulWord` wordSize) - (CmmLit (mkIntCLit wORD_SIZE)) live + emitMemcpyCall dst_p src_p (cmmMulWord dflags n (wordSize dflags)) + (CmmLit (mkIntCLit dflags wORD_SIZE)) live emitMemsetCall (cmmOffsetExprW dflags dst_p n) - (CmmLit (mkIntCLit 1)) + (CmmLit (mkIntCLit dflags 1)) card_bytes - (CmmLit (mkIntCLit wORD_SIZE)) + (CmmLit (mkIntCLit dflags wORD_SIZE)) live stmtC $ CmmAssign (CmmLocal res_r) arr - where - arrPtrsHdrSizeW dflags = CmmLit $ mkIntCLit $ fixedHdrSize dflags + - (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE) - myCapability = CmmReg baseReg `cmmSubWord` - CmmLit (mkIntCLit oFFSET_Capability_r) -- | Takes and offset in the destination array, the base address of -- the card table, and the number of elements affected (*not* the -- number of cards). Marks the relevant cards as dirty. emitSetCards :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code emitSetCards dst_start dst_cards_start n live = do - start_card <- assignTemp $ card dst_start - emitMemsetCall (dst_cards_start `cmmAddWord` start_card) - (CmmLit (mkIntCLit 1)) - (cardRoundUp n) - (CmmLit (mkIntCLit 1)) -- no alignment (1 byte) + dflags <- getDynFlags + start_card <- assignTemp $ card dflags dst_start + emitMemsetCall (cmmAddWord dflags dst_cards_start start_card) + (CmmLit (mkIntCLit dflags 1)) + (cardRoundUp dflags n) + (CmmLit (mkIntCLit dflags 1)) -- no alignment (1 byte) live -- Convert an element index to a card index -card :: CmmExpr -> CmmExpr -card i = i `cmmUShrWord` (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)) +card :: DynFlags -> CmmExpr -> CmmExpr +card dflags i = cmmUShrWord dflags i (CmmLit (mkIntCLit dflags mUT_ARR_PTRS_CARD_BITS)) -- Convert a number of elements to a number of cards, rounding up -cardRoundUp :: CmmExpr -> CmmExpr -cardRoundUp i = card (i `cmmAddWord` (CmmLit (mkIntCLit ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS) - 1)))) +cardRoundUp :: DynFlags -> CmmExpr -> CmmExpr +cardRoundUp dflags i = card dflags (cmmAddWord dflags i (CmmLit (mkIntCLit dflags ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS) - 1)))) -bytesToWordsRoundUp :: CmmExpr -> CmmExpr -bytesToWordsRoundUp e = (e `cmmAddWord` CmmLit (mkIntCLit (wORD_SIZE - 1))) - `cmmQuotWord` wordSize +bytesToWordsRoundUp :: DynFlags -> CmmExpr -> CmmExpr +bytesToWordsRoundUp dflags e + = cmmQuotWord dflags + (cmmAddWord dflags e (CmmLit (mkIntCLit dflags (wORD_SIZE - 1)))) + (wordSize dflags) -wordSize :: CmmExpr -wordSize = CmmLit (mkIntCLit wORD_SIZE) +wordSize :: DynFlags -> CmmExpr +wordSize dflags = CmmLit (mkIntCLit dflags wORD_SIZE) -- | Emit a call to @memcpy@. emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs index 975787e492..87c13ee3f8 100644 --- a/compiler/codeGen/CgProf.hs +++ b/compiler/codeGen/CgProf.hs @@ -80,11 +80,11 @@ staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit] -- The profiling header words in a static closure -- Was SET_STATIC_PROF_HDR staticProfHdr dflags ccs = ifProfilingL dflags [mkCCostCentreStack ccs, - staticLdvInit] + staticLdvInit dflags] dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr] -- Profiling header words in a dynamic closure -dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit] +dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags] initUpdFrameProf :: CmmExpr -> Code -- Initialise the profiling field of an update frame @@ -104,7 +104,7 @@ profDynAlloc :: ClosureInfo -> CmmExpr -> Code profDynAlloc cl_info ccs = ifProfiling $ do dflags <- getDynFlags - profAlloc (mkIntExpr (closureSize dflags cl_info)) ccs + profAlloc (mkIntExpr dflags (closureSize dflags cl_info)) ccs -- | Record the allocation of a closure (size is given by a CmmExpr) -- The size must be in words, because the allocation counter in a CCS counts @@ -118,9 +118,9 @@ profAlloc words ccs do dflags <- getDynFlags stmtC (addToMemE alloc_rep (cmmOffsetB dflags ccs oFFSET_CostCentreStack_mem_alloc) - (CmmMachOp (MO_UU_Conv wordWidth alloc_rep) $ - [CmmMachOp mo_wordSub [words, - mkIntExpr (profHdrSize dflags)]])) + (CmmMachOp (MO_UU_Conv (wordWidth dflags) alloc_rep) $ + [CmmMachOp (mo_wordSub dflags) [words, + mkIntExpr dflags (profHdrSize dflags)]])) -- subtract the "profiling overhead", which is the -- profiling header in a closure. where @@ -175,20 +175,19 @@ emitCostCentreDecl cc = do showPpr dflags (costCentreSrcSpan cc) -- XXX going via FastString to get UTF-8 encoding is silly ; let - lits = [ zero, -- StgInt ccID, + is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF + | otherwise = zero dflags + lits = [ zero dflags, -- StgInt ccID, label, -- char *label, modl, -- char *module, loc, -- char *srcloc, zero64, -- StgWord64 mem_alloc - zero, -- StgWord time_ticks + zero dflags, -- StgWord time_ticks is_caf, -- StgInt is_caf - zero -- struct _CostCentre *link + zero dflags -- struct _CostCentre *link ] ; emitDataLits (mkCCLabel cc) lits } - where - is_caf | isCafCC cc = mkIntCLit (ord 'c') -- 'c' == is a CAF - | otherwise = zero emitCostCentreStackDecl @@ -196,20 +195,21 @@ emitCostCentreStackDecl -> Code emitCostCentreStackDecl ccs | Just cc <- maybeSingletonCCS ccs = do - { let + { dflags <- getDynFlags + ; let -- Note: to avoid making any assumptions about how the -- C compiler (that compiles the RTS, in particular) does -- layouts of structs containing long-longs, simply -- pad out the struct with zero words until we hit the -- size of the overall struct (which we get via DerivedConstants.h) -- - lits = zero : mkCCostCentre cc : replicate (sizeof_ccs_words - 2) zero + lits = zero dflags : mkCCostCentre cc : replicate (sizeof_ccs_words - 2) (zero dflags) ; emitDataLits (mkCCSLabel ccs) lits } | otherwise = pprPanic "emitCostCentreStackDecl" (ppr ccs) -zero :: CmmLit -zero = mkIntCLit 0 +zero :: DynFlags -> CmmLit +zero dflags = mkIntCLit dflags 0 zero64 :: CmmLit zero64 = CmmInt 0 W64 @@ -255,17 +255,17 @@ bumpSccCount dflags ccs -- -- Initial value for the LDV field in a static closure -- -staticLdvInit :: CmmLit +staticLdvInit :: DynFlags -> CmmLit staticLdvInit = zeroCLit -- -- Initial value of the LDV field in a dynamic closure -- -dynLdvInit :: CmmExpr -dynLdvInit = -- (era << LDV_SHIFT) | LDV_STATE_CREATE - CmmMachOp mo_wordOr [ - CmmMachOp mo_wordShl [loadEra, mkIntExpr lDV_SHIFT ], - CmmLit (mkWordCLit lDV_STATE_CREATE) +dynLdvInit :: DynFlags -> CmmExpr +dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE + CmmMachOp (mo_wordOr dflags) [ + CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags lDV_SHIFT ], + CmmLit (mkWordCLit dflags lDV_STATE_CREATE) ] -- @@ -273,7 +273,7 @@ dynLdvInit = -- (era << LDV_SHIFT) | LDV_STATE_CREATE -- ldvRecordCreate :: CmmExpr -> Code ldvRecordCreate closure = do dflags <- getDynFlags - stmtC $ CmmStore (ldvWord dflags closure) dynLdvInit + stmtC $ CmmStore (ldvWord dflags closure) (dynLdvInit dflags) -- -- Called when a closure is entered, marks the closure as having been "used". @@ -295,19 +295,19 @@ ldvEnter cl_ptr = do 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))) + new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags)) + (CmmLit (mkWordCLit dflags lDV_CREATE_MASK))) + (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags lDV_STATE_USE))) ifProfiling $ -- if (era > 0) { -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) | -- era | LDV_STATE_USE } - emitIf (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit]) + emitIf (CmmMachOp (mo_wordUGt dflags) [loadEra dflags, CmmLit (zeroCLit dflags)]) (stmtC (CmmStore ldv_wd new_ldv_wd)) -loadEra :: CmmExpr -loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth) - [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId $ fsLit("era"))) cInt] +loadEra :: DynFlags -> CmmExpr +loadEra dflags = CmmMachOp (MO_UU_Conv cIntWidth (wordWidth dflags)) + [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId $ fsLit("era"))) cInt] ldvWord :: DynFlags -> CmmExpr -> CmmExpr -- Takes the address of a closure, and returns diff --git a/compiler/codeGen/CgTailCall.lhs b/compiler/codeGen/CgTailCall.lhs index b82e3080f3..5f5ff90e54 100644 --- a/compiler/codeGen/CgTailCall.lhs +++ b/compiler/codeGen/CgTailCall.lhs @@ -193,7 +193,7 @@ performTailCall fun_info arg_amodes pending_assts fun_name = idName fun_id lf_info = cgIdInfoLF fun_info fun_has_cafs = idCafInfo fun_id - untag_node = CmmAssign nodeReg (cmmUntag (CmmReg nodeReg)) + untag_node dflags = CmmAssign nodeReg (cmmUntag dflags (CmmReg nodeReg)) -- Test if closure is a constructor maybeSwitchOnCons dflags enterClosure eob | EndOfBlockInfo _ (CaseAlts lbl _ _) <- eob, @@ -203,7 +203,7 @@ performTailCall fun_info arg_amodes pending_assts = do { is_constr <- newLabelC -- Is the pointer tagged? -- Yes, jump to switch statement - ; stmtC (CmmCondBranch (cmmIsTagged (CmmReg nodeReg)) + ; stmtC (CmmCondBranch (cmmIsTagged dflags (CmmReg nodeReg)) is_constr) -- No, enter the closure. ; enterClosure @@ -232,7 +232,7 @@ performTailCall fun_info arg_amodes pending_assts -} -- No case expression involved, enter the closure. | otherwise - = do { stmtC untag_node + = do { stmtC $ untag_node dflags ; enterClosure } where diff --git a/compiler/codeGen/CgTicky.hs b/compiler/codeGen/CgTicky.hs index bc9a94c8bd..85b07a070c 100644 --- a/compiler/codeGen/CgTicky.hs +++ b/compiler/codeGen/CgTicky.hs @@ -98,14 +98,14 @@ emitTickyCounter cl_info args on_stk -- krc: note that all the fields are I32 now; some were I16 before, -- but the code generator wasn't handling that properly and it led to chaos, -- panic and disorder. - [ mkIntCLit 0, - mkIntCLit (length args),-- Arity - mkIntCLit on_stk, -- Words passed on stack + [ mkIntCLit dflags 0, + mkIntCLit dflags (length args),-- Arity + mkIntCLit dflags on_stk, -- Words passed on stack fun_descr_lit, arg_descr_lit, - zeroCLit, -- Entry count - zeroCLit, -- Allocs - zeroCLit -- Link + zeroCLit dflags, -- Entry count + zeroCLit dflags, -- Allocs + zeroCLit dflags -- Link ] } where name = closureName cl_info @@ -179,17 +179,17 @@ registerTickyCtr :: CLabel -> Code 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) + test = CmmMachOp (MO_Eq (wordWidth dflags)) [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl oFFSET_StgEntCounter_registeredp)) (bWord dflags), - CmmLit (mkIntCLit 0)] + CmmLit (mkIntCLit dflags 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)) ] + (CmmLit (mkIntCLit dflags 1)) ] ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs")) emitIf test (stmtsC register_stmts) diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index ca03dfa484..2ed464b766 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -93,33 +93,34 @@ addIdReps ids = [(idCgRep id, id) | id <- ids] cgLit :: Literal -> FCode CmmLit cgLit (MachStr s) = newByteStringCLit (bytesFB s) -cgLit other_lit = return (mkSimpleLit other_lit) - -mkSimpleLit :: Literal -> CmmLit -mkSimpleLit (MachChar c) = CmmInt (fromIntegral (ord c)) wordWidth -mkSimpleLit MachNullAddr = zeroCLit -mkSimpleLit (MachInt i) = CmmInt i wordWidth -mkSimpleLit (MachInt64 i) = CmmInt i W64 -mkSimpleLit (MachWord i) = CmmInt i wordWidth -mkSimpleLit (MachWord64 i) = CmmInt i W64 -mkSimpleLit (MachFloat r) = CmmFloat r W32 -mkSimpleLit (MachDouble r) = CmmFloat r W64 -mkSimpleLit (MachLabel fs ms fod) +cgLit other_lit = do dflags <- getDynFlags + return (mkSimpleLit dflags other_lit) + +mkSimpleLit :: DynFlags -> Literal -> CmmLit +mkSimpleLit dflags (MachChar c) = CmmInt (fromIntegral (ord c)) (wordWidth dflags) +mkSimpleLit dflags MachNullAddr = zeroCLit dflags +mkSimpleLit dflags (MachInt i) = CmmInt i (wordWidth dflags) +mkSimpleLit _ (MachInt64 i) = CmmInt i W64 +mkSimpleLit dflags (MachWord i) = CmmInt i (wordWidth dflags) +mkSimpleLit _ (MachWord64 i) = CmmInt i W64 +mkSimpleLit _ (MachFloat r) = CmmFloat r W32 +mkSimpleLit _ (MachDouble r) = CmmFloat r W64 +mkSimpleLit _ (MachLabel fs ms fod) = CmmLabel (mkForeignLabel fs ms labelSrc fod) where -- TODO: Literal labels might not actually be in the current package... labelSrc = ForeignLabelInThisPackage -mkSimpleLit (MachStr _) = panic "mkSimpleLit: MachStr" +mkSimpleLit _ (MachStr _) = panic "mkSimpleLit: MachStr" -- No LitInteger's should be left by the time this is called. CorePrep -- should have converted them all to a real core representation. -mkSimpleLit (LitInteger {}) = panic "mkSimpleLit: LitInteger" +mkSimpleLit _ (LitInteger {}) = panic "mkSimpleLit: LitInteger" mkLtOp :: DynFlags -> Literal -> MachOp -- On signed literals we must do a signed comparison -mkLtOp _ (MachInt _) = MO_S_Lt wordWidth +mkLtOp dflags (MachInt _) = MO_S_Lt (wordWidth dflags) mkLtOp _ (MachFloat _) = MO_F_Lt W32 mkLtOp _ (MachDouble _) = MO_F_Lt W64 -mkLtOp dflags lit = MO_U_Lt (typeWidth (cmmLitType dflags (mkSimpleLit lit))) +mkLtOp dflags lit = MO_U_Lt (typeWidth (cmmLitType dflags (mkSimpleLit dflags lit))) --------------------------------------------------- @@ -478,12 +479,13 @@ mk_switch _tag_expr [(_tag,stmts)] Nothing _lo_tag _hi_tag _via_C -- can't happen, so no need to test -- SINGLETON BRANCH: one equality check to do -mk_switch tag_expr [(tag,stmts)] (Just deflt) _lo_tag _hi_tag _via_C - = return (CmmCondBranch cond deflt `consCgStmt` stmts) - where - cond = cmmNeWord tag_expr (CmmLit (mkIntCLit tag)) +mk_switch tag_expr [(tag,stmts)] (Just deflt) _lo_tag _hi_tag _via_C = do + dflags <- getDynFlags + let + cond = cmmNeWord dflags tag_expr (CmmLit (mkIntCLit dflags tag)) -- We have lo_tag < hi_tag, but there's only one branch, -- so there must be a default + return (CmmCondBranch cond deflt `consCgStmt` stmts) -- ToDo: we might want to check for the two branch case, where one of -- the branches is the tag 0, because comparing '== 0' is likely to be @@ -521,8 +523,9 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C -- if we can knock off a bunch of default cases with one if, then do so | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches - = do { (assign_tag, tag_expr') <- assignTemp' tag_expr - ; let cond = cmmULtWord tag_expr' (CmmLit (mkIntCLit lowest_branch)) + = do { dflags <- getDynFlags + ; (assign_tag, tag_expr') <- assignTemp' tag_expr + ; let cond = cmmULtWord dflags tag_expr' (CmmLit (mkIntCLit dflags lowest_branch)) branch = CmmCondBranch cond deflt ; stmts <- mk_switch tag_expr' branches mb_deflt lowest_branch hi_tag via_C @@ -530,8 +533,9 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C } | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches - = do { (assign_tag, tag_expr') <- assignTemp' tag_expr - ; let cond = cmmUGtWord tag_expr' (CmmLit (mkIntCLit highest_branch)) + = do { dflags <- getDynFlags + ; (assign_tag, tag_expr') <- assignTemp' tag_expr + ; let cond = cmmUGtWord dflags tag_expr' (CmmLit (mkIntCLit dflags highest_branch)) branch = CmmCondBranch cond deflt ; stmts <- mk_switch tag_expr' branches mb_deflt lo_tag highest_branch via_C @@ -539,14 +543,15 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C } | otherwise -- Use an if-tree - = do { (assign_tag, tag_expr') <- assignTemp' tag_expr + = do { dflags <- getDynFlags + ; (assign_tag, tag_expr') <- assignTemp' tag_expr -- To avoid duplication ; lo_stmts <- mk_switch tag_expr' lo_branches mb_deflt lo_tag (mid_tag-1) via_C ; hi_stmts <- mk_switch tag_expr' hi_branches mb_deflt mid_tag hi_tag via_C ; hi_id <- forkCgStmts hi_stmts - ; let cond = cmmUGeWord tag_expr' (CmmLit (mkIntCLit mid_tag)) + ; let cond = cmmUGeWord dflags tag_expr' (CmmLit (mkIntCLit dflags mid_tag)) branch_stmt = CmmCondBranch cond hi_id ; return (assign_tag `consCgStmt` (branch_stmt `consCgStmt` lo_stmts)) } @@ -632,7 +637,7 @@ mk_lit_switch :: CmmExpr -> BlockId -> FCode CgStmts mk_lit_switch scrut deflt_blk_id [(lit,blk)] = do dflags <- getDynFlags - let cmm_lit = mkSimpleLit lit + let cmm_lit = mkSimpleLit dflags lit rep = cmmLitType dflags cmm_lit ne = if isFloatType rep then MO_F_Ne else MO_Ne cond = CmmMachOp (ne (typeWidth rep)) [scrut, CmmLit cmm_lit] @@ -655,7 +660,7 @@ mk_lit_switch scrut deflt_blk_id branches is_lo (t,_) = t < mid_lit cond dflags = CmmMachOp (mkLtOp dflags mid_lit) - [scrut, CmmLit (mkSimpleLit mid_lit)] + [scrut, CmmLit (mkSimpleLit dflags mid_lit)] ------------------------------------------------------------------------- -- @@ -782,6 +787,7 @@ possiblySameLoc _ _ _ _ = True -- Conservative getSRTInfo :: FCode C_SRT getSRTInfo = do + dflags <- getDynFlags srt_lbl <- getSRTLabel srt <- getSRT case srt of @@ -795,8 +801,8 @@ getSRTInfo = do let srt_desc_lbl = mkLargeSRTLabel id emitRODataLits "getSRTInfo" srt_desc_lbl ( cmmLabelOffW srt_lbl off - : mkWordCLit (fromIntegral len) - : map mkWordCLit bmp) + : mkWordCLit dflags (fromIntegral len) + : map (mkWordCLit dflags) bmp) return (C_SRT srt_desc_lbl 0 srt_escape) | otherwise @@ -914,10 +920,10 @@ fixStgRegExpr dflags expr -- expand it and defer to the above code. case reg `elem` activeStgRegs platform of True -> expr - False -> fixStgRegExpr dflags (CmmMachOp (MO_Add wordWidth) [ + False -> fixStgRegExpr dflags (CmmMachOp (MO_Add (wordWidth dflags)) [ CmmReg (CmmGlobal reg), CmmLit (CmmInt (fromIntegral offset) - wordWidth)]) + (wordWidth dflags))]) -- CmmLit, CmmReg (CmmLocal), CmmStackSlot _other -> expr diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index b3a3fc8de8..e3383bb97b 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -458,9 +458,9 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details node' = if node_points then Just node else Nothing ; tickyEnterFun cl_info ; enterCostCentreFun cc - (CmmMachOp mo_wordSub + (CmmMachOp (mo_wordSub dflags) [ CmmReg nodeReg - , mkIntExpr (funTag cl_info) ]) + , mkIntExpr dflags (funTag cl_info) ]) ; whenC node_points (ldvEnterClosure cl_info) ; granYield arg_regs node_points @@ -508,7 +508,7 @@ mkSlowEntryCode cl_info arg_regs -- function closure is already in `Node' jump = mkDirectJump dflags (mkLblExpr fast_lbl) (map (CmmReg . CmmLocal) arg_regs) - initUpdFrameOff + (initUpdFrameOff dflags) emitProcWithConvention Slow Nothing slow_lbl arg_regs jump | otherwise = return () @@ -716,7 +716,7 @@ link_caf node _is_upd = do -- see Note [atomic CAF entry] in rts/sm/Storage.c ; updfr <- getUpdFrameOff ; emit =<< mkCmmIfThen - (CmmMachOp mo_wordEq [ CmmReg (CmmLocal ret), CmmLit zeroCLit]) + (CmmMachOp (mo_wordEq dflags) [ CmmReg (CmmLocal ret), CmmLit (zeroCLit dflags)]) -- re-enter R1. Doing this directly is slightly dodgy; we're -- assuming lots of things, like the stack pointer hasn't -- moved since we entered the CAF. diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index a87bef110c..ccd7d96231 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -515,7 +515,7 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts ; if isSmallFamily fam_sz then do let -- Yes, bndr_reg has constr. tag in ls bits - tag_expr = cmmConstrTag1 (CmmReg bndr_reg) + tag_expr = cmmConstrTag1 dflags (CmmReg bndr_reg) branches' = [(tag+1,branch) | (tag,branch) <- branches] emitSwitch tag_expr branches' mb_deflt 1 fam_sz return AssignedDirectly @@ -688,7 +688,7 @@ emitEnter fun = do Return _ -> do { let entry = entryCode dflags $ closureInfoPtr dflags $ CmmReg nodeReg ; emit $ mkForeignJump dflags NativeNodeCall entry - [cmmUntag fun] updfr_off + [cmmUntag dflags fun] updfr_off ; return AssignedDirectly } @@ -732,7 +732,7 @@ emitEnter fun = do the_call = toCall entry (Just lret) updfr_off off outArgs regs ; emit $ copyout <*> - mkCbranch (cmmIsTagged (CmmReg nodeReg)) lret lcall <*> + mkCbranch (cmmIsTagged dflags (CmmReg nodeReg)) lret lcall <*> outOfLine lcall the_call <*> mkLabel lret <*> copyin diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index 0a6b6b9e5a..d6a9b92bfd 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -222,7 +222,7 @@ emitForeignCall safety results target args _ret let (off, copyout) = copyInOflow dflags NativeReturn (Young k) results -- see Note [safe foreign call convention] emit $ - ( mkStore (CmmStackSlot (Young k) (widthInBytes wordWidth)) + ( mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth dflags))) (CmmLit (CmmBlock k)) <*> mkLast (CmmForeignCall { tgt = temp_target , res = results @@ -337,10 +337,10 @@ openNursery dflags = catAGraphs [ (cmmOffsetExpr dflags (CmmLoad (nursery_bdescr_start dflags) (bWord dflags)) (cmmOffset dflags - (CmmMachOp mo_wordMul [ - CmmMachOp (MO_SS_Conv W32 wordWidth) + (CmmMachOp (mo_wordMul dflags) [ + CmmMachOp (MO_SS_Conv W32 (wordWidth dflags)) [CmmLoad (nursery_bdescr_blocks dflags) b32], - mkIntExpr bLOCK_SIZE + mkIntExpr dflags bLOCK_SIZE ]) (-1) ) diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index 27d4244e35..a19810b6fb 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -181,7 +181,7 @@ mkStaticClosureFields dflags info_tbl ccs caf_refs payload padding | not is_caf = [] - | otherwise = ASSERT(null payload) [mkIntCLit 0] + | otherwise = ASSERT(null payload) [mkIntCLit dflags 0] static_link_field | is_caf || staticClosureNeedsLink (mayHaveCafRefs caf_refs) info_tbl @@ -190,15 +190,15 @@ mkStaticClosureFields dflags info_tbl ccs caf_refs payload = [] saved_info_field - | is_caf = [mkIntCLit 0] + | is_caf = [mkIntCLit dflags 0] | otherwise = [] -- For a static constructor which has NoCafRefs, we set the -- static link field to a non-zero value so the garbage -- collector will ignore it. static_link_value - | mayHaveCafRefs caf_refs = mkIntCLit 0 - | otherwise = mkIntCLit 1 -- No CAF refs + | mayHaveCafRefs caf_refs = mkIntCLit dflags 0 + | otherwise = mkIntCLit dflags 1 -- No CAF refs mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit] @@ -401,9 +401,9 @@ entryHeapCheck cl_info nodeSet arity args code W32 -> Just (sLit "stg_gc_f1") W64 -> Just (sLit "stg_gc_d1") _other -> Nothing - | width == wordWidth = Just (mkGcLabel "stg_gc_unbx_r1") - | width == W64 = Just (mkGcLabel "stg_gc_l1") - | otherwise = Nothing + | width == wordWidth dflags = Just (mkGcLabel "stg_gc_unbx_r1") + | width == W64 = Just (mkGcLabel "stg_gc_l1") + | otherwise = Nothing where ty = localRegType reg width = typeWidth ty @@ -437,11 +437,11 @@ entryHeapCheck cl_info nodeSet arity args code -- else we do a normal call to stg_gc_noregs altHeapCheck :: [LocalReg] -> FCode a -> FCode a -altHeapCheck regs code - = case cannedGCEntryPoint regs of +altHeapCheck regs code = do + dflags <- getDynFlags + case cannedGCEntryPoint dflags regs of Nothing -> genericGC code Just gc -> do - dflags <- getDynFlags lret <- newLabelC let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) regs lcont <- newLabelC @@ -451,9 +451,10 @@ altHeapCheck regs code altHeapCheckReturnsTo :: [LocalReg] -> Label -> ByteOff -> FCode a -> FCode a altHeapCheckReturnsTo regs lret off code - = case cannedGCEntryPoint regs of - Nothing -> genericGC code - Just gc -> cannedGCReturnsTo True gc regs lret off code + = do dflags <- getDynFlags + case cannedGCEntryPoint dflags regs of + Nothing -> genericGC code + Just gc -> cannedGCReturnsTo True gc regs lret off code cannedGCReturnsTo :: Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff -> FCode a @@ -478,8 +479,8 @@ genericGC code call <- mkCall generic_gc (GC, GC) [] [] updfr_sz (0,[]) heapCheck False (call <*> mkBranch lretry) code -cannedGCEntryPoint :: [LocalReg] -> Maybe CmmExpr -cannedGCEntryPoint regs +cannedGCEntryPoint :: DynFlags -> [LocalReg] -> Maybe CmmExpr +cannedGCEntryPoint dflags regs = case regs of [] -> Just (mkGcLabel "stg_gc_noregs") [reg] @@ -489,9 +490,9 @@ cannedGCEntryPoint regs W64 -> Just (mkGcLabel "stg_gc_d1") _ -> Nothing - | width == wordWidth -> Just (mkGcLabel "stg_gc_unbx_r1") - | width == W64 -> Just (mkGcLabel "stg_gc_l1") - | otherwise -> Nothing + | width == wordWidth dflags -> Just (mkGcLabel "stg_gc_unbx_r1") + | width == W64 -> Just (mkGcLabel "stg_gc_l1") + | otherwise -> Nothing where ty = localRegType reg width = typeWidth ty @@ -540,15 +541,31 @@ do_checks :: Bool -- Should we check the stack? -> CmmAGraph -- What to do on failure -> FCode () do_checks checkStack alloc do_gc = do + dflags <- getDynFlags + let + alloc_lit = mkIntExpr dflags (alloc*wORD_SIZE) -- Bytes + bump_hp = cmmOffsetExprB dflags (CmmReg hpReg) alloc_lit + + -- Sp overflow if (Sp - CmmHighStack < SpLim) + sp_oflo = CmmMachOp (mo_wordULt dflags) + [CmmMachOp (MO_Sub (typeWidth (cmmRegType dflags spReg))) + [CmmReg spReg, CmmLit CmmHighStackMark], + CmmReg spLimReg] + + -- Hp overflow if (Hp > HpLim) + -- (Hp has been incremented by now) + -- HpLim points to the LAST WORD of valid allocation space. + hp_oflo = CmmMachOp (mo_wordUGt dflags) + [CmmReg hpReg, CmmReg (CmmGlobal HpLim)] + + alloc_n = mkAssign (CmmGlobal HpAlloc) alloc_lit gc_id <- newLabelC when checkStack $ do - dflags <- getDynFlags - emit =<< mkCmmIfGoto (sp_oflo dflags) gc_id + emit =<< mkCmmIfGoto sp_oflo gc_id when (alloc /= 0) $ do - dflags <- getDynFlags - emitAssign hpReg (bump_hp dflags) + emitAssign hpReg bump_hp emit =<< mkCmmIfThen hp_oflo (alloc_n <*> mkBranch gc_id) emitOutOfLine gc_id $ @@ -560,24 +577,6 @@ do_checks checkStack alloc do_gc = do -- stack check succeeds. Otherwise we might end up -- with slop at the end of the current block, which can -- confuse the LDV profiler. - where - alloc_lit = mkIntExpr (alloc*wORD_SIZE) -- Bytes - bump_hp dflags = cmmOffsetExprB dflags (CmmReg hpReg) alloc_lit - - -- Sp overflow if (Sp - CmmHighStack < SpLim) - sp_oflo dflags - = CmmMachOp mo_wordULt - [CmmMachOp (MO_Sub (typeWidth (cmmRegType dflags spReg))) - [CmmReg spReg, CmmLit CmmHighStackMark], - CmmReg spLimReg] - - -- Hp overflow if (Hp > HpLim) - -- (Hp has been incremented by now) - -- HpLim points to the LAST WORD of valid allocation space. - hp_oflo = CmmMachOp mo_wordUGt - [CmmReg hpReg, CmmReg (CmmGlobal HpLim)] - - alloc_n = mkAssign (CmmGlobal HpAlloc) alloc_lit {- diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index b670b2401e..1469554a8b 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -608,7 +608,7 @@ 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 dflags) wordWidth) [infoTableConstrTag dflags info_table] + = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableConstrTag dflags info_table] where info_table = infoTable dflags (closureInfoPtr dflags closure_ptr) @@ -616,7 +616,7 @@ 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 dflags) wordWidth) [infoTableClosureType dflags info_table] + = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableClosureType dflags info_table] where info_table = infoTable dflags (closureInfoPtr dflags closure_ptr) diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 39bd1feef1..fb290d8e96 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -283,15 +283,15 @@ initCgInfoDown dflags mod = MkCgInfoDown { cgd_dflags = dflags, cgd_mod = mod, cgd_statics = emptyVarEnv, - cgd_updfr_off = initUpdFrameOff, + cgd_updfr_off = initUpdFrameOff dflags, cgd_ticky = mkTopTickyCtrLabel, cgd_sequel = initSequel } initSequel :: Sequel initSequel = Return False -initUpdFrameOff :: UpdFrameOffset -initUpdFrameOff = widthInBytes wordWidth -- space for the RA +initUpdFrameOff :: DynFlags -> UpdFrameOffset +initUpdFrameOff dflags = widthInBytes (wordWidth dflags) -- space for the RA -------------------------------------------------------- @@ -518,11 +518,12 @@ forkClosureBody :: FCode () -> FCode () -- C-- from the fork is incorporated. forkClosureBody body_code - = do { info <- getInfoDown + = do { dflags <- getDynFlags + ; info <- getInfoDown ; us <- newUniqSupply ; state <- getState ; let body_info_down = info { cgd_sequel = initSequel - , cgd_updfr_off = initUpdFrameOff } + , cgd_updfr_off = initUpdFrameOff dflags } fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } ((),fork_state_out) = doFCode body_code body_info_down fork_state_in @@ -534,12 +535,13 @@ forkStatics :: FCode a -> FCode a -- The Abstract~C returned is attached to the current state, but the -- bindings and usage information is otherwise unchanged. forkStatics body_code - = do { info <- getInfoDown + = do { dflags <- getDynFlags + ; info <- getInfoDown ; us <- newUniqSupply ; state <- getState ; let rhs_info_down = info { cgd_statics = cgs_binds state , cgd_sequel = initSequel - , cgd_updfr_off = initUpdFrameOff } + , cgd_updfr_off = initUpdFrameOff dflags } (result, fork_state_out) = doFCode body_code rhs_info_down (initCgState us) ; setState (state `addCodeBlocksFrom` fork_state_out) @@ -680,7 +682,7 @@ emitProcWithConvention conv mb_info lbl args blocks ; us <- newUniqSupply ; let (offset, entry) = mkCallEntry dflags conv args blks = initUs_ us $ lgraphOfAGraph $ entry <*> blocks - ; let sinfo = StackInfo {arg_space = offset, updfr_space = Just initUpdFrameOff} + ; let sinfo = StackInfo {arg_space = offset, updfr_space = Just (initUpdFrameOff dflags)} tinfo = TopInfo {info_tbls = infos, stack_info=sinfo} proc_block = CmmProc tinfo lbl blks diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index e16557e09f..4efb272ee9 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -158,7 +158,7 @@ emitPrimOp :: DynFlags -- First we handle various awkward cases specially. The remaining -- easy cases are then handled by translateOp, defined below. -emitPrimOp _ [res_r,res_c] IntAddCOp [aa,bb] +emitPrimOp dflags [res_r,res_c] IntAddCOp [aa,bb] {- With some bit-twiddling, we can define int{Add,Sub}Czh portably in C, and without needing any comparisons. This may not be the @@ -180,19 +180,19 @@ emitPrimOp _ [res_r,res_c] IntAddCOp [aa,bb] -} = emit $ catAGraphs [ - mkAssign (CmmLocal res_r) (CmmMachOp mo_wordAdd [aa,bb]), + mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]), mkAssign (CmmLocal res_c) $ - CmmMachOp mo_wordUShr [ - CmmMachOp mo_wordAnd [ - CmmMachOp mo_wordNot [CmmMachOp mo_wordXor [aa,bb]], - CmmMachOp mo_wordXor [aa, CmmReg (CmmLocal res_r)] + CmmMachOp (mo_wordUShr dflags) [ + CmmMachOp (mo_wordAnd dflags) [ + CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]], + CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] ], - mkIntExpr (wORD_SIZE_IN_BITS - 1) + mkIntExpr dflags (wORD_SIZE_IN_BITS - 1) ] ] -emitPrimOp _ [res_r,res_c] IntSubCOp [aa,bb] +emitPrimOp dflags [res_r,res_c] IntSubCOp [aa,bb] {- Similarly: #define subIntCzh(r,c,a,b) \ { r = ((I_)(a)) - ((I_)(b)); \ @@ -203,14 +203,14 @@ emitPrimOp _ [res_r,res_c] IntSubCOp [aa,bb] c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1) -} = emit $ catAGraphs [ - mkAssign (CmmLocal res_r) (CmmMachOp mo_wordSub [aa,bb]), + mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]), mkAssign (CmmLocal res_c) $ - CmmMachOp mo_wordUShr [ - CmmMachOp mo_wordAnd [ - CmmMachOp mo_wordXor [aa,bb], - CmmMachOp mo_wordXor [aa, CmmReg (CmmLocal res_r)] + CmmMachOp (mo_wordUShr dflags) [ + CmmMachOp (mo_wordAnd dflags) [ + CmmMachOp (mo_wordXor dflags) [aa,bb], + CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)] ], - mkIntExpr (wORD_SIZE_IN_BITS - 1) + mkIntExpr dflags (wORD_SIZE_IN_BITS - 1) ] ] @@ -241,8 +241,8 @@ emitPrimOp dflags [res] GetCCSOfOp [arg] = emitAssign (CmmLocal res) val where val - | dopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag arg) - | otherwise = CmmLit zeroCLit + | dopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag dflags arg) + | otherwise = CmmLit (zeroCLit dflags) emitPrimOp _ [res] GetCurrentCCSOp [_dummy_arg] = emitAssign (CmmLocal res) curCCS @@ -283,14 +283,14 @@ emitPrimOp dflags [res] StableNameToIntOp [arg] -- #define eqStableNamezh(r,sn1,sn2) \ -- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn)) emitPrimOp dflags [res] EqStableNameOp [arg1,arg2] - = emitAssign (CmmLocal res) (CmmMachOp mo_wordEq [ + = emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [ cmmLoadIndexW dflags arg1 (fixedHdrSize dflags) (bWord dflags), cmmLoadIndexW dflags arg2 (fixedHdrSize dflags) (bWord dflags) ]) -emitPrimOp _ [res] ReallyUnsafePtrEqualityOp [arg1,arg2] - = emitAssign (CmmLocal res) (CmmMachOp mo_wordEq [arg1,arg2]) +emitPrimOp dflags [res] ReallyUnsafePtrEqualityOp [arg1,arg2] + = emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2]) -- #define addrToHValuezh(r,a) r=(P_)a emitPrimOp _ [res] AddrToAnyOp [arg] @@ -299,7 +299,7 @@ emitPrimOp _ [res] AddrToAnyOp [arg] -- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info)) -- Note: argument may be tagged! emitPrimOp dflags [res] DataToTagOp [arg] - = emitAssign (CmmLocal res) (getConstrTag dflags (cmmUntag arg)) + = emitAssign (CmmLocal res) (getConstrTag dflags (cmmUntag dflags arg)) {- Freezing arrays-of-ptrs requires changing an info table, for the benefit of the generational collector. It needs to scavenge mutable @@ -372,116 +372,116 @@ emitPrimOp dflags [res] SizeofMutableArrayArrayOp [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 dflags res IndexOffAddrOp_Char args = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexOffAddrOp_WideChar args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args emitPrimOp dflags res IndexOffAddrOp_Int args = doIndexOffAddrOp Nothing (bWord dflags) res args emitPrimOp dflags res IndexOffAddrOp_Word args = doIndexOffAddrOp Nothing (bWord dflags) res args emitPrimOp dflags res IndexOffAddrOp_Addr args = doIndexOffAddrOp Nothing (bWord dflags) res args emitPrimOp _ res IndexOffAddrOp_Float args = doIndexOffAddrOp Nothing f32 res args emitPrimOp _ res IndexOffAddrOp_Double args = doIndexOffAddrOp Nothing f64 res args emitPrimOp dflags res IndexOffAddrOp_StablePtr args = doIndexOffAddrOp Nothing (bWord dflags) res args -emitPrimOp _ 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 dflags res IndexOffAddrOp_Int8 args = doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexOffAddrOp_Int16 args = doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args +emitPrimOp dflags res IndexOffAddrOp_Int32 args = doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args emitPrimOp _ res IndexOffAddrOp_Int64 args = doIndexOffAddrOp Nothing b64 res args -emitPrimOp _ 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 dflags res IndexOffAddrOp_Word8 args = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexOffAddrOp_Word16 args = doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args +emitPrimOp dflags res IndexOffAddrOp_Word32 args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args emitPrimOp _ res IndexOffAddrOp_Word64 args = doIndexOffAddrOp Nothing b64 res args -- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr. -emitPrimOp _ res ReadOffAddrOp_Char args = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args -emitPrimOp _ res ReadOffAddrOp_WideChar args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args +emitPrimOp dflags res ReadOffAddrOp_Char args = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadOffAddrOp_WideChar args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args emitPrimOp dflags res ReadOffAddrOp_Int args = doIndexOffAddrOp Nothing (bWord dflags) res args emitPrimOp dflags res ReadOffAddrOp_Word args = doIndexOffAddrOp Nothing (bWord dflags) res args emitPrimOp dflags res ReadOffAddrOp_Addr args = doIndexOffAddrOp Nothing (bWord dflags) res args emitPrimOp _ res ReadOffAddrOp_Float args = doIndexOffAddrOp Nothing f32 res args emitPrimOp _ res ReadOffAddrOp_Double args = doIndexOffAddrOp Nothing f64 res args emitPrimOp dflags res ReadOffAddrOp_StablePtr args = doIndexOffAddrOp Nothing (bWord dflags) res args -emitPrimOp _ 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 dflags res ReadOffAddrOp_Int8 args = doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadOffAddrOp_Int16 args = doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args +emitPrimOp dflags res ReadOffAddrOp_Int32 args = doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args emitPrimOp _ res ReadOffAddrOp_Int64 args = doIndexOffAddrOp Nothing b64 res args -emitPrimOp _ 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 dflags res ReadOffAddrOp_Word8 args = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadOffAddrOp_Word16 args = doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args +emitPrimOp dflags res ReadOffAddrOp_Word32 args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args emitPrimOp _ res ReadOffAddrOp_Word64 args = doIndexOffAddrOp Nothing b64 res args -- IndexXXXArray -emitPrimOp _ res IndexByteArrayOp_Char args = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args -emitPrimOp _ res IndexByteArrayOp_WideChar args = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args +emitPrimOp dflags res IndexByteArrayOp_Char args = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexByteArrayOp_WideChar args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args emitPrimOp dflags res IndexByteArrayOp_Int args = doIndexByteArrayOp Nothing (bWord dflags) res args emitPrimOp dflags res IndexByteArrayOp_Word args = doIndexByteArrayOp Nothing (bWord dflags) res args emitPrimOp dflags res IndexByteArrayOp_Addr args = doIndexByteArrayOp Nothing (bWord dflags) res args emitPrimOp _ res IndexByteArrayOp_Float args = doIndexByteArrayOp Nothing f32 res args emitPrimOp _ res IndexByteArrayOp_Double args = doIndexByteArrayOp Nothing f64 res args emitPrimOp dflags res IndexByteArrayOp_StablePtr args = doIndexByteArrayOp Nothing (bWord dflags) res args -emitPrimOp _ 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 dflags res IndexByteArrayOp_Int8 args = doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexByteArrayOp_Int16 args = doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16 res args +emitPrimOp dflags res IndexByteArrayOp_Int32 args = doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32 res args emitPrimOp _ res IndexByteArrayOp_Int64 args = doIndexByteArrayOp Nothing b64 res args -emitPrimOp _ 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 dflags res IndexByteArrayOp_Word8 args = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res IndexByteArrayOp_Word16 args = doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16 res args +emitPrimOp dflags res IndexByteArrayOp_Word32 args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args emitPrimOp _ res IndexByteArrayOp_Word64 args = doIndexByteArrayOp Nothing b64 res args -- ReadXXXArray, identical to IndexXXXArray. -emitPrimOp _ res ReadByteArrayOp_Char args = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args -emitPrimOp _ res ReadByteArrayOp_WideChar args = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args +emitPrimOp dflags res ReadByteArrayOp_Char args = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadByteArrayOp_WideChar args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args emitPrimOp dflags res ReadByteArrayOp_Int args = doIndexByteArrayOp Nothing (bWord dflags) res args emitPrimOp dflags res ReadByteArrayOp_Word args = doIndexByteArrayOp Nothing (bWord dflags) res args emitPrimOp dflags res ReadByteArrayOp_Addr args = doIndexByteArrayOp Nothing (bWord dflags) res args emitPrimOp _ res ReadByteArrayOp_Float args = doIndexByteArrayOp Nothing f32 res args emitPrimOp _ res ReadByteArrayOp_Double args = doIndexByteArrayOp Nothing f64 res args emitPrimOp dflags res ReadByteArrayOp_StablePtr args = doIndexByteArrayOp Nothing (bWord dflags) res args -emitPrimOp _ 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 dflags res ReadByteArrayOp_Int8 args = doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadByteArrayOp_Int16 args = doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16 res args +emitPrimOp dflags res ReadByteArrayOp_Int32 args = doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32 res args emitPrimOp _ res ReadByteArrayOp_Int64 args = doIndexByteArrayOp Nothing b64 res args -emitPrimOp _ 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 dflags res ReadByteArrayOp_Word8 args = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args +emitPrimOp dflags res ReadByteArrayOp_Word16 args = doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16 res args +emitPrimOp dflags res ReadByteArrayOp_Word32 args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args emitPrimOp _ res ReadByteArrayOp_Word64 args = doIndexByteArrayOp Nothing b64 res args -- WriteXXXoffAddr -emitPrimOp _ res WriteOffAddrOp_Char args = doWriteOffAddrOp (Just mo_WordTo8) res args -emitPrimOp _ res WriteOffAddrOp_WideChar args = doWriteOffAddrOp (Just mo_WordTo32) res args +emitPrimOp dflags res WriteOffAddrOp_Char args = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) res args +emitPrimOp dflags res WriteOffAddrOp_WideChar args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) res args emitPrimOp _ res WriteOffAddrOp_Int args = doWriteOffAddrOp Nothing res args emitPrimOp _ res WriteOffAddrOp_Word args = doWriteOffAddrOp Nothing res args emitPrimOp _ res WriteOffAddrOp_Addr args = doWriteOffAddrOp Nothing res args emitPrimOp _ res WriteOffAddrOp_Float args = doWriteOffAddrOp Nothing res args emitPrimOp _ res WriteOffAddrOp_Double args = doWriteOffAddrOp Nothing res args emitPrimOp _ res WriteOffAddrOp_StablePtr args = doWriteOffAddrOp Nothing res args -emitPrimOp _ 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 dflags res WriteOffAddrOp_Int8 args = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) res args +emitPrimOp dflags res WriteOffAddrOp_Int16 args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) res args +emitPrimOp dflags res WriteOffAddrOp_Int32 args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) res args emitPrimOp _ res WriteOffAddrOp_Int64 args = doWriteOffAddrOp Nothing res args -emitPrimOp _ 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 dflags res WriteOffAddrOp_Word8 args = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) res args +emitPrimOp dflags res WriteOffAddrOp_Word16 args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) res args +emitPrimOp dflags res WriteOffAddrOp_Word32 args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) res args emitPrimOp _ res WriteOffAddrOp_Word64 args = doWriteOffAddrOp Nothing res args -- WriteXXXArray -emitPrimOp _ res WriteByteArrayOp_Char args = doWriteByteArrayOp (Just mo_WordTo8) res args -emitPrimOp _ res WriteByteArrayOp_WideChar args = doWriteByteArrayOp (Just mo_WordTo32) res args +emitPrimOp dflags res WriteByteArrayOp_Char args = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) res args +emitPrimOp dflags res WriteByteArrayOp_WideChar args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) res args emitPrimOp _ res WriteByteArrayOp_Int args = doWriteByteArrayOp Nothing res args emitPrimOp _ res WriteByteArrayOp_Word args = doWriteByteArrayOp Nothing res args emitPrimOp _ res WriteByteArrayOp_Addr args = doWriteByteArrayOp Nothing res args emitPrimOp _ res WriteByteArrayOp_Float args = doWriteByteArrayOp Nothing res args emitPrimOp _ res WriteByteArrayOp_Double args = doWriteByteArrayOp Nothing res args emitPrimOp _ res WriteByteArrayOp_StablePtr args = doWriteByteArrayOp Nothing res args -emitPrimOp _ 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 dflags res WriteByteArrayOp_Int8 args = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) res args +emitPrimOp dflags res WriteByteArrayOp_Int16 args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) res args +emitPrimOp dflags res WriteByteArrayOp_Int32 args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) res args emitPrimOp _ res WriteByteArrayOp_Int64 args = doWriteByteArrayOp Nothing res args -emitPrimOp _ 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 dflags res WriteByteArrayOp_Word8 args = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) res args +emitPrimOp dflags res WriteByteArrayOp_Word16 args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) res args +emitPrimOp dflags res WriteByteArrayOp_Word32 args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) res args emitPrimOp _ res WriteByteArrayOp_Word64 args = doWriteByteArrayOp Nothing res args -- Copying and setting byte arrays @@ -493,31 +493,31 @@ emitPrimOp _ [] SetByteArrayOp [ba,off,len,c] = doSetByteArrayOp ba off len c -- Population count -emitPrimOp _ [res] PopCnt8Op [w] = - emitPopCntCall res (CmmMachOp mo_WordTo8 [w]) W8 -emitPrimOp _ [res] PopCnt16Op [w] = - emitPopCntCall res (CmmMachOp mo_WordTo16 [w]) W16 -emitPrimOp _ [res] PopCnt32Op [w] = - emitPopCntCall res (CmmMachOp mo_WordTo32 [w]) W32 +emitPrimOp dflags [res] PopCnt8Op [w] = + emitPopCntCall res (CmmMachOp (mo_WordTo8 dflags) [w]) W8 +emitPrimOp dflags [res] PopCnt16Op [w] = + emitPopCntCall res (CmmMachOp (mo_WordTo16 dflags) [w]) W16 +emitPrimOp dflags [res] PopCnt32Op [w] = + emitPopCntCall res (CmmMachOp (mo_WordTo32 dflags) [w]) W32 emitPrimOp _ [res] PopCnt64Op [w] = emitPopCntCall res w W64 -- arg always has type W64, no need to narrow -emitPrimOp _ [res] PopCntOp [w] = - emitPopCntCall res w wordWidth +emitPrimOp dflags [res] PopCntOp [w] = + emitPopCntCall res w (wordWidth dflags) -- The rest just translate straightforwardly -emitPrimOp _s [res] op [arg] +emitPrimOp dflags [res] op [arg] | nopOp op = emitAssign (CmmLocal res) arg | Just (mop,rep) <- narrowOp op = emitAssign (CmmLocal res) $ - CmmMachOp (mop rep wordWidth) [CmmMachOp (mop wordWidth rep) [arg]] + CmmMachOp (mop rep (wordWidth dflags)) [CmmMachOp (mop (wordWidth dflags) rep) [arg]] -emitPrimOp _ r@[res] op args +emitPrimOp dflags r@[res] op args | Just prim <- callishOp op = do emitPrimCall r prim args - | Just mop <- translateOp op + | Just mop <- translateOp dflags op = let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args) in emit stmt @@ -531,19 +531,19 @@ type GenericOp = [CmmFormal] -> [CmmActual] -> FCode () callishPrimOpSupported :: DynFlags -> PrimOp -> Either CallishMachOp GenericOp callishPrimOpSupported dflags op = case op of - IntQuotRemOp | ncg && x86ish -> Left (MO_S_QuotRem wordWidth) - | otherwise -> Right genericIntQuotRemOp + IntQuotRemOp | ncg && x86ish -> Left (MO_S_QuotRem (wordWidth dflags)) + | otherwise -> Right (genericIntQuotRemOp dflags) - WordQuotRemOp | ncg && x86ish -> Left (MO_U_QuotRem wordWidth) - | otherwise -> Right genericWordQuotRemOp + WordQuotRemOp | ncg && x86ish -> Left (MO_U_QuotRem (wordWidth dflags)) + | otherwise -> Right (genericWordQuotRemOp dflags) - WordQuotRem2Op | ncg && x86ish -> Left (MO_U_QuotRem2 wordWidth) + WordQuotRem2Op | ncg && x86ish -> Left (MO_U_QuotRem2 (wordWidth dflags)) | otherwise -> Right (genericWordQuotRem2Op dflags) - WordAdd2Op | ncg && x86ish -> Left (MO_Add2 wordWidth) + WordAdd2Op | ncg && x86ish -> Left (MO_Add2 (wordWidth dflags)) | otherwise -> Right genericWordAdd2Op - WordMul2Op | ncg && x86ish -> Left (MO_U_Mul2 wordWidth) + WordMul2Op | ncg && x86ish -> Left (MO_U_Mul2 (wordWidth dflags)) | otherwise -> Right genericWordMul2Op _ -> panic "emitPrimOp: can't translate PrimOp" (ppr op) @@ -557,37 +557,37 @@ callishPrimOpSupported dflags op ArchX86_64 -> True _ -> False -genericIntQuotRemOp :: GenericOp -genericIntQuotRemOp [res_q, res_r] [arg_x, arg_y] +genericIntQuotRemOp :: DynFlags -> GenericOp +genericIntQuotRemOp dflags [res_q, res_r] [arg_x, arg_y] = emit $ mkAssign (CmmLocal res_q) - (CmmMachOp (MO_S_Quot wordWidth) [arg_x, arg_y]) <*> + (CmmMachOp (MO_S_Quot (wordWidth dflags)) [arg_x, arg_y]) <*> mkAssign (CmmLocal res_r) - (CmmMachOp (MO_S_Rem wordWidth) [arg_x, arg_y]) -genericIntQuotRemOp _ _ = panic "genericIntQuotRemOp" + (CmmMachOp (MO_S_Rem (wordWidth dflags)) [arg_x, arg_y]) +genericIntQuotRemOp _ _ _ = panic "genericIntQuotRemOp" -genericWordQuotRemOp :: GenericOp -genericWordQuotRemOp [res_q, res_r] [arg_x, arg_y] +genericWordQuotRemOp :: DynFlags -> GenericOp +genericWordQuotRemOp dflags [res_q, res_r] [arg_x, arg_y] = emit $ mkAssign (CmmLocal res_q) - (CmmMachOp (MO_U_Quot wordWidth) [arg_x, arg_y]) <*> + (CmmMachOp (MO_U_Quot (wordWidth dflags)) [arg_x, arg_y]) <*> mkAssign (CmmLocal res_r) - (CmmMachOp (MO_U_Rem wordWidth) [arg_x, arg_y]) -genericWordQuotRemOp _ _ = panic "genericWordQuotRemOp" + (CmmMachOp (MO_U_Rem (wordWidth dflags)) [arg_x, arg_y]) +genericWordQuotRemOp _ _ _ = panic "genericWordQuotRemOp" genericWordQuotRem2Op :: DynFlags -> GenericOp genericWordQuotRem2Op dflags [res_q, res_r] [arg_x_high, arg_x_low, arg_y] - = emit =<< f (widthInBits wordWidth) zero arg_x_high arg_x_low + = emit =<< f (widthInBits (wordWidth dflags)) zero arg_x_high arg_x_low where ty = cmmExprType dflags arg_x_high - shl x i = CmmMachOp (MO_Shl wordWidth) [x, i] - shr x i = CmmMachOp (MO_U_Shr wordWidth) [x, i] - or x y = CmmMachOp (MO_Or wordWidth) [x, y] - ge x y = CmmMachOp (MO_U_Ge wordWidth) [x, y] - ne x y = CmmMachOp (MO_Ne wordWidth) [x, y] - minus x y = CmmMachOp (MO_Sub wordWidth) [x, y] - times x y = CmmMachOp (MO_Mul wordWidth) [x, y] + shl x i = CmmMachOp (MO_Shl (wordWidth dflags)) [x, i] + shr x i = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, i] + or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y] + ge x y = CmmMachOp (MO_U_Ge (wordWidth dflags)) [x, y] + ne x y = CmmMachOp (MO_Ne (wordWidth dflags)) [x, y] + minus x y = CmmMachOp (MO_Sub (wordWidth dflags)) [x, y] + times x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y] zero = lit 0 one = lit 1 - negone = lit (fromIntegral (widthInBits wordWidth) - 1) - lit i = CmmLit (CmmInt i wordWidth) + negone = lit (fromIntegral (widthInBits (wordWidth dflags)) - 1) + lit i = CmmLit (CmmInt i (wordWidth dflags)) f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode CmmAGraph f 0 acc high _ = return (mkAssign (CmmLocal res_q) acc <*> @@ -627,14 +627,14 @@ genericWordAdd2Op [res_h, res_l] [arg_x, arg_y] = do dflags <- getDynFlags 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] + let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww] + toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww] + bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm] + add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y] + or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y] hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags))) - wordWidth) - hwm = CmmLit (CmmInt (halfWordMask dflags) wordWidth) + (wordWidth dflags)) + hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags)) emit $ catAGraphs [mkAssign (CmmLocal r1) (add (bottomHalf arg_x) (bottomHalf arg_y)), @@ -658,16 +658,16 @@ genericWordMul2Op [res_h, res_l] [arg_x, arg_y] r <- liftM CmmLocal $ newTemp t -- This generic implementation is very simple and slow. We might -- well be able to do better, but for now this at least works. - let topHalf x = CmmMachOp (MO_U_Shr wordWidth) [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] + let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww] + toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww] + bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm] + add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y] sum = foldl1 add - mul x y = CmmMachOp (MO_Mul wordWidth) [x, y] - or x y = CmmMachOp (MO_Or wordWidth) [x, y] + mul x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y] + or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y] hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags))) - wordWidth) - hwm = CmmLit (CmmInt (halfWordMask dflags) wordWidth) + (wordWidth dflags)) + hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags)) emit $ catAGraphs [mkAssign xlyl (mul (bottomHalf arg_x) (bottomHalf arg_y)), @@ -713,125 +713,125 @@ narrowOp _ = Nothing -- Native word signless ops -translateOp :: PrimOp -> Maybe MachOp -translateOp IntAddOp = Just mo_wordAdd -translateOp IntSubOp = Just mo_wordSub -translateOp WordAddOp = Just mo_wordAdd -translateOp WordSubOp = Just mo_wordSub -translateOp AddrAddOp = Just mo_wordAdd -translateOp AddrSubOp = Just mo_wordSub - -translateOp IntEqOp = Just mo_wordEq -translateOp IntNeOp = Just mo_wordNe -translateOp WordEqOp = Just mo_wordEq -translateOp WordNeOp = Just mo_wordNe -translateOp AddrEqOp = Just mo_wordEq -translateOp AddrNeOp = Just mo_wordNe - -translateOp AndOp = Just mo_wordAnd -translateOp OrOp = Just mo_wordOr -translateOp XorOp = Just mo_wordXor -translateOp NotOp = Just mo_wordNot -translateOp SllOp = Just mo_wordShl -translateOp SrlOp = Just mo_wordUShr - -translateOp AddrRemOp = Just mo_wordURem +translateOp :: DynFlags -> PrimOp -> Maybe MachOp +translateOp dflags IntAddOp = Just (mo_wordAdd dflags) +translateOp dflags IntSubOp = Just (mo_wordSub dflags) +translateOp dflags WordAddOp = Just (mo_wordAdd dflags) +translateOp dflags WordSubOp = Just (mo_wordSub dflags) +translateOp dflags AddrAddOp = Just (mo_wordAdd dflags) +translateOp dflags AddrSubOp = Just (mo_wordSub dflags) + +translateOp dflags IntEqOp = Just (mo_wordEq dflags) +translateOp dflags IntNeOp = Just (mo_wordNe dflags) +translateOp dflags WordEqOp = Just (mo_wordEq dflags) +translateOp dflags WordNeOp = Just (mo_wordNe dflags) +translateOp dflags AddrEqOp = Just (mo_wordEq dflags) +translateOp dflags AddrNeOp = Just (mo_wordNe dflags) + +translateOp dflags AndOp = Just (mo_wordAnd dflags) +translateOp dflags OrOp = Just (mo_wordOr dflags) +translateOp dflags XorOp = Just (mo_wordXor dflags) +translateOp dflags NotOp = Just (mo_wordNot dflags) +translateOp dflags SllOp = Just (mo_wordShl dflags) +translateOp dflags SrlOp = Just (mo_wordUShr dflags) + +translateOp dflags AddrRemOp = Just (mo_wordURem dflags) -- Native word signed ops -translateOp IntMulOp = Just mo_wordMul -translateOp IntMulMayOfloOp = Just (MO_S_MulMayOflo wordWidth) -translateOp IntQuotOp = Just mo_wordSQuot -translateOp IntRemOp = Just mo_wordSRem -translateOp IntNegOp = Just mo_wordSNeg +translateOp dflags IntMulOp = Just (mo_wordMul dflags) +translateOp dflags IntMulMayOfloOp = Just (MO_S_MulMayOflo (wordWidth dflags)) +translateOp dflags IntQuotOp = Just (mo_wordSQuot dflags) +translateOp dflags IntRemOp = Just (mo_wordSRem dflags) +translateOp dflags IntNegOp = Just (mo_wordSNeg dflags) -translateOp IntGeOp = Just mo_wordSGe -translateOp IntLeOp = Just mo_wordSLe -translateOp IntGtOp = Just mo_wordSGt -translateOp IntLtOp = Just mo_wordSLt +translateOp dflags IntGeOp = Just (mo_wordSGe dflags) +translateOp dflags IntLeOp = Just (mo_wordSLe dflags) +translateOp dflags IntGtOp = Just (mo_wordSGt dflags) +translateOp dflags IntLtOp = Just (mo_wordSLt dflags) -translateOp ISllOp = Just mo_wordShl -translateOp ISraOp = Just mo_wordSShr -translateOp ISrlOp = Just mo_wordUShr +translateOp dflags ISllOp = Just (mo_wordShl dflags) +translateOp dflags ISraOp = Just (mo_wordSShr dflags) +translateOp dflags ISrlOp = Just (mo_wordUShr dflags) -- Native word unsigned ops -translateOp WordGeOp = Just mo_wordUGe -translateOp WordLeOp = Just mo_wordULe -translateOp WordGtOp = Just mo_wordUGt -translateOp WordLtOp = Just mo_wordULt +translateOp dflags WordGeOp = Just (mo_wordUGe dflags) +translateOp dflags WordLeOp = Just (mo_wordULe dflags) +translateOp dflags WordGtOp = Just (mo_wordUGt dflags) +translateOp dflags WordLtOp = Just (mo_wordULt dflags) -translateOp WordMulOp = Just mo_wordMul -translateOp WordQuotOp = Just mo_wordUQuot -translateOp WordRemOp = Just mo_wordURem +translateOp dflags WordMulOp = Just (mo_wordMul dflags) +translateOp dflags WordQuotOp = Just (mo_wordUQuot dflags) +translateOp dflags WordRemOp = Just (mo_wordURem dflags) -translateOp AddrGeOp = Just mo_wordUGe -translateOp AddrLeOp = Just mo_wordULe -translateOp AddrGtOp = Just mo_wordUGt -translateOp AddrLtOp = Just mo_wordULt +translateOp dflags AddrGeOp = Just (mo_wordUGe dflags) +translateOp dflags AddrLeOp = Just (mo_wordULe dflags) +translateOp dflags AddrGtOp = Just (mo_wordUGt dflags) +translateOp dflags AddrLtOp = Just (mo_wordULt dflags) -- Char# ops -translateOp CharEqOp = Just (MO_Eq wordWidth) -translateOp CharNeOp = Just (MO_Ne wordWidth) -translateOp CharGeOp = Just (MO_U_Ge wordWidth) -translateOp CharLeOp = Just (MO_U_Le wordWidth) -translateOp CharGtOp = Just (MO_U_Gt wordWidth) -translateOp CharLtOp = Just (MO_U_Lt wordWidth) +translateOp dflags CharEqOp = Just (MO_Eq (wordWidth dflags)) +translateOp dflags CharNeOp = Just (MO_Ne (wordWidth dflags)) +translateOp dflags CharGeOp = Just (MO_U_Ge (wordWidth dflags)) +translateOp dflags CharLeOp = Just (MO_U_Le (wordWidth dflags)) +translateOp dflags CharGtOp = Just (MO_U_Gt (wordWidth dflags)) +translateOp dflags CharLtOp = Just (MO_U_Lt (wordWidth dflags)) -- Double ops -translateOp DoubleEqOp = Just (MO_F_Eq W64) -translateOp DoubleNeOp = Just (MO_F_Ne W64) -translateOp DoubleGeOp = Just (MO_F_Ge W64) -translateOp DoubleLeOp = Just (MO_F_Le W64) -translateOp DoubleGtOp = Just (MO_F_Gt W64) -translateOp DoubleLtOp = Just (MO_F_Lt W64) +translateOp _ DoubleEqOp = Just (MO_F_Eq W64) +translateOp _ DoubleNeOp = Just (MO_F_Ne W64) +translateOp _ DoubleGeOp = Just (MO_F_Ge W64) +translateOp _ DoubleLeOp = Just (MO_F_Le W64) +translateOp _ DoubleGtOp = Just (MO_F_Gt W64) +translateOp _ DoubleLtOp = Just (MO_F_Lt W64) -translateOp DoubleAddOp = Just (MO_F_Add W64) -translateOp DoubleSubOp = Just (MO_F_Sub W64) -translateOp DoubleMulOp = Just (MO_F_Mul W64) -translateOp DoubleDivOp = Just (MO_F_Quot W64) -translateOp DoubleNegOp = Just (MO_F_Neg W64) +translateOp _ DoubleAddOp = Just (MO_F_Add W64) +translateOp _ DoubleSubOp = Just (MO_F_Sub W64) +translateOp _ DoubleMulOp = Just (MO_F_Mul W64) +translateOp _ DoubleDivOp = Just (MO_F_Quot W64) +translateOp _ DoubleNegOp = Just (MO_F_Neg W64) -- Float ops -translateOp FloatEqOp = Just (MO_F_Eq W32) -translateOp FloatNeOp = Just (MO_F_Ne W32) -translateOp FloatGeOp = Just (MO_F_Ge W32) -translateOp FloatLeOp = Just (MO_F_Le W32) -translateOp FloatGtOp = Just (MO_F_Gt W32) -translateOp FloatLtOp = Just (MO_F_Lt W32) +translateOp _ FloatEqOp = Just (MO_F_Eq W32) +translateOp _ FloatNeOp = Just (MO_F_Ne W32) +translateOp _ FloatGeOp = Just (MO_F_Ge W32) +translateOp _ FloatLeOp = Just (MO_F_Le W32) +translateOp _ FloatGtOp = Just (MO_F_Gt W32) +translateOp _ FloatLtOp = Just (MO_F_Lt W32) -translateOp FloatAddOp = Just (MO_F_Add W32) -translateOp FloatSubOp = Just (MO_F_Sub W32) -translateOp FloatMulOp = Just (MO_F_Mul W32) -translateOp FloatDivOp = Just (MO_F_Quot W32) -translateOp FloatNegOp = Just (MO_F_Neg W32) +translateOp _ FloatAddOp = Just (MO_F_Add W32) +translateOp _ FloatSubOp = Just (MO_F_Sub W32) +translateOp _ FloatMulOp = Just (MO_F_Mul W32) +translateOp _ FloatDivOp = Just (MO_F_Quot W32) +translateOp _ FloatNegOp = Just (MO_F_Neg W32) -- Conversions -translateOp Int2DoubleOp = Just (MO_SF_Conv wordWidth W64) -translateOp Double2IntOp = Just (MO_FS_Conv W64 wordWidth) +translateOp dflags Int2DoubleOp = Just (MO_SF_Conv (wordWidth dflags) W64) +translateOp dflags Double2IntOp = Just (MO_FS_Conv W64 (wordWidth dflags)) -translateOp Int2FloatOp = Just (MO_SF_Conv wordWidth W32) -translateOp Float2IntOp = Just (MO_FS_Conv W32 wordWidth) +translateOp dflags Int2FloatOp = Just (MO_SF_Conv (wordWidth dflags) W32) +translateOp dflags Float2IntOp = Just (MO_FS_Conv W32 (wordWidth dflags)) -translateOp Float2DoubleOp = Just (MO_FF_Conv W32 W64) -translateOp Double2FloatOp = Just (MO_FF_Conv W64 W32) +translateOp _ Float2DoubleOp = Just (MO_FF_Conv W32 W64) +translateOp _ Double2FloatOp = Just (MO_FF_Conv W64 W32) -- Word comparisons masquerading as more exotic things. -translateOp SameMutVarOp = Just mo_wordEq -translateOp SameMVarOp = Just mo_wordEq -translateOp SameMutableArrayOp = Just mo_wordEq -translateOp SameMutableByteArrayOp = Just mo_wordEq -translateOp SameMutableArrayArrayOp= Just mo_wordEq -translateOp SameTVarOp = Just mo_wordEq -translateOp EqStablePtrOp = Just mo_wordEq +translateOp dflags SameMutVarOp = Just (mo_wordEq dflags) +translateOp dflags SameMVarOp = Just (mo_wordEq dflags) +translateOp dflags SameMutableArrayOp = Just (mo_wordEq dflags) +translateOp dflags SameMutableByteArrayOp = Just (mo_wordEq dflags) +translateOp dflags SameMutableArrayArrayOp= Just (mo_wordEq dflags) +translateOp dflags SameTVarOp = Just (mo_wordEq dflags) +translateOp dflags EqStablePtrOp = Just (mo_wordEq dflags) -translateOp _ = Nothing +translateOp _ _ = Nothing -- These primops are implemented by CallishMachOps, because they sometimes -- turn into foreign calls depending on the backend. @@ -913,8 +913,8 @@ doWritePtrArrayOp addr idx val cmmOffsetExpr dflags (cmmOffsetExprW dflags (cmmOffsetB dflags addr (arrPtrsHdrSize dflags)) (loadArrPtrsSize dflags addr)) - (CmmMachOp mo_wordUShr [idx, - mkIntExpr mUT_ARR_PTRS_CARD_BITS]) + (CmmMachOp (mo_wordUShr dflags) [idx, + mkIntExpr dflags mUT_ARR_PTRS_CARD_BITS]) ) (CmmLit (CmmInt 1 W8)) loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr @@ -967,7 +967,8 @@ doCopyByteArrayOp = emitCopyByteArray copy -- Copy data (we assume the arrays aren't overlapping since -- they're of different types) copy _src _dst dst_p src_p bytes = - emitMemcpyCall dst_p src_p bytes (mkIntExpr 1) + do dflags <- getDynFlags + emitMemcpyCall dst_p src_p bytes (mkIntExpr dflags 1) -- | Takes a source 'MutableByteArray#', an offset in the source -- array, a destination 'MutableByteArray#', an offset into the @@ -982,11 +983,12 @@ doCopyMutableByteArrayOp = emitCopyByteArray copy -- we were provided are the same array! -- TODO: Optimize branch for common case of no aliasing. copy src dst dst_p src_p bytes = do + dflags <- getDynFlags [moveCall, cpyCall] <- forkAlts [ - getCode $ emitMemmoveCall dst_p src_p bytes (mkIntExpr 1), - getCode $ emitMemcpyCall dst_p src_p bytes (mkIntExpr 1) + getCode $ emitMemmoveCall dst_p src_p bytes (mkIntExpr dflags 1), + getCode $ emitMemcpyCall dst_p src_p bytes (mkIntExpr dflags 1) ] - emit =<< mkCmmIfThenElse (cmmEqWord src dst) moveCall cpyCall + emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()) @@ -1009,7 +1011,7 @@ doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr doSetByteArrayOp ba off len c = do dflags <- getDynFlags p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off - emitMemsetCall p c len (mkIntExpr 1) + emitMemsetCall p c len (mkIntExpr dflags 1) -- ---------------------------------------------------------------------------- -- Copying pointer arrays @@ -1039,7 +1041,8 @@ doCopyArrayOp = emitCopyArray copy -- Copy data (we assume the arrays aren't overlapping since -- they're of different types) copy _src _dst dst_p src_p bytes = - emitMemcpyCall dst_p src_p bytes (mkIntExpr wORD_SIZE) + do dflags <- getDynFlags + emitMemcpyCall dst_p src_p bytes (mkIntExpr dflags wORD_SIZE) -- | Takes a source 'MutableArray#', an offset in the source array, a @@ -1054,11 +1057,12 @@ doCopyMutableArrayOp = emitCopyArray copy -- we were provided are the same array! -- TODO: Optimize branch for common case of no aliasing. copy src dst dst_p src_p bytes = do + dflags <- getDynFlags [moveCall, cpyCall] <- forkAlts [ - getCode $ emitMemmoveCall dst_p src_p bytes (mkIntExpr wORD_SIZE), - getCode $ emitMemcpyCall dst_p src_p bytes (mkIntExpr wORD_SIZE) + getCode $ emitMemmoveCall dst_p src_p bytes (mkIntExpr dflags wORD_SIZE), + getCode $ emitMemcpyCall dst_p src_p bytes (mkIntExpr dflags wORD_SIZE) ] - emit =<< mkCmmIfThenElse (cmmEqWord src dst) moveCall cpyCall + emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()) @@ -1079,7 +1083,7 @@ emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 = do 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) + bytes <- assignTempE $ cmmMulWord dflags n (mkIntExpr dflags wORD_SIZE) copy src dst dst_p src_p bytes @@ -1095,20 +1099,23 @@ emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 = do emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () emitCloneArray info_p res_r src0 src_off0 n0 = do + dflags <- getDynFlags + let arrPtrsHdrSizeW dflags = mkIntExpr dflags (fixedHdrSize dflags + + (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE)) + myCapability = cmmSubWord dflags (CmmReg baseReg) (mkIntExpr dflags oFFSET_Capability_r) -- Passed as arguments (be careful) src <- assignTempE src0 src_off <- assignTempE src_off0 n <- assignTempE n0 - card_bytes <- assignTempE $ cardRoundUp n - size <- assignTempE $ n `cmmAddWord` bytesToWordsRoundUp card_bytes - dflags <- getDynFlags - words <- assignTempE $ arrPtrsHdrSizeW dflags `cmmAddWord` size + card_bytes <- assignTempE $ cardRoundUp dflags n + size <- assignTempE $ cmmAddWord dflags n (bytesToWordsRoundUp dflags card_bytes) + words <- assignTempE $ cmmAddWord dflags (arrPtrsHdrSizeW dflags) size arr_r <- newTemp (bWord dflags) emitAllocateCall arr_r myCapability words - tickyAllocPrim (mkIntExpr (arrPtrsHdrSize dflags)) (n `cmmMulWord` wordSize) - zeroExpr + tickyAllocPrim (mkIntExpr dflags (arrPtrsHdrSize dflags)) (cmmMulWord dflags n (wordSize dflags)) + (zeroExpr dflags) let arr = CmmReg (CmmLocal arr_r) emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCS @@ -1121,43 +1128,40 @@ emitCloneArray info_p res_r src0 src_off0 n0 = do src_p <- assignTempE $ cmmOffsetExprW dflags (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off - emitMemcpyCall dst_p src_p (n `cmmMulWord` wordSize) (mkIntExpr wORD_SIZE) + emitMemcpyCall dst_p src_p (cmmMulWord dflags n (wordSize dflags)) (mkIntExpr dflags wORD_SIZE) emitMemsetCall (cmmOffsetExprW dflags dst_p n) - (mkIntExpr 1) + (mkIntExpr dflags 1) card_bytes - (mkIntExpr wORD_SIZE) + (mkIntExpr dflags wORD_SIZE) emit $ mkAssign (CmmLocal res_r) arr - where - arrPtrsHdrSizeW dflags = mkIntExpr (fixedHdrSize dflags + - (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE)) - myCapability = CmmReg baseReg `cmmSubWord` mkIntExpr oFFSET_Capability_r -- | Takes and offset in the destination array, the base address of -- the card table, and the number of elements affected (*not* the -- number of cards). Marks the relevant cards as dirty. emitSetCards :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () emitSetCards dst_start dst_cards_start n = do - start_card <- assignTempE $ card dst_start - emitMemsetCall (dst_cards_start `cmmAddWord` start_card) - (mkIntExpr 1) - (cardRoundUp n) - (mkIntExpr 1) -- no alignment (1 byte) + dflags <- getDynFlags + start_card <- assignTempE $ card dflags dst_start + emitMemsetCall (cmmAddWord dflags dst_cards_start start_card) + (mkIntExpr dflags 1) + (cardRoundUp dflags n) + (mkIntExpr dflags 1) -- no alignment (1 byte) -- Convert an element index to a card index -card :: CmmExpr -> CmmExpr -card i = i `cmmUShrWord` mkIntExpr mUT_ARR_PTRS_CARD_BITS +card :: DynFlags -> CmmExpr -> CmmExpr +card dflags i = cmmUShrWord dflags i (mkIntExpr dflags mUT_ARR_PTRS_CARD_BITS) -- Convert a number of elements to a number of cards, rounding up -cardRoundUp :: CmmExpr -> CmmExpr -cardRoundUp i = card (i `cmmAddWord` (mkIntExpr ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS) - 1))) +cardRoundUp :: DynFlags -> CmmExpr -> CmmExpr +cardRoundUp dflags i = card dflags (cmmAddWord dflags i (mkIntExpr dflags ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS) - 1))) -bytesToWordsRoundUp :: CmmExpr -> CmmExpr -bytesToWordsRoundUp e = (e `cmmAddWord` mkIntExpr (wORD_SIZE - 1)) - `cmmQuotWord` wordSize +bytesToWordsRoundUp :: DynFlags -> CmmExpr -> CmmExpr +bytesToWordsRoundUp dflags e = cmmQuotWord dflags (cmmAddWord dflags e (mkIntExpr dflags (wORD_SIZE - 1))) + (wordSize dflags) -wordSize :: CmmExpr -wordSize = mkIntExpr wORD_SIZE +wordSize :: DynFlags -> CmmExpr +wordSize dflags = mkIntExpr dflags wORD_SIZE -- | Emit a call to @memcpy@. emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index c980493de1..715bbb7415 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -94,11 +94,11 @@ staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit] -- The profiling header words in a static closure -- Was SET_STATIC_PROF_HDR staticProfHdr dflags ccs - = ifProfilingL dflags [mkCCostCentreStack ccs, staticLdvInit] + = ifProfilingL dflags [mkCCostCentreStack ccs, staticLdvInit dflags] dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr] -- Profiling header words in a dynamic closure -dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit] +dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags] initUpdFrameProf :: ByteOff -> FCode () -- Initialise the profiling field of an update frame @@ -164,7 +164,7 @@ profDynAlloc :: SMRep -> CmmExpr -> FCode () profDynAlloc rep ccs = ifProfiling $ do dflags <- getDynFlags - profAlloc (mkIntExpr (heapClosureSize dflags rep)) ccs + profAlloc (mkIntExpr dflags (heapClosureSize dflags rep)) ccs -- | Record the allocation of a closure (size is given by a CmmExpr) -- The size must be in words, because the allocation counter in a CCS counts @@ -175,9 +175,9 @@ profAlloc words ccs do dflags <- getDynFlags emit (addToMemE alloc_rep (cmmOffsetB dflags ccs oFFSET_CostCentreStack_mem_alloc) - (CmmMachOp (MO_UU_Conv wordWidth (typeWidth alloc_rep)) $ - [CmmMachOp mo_wordSub [words, - mkIntExpr (profHdrSize dflags)]])) + (CmmMachOp (MO_UU_Conv (wordWidth dflags) (typeWidth alloc_rep)) $ + [CmmMachOp (mo_wordSub dflags) [words, + mkIntExpr dflags (profHdrSize dflags)]])) -- subtract the "profiling overhead", which is the -- profiling header in a closure. where @@ -230,48 +230,48 @@ initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs) emitCostCentreDecl :: CostCentre -> FCode () emitCostCentreDecl cc = do + { dflags <- getDynFlags + ; let is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF + | otherwise = zero dflags -- NB. bytesFS: we want the UTF-8 bytes here (#5559) - { label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc) + ; label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc) ; modl <- newByteStringCLit (bytesFS $ Module.moduleNameFS $ Module.moduleName $ cc_mod cc) - ; dflags <- getDynFlags ; loc <- newByteStringCLit $ bytesFS $ mkFastString $ showPpr dflags (costCentreSrcSpan cc) -- XXX going via FastString to get UTF-8 encoding is silly ; let - lits = [ zero, -- StgInt ccID, + lits = [ zero dflags, -- StgInt ccID, label, -- char *label, modl, -- char *module, loc, -- char *srcloc, zero64, -- StgWord64 mem_alloc - zero, -- StgWord time_ticks + zero dflags, -- StgWord time_ticks is_caf, -- StgInt is_caf - zero -- struct _CostCentre *link + zero dflags -- struct _CostCentre *link ] ; emitDataLits (mkCCLabel cc) lits } - where - is_caf | isCafCC cc = mkIntCLit (ord 'c') -- 'c' == is a CAF - | otherwise = zero emitCostCentreStackDecl :: CostCentreStack -> FCode () emitCostCentreStackDecl ccs = case maybeSingletonCCS ccs of - Just cc -> emitDataLits (mkCCSLabel ccs) (mk_lits cc) - Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs) - where - mk_lits cc = zero : - mkCCostCentre cc : - replicate (sizeof_ccs_words - 2) zero - -- Note: to avoid making any assumptions about how the - -- C compiler (that compiles the RTS, in particular) does - -- layouts of structs containing long-longs, simply - -- pad out the struct with zero words until we hit the - -- size of the overall struct (which we get via DerivedConstants.h) - -zero :: CmmLit -zero = mkIntCLit 0 + Just cc -> + do dflags <- getDynFlags + let mk_lits cc = zero dflags : + mkCCostCentre cc : + replicate (sizeof_ccs_words - 2) (zero dflags) + -- Note: to avoid making any assumptions about how the + -- C compiler (that compiles the RTS, in particular) does + -- layouts of structs containing long-longs, simply + -- pad out the struct with zero words until we hit the + -- size of the overall struct (which we get via DerivedConstants.h) + emitDataLits (mkCCSLabel ccs) (mk_lits cc) + Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs) + +zero :: DynFlags -> CmmLit +zero dflags = mkIntCLit dflags 0 zero64 :: CmmLit zero64 = CmmInt 0 W64 @@ -318,17 +318,17 @@ bumpSccCount dflags ccs -- -- Initial value for the LDV field in a static closure -- -staticLdvInit :: CmmLit +staticLdvInit :: DynFlags -> CmmLit staticLdvInit = zeroCLit -- -- Initial value of the LDV field in a dynamic closure -- -dynLdvInit :: CmmExpr -dynLdvInit = -- (era << LDV_SHIFT) | LDV_STATE_CREATE - CmmMachOp mo_wordOr [ - CmmMachOp mo_wordShl [loadEra, mkIntExpr lDV_SHIFT ], - CmmLit (mkWordCLit lDV_STATE_CREATE) +dynLdvInit :: DynFlags -> CmmExpr +dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE + CmmMachOp (mo_wordOr dflags) [ + CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags lDV_SHIFT ], + CmmLit (mkWordCLit dflags lDV_STATE_CREATE) ] -- @@ -336,7 +336,7 @@ dynLdvInit = -- (era << LDV_SHIFT) | LDV_STATE_CREATE -- ldvRecordCreate :: CmmExpr -> FCode () ldvRecordCreate closure = do dflags <- getDynFlags - emit $ mkStore (ldvWord dflags closure) dynLdvInit + emit $ mkStore (ldvWord dflags closure) (dynLdvInit dflags) -- -- Called when a closure is entered, marks the closure as having been "used". @@ -356,19 +356,19 @@ 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))) + new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags)) + (CmmLit (mkWordCLit dflags lDV_CREATE_MASK))) + (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags lDV_STATE_USE))) ifProfiling $ -- if (era > 0) { -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) | -- era | LDV_STATE_USE } - emit =<< mkCmmIfThenElse (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit]) + emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt dflags) [loadEra dflags, CmmLit (zeroCLit dflags)]) (mkStore ldv_wd new_ldv_wd) mkNop -loadEra :: CmmExpr -loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth) +loadEra :: DynFlags -> CmmExpr +loadEra dflags = CmmMachOp (MO_UU_Conv cIntWidth (wordWidth dflags)) [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "era"))) cInt] ldvWord :: DynFlags -> CmmExpr -> CmmExpr diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs index e6cb6ed84b..d86d84a26c 100644 --- a/compiler/codeGen/StgCmmTicky.hs +++ b/compiler/codeGen/StgCmmTicky.hs @@ -106,14 +106,14 @@ emitTickyCounter cl_info args -- krc: note that all the fields are I32 now; some were I16 before, -- but the code generator wasn't handling that properly and it led to chaos, -- panic and disorder. - [ mkIntCLit 0, - mkIntCLit (length args), -- Arity - mkIntCLit 0, -- XXX: we no longer know this! Words passed on stack + [ mkIntCLit dflags 0, + mkIntCLit dflags (length args), -- Arity + mkIntCLit dflags 0, -- XXX: we no longer know this! Words passed on stack fun_descr_lit, arg_descr_lit, - zeroCLit, -- Entry count - zeroCLit, -- Allocs - zeroCLit -- Link + zeroCLit dflags, -- Entry count + zeroCLit dflags, -- Allocs + zeroCLit dflags -- Link ] } -- When printing the name of a thing in a ticky file, we want to @@ -183,17 +183,17 @@ 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) + test = CmmMachOp (MO_Eq (wordWidth dflags)) [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl oFFSET_StgEntCounter_registeredp)) (bWord dflags), - zeroExpr] + zeroExpr dflags] register_stmts = [ 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) ] + (mkIntExpr dflags 1) ] ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs")) emit =<< mkCmmIfThen test (catAGraphs register_stmts) diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index b402199ac4..1b934df9f7 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -86,31 +86,32 @@ import Data.Maybe cgLit :: Literal -> FCode CmmLit cgLit (MachStr s) = newByteStringCLit (bytesFB s) -- not unpackFS; we want the UTF-8 byte stream. -cgLit other_lit = return (mkSimpleLit other_lit) +cgLit other_lit = do dflags <- getDynFlags + return (mkSimpleLit dflags other_lit) mkLtOp :: DynFlags -> Literal -> MachOp -- On signed literals we must do a signed comparison -mkLtOp _ (MachInt _) = MO_S_Lt wordWidth +mkLtOp dflags (MachInt _) = MO_S_Lt (wordWidth dflags) mkLtOp _ (MachFloat _) = MO_F_Lt W32 mkLtOp _ (MachDouble _) = MO_F_Lt W64 -mkLtOp dflags lit = MO_U_Lt (typeWidth (cmmLitType dflags (mkSimpleLit lit))) +mkLtOp dflags lit = MO_U_Lt (typeWidth (cmmLitType dflags (mkSimpleLit dflags lit))) -- ToDo: seems terribly indirect! -mkSimpleLit :: Literal -> CmmLit -mkSimpleLit (MachChar c) = CmmInt (fromIntegral (ord c)) wordWidth -mkSimpleLit MachNullAddr = zeroCLit -mkSimpleLit (MachInt i) = CmmInt i wordWidth -mkSimpleLit (MachInt64 i) = CmmInt i W64 -mkSimpleLit (MachWord i) = CmmInt i wordWidth -mkSimpleLit (MachWord64 i) = CmmInt i W64 -mkSimpleLit (MachFloat r) = CmmFloat r W32 -mkSimpleLit (MachDouble r) = CmmFloat r W64 -mkSimpleLit (MachLabel fs ms fod) +mkSimpleLit :: DynFlags -> Literal -> CmmLit +mkSimpleLit dflags (MachChar c) = CmmInt (fromIntegral (ord c)) (wordWidth dflags) +mkSimpleLit dflags MachNullAddr = zeroCLit dflags +mkSimpleLit dflags (MachInt i) = CmmInt i (wordWidth dflags) +mkSimpleLit _ (MachInt64 i) = CmmInt i W64 +mkSimpleLit dflags (MachWord i) = CmmInt i (wordWidth dflags) +mkSimpleLit _ (MachWord64 i) = CmmInt i W64 +mkSimpleLit _ (MachFloat r) = CmmFloat r W32 +mkSimpleLit _ (MachDouble r) = CmmFloat r W64 +mkSimpleLit _ (MachLabel fs ms fod) = CmmLabel (mkForeignLabel fs ms labelSrc fod) where -- TODO: Literal labels might not actually be in the current package... labelSrc = ForeignLabelInThisPackage -mkSimpleLit other = pprPanic "mkSimpleLit" (ppr other) +mkSimpleLit _ other = pprPanic "mkSimpleLit" (ppr other) -------------------------------------------------------------------------- -- @@ -514,11 +515,11 @@ mk_switch _tag_expr [(_tag,lbl)] Nothing _ _ _ -- SINGLETON BRANCH: one equality check to do mk_switch tag_expr [(tag,lbl)] (Just deflt) _ _ _ - = return (mkCbranch cond deflt lbl) - where - cond = cmmNeWord tag_expr (mkIntExpr tag) - -- We have lo_tag < hi_tag, but there's only one branch, - -- so there must be a default + = do dflags <- getDynFlags + let cond = cmmNeWord dflags tag_expr (mkIntExpr dflags tag) + -- We have lo_tag < hi_tag, but there's only one branch, + -- so there must be a default + return (mkCbranch cond deflt lbl) -- ToDo: we might want to check for the two branch case, where one of -- the branches is the tag 0, because comparing '== 0' is likely to be @@ -551,28 +552,31 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C -- if we can knock off a bunch of default cases with one if, then do so | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches - = do stmts <- mk_switch tag_expr branches mb_deflt + = do dflags <- getDynFlags + stmts <- mk_switch tag_expr branches mb_deflt lowest_branch hi_tag via_C mkCmmIfThenElse - (cmmULtWord tag_expr (mkIntExpr lowest_branch)) + (cmmULtWord dflags tag_expr (mkIntExpr dflags lowest_branch)) (mkBranch deflt) stmts | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches - = do stmts <- mk_switch tag_expr branches mb_deflt + = do dflags <- getDynFlags + stmts <- mk_switch tag_expr branches mb_deflt lo_tag highest_branch via_C mkCmmIfThenElse - (cmmUGtWord tag_expr (mkIntExpr highest_branch)) + (cmmUGtWord dflags tag_expr (mkIntExpr dflags highest_branch)) (mkBranch deflt) stmts | otherwise -- Use an if-tree - = do lo_stmts <- mk_switch tag_expr lo_branches mb_deflt + = do dflags <- getDynFlags + lo_stmts <- mk_switch tag_expr lo_branches mb_deflt lo_tag (mid_tag-1) via_C hi_stmts <- mk_switch tag_expr hi_branches mb_deflt mid_tag hi_tag via_C mkCmmIfThenElse - (cmmUGeWord tag_expr (mkIntExpr mid_tag)) + (cmmUGeWord dflags tag_expr (mkIntExpr dflags mid_tag)) hi_stmts lo_stmts -- we test (e >= mid_tag) rather than (e < mid_tag), because @@ -656,7 +660,7 @@ mk_lit_switch scrut deflt [(lit,blk)] = do dflags <- getDynFlags let - cmm_lit = mkSimpleLit lit + cmm_lit = mkSimpleLit dflags lit cmm_ty = cmmLitType dflags cmm_lit rep = typeWidth cmm_ty ne = if isFloatType cmm_ty then MO_F_Ne rep else MO_Ne rep @@ -676,7 +680,7 @@ mk_lit_switch scrut deflt_blk_id branches is_lo (t,_) = t < mid_lit cond dflags = CmmMachOp (mkLtOp dflags mid_lit) - [scrut, CmmLit (mkSimpleLit mid_lit)] + [scrut, CmmLit (mkSimpleLit dflags mid_lit)] -------------- diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 1490360057..1493a40a6b 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -955,13 +955,13 @@ cmmExprConFold referenceKind expr = do -- SDM: re-enabled for now, while cmmRewriteAssignments is turned off let expr' = if False -- dopt Opt_TryNewCodeGen dflags then expr - else cmmExprCon (targetPlatform dflags) expr + else cmmExprCon dflags expr cmmExprNative referenceKind expr' -cmmExprCon :: Platform -> CmmExpr -> CmmExpr -cmmExprCon platform (CmmLoad addr rep) = CmmLoad (cmmExprCon platform addr) rep -cmmExprCon platform (CmmMachOp mop args) - = cmmMachOpFold platform mop (map (cmmExprCon platform) args) +cmmExprCon :: DynFlags -> CmmExpr -> CmmExpr +cmmExprCon dflags (CmmLoad addr rep) = CmmLoad (cmmExprCon dflags addr) rep +cmmExprCon dflags (CmmMachOp mop args) + = cmmMachOpFold dflags mop (map (cmmExprCon dflags) args) cmmExprCon _ other = other -- handles both PIC and non-PIC cases... a very strange mixture @@ -993,9 +993,9 @@ cmmExprNative referenceKind expr = do -> do dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl -- need to optimize here, since it's late - return $ cmmMachOpFold platform (MO_Add wordWidth) [ + return $ cmmMachOpFold dflags (MO_Add (wordWidth dflags)) [ dynRef, - (CmmLit $ CmmInt (fromIntegral off) wordWidth) + (CmmLit $ CmmInt (fromIntegral off) (wordWidth dflags)) ] -- On powerpc (non-PIC), it's easier to jump directly to a label than diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs index 2135020097..af4bb9e9ed 100644 --- a/compiler/nativeGen/PIC.hs +++ b/compiler/nativeGen/PIC.hs @@ -161,7 +161,7 @@ cmmMakePicReference dflags lbl | (dopt Opt_PIC dflags || not (dopt Opt_Static dflags)) && absoluteLabel lbl - = CmmMachOp (MO_Add wordWidth) + = CmmMachOp (MO_Add (wordWidth dflags)) [ CmmReg (CmmGlobal PicBaseReg) , CmmLit $ picRelative (platformArch $ targetPlatform dflags) @@ -641,11 +641,11 @@ pprImportedSymbol _ platform@(Platform { platformArch = ArchPPC_64 }) _ | osElfTarget (platformOS platform) = empty -pprImportedSymbol _ platform importedLbl +pprImportedSymbol dflags platform importedLbl | osElfTarget (platformOS platform) = case dynamicLinkerLabelInfo importedLbl of Just (SymbolPtr, lbl) - -> let symbolSize = case wordWidth of + -> let symbolSize = case wordWidth dflags of W32 -> sLit "\t.long" W64 -> sLit "\t.quad" _ -> panic "Unknown wordRep in pprImportedSymbol" @@ -703,8 +703,9 @@ initializePicBase_ppc ArchPPC os picReg (CmmProc info lab (ListGraph blocks) : statics) | osElfTarget os = do + dflags <- getDynFlags gotOffLabel <- getNewLabelNat - tmp <- getNewRegNat $ intSize wordWidth + tmp <- getNewRegNat $ intSize (wordWidth dflags) let gotOffset = CmmData Text $ Statics gotOffLabel [ CmmStaticLit (CmmLabelDiffOff gotLabel diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index 307c65b441..367c0fbdec 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -206,9 +206,9 @@ temporary, then do the other computation, and then use the temporary: -- | Convert a BlockId to some CmmStatic data -jumpTableEntry :: Maybe BlockId -> CmmStatic -jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordWidth) -jumpTableEntry (Just blockid) = CmmStaticLit (CmmLabel blockLabel) +jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic +jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags)) +jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel) where blockLabel = mkAsmTempLabel (getUnique blockid) @@ -1197,9 +1197,9 @@ generateJumpTableForInstr :: DynFlags -> Instr generateJumpTableForInstr dflags (BCTR ids (Just lbl)) = let jumpTable | dopt Opt_PIC dflags = map jumpTableEntryRel ids - | otherwise = map jumpTableEntry ids + | otherwise = map (jumpTableEntry dflags) ids where jumpTableEntryRel Nothing - = CmmStaticLit (CmmInt 0 wordWidth) + = CmmStaticLit (CmmInt 0 (wordWidth dflags)) jumpTableEntryRel (Just blockid) = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0) where blockLabel = mkAsmTempLabel (getUnique blockid) diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index 27dafb7d42..9d6aeaafc9 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -165,9 +165,9 @@ temporary, then do the other computation, and then use the temporary: -- | Convert a BlockId to some CmmStatic data -jumpTableEntry :: Maybe BlockId -> CmmStatic -jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordWidth) -jumpTableEntry (Just blockid) = CmmStaticLit (CmmLabel blockLabel) +jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic +jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags)) +jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel) where blockLabel = mkAsmTempLabel (getUnique blockid) @@ -324,8 +324,8 @@ genSwitch dflags expr ids generateJumpTableForInstr :: DynFlags -> Instr -> Maybe (NatCmmDecl CmmStatics Instr) -generateJumpTableForInstr _ (JMP_TBL _ ids label) = - let jumpTable = map jumpTableEntry ids +generateJumpTableForInstr dflags (JMP_TBL _ ids label) = + let jumpTable = map (jumpTableEntry dflags) ids in Just (CmmData ReadOnlyData (Statics label jumpTable)) generateJumpTableForInstr _ _ = Nothing diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index 9e4dd24dd2..5e51a87699 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -275,9 +275,9 @@ is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000 -- | Convert a BlockId to some CmmStatic data -jumpTableEntry :: Maybe BlockId -> CmmStatic -jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordWidth) -jumpTableEntry (Just blockid) = CmmStaticLit (CmmLabel blockLabel) +jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic +jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags)) +jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel) where blockLabel = mkAsmTempLabel (getUnique blockid) @@ -2075,7 +2075,7 @@ genCCall64' dflags target dest_regs args = do -- stdcall has callee do it, but is not supported on -- x86_64 target (see #3336) (if real_size==0 then [] else - [ADD (intSize wordWidth) (OpImm (ImmInt real_size)) (OpReg esp)]) + [ADD (intSize (wordWidth dflags)) (OpImm (ImmInt real_size)) (OpReg esp)]) ++ [DELTA (delta + real_size)] ) @@ -2171,7 +2171,7 @@ genCCall64' dflags target dest_regs args = do delta <- getDeltaNat setDeltaNat (delta-arg_size) let code' = code `appOL` arg_code `appOL` toOL [ - SUB (intSize wordWidth) (OpImm (ImmInt arg_size)) (OpReg rsp) , + SUB (intSize (wordWidth dflags)) (OpImm (ImmInt arg_size)) (OpReg rsp) , DELTA (delta-arg_size), MOV (floatSize width) (OpReg arg_reg) (OpAddr (spRel platform 0))] push_args rest code' @@ -2292,7 +2292,7 @@ genSwitch dflags expr ids return $ if target32Bit (targetPlatform dflags) then e_code `appOL` t_code `appOL` toOL [ - ADD (intSize wordWidth) op (OpReg tableReg), + ADD (intSize (wordWidth dflags)) op (OpReg tableReg), JMP_TBL (OpReg tableReg) ids ReadOnlyData lbl ] else case platformOS (targetPlatform dflags) of @@ -2305,7 +2305,7 @@ genSwitch dflags expr ids -- if L0 is not preceded by a non-anonymous -- label in its section. e_code `appOL` t_code `appOL` toOL [ - ADD (intSize wordWidth) op (OpReg tableReg), + ADD (intSize (wordWidth dflags)) op (OpReg tableReg), JMP_TBL (OpReg tableReg) ids Text lbl ] _ -> @@ -2319,7 +2319,7 @@ genSwitch dflags expr ids -- once binutils 2.17 is standard. e_code `appOL` t_code `appOL` toOL [ MOVSxL II32 op (OpReg reg), - ADD (intSize wordWidth) (OpReg reg) (OpReg tableReg), + ADD (intSize (wordWidth dflags)) (OpReg reg) (OpReg tableReg), JMP_TBL (OpReg tableReg) ids ReadOnlyData lbl ] | otherwise @@ -2343,12 +2343,12 @@ createJumpTable dflags ids section lbl = let jumpTable | dopt Opt_PIC dflags = let jumpTableEntryRel Nothing - = CmmStaticLit (CmmInt 0 wordWidth) + = CmmStaticLit (CmmInt 0 (wordWidth dflags)) jumpTableEntryRel (Just blockid) = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0) where blockLabel = mkAsmTempLabel (getUnique blockid) in map jumpTableEntryRel ids - | otherwise = map jumpTableEntry ids + | otherwise = map (jumpTableEntry dflags) ids in CmmData section (1, Statics lbl jumpTable) -- ----------------------------------------------------------------------------- |