diff options
| author | Ian Lynagh <ian@well-typed.com> | 2012-09-16 17:45:03 +0100 |
|---|---|---|
| committer | Ian Lynagh <ian@well-typed.com> | 2012-09-16 17:45:03 +0100 |
| commit | 17910899dacc892fd652d9206340d2bc2b2c5fc1 (patch) | |
| tree | c39b870bea8c77390c19e6d9694d38aa931fc2ed | |
| parent | a62b56ef0b9d1750289ffd3f77b578dc73452374 (diff) | |
| download | haskell-17910899dacc892fd652d9206340d2bc2b2c5fc1.tar.gz | |
Move wORD_SIZE into platformConstants
63 files changed, 551 insertions, 552 deletions
diff --git a/compiler/cmm/Bitmap.hs b/compiler/cmm/Bitmap.hs index f4cfe3f401..93217d5192 100644 --- a/compiler/cmm/Bitmap.hs +++ b/compiler/cmm/Bitmap.hs @@ -24,7 +24,6 @@ module Bitmap ( #include "../includes/MachDeps.h" import SMRep -import Constants import DynFlags import Util @@ -84,9 +83,10 @@ possible, or fall back to an external pointer when the bitmap is too large. This value represents the largest size of bitmap that can be packed into a single word. -} -mAX_SMALL_BITMAP_SIZE :: Int -mAX_SMALL_BITMAP_SIZE | wORD_SIZE == 4 = 27 - | otherwise = 58 +mAX_SMALL_BITMAP_SIZE :: DynFlags -> Int +mAX_SMALL_BITMAP_SIZE dflags + | wORD_SIZE dflags == 4 = 27 + | otherwise = 58 seqBitmap :: Bitmap -> a -> a seqBitmap = seqList diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index 37354193f8..30e0addbdc 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -233,7 +233,7 @@ to_SRT dflags top_srt off len bmp let srt_desc_lbl = mkLargeSRTLabel id tbl = CmmData RelocatableReadOnlyData $ Statics srt_desc_lbl $ map CmmStaticLit - ( cmmLabelOffW top_srt off + ( cmmLabelOffW dflags top_srt off : mkWordCLit dflags (fromIntegral len) : map (mkWordCLit dflags) bmp) return (Just tbl, C_SRT srt_desc_lbl 0 srt_escape) diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs index fb6c27c66b..235fe7f911 100644 --- a/compiler/cmm/CmmCallConv.hs +++ b/compiler/cmm/CmmCallConv.hs @@ -18,7 +18,6 @@ import SMRep import Cmm (Convention(..)) import PprCmm () -import Constants import qualified Data.List as L import DynFlags import Outputable @@ -92,7 +91,7 @@ assignArgumentsPos dflags conv arg_ty reps = assignments assign_stk _ assts [] = assts assign_stk offset assts (r:rs) = assign_stk off' ((r, StackParam off') : assts) rs where w = typeWidth (arg_ty r) - size = (((widthInBytes w - 1) `div` wORD_SIZE) + 1) * wORD_SIZE + size = (((widthInBytes w - 1) `div` wORD_SIZE dflags) + 1) * wORD_SIZE dflags off' = offset + size ----------------------------------------------------------------------------- diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index 10e37bb095..94e38ae071 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -173,7 +173,7 @@ mkInfoTableContents dflags | StackRep frame <- smrep = do { (prof_lits, prof_data) <- mkProfLits dflags prof - ; let (srt_label, srt_bitmap) = mkSRTLit srt + ; let (srt_label, srt_bitmap) = mkSRTLit dflags srt ; (liveness_lit, liveness_data) <- mkLivenessBits dflags frame ; let std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit @@ -186,7 +186,7 @@ mkInfoTableContents dflags | HeapRep _ ptrs nonptrs closure_type <- smrep = do { let layout = packHalfWordsCLit dflags ptrs nonptrs ; (prof_lits, prof_data) <- mkProfLits dflags prof - ; let (srt_label, srt_bitmap) = mkSRTLit srt + ; let (srt_label, srt_bitmap) = mkSRTLit dflags srt ; (mb_srt_field, mb_layout, extra_bits, ct_data) <- mk_pieces closure_type srt_label ; let std_info = mkStdInfoTable dflags prof_lits @@ -233,11 +233,12 @@ mkInfoTableContents dflags mkInfoTableContents _ _ _ = panic "mkInfoTableContents" -- NonInfoTable dealt with earlier -mkSRTLit :: C_SRT +mkSRTLit :: DynFlags + -> C_SRT -> ([CmmLit], -- srt_label, if any StgHalfWord) -- srt_bitmap -mkSRTLit NoC_SRT = ([], 0) -mkSRTLit (C_SRT lbl off bitmap) = ([cmmLabelOffW lbl off], bitmap) +mkSRTLit _ NoC_SRT = ([], 0) +mkSRTLit dflags (C_SRT lbl off bitmap) = ([cmmLabelOffW dflags lbl off], bitmap) ------------------------------------------------------------------------- @@ -303,7 +304,7 @@ mkLivenessBits :: DynFlags -> Liveness -> UniqSM (CmmLit, [RawCmmDecl]) -- 2. Large bitmap CmmData if needed mkLivenessBits dflags liveness - | n_bits > mAX_SMALL_BITMAP_SIZE -- does not fit in one word + | n_bits > mAX_SMALL_BITMAP_SIZE dflags -- does not fit in one word = do { uniq <- getUniqueUs ; let bitmap_lbl = mkBitmapLabel uniq ; return (CmmLabel bitmap_lbl, diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs index ea9a4bb7ba..5505b92f5a 100644 --- a/compiler/cmm/CmmLayoutStack.hs +++ b/compiler/cmm/CmmLayoutStack.hs @@ -17,7 +17,6 @@ import CmmLive import CmmProcPoint import SMRep import Hoopl -import Constants import UniqSupply import Maybes import UniqFM @@ -345,7 +344,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off CmmForeignCall{ succ = cont_lbl, .. } -> do - return $ lastCall cont_lbl wORD_SIZE wORD_SIZE (sm_ret_off stack0) + return $ lastCall cont_lbl (wORD_SIZE dflags) (wORD_SIZE dflags) (sm_ret_off stack0) -- one word each for args and results: the return address CmmBranch{..} -> handleBranches @@ -381,7 +380,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps = (save_assignments, new_cont_stack) where (new_cont_stack, save_assignments) - = setupStackFrame lbl liveness cml_ret_off cml_ret_args stack0 + = setupStackFrame dflags lbl liveness cml_ret_off cml_ret_args stack0 -- For other last nodes (branches), if any of the targets is a @@ -404,7 +403,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps out = mapFromList [ (l', cont_stack) | l' <- successors last ] return ( assigs - , spOffsetForCall sp0 cont_stack wORD_SIZE + , spOffsetForCall sp0 cont_stack (wORD_SIZE dflags) , last , [] , out) @@ -440,7 +439,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps (stack2, assigs) = --pprTrace "first visit to proc point" -- (ppr l <+> ppr stack1) $ - setupStackFrame l liveness (sm_ret_off stack0) + setupStackFrame dflags l liveness (sm_ret_off stack0) cont_args stack0 -- (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 assigs @@ -496,14 +495,15 @@ fixupStack old_stack new_stack = concatMap move new_locs setupStackFrame - :: BlockId -- label of continuation + :: DynFlags + -> BlockId -- label of continuation -> BlockEnv CmmLive -- liveness -> ByteOff -- updfr -> ByteOff -- bytes of return values on stack -> StackMap -- current StackMap -> (StackMap, [CmmNode O O]) -setupStackFrame lbl liveness updfr_off ret_args stack0 +setupStackFrame dflags lbl liveness updfr_off ret_args stack0 = (cont_stack, assignments) where -- get the set of LocalRegs live in the continuation @@ -519,7 +519,7 @@ setupStackFrame lbl liveness updfr_off ret_args stack0 -- everything up to updfr_off is off-limits -- stack1 contains updfr_off, plus everything we need to save - (stack1, assignments) = allocate updfr_off live stack0 + (stack1, assignments) = allocate dflags updfr_off live stack0 -- And the Sp at the continuation is: -- sm_sp stack1 + ret_args @@ -600,9 +600,10 @@ futureContinuation middle = foldBlockNodesB f middle Nothing -- on the stack and return the new StackMap and the assignments to do -- the saving. -- -allocate :: ByteOff -> RegSet -> StackMap -> (StackMap, [CmmNode O O]) -allocate ret_off live stackmap@StackMap{ sm_sp = sp0 - , sm_regs = regs0 } +allocate :: DynFlags -> ByteOff -> RegSet -> StackMap + -> (StackMap, [CmmNode O O]) +allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0 + , sm_regs = regs0 } = -- pprTrace "allocate" (ppr live $$ ppr stackmap) $ @@ -613,37 +614,37 @@ allocate ret_off live stackmap@StackMap{ sm_sp = sp0 -- make a map of the stack let stack = reverse $ Array.elems $ - accumArray (\_ x -> x) Empty (1, toWords (max sp0 ret_off)) $ + accumArray (\_ x -> x) Empty (1, toWords dflags (max sp0 ret_off)) $ ret_words ++ live_words where ret_words = [ (x, Occupied) - | x <- [ 1 .. toWords ret_off] ] + | x <- [ 1 .. toWords dflags ret_off] ] live_words = - [ (toWords x, Occupied) + [ (toWords dflags x, Occupied) | (r,off) <- eltsUFM regs1, - let w = localRegBytes r, - x <- [ off, off-wORD_SIZE .. off - w + 1] ] + let w = localRegBytes dflags r, + x <- [ off, off - wORD_SIZE dflags .. off - w + 1] ] in -- Pass over the stack: find slots to save all the new live variables, -- choosing the oldest slots first (hence a foldr). let save slot ([], stack, n, assigs, regs) -- no more regs to save - = ([], slot:stack, n `plusW` 1, assigs, regs) + = ([], slot:stack, plusW dflags n 1, assigs, regs) save slot (to_save, stack, n, assigs, regs) = case slot of - Occupied -> (to_save, Occupied:stack, n `plusW` 1, assigs, regs) + Occupied -> (to_save, Occupied:stack, plusW dflags n 1, assigs, regs) Empty | Just (stack', r, to_save') <- select_save to_save (slot:stack) -> let assig = CmmStore (CmmStackSlot Old n') (CmmReg (CmmLocal r)) - n' = n `plusW` 1 + n' = plusW dflags n 1 in (to_save', stack', n', assig : assigs, (r,(r,n')):regs) | otherwise - -> (to_save, slot:stack, n `plusW` 1, assigs, regs) + -> (to_save, slot:stack, plusW dflags n 1, assigs, regs) -- we should do better here: right now we'll fit the smallest first, -- but it would make more sense to fit the biggest first. @@ -656,7 +657,7 @@ allocate ret_off live stackmap@StackMap{ sm_sp = sp0 = Just (replicate words Occupied ++ rest, r, rs++no_fit) | otherwise = go rs (r:no_fit) - where words = localRegWords r + where words = localRegWords dflags r -- fill in empty slots as much as possible (still_to_save, save_stack, n, save_assigs, save_regs) @@ -669,14 +670,14 @@ allocate ret_off live stackmap@StackMap{ sm_sp = sp0 push r (n, assigs, regs) = (n', assig : assigs, (r,(r,n')) : regs) where - n' = n + localRegBytes r + n' = n + localRegBytes dflags r assig = CmmStore (CmmStackSlot Old n') (CmmReg (CmmLocal r)) trim_sp | not (null push_regs) = push_sp | otherwise - = n `plusW` (- length (takeWhile isEmpty save_stack)) + = plusW dflags n (- length (takeWhile isEmpty save_stack)) final_regs = regs1 `addListToUFM` push_regs `addListToUFM` save_regs @@ -685,7 +686,7 @@ allocate ret_off live stackmap@StackMap{ sm_sp = sp0 -- XXX should be an assert if ( n /= max sp0 ret_off ) then pprPanic "allocate" (ppr n <+> ppr sp0 <+> ppr ret_off) else - if (trim_sp .&. (wORD_SIZE - 1)) /= 0 then pprPanic "allocate2" (ppr trim_sp <+> ppr final_regs <+> ppr push_sp) else + if (trim_sp .&. (wORD_SIZE dflags - 1)) /= 0 then pprPanic "allocate2" (ppr trim_sp <+> ppr final_regs <+> ppr push_sp) else ( stackmap { sm_regs = final_regs , sm_sp = trim_sp } , push_assigs ++ save_assigs ) @@ -843,8 +844,8 @@ elimStackStores stackmap stackmaps area_off nodes -- Update info tables to include stack liveness -setInfoTableStackMap :: BlockEnv StackMap -> CmmDecl -> CmmDecl -setInfoTableStackMap stackmaps (CmmProc top_info@TopInfo{..} l g) +setInfoTableStackMap :: DynFlags -> BlockEnv StackMap -> CmmDecl -> CmmDecl +setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l g) = CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l g where fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } = @@ -855,18 +856,18 @@ setInfoTableStackMap stackmaps (CmmProc top_info@TopInfo{..} l g) get_liveness lbl = case mapLookup lbl stackmaps of Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl <+> ppr info_tbls) - Just sm -> stackMapToLiveness sm + Just sm -> stackMapToLiveness dflags sm -setInfoTableStackMap _ d = d +setInfoTableStackMap _ _ d = d -stackMapToLiveness :: StackMap -> Liveness -stackMapToLiveness StackMap{..} = +stackMapToLiveness :: DynFlags -> StackMap -> Liveness +stackMapToLiveness dflags StackMap{..} = reverse $ Array.elems $ - accumArray (\_ x -> x) True (toWords sm_ret_off + 1, - toWords (sm_sp - sm_args)) live_words + accumArray (\_ x -> x) True (toWords dflags sm_ret_off + 1, + toWords dflags (sm_sp - sm_args)) live_words where - live_words = [ (toWords off, False) + live_words = [ (toWords dflags off, False) | (r,off) <- eltsUFM sm_regs, isGcPtrType (localRegType r) ] @@ -982,8 +983,8 @@ callResumeThread new_base id = -- ----------------------------------------------------------------------------- -plusW :: ByteOff -> WordOff -> ByteOff -plusW b w = b + w * wORD_SIZE +plusW :: DynFlags -> ByteOff -> WordOff -> ByteOff +plusW dflags b w = b + w * wORD_SIZE dflags dropEmpty :: WordOff -> [StackSlot] -> Maybe [StackSlot] dropEmpty 0 ss = Just ss @@ -994,14 +995,15 @@ isEmpty :: StackSlot -> Bool isEmpty Empty = True isEmpty _ = False -localRegBytes :: LocalReg -> ByteOff -localRegBytes r = roundUpToWords (widthInBytes (typeWidth (localRegType r))) +localRegBytes :: DynFlags -> LocalReg -> ByteOff +localRegBytes dflags r + = roundUpToWords dflags (widthInBytes (typeWidth (localRegType r))) -localRegWords :: LocalReg -> WordOff -localRegWords = toWords . localRegBytes +localRegWords :: DynFlags -> LocalReg -> WordOff +localRegWords dflags = toWords dflags . localRegBytes dflags -toWords :: ByteOff -> WordOff -toWords x = x `quot` wORD_SIZE +toWords :: DynFlags -> ByteOff -> WordOff +toWords dflags x = x `quot` wORD_SIZE dflags insertReloads :: StackMap -> [CmmNode O O] diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index 0afe2a3b50..87a3ebfb5e 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -18,7 +18,6 @@ import PprCmm () import BlockId import FastString import Outputable -import Constants import DynFlags import Data.Maybe @@ -108,6 +107,7 @@ cmmCheckMachOp op _ tys = do dflags <- getDynFlags return (machOpResultType dflags op tys) +{- isOffsetOp :: MachOp -> Bool isOffsetOp (MO_Add _) = True isOffsetOp (MO_Sub _) = True @@ -117,10 +117,10 @@ isOffsetOp _ = False -- check for funny-looking sub-word offsets. _cmmCheckWordAddress :: CmmExpr -> CmmLint () _cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)]) - | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0 + | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0 = cmmLintDubiousWordOffset e _cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg]) - | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0 + | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0 = cmmLintDubiousWordOffset e _cmmCheckWordAddress _ = return () @@ -130,6 +130,7 @@ _cmmCheckWordAddress _ notNodeReg :: CmmExpr -> Bool notNodeReg (CmmReg reg) | reg == nodeReg = False notNodeReg _ = True +-} lintCmmMiddle :: CmmNode O O -> CmmLint () lintCmmMiddle node = case node of @@ -239,7 +240,10 @@ cmmLintAssignErr stmt e_ty r_ty text "Rhs ty:" <+> ppr e_ty])) +{- cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a cmmLintDubiousWordOffset expr = cmmLintErr (text "offset is not a multiple of words: " $$ nest 2 (ppr expr)) +-} + diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 7937b88ea3..3061062a4c 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -340,9 +340,10 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals_without_hints0 ')' -- closure type, live regs {% withThisPackage $ \pkg -> - do live <- sequence (map (liftM Just) $7) + do dflags <- getDynFlags + live <- sequence (map (liftM Just) $7) let prof = NoProfilingInfo - bitmap = mkLiveness live + bitmap = mkLiveness dflags live rep = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap return (mkCmmRetLabel pkg $3, CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3 @@ -888,7 +889,7 @@ adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [CmmHinted CmmExpr] adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args | platformOS (targetPlatform dflags) == OSMinGW32 = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args)))) - where size (CmmHinted e _) = max wORD_SIZE (widthInBytes (typeWidth (cmmExprType dflags e))) + where size (CmmHinted e _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e))) -- c.f. CgForeignCall.emitForeignCall adjCallTarget _ _ expr _ = expr @@ -943,8 +944,8 @@ emitRetUT args = do emitSimultaneously stmts -- NB. the args might overlap with the stack slots -- or regs that we assign to, so better use -- simultaneous assignments here (#3546) - when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp))) - stmtC $ CmmJump (entryCode dflags (CmmLoad (cmmRegOffW spReg sp) (bWord dflags))) (Just live) + when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW dflags spReg (-sp))) + stmtC $ CmmJump (entryCode dflags (CmmLoad (cmmRegOffW dflags spReg sp) (bWord dflags))) (Just live) -- ----------------------------------------------------------------------------- -- If-then-else and boolean expressions @@ -1053,7 +1054,7 @@ doSwitch mb_range scrut arms deflt initEnv :: DynFlags -> Env initEnv dflags = listToUFM [ ( fsLit "SIZEOF_StgHeader", - VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags * wORD_SIZE)) (wordWidth dflags)) )), + VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags * wORD_SIZE dflags)) (wordWidth dflags)) )), ( fsLit "SIZEOF_StgInfoTable", VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth dflags)) )) ] diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs index 6ee40d9a74..76927266ad 100644 --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -119,7 +119,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) ------------- Populate info tables with stack info ----------------- gs <- {-# SCC "setInfoTableStackMap" #-} - return $ map (setInfoTableStackMap stackmaps) gs + return $ map (setInfoTableStackMap dflags stackmaps) gs dumps Opt_D_dump_cmmz_info "after setInfoTableStackMap" gs ----------- Control-flow optimisations ----------------------------- @@ -137,7 +137,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) ------------- Populate info tables with stack info ----------------- g <- {-# SCC "setInfoTableStackMap" #-} - return $ setInfoTableStackMap stackmaps g + return $ setInfoTableStackMap dflags stackmaps g dump' Opt_D_dump_cmmz_info "after setInfoTableStackMap" g ----------- Control-flow optimisations ----------------------------- diff --git a/compiler/cmm/CmmType.hs b/compiler/cmm/CmmType.hs index 66b4c8302b..c0ce9e3d88 100644 --- a/compiler/cmm/CmmType.hs +++ b/compiler/cmm/CmmType.hs @@ -17,7 +17,6 @@ where #include "HsVersions.h" -import Constants import DynFlags import FastString import Outputable @@ -161,22 +160,22 @@ mrStr W80 = sLit("W80") -------- Common Widths ------------ wordWidth :: DynFlags -> Width -wordWidth _ - | wORD_SIZE == 4 = W32 - | wORD_SIZE == 8 = W64 - | otherwise = panic "MachOp.wordRep: Unknown word size" +wordWidth dflags + | wORD_SIZE dflags == 4 = W32 + | wORD_SIZE dflags == 8 = W64 + | otherwise = panic "MachOp.wordRep: Unknown word size" halfWordWidth :: DynFlags -> Width -halfWordWidth _ - | wORD_SIZE == 4 = W16 - | wORD_SIZE == 8 = W32 - | otherwise = panic "MachOp.halfWordRep: Unknown word size" +halfWordWidth dflags + | wORD_SIZE dflags == 4 = W16 + | wORD_SIZE dflags == 8 = W32 + | otherwise = panic "MachOp.halfWordRep: Unknown word size" halfWordMask :: DynFlags -> Integer -halfWordMask _ - | wORD_SIZE == 4 = 0xFFFF - | wORD_SIZE == 8 = 0xFFFFFFFF - | otherwise = panic "MachOp.halfWordMask: Unknown word size" +halfWordMask dflags + | wORD_SIZE dflags == 4 = 0xFFFF + | wORD_SIZE dflags == 8 = 0xFFFFFFFF + | otherwise = panic "MachOp.halfWordMask: Unknown word size" -- cIntRep is the Width for a C-language 'int' cIntWidth, cLongWidth :: Width diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs index 75bdf61ee4..9a645312a6 100644 --- a/compiler/cmm/CmmUtils.hs +++ b/compiler/cmm/CmmUtils.hs @@ -72,7 +72,7 @@ import CLabel import Outputable import Unique import UniqSupply -import Constants( wORD_SIZE, tAG_MASK ) +import Constants( tAG_MASK ) import DynFlags import Util @@ -272,16 +272,16 @@ cmmOffsetExprW dflags e (CmmLit (CmmInt n _)) = cmmOffsetW dflags e (fromIntege 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) +cmmOffsetW dflags e n = cmmOffsetB dflags e (wORD_SIZE dflags * n) -cmmRegOffW :: CmmReg -> WordOff -> CmmExpr -cmmRegOffW reg wd_off = cmmRegOffB reg (wd_off * wORD_SIZE) +cmmRegOffW :: DynFlags -> CmmReg -> WordOff -> CmmExpr +cmmRegOffW dflags reg wd_off = cmmRegOffB reg (wd_off * wORD_SIZE dflags) -cmmOffsetLitW :: CmmLit -> WordOff -> CmmLit -cmmOffsetLitW lit wd_off = cmmOffsetLitB lit (wORD_SIZE * wd_off) +cmmOffsetLitW :: DynFlags -> CmmLit -> WordOff -> CmmLit +cmmOffsetLitW dflags lit wd_off = cmmOffsetLitB lit (wORD_SIZE dflags * wd_off) -cmmLabelOffW :: CLabel -> WordOff -> CmmLit -cmmLabelOffW lbl wd_off = cmmLabelOffB lbl (wORD_SIZE * wd_off) +cmmLabelOffW :: DynFlags -> CLabel -> WordOff -> CmmLit +cmmLabelOffW dflags lbl wd_off = cmmLabelOffB lbl (wORD_SIZE dflags * wd_off) cmmLoadIndexW :: DynFlags -> CmmExpr -> Int -> CmmType -> CmmExpr cmmLoadIndexW dflags base off ty = CmmLoad (cmmOffsetW dflags base off) ty @@ -309,8 +309,8 @@ cmmNegate :: DynFlags -> CmmExpr -> CmmExpr cmmNegate _ (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep) cmmNegate dflags e = CmmMachOp (MO_S_Neg (cmmExprWidth dflags e)) [e] -blankWord :: CmmStatic -blankWord = CmmUninitialised wORD_SIZE +blankWord :: DynFlags -> CmmStatic +blankWord dflags = CmmUninitialised (wORD_SIZE dflags) --------------------------------------------------- -- @@ -371,15 +371,15 @@ cmmConstrTag1 dflags e = cmmAndWord dflags e (cmmTagMask dflags) -- --------------------------------------------- -mkLiveness :: [Maybe LocalReg] -> Liveness -mkLiveness [] = [] -mkLiveness (reg:regs) - = take sizeW bits ++ mkLiveness regs +mkLiveness :: DynFlags -> [Maybe LocalReg] -> Liveness +mkLiveness _ [] = [] +mkLiveness dflags (reg:regs) + = take sizeW bits ++ mkLiveness dflags regs where sizeW = case reg of Nothing -> 1 - Just r -> (widthInBytes (typeWidth (localRegType r)) + wORD_SIZE - 1) - `quot` wORD_SIZE + Just r -> (widthInBytes (typeWidth (localRegType r)) + wORD_SIZE dflags - 1) + `quot` wORD_SIZE dflags -- number of words, rounded up bits = repeat $ is_non_ptr reg -- True <=> Non Ptr diff --git a/compiler/cmm/OldCmmLint.hs b/compiler/cmm/OldCmmLint.hs index 9146aa74a3..5dd3209892 100644 --- a/compiler/cmm/OldCmmLint.hs +++ b/compiler/cmm/OldCmmLint.hs @@ -22,7 +22,6 @@ import OldCmm import CLabel import Outputable import OldPprCmm() -import Constants import FastString import DynFlags @@ -97,6 +96,7 @@ cmmCheckMachOp dflags op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys cmmCheckMachOp dflags op _ tys = return (machOpResultType dflags op tys) +{- isOffsetOp :: MachOp -> Bool isOffsetOp (MO_Add _) = True isOffsetOp (MO_Sub _) = True @@ -106,10 +106,10 @@ isOffsetOp _ = False -- check for funny-looking sub-word offsets. _cmmCheckWordAddress :: CmmExpr -> CmmLint () _cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)]) - | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0 + | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0 = cmmLintDubiousWordOffset e _cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg]) - | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0 + | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0 = cmmLintDubiousWordOffset e _cmmCheckWordAddress _ = return () @@ -119,6 +119,7 @@ _cmmCheckWordAddress _ notNodeReg :: CmmExpr -> Bool notNodeReg (CmmReg reg) | reg == nodeReg = False notNodeReg _ = True +-} lintCmmStmt :: DynFlags -> BlockSet -> CmmStmt -> CmmLint () lintCmmStmt dflags labels = lint @@ -204,7 +205,10 @@ cmmLintAssignErr stmt e_ty r_ty +{- cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a cmmLintDubiousWordOffset expr = cmmLintErr (text "offset is not a multiple of words: " $$ nest 2 (ppr expr)) +-} + diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index b40b34aaa5..e6c9ac3a15 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -374,7 +374,7 @@ pprLoad dflags e ty -> char '*' <> pprAsPtrReg r CmmRegOff r off | isPtrReg r && width == wordWidth dflags - , off `rem` wORD_SIZE == 0 && not (isFloatType ty) + , off `rem` wORD_SIZE dflags == 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 dflags)) @@ -480,9 +480,9 @@ 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 + | wORD_SIZE dflags == 8, CmmStaticLit (CmmInt 0 W32) : rest' <- rest = pprLit1 (floatToWord dflags f) : pprStatics dflags rest' - | wORD_SIZE == 4 + | wORD_SIZE dflags == 4 = pprLit1 (floatToWord dflags f) : pprStatics dflags rest | otherwise = pprPanic "pprStatics: float" (vcat (map ppr' rest)) @@ -721,7 +721,7 @@ pprAssign _ r1 (CmmReg r2) -- dest is a reg, rhs is a CmmRegOff pprAssign dflags r1 (CmmRegOff r2 off) - | isPtrReg r1 && isPtrReg r2 && (off `rem` wORD_SIZE == 0) + | isPtrReg r1 && isPtrReg r2 && (off `rem` wORD_SIZE dflags == 0) = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ] where off1 = off `shiftR` wordShift dflags @@ -911,7 +911,7 @@ pprExternDecl _in_srt lbl -- add the @n suffix to the label (#2276) stdcall_decl sz = sdocWithDynFlags $ \dflags -> ptext (sLit "extern __attribute__((stdcall)) void ") <> ppr lbl - <> parens (commafy (replicate (sz `quot` wORD_SIZE) (machRep_U_CType (wordWidth dflags)))) + <> parens (commafy (replicate (sz `quot` wORD_SIZE dflags) (machRep_U_CType (wordWidth dflags)))) <> semi type TEState = (UniqSet LocalReg, Map CLabel ()) @@ -1059,10 +1059,10 @@ pprStringInCStyle s = doubleQuotes (text (concatMap charToC s)) -- This is a hack to turn the floating point numbers into ints that we -- can safely initialise to static locations. -big_doubles :: Bool -big_doubles - | widthInBytes W64 == 2 * wORD_SIZE = True - | widthInBytes W64 == wORD_SIZE = False +big_doubles :: DynFlags -> Bool +big_doubles dflags + | widthInBytes W64 == 2 * wORD_SIZE dflags = True + | widthInBytes W64 == wORD_SIZE dflags = False | otherwise = panic "big_doubles" castFloatToIntArray :: STUArray s Int Float -> ST s (STUArray s Int Int) @@ -1084,7 +1084,7 @@ floatToWord dflags r doubleToWords :: DynFlags -> Rational -> [CmmLit] doubleToWords dflags r - | big_doubles -- doubles are 2 words + | big_doubles dflags -- doubles are 2 words = runST (do arr <- newArray_ ((0::Int),1) writeArray arr 0 (fromRational r) diff --git a/compiler/cmm/SMRep.lhs b/compiler/cmm/SMRep.lhs index 79e19105a9..2c9cb32ec0 100644 --- a/compiler/cmm/SMRep.lhs +++ b/compiler/cmm/SMRep.lhs @@ -45,7 +45,6 @@ module SMRep ( #include "../includes/MachDeps.h" import DynFlags -import Constants import Outputable import FastString @@ -65,8 +64,8 @@ import Data.Bits type WordOff = Int -- Word offset, or word count type ByteOff = Int -- Byte offset, or byte count -roundUpToWords :: ByteOff -> ByteOff -roundUpToWords n = (n + (wORD_SIZE - 1)) .&. (complement (wORD_SIZE - 1)) +roundUpToWords :: DynFlags -> ByteOff -> ByteOff +roundUpToWords dflags n = (n + (wORD_SIZE dflags - 1)) .&. (complement (wORD_SIZE dflags - 1)) \end{code} StgWord is a type representing an StgWord on the target platform. @@ -235,17 +234,17 @@ minClosureSize dflags = fixedHdrSize dflags + mIN_PAYLOAD_SIZE dflags arrWordsHdrSize :: DynFlags -> ByteOff arrWordsHdrSize dflags - = fixedHdrSize dflags * wORD_SIZE + sIZEOF_StgArrWords_NoHdr dflags + = fixedHdrSize dflags * wORD_SIZE dflags + sIZEOF_StgArrWords_NoHdr dflags arrPtrsHdrSize :: DynFlags -> ByteOff arrPtrsHdrSize dflags - = fixedHdrSize dflags * wORD_SIZE + sIZEOF_StgMutArrPtrs_NoHdr dflags + = fixedHdrSize dflags * wORD_SIZE dflags + sIZEOF_StgMutArrPtrs_NoHdr dflags -- Thunks have an extra header word on SMP, so the update doesn't -- splat the payload. thunkHdrSize :: DynFlags -> WordOff thunkHdrSize dflags = fixedHdrSize dflags + smp_hdr - where smp_hdr = sIZEOF_StgSMPThunkHeader dflags `quot` wORD_SIZE + where smp_hdr = sIZEOF_StgSMPThunkHeader dflags `quot` wORD_SIZE dflags nonHdrSize :: SMRep -> WordOff diff --git a/compiler/codeGen/CgBindery.lhs b/compiler/codeGen/CgBindery.lhs index 7fe79804fa..4cb12a8194 100644 --- a/compiler/codeGen/CgBindery.lhs +++ b/compiler/codeGen/CgBindery.lhs @@ -38,8 +38,8 @@ import CgStackery import CgUtils import CLabel import ClosureInfo -import Constants +import DynFlags import OldCmm import PprCmm ( {- instance Outputable -} ) import SMRep @@ -184,8 +184,8 @@ letNoEscapeIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLNE sp) lf_ stackIdInfo :: Id -> VirtualSpOffset -> LambdaFormInfo -> CgIdInfo stackIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLoc sp) lf_info -nodeIdInfo :: Id -> Int -> LambdaFormInfo -> CgIdInfo -nodeIdInfo id offset lf_info = mkCgIdInfo id (VirNodeLoc (wORD_SIZE*offset)) NoStableLoc lf_info +nodeIdInfo :: DynFlags -> Id -> Int -> LambdaFormInfo -> CgIdInfo +nodeIdInfo dflags id offset lf_info = mkCgIdInfo id (VirNodeLoc (wORD_SIZE dflags * offset)) NoStableLoc lf_info regIdInfo :: Id -> CmmReg -> LambdaFormInfo -> CgIdInfo regIdInfo id reg lf_info = mkCgIdInfo id (RegLoc reg) NoStableLoc lf_info @@ -199,9 +199,9 @@ taggedHeapIdInfo :: Id -> VirtualHpOffset -> LambdaFormInfo -> DataCon taggedHeapIdInfo id offset lf_info con = mkTaggedCgIdInfo id (VirHpLoc offset) NoStableLoc lf_info con -untagNodeIdInfo :: Id -> Int -> LambdaFormInfo -> Int -> CgIdInfo -untagNodeIdInfo id offset lf_info tag - = mkCgIdInfo id (VirNodeLoc (wORD_SIZE*offset - tag)) NoStableLoc lf_info +untagNodeIdInfo :: DynFlags -> Id -> Int -> LambdaFormInfo -> Int -> CgIdInfo +untagNodeIdInfo dflags id offset lf_info tag + = mkCgIdInfo id (VirNodeLoc (wORD_SIZE dflags * offset - tag)) NoStableLoc lf_info idInfoToAmode :: CgIdInfo -> FCode CmmExpr @@ -440,11 +440,13 @@ bindArgsToRegs args bindNewToNode :: Id -> VirtualHpOffset -> LambdaFormInfo -> Code bindNewToNode id offset lf_info - = addBindC id (nodeIdInfo id offset lf_info) + = do dflags <- getDynFlags + addBindC id (nodeIdInfo dflags id offset lf_info) bindNewToUntagNode :: Id -> VirtualHpOffset -> LambdaFormInfo -> Int -> Code bindNewToUntagNode id offset lf_info tag - = addBindC id (untagNodeIdInfo id offset lf_info tag) + = do dflags <- getDynFlags + addBindC id (untagNodeIdInfo dflags id offset lf_info tag) -- Create a new temporary whose unique is that in the id, -- bind the id to it, and return the addressing mode for the @@ -497,9 +499,10 @@ Probably *naughty* to look inside monad... nukeDeadBindings :: StgLiveVars -- All the *live* variables -> Code nukeDeadBindings live_vars = do + dflags <- getDynFlags binds <- getBinds let (dead_stk_slots, bs') = - dead_slots live_vars + dead_slots dflags live_vars [] [] [ (cg_id b, b) | b <- varEnvElts binds ] setBinds $ mkVarEnv bs' @@ -509,7 +512,8 @@ nukeDeadBindings live_vars = do Several boring auxiliary functions to do the dirty work. \begin{code} -dead_slots :: StgLiveVars +dead_slots :: DynFlags + -> StgLiveVars -> [(Id,CgIdInfo)] -> [VirtualSpOffset] -> [(Id,CgIdInfo)] @@ -517,12 +521,12 @@ dead_slots :: StgLiveVars -- dead_slots carries accumulating parameters for -- filtered bindings, dead slots -dead_slots _ fbs ds [] +dead_slots _ _ fbs ds [] = (ds, reverse fbs) -- Finished; rm the dups, if any -dead_slots live_vars fbs ds ((v,i):bs) +dead_slots dflags live_vars fbs ds ((v,i):bs) | v `elementOfUniqSet` live_vars - = dead_slots live_vars ((v,i):fbs) ds bs + = dead_slots dflags live_vars ((v,i):fbs) ds bs -- Live, so don't record it in dead slots -- Instead keep it in the filtered bindings @@ -530,12 +534,12 @@ dead_slots live_vars fbs ds ((v,i):bs) = case cg_stb i of VirStkLoc offset | size > 0 - -> dead_slots live_vars fbs ([offset-size+1 .. offset] ++ ds) bs + -> dead_slots dflags live_vars fbs ([offset-size+1 .. offset] ++ ds) bs - _ -> dead_slots live_vars fbs ds bs + _ -> dead_slots dflags live_vars fbs ds bs where size :: WordOff - size = cgRepSizeW (cg_rep i) + size = cgRepSizeW dflags (cg_rep i) getLiveStackSlots :: FCode [VirtualSpOffset] -- Return the offsets of slots in stack containig live pointers diff --git a/compiler/codeGen/CgCallConv.hs b/compiler/codeGen/CgCallConv.hs index 2be57893dd..45edd64666 100644 --- a/compiler/codeGen/CgCallConv.hs +++ b/compiler/codeGen/CgCallConv.hs @@ -66,18 +66,18 @@ import Data.Bits ------------------------- mkArgDescr :: Name -> [Id] -> FCode ArgDescr mkArgDescr _nm args - = case stdPattern arg_reps of - Just spec_id -> return (ArgSpec spec_id) - Nothing -> return (ArgGen arg_bits) - where - arg_bits = argBits arg_reps - arg_reps = filter nonVoidArg (map idCgRep args) - -- Getting rid of voids eases matching of standard patterns - -argBits :: [CgRep] -> [Bool] -- True for non-ptr, False for ptr -argBits [] = [] -argBits (PtrArg : args) = False : argBits args -argBits (arg : args) = take (cgRepSizeW arg) (repeat True) ++ argBits args + = do dflags <- getDynFlags + let arg_bits = argBits dflags arg_reps + arg_reps = filter nonVoidArg (map idCgRep args) + -- Getting rid of voids eases matching of standard patterns + case stdPattern arg_reps of + Just spec_id -> return (ArgSpec spec_id) + Nothing -> return (ArgGen arg_bits) + +argBits :: DynFlags -> [CgRep] -> [Bool] -- True for non-ptr, False for ptr +argBits _ [] = [] +argBits dflags (PtrArg : args) = False : argBits dflags args +argBits dflags (arg : args) = take (cgRepSizeW dflags arg) (repeat True) ++ argBits dflags args stdPattern :: [CgRep] -> Maybe StgHalfWord stdPattern [] = Just ARG_NONE -- just void args, probably diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs index fce910489e..0ed87384d3 100644 --- a/compiler/codeGen/CgClosure.lhs +++ b/compiler/codeGen/CgClosure.lhs @@ -279,7 +279,7 @@ closureCodeBody _binder_info cl_info cc args body -- eg. if we're compiling a let-no-escape). ; vSp <- getVirtSp ; let (reg_args, other_args) = assignCallRegs dflags (addIdReps args) - (sp_top, stk_args) = mkVirtStkOffsets vSp other_args + (sp_top, stk_args) = mkVirtStkOffsets dflags vSp other_args -- Allocate the global ticky counter ; let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) (clHasCafRefs cl_info) @@ -365,22 +365,22 @@ mkSlowEntryCode dflags cl_info reg_args reps_w_regs :: [(CgRep,GlobalReg)] reps_w_regs = [(idCgRep id, reg) | (id,reg) <- reverse reg_args] (final_stk_offset, stk_offsets) - = mapAccumL (\off (rep,_) -> (off + cgRepSizeW rep, off)) + = mapAccumL (\off (rep,_) -> (off + cgRepSizeW dflags rep, off)) 0 reps_w_regs load_assts = zipWithEqual "mk_load" mk_load reps_w_regs stk_offsets mk_load (rep,reg) offset = CmmAssign (CmmGlobal reg) - (CmmLoad (cmmRegOffW spReg offset) + (CmmLoad (cmmRegOffW dflags spReg offset) (argMachRep dflags rep)) save_assts = zipWithEqual "mk_save" mk_save reps_w_regs stk_offsets mk_save (rep,reg) offset = ASSERT( argMachRep dflags rep `cmmEqType` globalRegType dflags reg ) - CmmStore (cmmRegOffW spReg offset) + CmmStore (cmmRegOffW dflags spReg offset) (CmmReg (CmmGlobal reg)) - stk_adj_pop = CmmAssign spReg (cmmRegOffW spReg final_stk_offset) - stk_adj_push = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset)) + stk_adj_pop = CmmAssign spReg (cmmRegOffW dflags spReg final_stk_offset) + stk_adj_push = CmmAssign spReg (cmmRegOffW dflags spReg (- final_stk_offset)) live_regs = Just $ map snd reps_w_regs jump_to_entry = CmmJump (mkLblExpr (entryLabelFromCI dflags cl_info)) live_regs \end{code} diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs index 8afbc8f64e..c2d99541c6 100644 --- a/compiler/codeGen/CgCon.lhs +++ b/compiler/codeGen/CgCon.lhs @@ -192,7 +192,7 @@ buildDynCon' dflags platform binder _ con [arg_amode] = do { let intlike_lbl = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_INTLIKE_closure") offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSize dflags + 1) -- INTLIKE closures consist of a header and one word payload - intlike_amode = CmmLit (cmmLabelOffW intlike_lbl offsetW) + intlike_amode = CmmLit (cmmLabelOffW dflags intlike_lbl offsetW) ; returnFC (taggedStableIdInfo binder intlike_amode (mkConLFInfo con) con) } buildDynCon' dflags platform binder _ con [arg_amode] @@ -204,7 +204,7 @@ buildDynCon' dflags platform binder _ con [arg_amode] = do { let charlike_lbl = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_CHARLIKE_closure") offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSize dflags + 1) -- CHARLIKE closures consist of a header and one word payload - charlike_amode = CmmLit (cmmLabelOffW charlike_lbl offsetW) + charlike_amode = CmmLit (cmmLabelOffW dflags charlike_lbl offsetW) ; returnFC (taggedStableIdInfo binder charlike_amode (mkConLFInfo con) con) } \end{code} @@ -284,8 +284,8 @@ bindUnboxedTupleComponents args -- Allocate the rest on the stack -- The real SP points to the return address, above which any -- leftover unboxed-tuple components will be allocated - (ptr_sp, ptr_offsets) = mkVirtStkOffsets rsp ptr_args - (nptr_sp, nptr_offsets) = mkVirtStkOffsets ptr_sp nptr_args + (ptr_sp, ptr_offsets) = mkVirtStkOffsets dflags rsp ptr_args + (nptr_sp, nptr_offsets) = mkVirtStkOffsets dflags ptr_sp nptr_args ptrs = ptr_sp - rsp nptrs = nptr_sp - ptr_sp diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs index 435fbb0558..824a82635d 100644 --- a/compiler/codeGen/CgForeignCall.hs +++ b/compiler/codeGen/CgForeignCall.hs @@ -30,7 +30,6 @@ import OldCmm import OldCmmUtils import SMRep import ForeignCall -import Constants import DynFlags import Outputable import Module @@ -103,7 +102,7 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live = do | otherwise = Nothing -- ToDo: this might not be correct for 64-bit API - arg_size rep = max (widthInBytes (typeWidth rep)) wORD_SIZE + arg_size rep = max (widthInBytes (typeWidth rep)) (wORD_SIZE dflags) vols <- getVolatileRegs live srt <- getSRTInfo emitForeignCall' safety results @@ -286,7 +285,7 @@ stack_STACK dflags = closureField dflags (oFFSET_StgStack_stack dflags) stack_SP dflags = closureField dflags (oFFSET_StgStack_sp dflags) closureField :: DynFlags -> ByteOff -> ByteOff -closureField dflags off = off + fixedHdrSize dflags * wORD_SIZE +closureField dflags off = off + fixedHdrSize dflags * wORD_SIZE dflags stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr stgSp = CmmReg sp diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs index f3cb7796f4..c7f6f294ce 100644 --- a/compiler/codeGen/CgHeapery.lhs +++ b/compiler/codeGen/CgHeapery.lhs @@ -42,7 +42,6 @@ import TyCon import CostCentre import Util import Module -import Constants import Outputable import DynFlags import FastString @@ -103,8 +102,9 @@ setRealHp new_realHp getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr getHpRelOffset virtual_offset - = do { hp_usg <- getHpUsage - ; return (cmmRegOffW hpReg (hpRel (realHp hp_usg) virtual_offset)) } + = do { dflags <- getDynFlags + ; hp_usg <- getHpUsage + ; return (cmmRegOffW dflags hpReg (hpRel (realHp hp_usg) virtual_offset)) } \end{code} @@ -165,7 +165,7 @@ mkVirtHeapOffsets dflags is_thunk things | otherwise = fixedHdrSize dflags computeOffset wds_so_far (rep, thing) - = (wds_so_far + cgRepSizeW rep, (thing, hdr_size + wds_so_far)) + = (wds_so_far + cgRepSizeW dflags rep, (thing, hdr_size + wds_so_far)) \end{code} @@ -244,7 +244,7 @@ mkStaticClosure dflags info_lbl ccs payload padding_wds static_link_field saved_ padLitToWord :: DynFlags -> CmmLit -> [CmmLit] padLitToWord dflags lit = lit : padding pad_length where width = typeWidth (cmmLitType dflags lit) - pad_length = wORD_SIZE - widthInBytes width :: Int + pad_length = wORD_SIZE dflags - widthInBytes width :: Int padding n | n <= 0 = [] | n `rem` 2 /= 0 = CmmInt 0 W8 : padding (n-1) @@ -461,8 +461,8 @@ do_checks stk hp reg_save_code rts_lbl live "See: http://hackage.haskell.org/trac/ghc/ticket/4505", "Suggestion: read data from a file instead of having large static data", "structures in the code."]) - else do_checks' (mkIntExpr dflags (stk * wORD_SIZE)) - (mkIntExpr dflags (hp * wORD_SIZE)) + else do_checks' (mkIntExpr dflags (stk * wORD_SIZE dflags)) + (mkIntExpr dflags (hp * wORD_SIZE dflags)) (stk /= 0) (hp /= 0) reg_save_code rts_lbl live -- The offsets are now in *bytes* diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs index ce4228e0fc..03c0edde36 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -43,7 +43,6 @@ import CLabel import Name import Unique -import Constants import DynFlags import Util import Outputable @@ -94,16 +93,17 @@ emitReturnTarget -> CgStmts -- The direct-return code (if any) -> FCode CLabel emitReturnTarget name stmts - = do { srt_info <- getSRTInfo - ; blks <- cgStmtsToBlocks stmts - ; frame <- mkStackLayout - ; let smrep = mkStackRep (mkLiveness frame) - info = CmmInfoTable { cit_lbl = info_lbl - , cit_prof = NoProfilingInfo - , cit_rep = smrep - , cit_srt = srt_info } - ; emitInfoTableAndCode entry_lbl info args blks - ; return info_lbl } + = do dflags <- getDynFlags + srt_info <- getSRTInfo + blks <- cgStmtsToBlocks stmts + frame <- mkStackLayout + let smrep = mkStackRep (mkLiveness dflags frame) + info = CmmInfoTable { cit_lbl = info_lbl + , cit_prof = NoProfilingInfo + , cit_rep = smrep + , cit_srt = srt_info } + emitInfoTableAndCode entry_lbl info args blks + return info_lbl where args = {- trace "emitReturnTarget: missing args" -} [] uniq = getUnique name @@ -173,7 +173,7 @@ stack_layout _ [] sizeW = replicate sizeW Nothing stack_layout dflags ((off, bind):binds) sizeW | off == sizeW - 1 = (Just stack_bind) : (stack_layout dflags binds (sizeW - rep_size)) where - rep_size = cgRepSizeW (cgIdInfoArgRep bind) + rep_size = cgRepSizeW dflags (cgIdInfoArgRep bind) stack_bind = LocalReg unique machRep unique = getUnique (cgIdInfoId bind) machRep = argMachRep dflags (cgIdInfoArgRep bind) @@ -258,7 +258,7 @@ stdInfoTableSizeW dflags | otherwise = 0 stdInfoTableSizeB :: DynFlags -> ByteOff -stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE +stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE dflags stdSrtBitmapOffset :: DynFlags -> ByteOff -- Byte offset of the SRT bitmap half-word which is @@ -267,11 +267,11 @@ stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE stdClosureTypeOffset :: DynFlags -> ByteOff -- Byte offset of the closure type half-word -stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE +stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff -stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2*wORD_SIZE -stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2*wORD_SIZE + hALF_WORD_SIZE +stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags +stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE ------------------------------------------------------------------------- -- diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs index 854a81a101..98c7e21332 100644 --- a/compiler/codeGen/CgPrimOp.hs +++ b/compiler/codeGen/CgPrimOp.hs @@ -28,7 +28,6 @@ import OldCmmUtils import PrimOp import SMRep import Module -import Constants import Outputable import DynFlags import FastString @@ -851,7 +850,7 @@ doWritePtrArrayOp addr idx val loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB dflags addr off) (bWord dflags) - where off = fixedHdrSize dflags * wORD_SIZE + oFFSET_StgMutArrPtrs_ptrs dflags + where off = fixedHdrSize dflags * wORD_SIZE dflags + oFFSET_StgMutArrPtrs_ptrs dflags mkBasicIndexedRead :: ByteOff -> Maybe MachOp -> CmmType -> LocalReg -> CmmExpr -> CmmExpr -> Code @@ -967,7 +966,7 @@ doCopyArrayOp = emitCopyArray copy -- they're of different types) copy _src _dst dst_p src_p bytes live = do dflags <- getDynFlags - emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit dflags wORD_SIZE)) live + emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit dflags (wORD_SIZE dflags))) live -- | Takes a source 'MutableArray#', an offset in the source array, a -- destination 'MutableArray#', an offset into the destination array, @@ -983,8 +982,8 @@ doCopyMutableArrayOp = emitCopyArray copy copy src dst dst_p src_p bytes 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) + (emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit dflags (wORD_SIZE dflags))) live) + (emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit dflags (wORD_SIZE dflags))) live) emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code) @@ -1007,7 +1006,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 dflags n (CmmLit (mkIntCLit dflags wORD_SIZE)) + bytes <- assignTemp $ cmmMulWord dflags n (CmmLit (mkIntCLit dflags (wORD_SIZE dflags))) copy src dst dst_p src_p bytes live @@ -1025,7 +1024,7 @@ emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> CmmExpr emitCloneArray info_p res_r src0 src_off0 n0 live = do dflags <- getDynFlags let arrPtrsHdrSizeW dflags = CmmLit $ mkIntCLit dflags $ fixedHdrSize dflags + - (sIZEOF_StgMutArrPtrs_NoHdr dflags `div` wORD_SIZE) + (sIZEOF_StgMutArrPtrs_NoHdr dflags `div` wORD_SIZE dflags) myCapability = cmmSubWord dflags (CmmReg baseReg) (CmmLit (mkIntCLit dflags (oFFSET_Capability_r dflags))) -- Assign the arguments to temporaries so the code generator can @@ -1045,9 +1044,9 @@ emitCloneArray info_p res_r src0 src_off0 n0 live = do let arr = CmmReg (CmmLocal arr_r) emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCS - stmtC $ CmmStore (cmmOffsetB dflags arr (fixedHdrSize dflags * wORD_SIZE + + stmtC $ CmmStore (cmmOffsetB dflags arr (fixedHdrSize dflags * wORD_SIZE dflags + oFFSET_StgMutArrPtrs_ptrs dflags)) n - stmtC $ CmmStore (cmmOffsetB dflags arr (fixedHdrSize dflags * wORD_SIZE + + stmtC $ CmmStore (cmmOffsetB dflags arr (fixedHdrSize dflags * wORD_SIZE dflags + oFFSET_StgMutArrPtrs_size dflags)) size dst_p <- assignTemp $ cmmOffsetB dflags arr (arrPtrsHdrSize dflags) @@ -1055,12 +1054,12 @@ emitCloneArray info_p res_r src0 src_off0 n0 live = do src_off emitMemcpyCall dst_p src_p (cmmMulWord dflags n (wordSize dflags)) - (CmmLit (mkIntCLit dflags wORD_SIZE)) live + (CmmLit (mkIntCLit dflags (wORD_SIZE dflags))) live emitMemsetCall (cmmOffsetExprW dflags dst_p n) (CmmLit (mkIntCLit dflags 1)) card_bytes - (CmmLit (mkIntCLit dflags wORD_SIZE)) + (CmmLit (mkIntCLit dflags (wORD_SIZE dflags))) live stmtC $ CmmAssign (CmmLocal res_r) arr @@ -1088,11 +1087,11 @@ cardRoundUp dflags i = card dflags (cmmAddWord dflags i (CmmLit (mkIntCLit dflag bytesToWordsRoundUp :: DynFlags -> CmmExpr -> CmmExpr bytesToWordsRoundUp dflags e = cmmQuotWord dflags - (cmmAddWord dflags e (CmmLit (mkIntCLit dflags (wORD_SIZE - 1)))) + (cmmAddWord dflags e (CmmLit (mkIntCLit dflags (wORD_SIZE dflags - 1)))) (wordSize dflags) wordSize :: DynFlags -> CmmExpr -wordSize dflags = CmmLit (mkIntCLit dflags wORD_SIZE) +wordSize dflags = CmmLit (mkIntCLit dflags (wORD_SIZE dflags)) -- | Emit a call to @memcpy@. emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs index 19376b95ca..4a611d1e1d 100644 --- a/compiler/codeGen/CgProf.hs +++ b/compiler/codeGen/CgProf.hs @@ -45,7 +45,6 @@ import CostCentre import DynFlags import FastString import Module -import Constants -- Lots of field offsets import Outputable import Data.Char @@ -203,7 +202,9 @@ emitCostCentreStackDecl ccs -- pad out the struct with zero words until we hit the -- size of the overall struct (which we get via DerivedConstants.h) -- - lits = zero dflags : mkCCostCentre cc : replicate (sizeof_ccs_words - 2) (zero dflags) + lits = zero dflags + : mkCCostCentre cc + : replicate (sizeof_ccs_words dflags - 2) (zero dflags) ; emitDataLits (mkCCSLabel ccs) lits } | otherwise = pprPanic "emitCostCentreStackDecl" (ppr ccs) @@ -213,13 +214,13 @@ zero dflags = mkIntCLit dflags 0 zero64 :: CmmLit zero64 = CmmInt 0 W64 -sizeof_ccs_words :: Int -sizeof_ccs_words +sizeof_ccs_words :: DynFlags -> Int +sizeof_ccs_words dflags -- round up to the next word. | ms == 0 = ws | otherwise = ws + 1 where - (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE + (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE dflags -- --------------------------------------------------------------------------- -- Set the current cost centre stack diff --git a/compiler/codeGen/CgStackery.lhs b/compiler/codeGen/CgStackery.lhs index 7c4caf4e1d..2f7bdfc083 100644 --- a/compiler/codeGen/CgStackery.lhs +++ b/compiler/codeGen/CgStackery.lhs @@ -37,7 +37,6 @@ import SMRep import OldCmm import OldCmmUtils import CLabel -import Constants import DynFlags import Util import OrdList @@ -101,8 +100,9 @@ setRealSp new_real_sp getSpRelOffset :: VirtualSpOffset -> FCode CmmExpr getSpRelOffset virtual_offset - = do { real_sp <- getRealSp - ; return (cmmRegOffW spReg (spRel real_sp virtual_offset)) } + = do dflags <- getDynFlags + real_sp <- getRealSp + return (cmmRegOffW dflags spReg (spRel real_sp virtual_offset)) \end{code} @@ -118,12 +118,13 @@ increase towards the top of stack). \begin{code} mkVirtStkOffsets - :: VirtualSpOffset -- Offset of the last allocated thing + :: DynFlags + -> VirtualSpOffset -- Offset of the last allocated thing -> [(CgRep,a)] -- things to make offsets for -> (VirtualSpOffset, -- OUTPUTS: Topmost allocated word [(a, VirtualSpOffset)]) -- things with offsets (voids filtered out) -mkVirtStkOffsets init_Sp_offset things +mkVirtStkOffsets dflags init_Sp_offset things = loop init_Sp_offset [] (reverse things) where loop offset offs [] = (offset,offs) @@ -132,7 +133,7 @@ mkVirtStkOffsets init_Sp_offset things loop offset offs ((rep,t):things) = loop thing_slot ((t,thing_slot):offs) things where - thing_slot = offset + cgRepSizeW rep + thing_slot = offset + cgRepSizeW dflags rep -- offset of thing is offset+size, because we're -- growing the stack *downwards* as the offsets increase. @@ -149,12 +150,13 @@ mkStkAmodes CmmStmts) -- Assignments to appropriate stk slots mkStkAmodes tail_Sp things - = do { rSp <- getRealSp - ; let (last_Sp_offset, offsets) = mkVirtStkOffsets tail_Sp things - abs_cs = [ CmmStore (cmmRegOffW spReg (spRel rSp offset)) amode - | (amode, offset) <- offsets - ] - ; returnFC (last_Sp_offset, toOL abs_cs) } + = do dflags <- getDynFlags + rSp <- getRealSp + let (last_Sp_offset, offsets) = mkVirtStkOffsets dflags tail_Sp things + abs_cs = [ CmmStore (cmmRegOffW dflags spReg (spRel rSp offset)) amode + | (amode, offset) <- offsets + ] + returnFC (last_Sp_offset, toOL abs_cs) \end{code} %************************************************************************ @@ -167,7 +169,11 @@ Allocate a virtual offset for something. \begin{code} allocPrimStack :: CgRep -> FCode VirtualSpOffset -allocPrimStack rep +allocPrimStack rep = do dflags <- getDynFlags + allocPrimStack' dflags rep + +allocPrimStack' :: DynFlags -> CgRep -> FCode VirtualSpOffset +allocPrimStack' dflags rep = do { stk_usg <- getStkUsage ; let free_stk = freeStk stk_usg ; case find_block free_stk of @@ -183,7 +189,7 @@ allocPrimStack rep } where size :: WordOff - size = cgRepSizeW rep + size = cgRepSizeW dflags rep -- Find_block looks for a contiguous chunk of free slots -- returning the offset of its topmost word @@ -289,7 +295,7 @@ pushSpecUpdateFrame lbl updatee code ; MASSERT(case sequel of { OnStack -> True; _ -> False}) } ; dflags <- getDynFlags ; allocStackTop (fixedHdrSize dflags + - sIZEOF_StgUpdateFrame_NoHdr dflags `quot` wORD_SIZE) + sIZEOF_StgUpdateFrame_NoHdr dflags `quot` wORD_SIZE dflags) ; vsp <- getVirtSp ; setStackFrame vsp ; frame_addr <- getSpRelOffset vsp @@ -322,7 +328,7 @@ emitSpecPushUpdateFrame lbl frame_addr updatee = do off_updatee :: DynFlags -> ByteOff off_updatee dflags - = fixedHdrSize dflags * wORD_SIZE + (oFFSET_StgUpdateFrame_updatee dflags) + = fixedHdrSize dflags * wORD_SIZE dflags + oFFSET_StgUpdateFrame_updatee dflags \end{code} diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 228c5bd2c6..ab64f56c4b 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -800,7 +800,7 @@ getSRTInfo = do -> do id <- newUnique let srt_desc_lbl = mkLargeSRTLabel id emitRODataLits "getSRTInfo" srt_desc_lbl - ( cmmLabelOffW srt_lbl off + ( cmmLabelOffW dflags srt_lbl off : mkWordCLit dflags (fromIntegral len) : map (mkWordCLit dflags) bmp) return (C_SRT srt_desc_lbl 0 srt_escape) diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs index 1b1c360f83..6b6bd8b294 100644 --- a/compiler/codeGen/ClosureInfo.lhs +++ b/compiler/codeGen/ClosureInfo.lhs @@ -342,17 +342,17 @@ separateByPtrFollowness things \end{code} \begin{code} -cgRepSizeB :: CgRep -> ByteOff -cgRepSizeB DoubleArg = dOUBLE_SIZE -cgRepSizeB LongArg = wORD64_SIZE -cgRepSizeB VoidArg = 0 -cgRepSizeB _ = wORD_SIZE - -cgRepSizeW :: CgRep -> ByteOff -cgRepSizeW DoubleArg = dOUBLE_SIZE `quot` wORD_SIZE -cgRepSizeW LongArg = wORD64_SIZE `quot` wORD_SIZE -cgRepSizeW VoidArg = 0 -cgRepSizeW _ = 1 +cgRepSizeB :: DynFlags -> CgRep -> ByteOff +cgRepSizeB _ DoubleArg = dOUBLE_SIZE +cgRepSizeB _ LongArg = wORD64_SIZE +cgRepSizeB _ VoidArg = 0 +cgRepSizeB dflags _ = wORD_SIZE dflags + +cgRepSizeW :: DynFlags -> CgRep -> ByteOff +cgRepSizeW dflags DoubleArg = dOUBLE_SIZE `quot` wORD_SIZE dflags +cgRepSizeW dflags LongArg = wORD64_SIZE `quot` wORD_SIZE dflags +cgRepSizeW _ VoidArg = 0 +cgRepSizeW _ _ = 1 retAddrSizeW :: WordOff retAddrSizeW = 1 -- One word diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index aac1abfe0c..8f93303630 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -43,7 +43,6 @@ import Module import ListSetOps import Util import BasicTypes -import Constants import Outputable import FastString import Maybes @@ -634,7 +633,7 @@ pushUpdateFrame lbl updatee body updfr <- getUpdFrameOff dflags <- getDynFlags let - hdr = fixedHdrSize dflags * wORD_SIZE + hdr = fixedHdrSize dflags * wORD_SIZE dflags frame = updfr + hdr + sIZEOF_StgUpdateFrame_NoHdr dflags off_updatee = hdr + oFFSET_StgUpdateFrame_updatee dflags -- diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index 0e0f2f13f8..124e0cd9d3 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -189,7 +189,7 @@ buildDynCon' dflags platform binder _cc con [arg] val_int = fromIntegral val :: Int offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSize dflags + 1) -- INTLIKE closures consist of a header and one word payload - intlike_amode = cmmLabelOffW intlike_lbl offsetW + intlike_amode = cmmLabelOffW dflags intlike_lbl offsetW ; return ( litIdInfo dflags binder (mkConLFInfo con) intlike_amode , return mkNop) } @@ -203,7 +203,7 @@ buildDynCon' dflags platform binder _cc con [arg] = do { let charlike_lbl = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_CHARLIKE_closure") offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSize dflags + 1) -- CHARLIKE closures consist of a header and one word payload - charlike_amode = cmmLabelOffW charlike_lbl offsetW + charlike_amode = cmmLabelOffW dflags charlike_lbl offsetW ; return ( litIdInfo dflags binder (mkConLFInfo con) charlike_amode , return mkNop) } diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index ca5f49794b..9e4db9cdaa 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -34,7 +34,6 @@ import TysPrim import CLabel import SMRep import ForeignCall -import Constants import DynFlags import Maybes import Outputable @@ -66,7 +65,7 @@ cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty -- ToDo: this might not be correct for 64-bit API arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType dflags arg) - wORD_SIZE + (wORD_SIZE dflags) ; cmm_args <- getFCallArgs stg_args ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty ; let ((call_args, arg_hints), cmm_target) @@ -363,7 +362,7 @@ stack_SP dflags = closureField dflags (oFFSET_StgStack_sp dflags) closureField :: DynFlags -> ByteOff -> ByteOff -closureField dflags off = off + fixedHdrSize dflags * wORD_SIZE +closureField dflags off = off + fixedHdrSize dflags * wORD_SIZE dflags stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr stgSp = CmmReg sp diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index a19810b6fb..fb3739177c 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -44,7 +44,6 @@ import IdInfo( CafInfo(..), mayHaveCafRefs ) import Module import DynFlags import FastString( mkFastString, fsLit ) -import Constants import Util import Control.Monad (when) @@ -222,7 +221,7 @@ mkStaticClosure dflags info_lbl ccs payload padding static_link_field saved_info padLitToWord :: DynFlags -> CmmLit -> [CmmLit] padLitToWord dflags lit = lit : padding pad_length where width = typeWidth (cmmLitType dflags lit) - pad_length = wORD_SIZE - widthInBytes width :: Int + pad_length = wORD_SIZE dflags - widthInBytes width :: Int padding n | n <= 0 = [] | n `rem` 2 /= 0 = CmmInt 0 W8 : padding (n-1) @@ -543,7 +542,7 @@ do_checks :: Bool -- Should we check the stack? do_checks checkStack alloc do_gc = do dflags <- getDynFlags let - alloc_lit = mkIntExpr dflags (alloc*wORD_SIZE) -- Bytes + alloc_lit = mkIntExpr dflags (alloc * wORD_SIZE dflags) -- Bytes bump_hp = cmmOffsetExprB dflags (CmmReg hpReg) alloc_lit -- Sp overflow if (Sp - CmmHighStack < SpLim) diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index a7426284a3..8e4d21e352 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -219,7 +219,7 @@ direct_call caller call_conv lbl arity args emitCallWithExtraStack (call_conv, NativeReturn) target (nonVArgs fast_args) - (mkStkOffsets (stack_args dflags)) + (mkStkOffsets dflags (stack_args dflags)) where target = CmmLit (CmmLabel lbl) (fast_args, rest_args) = splitAt real_arity args @@ -329,10 +329,11 @@ slowCallPattern [] = (fsLit "stg_ap_0", 0) -- See Note [over-saturated calls]. mkStkOffsets - :: [(ArgRep, Maybe CmmExpr)] -- things to make offsets for + :: DynFlags + -> [(ArgRep, Maybe CmmExpr)] -- things to make offsets for -> ( ByteOff -- OUTPUTS: Topmost allocated word , [(CmmExpr, ByteOff)] ) -- things with offsets (voids filtered out) -mkStkOffsets things +mkStkOffsets dflags things = loop 0 [] (reverse things) where loop offset offs [] = (offset,offs) @@ -341,7 +342,7 @@ mkStkOffsets things loop offset offs ((rep,Just thing):things) = loop thing_off ((thing, thing_off):offs) things where - thing_off = offset + argRepSizeW rep * wORD_SIZE + thing_off = offset + argRepSizeW dflags rep * wORD_SIZE dflags -- offset of thing is offset+size, because we're -- growing the stack *downwards* as the offsets increase. @@ -382,13 +383,13 @@ isNonV :: ArgRep -> Bool isNonV V = False isNonV _ = True -argRepSizeW :: ArgRep -> WordOff -- Size in words -argRepSizeW N = 1 -argRepSizeW P = 1 -argRepSizeW F = 1 -argRepSizeW L = wORD64_SIZE `quot` wORD_SIZE -argRepSizeW D = dOUBLE_SIZE `quot` wORD_SIZE -argRepSizeW V = 0 +argRepSizeW :: DynFlags -> ArgRep -> WordOff -- Size in words +argRepSizeW _ N = 1 +argRepSizeW _ P = 1 +argRepSizeW _ F = 1 +argRepSizeW dflags L = wORD64_SIZE `quot` wORD_SIZE dflags +argRepSizeW dflags D = dOUBLE_SIZE `quot` wORD_SIZE dflags +argRepSizeW _ V = 0 idArgRep :: Id -> ArgRep idArgRep = toArgRep . idPrimRep @@ -405,8 +406,9 @@ hpRel hp off = off - hp getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr getHpRelOffset virtual_offset - = do { hp_usg <- getHpUsage - ; return (cmmRegOffW hpReg (hpRel (realHp hp_usg) virtual_offset)) } + = do dflags <- getDynFlags + hp_usg <- getHpUsage + return (cmmRegOffW dflags hpReg (hpRel (realHp hp_usg) virtual_offset)) mkVirtHeapOffsets :: DynFlags @@ -438,7 +440,7 @@ mkVirtHeapOffsets dflags is_thunk things | otherwise = fixedHdrSize dflags computeOffset wds_so_far (rep, thing) - = (wds_so_far + argRepSizeW (toArgRep rep), + = (wds_so_far + argRepSizeW dflags (toArgRep rep), (NonVoid thing, hdr_size + wds_so_far)) mkVirtConstrOffsets :: DynFlags -> [(PrimRep,a)] -> (WordOff, WordOff, [(NonVoid a, VirtualHpOffset)]) @@ -462,19 +464,20 @@ mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags False #include "../includes/rts/storage/FunTypes.h" mkArgDescr :: Name -> [Id] -> FCode ArgDescr -mkArgDescr _nm args - = case stdPattern arg_reps of - Just spec_id -> return (ArgSpec spec_id) - Nothing -> return (ArgGen arg_bits) - where - arg_bits = argBits arg_reps - arg_reps = filter isNonV (map idArgRep args) - -- Getting rid of voids eases matching of standard patterns - -argBits :: [ArgRep] -> [Bool] -- True for non-ptr, False for ptr -argBits [] = [] -argBits (P : args) = False : argBits args -argBits (arg : args) = take (argRepSizeW arg) (repeat True) ++ argBits args +mkArgDescr _nm args + = do dflags <- getDynFlags + let arg_bits = argBits dflags arg_reps + arg_reps = filter isNonV (map idArgRep args) + -- Getting rid of voids eases matching of standard patterns + case stdPattern arg_reps of + Just spec_id -> return (ArgSpec spec_id) + Nothing -> return (ArgGen arg_bits) + +argBits :: DynFlags -> [ArgRep] -> [Bool] -- True for non-ptr, False for ptr +argBits _ [] = [] +argBits dflags (P : args) = False : argBits dflags args +argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True) + ++ argBits dflags args ---------------------- stdPattern :: [ArgRep] -> Maybe StgHalfWord @@ -570,7 +573,7 @@ stdInfoTableSizeW dflags | otherwise = 0 stdInfoTableSizeB :: DynFlags -> ByteOff -stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE :: ByteOff +stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE dflags stdSrtBitmapOffset :: DynFlags -> ByteOff -- Byte offset of the SRT bitmap half-word which is @@ -579,11 +582,11 @@ stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE stdClosureTypeOffset :: DynFlags -> ByteOff -- Byte offset of the closure type half-word -stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE +stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff -stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2*wORD_SIZE -stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2*wORD_SIZE + hALF_WORD_SIZE +stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags +stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE ------------------------------------------------------------------------- -- diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 0d5e3778bf..cbb2aa70bd 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -42,7 +42,6 @@ import CLabel import CmmUtils import PrimOp import SMRep -import Constants import Module import FastString import Outputable @@ -919,7 +918,7 @@ doWritePtrArrayOp addr idx val loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB dflags addr off) (bWord dflags) - where off = fixedHdrSize dflags * wORD_SIZE + oFFSET_StgMutArrPtrs_ptrs dflags + where off = fixedHdrSize dflags * wORD_SIZE dflags + oFFSET_StgMutArrPtrs_ptrs dflags mkBasicIndexedRead :: ByteOff -> Maybe MachOp -> CmmType -> LocalReg -> CmmExpr -> CmmExpr -> FCode () @@ -1042,7 +1041,7 @@ doCopyArrayOp = emitCopyArray copy -- they're of different types) copy _src _dst dst_p src_p bytes = do dflags <- getDynFlags - emitMemcpyCall dst_p src_p bytes (mkIntExpr dflags wORD_SIZE) + emitMemcpyCall dst_p src_p bytes (mkIntExpr dflags (wORD_SIZE dflags)) -- | Takes a source 'MutableArray#', an offset in the source array, a @@ -1059,8 +1058,8 @@ doCopyMutableArrayOp = emitCopyArray copy copy src dst dst_p src_p bytes = do dflags <- getDynFlags [moveCall, cpyCall] <- forkAlts [ - getCode $ emitMemmoveCall dst_p src_p bytes (mkIntExpr dflags wORD_SIZE), - getCode $ emitMemcpyCall dst_p src_p bytes (mkIntExpr dflags wORD_SIZE) + getCode $ emitMemmoveCall dst_p src_p bytes (mkIntExpr dflags (wORD_SIZE dflags)), + getCode $ emitMemcpyCall dst_p src_p bytes (mkIntExpr dflags (wORD_SIZE dflags)) ] emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall @@ -1083,7 +1082,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 dflags n (mkIntExpr dflags wORD_SIZE) + bytes <- assignTempE $ cmmMulWord dflags n (mkIntExpr dflags (wORD_SIZE dflags)) copy src dst dst_p src_p bytes @@ -1101,7 +1100,7 @@ emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> CmmExpr emitCloneArray info_p res_r src0 src_off0 n0 = do dflags <- getDynFlags let arrPtrsHdrSizeW dflags = mkIntExpr dflags (fixedHdrSize dflags + - (sIZEOF_StgMutArrPtrs_NoHdr dflags `div` wORD_SIZE)) + (sIZEOF_StgMutArrPtrs_NoHdr dflags `div` wORD_SIZE dflags)) myCapability = cmmSubWord dflags (CmmReg baseReg) (mkIntExpr dflags (oFFSET_Capability_r dflags)) -- Passed as arguments (be careful) src <- assignTempE src0 @@ -1119,21 +1118,21 @@ emitCloneArray info_p res_r src0 src_off0 n0 = do let arr = CmmReg (CmmLocal arr_r) emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCS - emit $ mkStore (cmmOffsetB dflags arr (fixedHdrSize dflags * wORD_SIZE + + emit $ mkStore (cmmOffsetB dflags arr (fixedHdrSize dflags * wORD_SIZE dflags + oFFSET_StgMutArrPtrs_ptrs dflags)) n - emit $ mkStore (cmmOffsetB dflags arr (fixedHdrSize dflags * wORD_SIZE + + emit $ mkStore (cmmOffsetB dflags arr (fixedHdrSize dflags * wORD_SIZE dflags + oFFSET_StgMutArrPtrs_size dflags)) size dst_p <- assignTempE $ cmmOffsetB dflags arr (arrPtrsHdrSize dflags) src_p <- assignTempE $ cmmOffsetExprW dflags (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off - emitMemcpyCall dst_p src_p (cmmMulWord dflags n (wordSize dflags)) (mkIntExpr dflags wORD_SIZE) + emitMemcpyCall dst_p src_p (cmmMulWord dflags n (wordSize dflags)) (mkIntExpr dflags (wORD_SIZE dflags)) emitMemsetCall (cmmOffsetExprW dflags dst_p n) (mkIntExpr dflags 1) card_bytes - (mkIntExpr dflags wORD_SIZE) + (mkIntExpr dflags (wORD_SIZE dflags)) emit $ mkAssign (CmmLocal res_r) arr -- | Takes and offset in the destination array, the base address of @@ -1157,11 +1156,11 @@ cardRoundUp :: DynFlags -> CmmExpr -> CmmExpr cardRoundUp dflags i = card dflags (cmmAddWord dflags i (mkIntExpr dflags ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS dflags) - 1))) bytesToWordsRoundUp :: DynFlags -> CmmExpr -> CmmExpr -bytesToWordsRoundUp dflags e = cmmQuotWord dflags (cmmAddWord dflags e (mkIntExpr dflags (wORD_SIZE - 1))) +bytesToWordsRoundUp dflags e = cmmQuotWord dflags (cmmAddWord dflags e (mkIntExpr dflags (wORD_SIZE dflags - 1))) (wordSize dflags) wordSize :: DynFlags -> CmmExpr -wordSize dflags = mkIntExpr dflags wORD_SIZE +wordSize dflags = mkIntExpr dflags (wORD_SIZE dflags) -- | Emit a call to @memcpy@. emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index d5fa9d73a1..9eee38f7cb 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -54,7 +54,6 @@ import CostCentre import DynFlags import FastString import Module -import Constants -- Lots of field offsets import Outputable import Control.Monad @@ -263,7 +262,7 @@ emitCostCentreStackDecl ccs do dflags <- getDynFlags let mk_lits cc = zero dflags : mkCCostCentre cc : - replicate (sizeof_ccs_words - 2) (zero dflags) + replicate (sizeof_ccs_words dflags - 2) (zero dflags) -- Note: to avoid making any assumptions about how the -- C compiler (that compiles the RTS, in particular) does -- layouts of structs containing long-longs, simply @@ -277,13 +276,13 @@ zero dflags = mkIntCLit dflags 0 zero64 :: CmmLit zero64 = CmmInt 0 W64 -sizeof_ccs_words :: Int -sizeof_ccs_words +sizeof_ccs_words :: DynFlags -> Int +sizeof_ccs_words dflags -- round up to the next word. | ms == 0 = ws | otherwise = ws + 1 where - (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE + (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE dflags -- --------------------------------------------------------------------------- -- Set the current cost centre stack diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 52bd114b5d..4471b78151 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -57,7 +57,6 @@ import ForeignCall import IdInfo import Type import TyCon -import Constants import SMRep import Module import Literal @@ -150,7 +149,7 @@ mkTaggedObjectLoad dflags reg base offset tag = mkAssign (CmmLocal reg) (CmmLoad (cmmOffsetB dflags (CmmReg (CmmLocal base)) - (wORD_SIZE*offset - tag)) + (wORD_SIZE dflags * offset - tag)) (localRegType reg)) ------------------------------------------------------------------------- diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index d93f85602d..493ff0c13e 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -104,7 +104,7 @@ addTicksToBinds dflags mod mod_loc exports tyCons binds = let count = tickBoxCount st hashNo <- writeMixEntries dflags mod count entries orig_file2 - modBreaks <- mkModBreaks count entries + modBreaks <- mkModBreaks dflags count entries doIfSet_dyn dflags Opt_D_dump_ticked $ log_action dflags dflags SevDump noSrcSpan defaultDumpStyle @@ -126,9 +126,9 @@ guessSourceFile binds orig_file = _ -> orig_file -mkModBreaks :: Int -> [MixEntry_] -> IO ModBreaks -mkModBreaks count entries = do - breakArray <- newBreakArray $ length entries +mkModBreaks :: DynFlags -> Int -> [MixEntry_] -> IO ModBreaks +mkModBreaks dflags count entries = do + breakArray <- newBreakArray dflags $ length entries let locsTicks = listArray (0,count-1) [ span | (span,_,_,_) <- entries ] varsTicks = listArray (0,count-1) [ vars | (_,_,vars,_) <- entries ] diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs index a2459f5a4c..e02ef7b385 100644 --- a/compiler/deSugar/DsCCall.lhs +++ b/compiler/deSugar/DsCCall.lhs @@ -47,7 +47,6 @@ import BasicTypes import Literal import PrelNames import VarSet -import Constants import DynFlags import Outputable import Util @@ -357,9 +356,10 @@ resultWrapper result_ty -- This includes types like Ptr and ForeignPtr | Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitProductType_maybe result_ty, dataConSourceArity data_con == 1 - = do let + = do dflags <- getDynFlags + let (unwrapped_res_ty : _) = data_con_arg_tys - narrow_wrapper = maybeNarrow tycon + narrow_wrapper = maybeNarrow dflags tycon (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty return (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con)) @@ -375,16 +375,16 @@ resultWrapper result_ty -- standard appears to say that this is the responsibility of the -- caller, not the callee. -maybeNarrow :: TyCon -> (CoreExpr -> CoreExpr) -maybeNarrow tycon +maybeNarrow :: DynFlags -> TyCon -> (CoreExpr -> CoreExpr) +maybeNarrow dflags tycon | tycon `hasKey` int8TyConKey = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e | tycon `hasKey` int16TyConKey = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e | tycon `hasKey` int32TyConKey - && wORD_SIZE > 4 = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e + && wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e | tycon `hasKey` word8TyConKey = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e | tycon `hasKey` word32TyConKey - && wORD_SIZE > 4 = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e + && wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e | otherwise = id \end{code} diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index 478c5985c8..cc6b6afada 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -44,7 +44,6 @@ import FastString import DynFlags import Platform import Config -import Constants import OrdList import Pair import Util @@ -533,10 +532,10 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc type_string -- libffi needs to know the result type too: - | libffi = primTyDescChar res_hty : arg_type_string + | libffi = primTyDescChar dflags res_hty : arg_type_string | otherwise = arg_type_string - arg_type_string = [primTyDescChar ty | (_,_,ty,_) <- arg_info] + arg_type_string = [primTyDescChar dflags ty | (_,_,ty,_) <- arg_info] -- just the real args -- add some auxiliary args; the stable ptr in the wrapper case, and @@ -782,8 +781,8 @@ getPrimTyOf ty -- represent a primitive type as a Char, for building a string that -- described the foreign function type. The types are size-dependent, -- e.g. 'W' is a signed 32-bit integer. -primTyDescChar :: Type -> Char -primTyDescChar ty +primTyDescChar :: DynFlags -> Type -> Char +primTyDescChar dflags ty | ty `eqType` unitTy = 'v' | otherwise = case typePrimRep (getPrimTyOf ty) of @@ -797,7 +796,7 @@ primTyDescChar ty _ -> pprPanic "primTyDescChar" (ppr ty) where (signed_word, unsigned_word) - | wORD_SIZE == 4 = ('W','w') - | wORD_SIZE == 8 = ('L','l') - | otherwise = panic "primTyDescChar" + | wORD_SIZE dflags == 4 = ('W','w') + | wORD_SIZE dflags == 8 = ('L','l') + | otherwise = panic "primTyDescChar" \end{code} diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs index e9dc7d1b21..15c41d044e 100644 --- a/compiler/ghci/ByteCodeAsm.lhs +++ b/compiler/ghci/ByteCodeAsm.lhs @@ -27,7 +27,6 @@ import NameSet import Literal import TyCon import PrimOp -import Constants import FastString import SMRep import ClosureInfo -- CgRep stuff @@ -432,9 +431,9 @@ assembleI dflags i = case i of litlabel fs = lit [BCONPtrLbl fs] addr = words . mkLitPtr float = words . mkLitF - double = words . mkLitD + double = words . mkLitD dflags int = words . mkLitI - int64 = words . mkLitI64 + int64 = words . mkLitI64 dflags words ws = lit (map BCONPtrWord ws) word w = words [w] @@ -460,11 +459,11 @@ return_ubx PtrArg = bci_RETURN_P -- Make lists of host-sized words for literals, so that when the -- words are placed in memory at increasing addresses, the -- bit pattern is correct for the host's word size and endianness. -mkLitI :: Int -> [Word] -mkLitF :: Float -> [Word] -mkLitD :: Double -> [Word] -mkLitPtr :: Ptr () -> [Word] -mkLitI64 :: Int64 -> [Word] +mkLitI :: Int -> [Word] +mkLitF :: Float -> [Word] +mkLitD :: DynFlags -> Double -> [Word] +mkLitPtr :: Ptr () -> [Word] +mkLitI64 :: DynFlags -> Int64 -> [Word] mkLitF f = runST (do @@ -475,8 +474,8 @@ mkLitF f return [w0 :: Word] ) -mkLitD d - | wORD_SIZE == 4 +mkLitD dflags d + | wORD_SIZE dflags == 4 = runST (do arr <- newArray_ ((0::Int),1) writeArray arr 0 d @@ -485,7 +484,7 @@ mkLitD d w1 <- readArray d_arr 1 return [w0 :: Word, w1] ) - | wORD_SIZE == 8 + | wORD_SIZE dflags == 8 = runST (do arr <- newArray_ ((0::Int),0) writeArray arr 0 d @@ -496,8 +495,8 @@ mkLitD d | otherwise = panic "mkLitD: Bad wORD_SIZE" -mkLitI64 ii - | wORD_SIZE == 4 +mkLitI64 dflags ii + | wORD_SIZE dflags == 4 = runST (do arr <- newArray_ ((0::Int),1) writeArray arr 0 ii @@ -506,7 +505,7 @@ mkLitI64 ii w1 <- readArray d_arr 1 return [w0 :: Word,w1] ) - | wORD_SIZE == 8 + | wORD_SIZE dflags == 8 = runST (do arr <- newArray_ ((0::Int),0) writeArray arr 0 ii diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index e400d7afb7..af7a06876d 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -22,7 +22,6 @@ import ByteCodeAsm import ByteCodeLink import LibFFI -import Constants import DynFlags import Outputable import Platform @@ -166,7 +165,7 @@ mkProtoBCO mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks = ProtoBCO { protoBCOName = nm, - protoBCOInstrs = maybe_with_stack_check dflags, + protoBCOInstrs = maybe_with_stack_check, protoBCOBitmap = bitmap, protoBCOBitmapSize = bitmap_size, protoBCOArity = arity, @@ -181,7 +180,7 @@ mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallo -- BCO anyway, so we only need to add an explicit one in the -- (hopefully rare) cases when the (overestimated) stack use -- exceeds iNTERP_STACK_CHECK_THRESH. - maybe_with_stack_check dflags + maybe_with_stack_check | is_ret && stack_usage < fromIntegral (aP_STACK_SPLIM dflags) = peep_d -- don't do stack checks at return points, -- everything is aggregated up to the top BCO @@ -208,11 +207,11 @@ mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallo peep [] = [] -argBits :: [CgRep] -> [Bool] -argBits [] = [] -argBits (rep : args) - | isFollowableArg rep = False : argBits args - | otherwise = take (cgRepSizeW rep) (repeat True) ++ argBits args +argBits :: DynFlags -> [CgRep] -> [Bool] +argBits _ [] = [] +argBits dflags (rep : args) + | isFollowableArg rep = False : argBits dflags args + | otherwise = take (cgRepSizeW dflags rep) (repeat True) ++ argBits dflags args -- ----------------------------------------------------------------------------- -- schemeTopBind @@ -293,12 +292,12 @@ schemeR_wrk fvs nm original_body (args, body) -- \fv1..fvn x1..xn -> e -- i.e. the fvs come first - szsw_args = map (fromIntegral . idSizeW) all_args + szsw_args = map (fromIntegral . idSizeW dflags) all_args szw_args = sum szsw_args p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsw_args)) -- make the arg bitmap - bits = argBits (reverse (map idCgRep all_args)) + bits = argBits dflags (reverse (map idCgRep all_args)) bitmap_size = genericLength bits bitmap = mkBitmap dflags bits body_code <- schemeER_wrk szw_args p_init body @@ -400,15 +399,16 @@ schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body)) -- General case for let. Generates correct, if inefficient, code in -- all situations. -schemeE d s p (AnnLet binds (_,body)) - = let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs]) +schemeE d s p (AnnLet binds (_,body)) = do + dflags <- getDynFlags + let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs]) AnnRec xs_n_rhss -> unzip xs_n_rhss n_binds = genericLength xs fvss = map (fvsToEnv p' . fst) rhss -- Sizes of free vars - sizes = map (\rhs_fvs -> sum (map (fromIntegral . idSizeW) rhs_fvs)) fvss + sizes = map (\rhs_fvs -> sum (map (fromIntegral . idSizeW dflags) rhs_fvs)) fvss -- the arity of each rhs arities = map (genericLength . fst . collect) rhss @@ -451,7 +451,6 @@ schemeE d s p (AnnLet binds (_,body)) | (fvs, x, rhs, size, arity, n) <- zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1] ] - in do body_code <- schemeE d' s p' body thunk_codes <- sequence compile_binds return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code) @@ -793,7 +792,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple | otherwise = 1 -- depth of stack after the return value has been pushed - d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW bndr) + d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW dflags bndr) -- depth of stack after the extra info table for an unboxed return -- has been pushed, if any. This is the stack depth at the @@ -827,8 +826,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple | otherwise = let (ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs - ptr_sizes = map (fromIntegral . idSizeW) ptrs - nptrs_sizes = map (fromIntegral . idSizeW) nptrs + ptr_sizes = map (fromIntegral . idSizeW dflags) ptrs + nptrs_sizes = map (fromIntegral . idSizeW dflags) nptrs bind_sizes = ptr_sizes ++ nptrs_sizes size = sum ptr_sizes + sum nptrs_sizes -- the UNPACK instruction unpacks in reverse order... @@ -928,10 +927,13 @@ generateCCall :: Word -> Sequel -- stack and sequel depths -> BcM BCInstrList generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l - = let + = do + dflags <- getDynFlags + + let -- useful constants addr_sizeW :: Word16 - addr_sizeW = fromIntegral (cgRepSizeW NonPtrArg) + addr_sizeW = fromIntegral (cgRepSizeW dflags NonPtrArg) -- Get the args on the stack, with tags and suitably -- dereferenced for the CCall. For each arg, return the @@ -947,14 +949,12 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l -- contains. Just t | t == arrayPrimTyCon || t == mutableArrayPrimTyCon - -> do dflags <- getDynFlags - rest <- pargs (d + fromIntegral addr_sizeW) az + -> do rest <- pargs (d + fromIntegral addr_sizeW) az code <- parg_ArrayishRep (fromIntegral (arrPtrsHdrSize dflags)) d p a return ((code,AddrRep):rest) | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon - -> do dflags <- getDynFlags - rest <- pargs (d + fromIntegral addr_sizeW) az + -> do rest <- pargs (d + fromIntegral addr_sizeW) az code <- parg_ArrayishRep (fromIntegral (arrWordsHdrSize dflags)) d p a return ((code,AddrRep):rest) @@ -975,11 +975,10 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l -- header and then pretend this is an Addr#. return (push_fo `snocOL` SWIZZLE 0 hdrSize) - in do code_n_reps <- pargs d0 args_r_to_l let (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps - a_reps_sizeW = fromIntegral (sum (map primRepSizeW a_reps_pushed_r_to_l)) + a_reps_sizeW = fromIntegral (sum (map (primRepSizeW dflags) a_reps_pushed_r_to_l)) push_args = concatOL pushs_arg d_after_args = d0 + a_reps_sizeW @@ -1035,7 +1034,6 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l -} -- resolve static address get_target_info = do - dflags <- getDynFlags case target of DynamicTarget -> return (False, panic "ByteCodeGen.generateCCall(dyn)") @@ -1049,7 +1047,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l stdcall_adj_target | OSMinGW32 <- platformOS (targetPlatform dflags) , StdCallConv <- cconv - = let size = fromIntegral a_reps_sizeW * wORD_SIZE in + = let size = fromIntegral a_reps_sizeW * wORD_SIZE dflags in mkFastString (unpackFS target ++ '@':show size) | otherwise = target @@ -1074,7 +1072,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l -- Push the return placeholder. For a call returning nothing, -- this is a VoidArg (tag). - r_sizeW = fromIntegral (primRepSizeW r_rep) + r_sizeW = fromIntegral (primRepSizeW dflags r_rep) d_after_r = d_after_Addr + fromIntegral r_sizeW r_lit = mkDummyLiteral r_rep push_r = (if returns_void @@ -1092,7 +1090,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l -- the only difference in libffi mode is that we prepare a cif -- describing the call type by calling libffi, and we attach the -- address of this to the CCALL instruction. - token <- ioToBc $ prepForeignCall cconv a_reps r_rep + token <- ioToBc $ prepForeignCall dflags cconv a_reps r_rep let addr_of_marshaller = castPtrToFunPtr token recordItblMallocBc (ItblPtr (castFunPtrToPtr addr_of_marshaller)) @@ -1219,8 +1217,11 @@ pushAtom d p (AnnVar v) = return (unitOL (PUSH_PRIMOP primop), 1) | Just d_v <- lookupBCEnv_maybe v p -- v is a local variable - = let l = trunc16 $ d - d_v + fromIntegral sz - 2 - in return (toOL (genericReplicate sz (PUSH_L l)), sz) + = do dflags <- getDynFlags + let sz :: Word16 + sz = fromIntegral (idSizeW dflags v) + l = trunc16 $ d - d_v + fromIntegral sz - 2 + return (toOL (genericReplicate sz (PUSH_L l)), sz) -- d - d_v the number of words between the TOS -- and the 1st slot of the object -- @@ -1232,17 +1233,22 @@ pushAtom d p (AnnVar v) -- Having found the last slot, we proceed to copy the right number of -- slots on to the top of the stack. - | otherwise -- v must be a global variable - = ASSERT(sz == 1) - return (unitOL (PUSH_G (getName v)), sz) + | otherwise -- v must be a global variable + = do dflags <- getDynFlags + let sz :: Word16 + sz = fromIntegral (idSizeW dflags v) + MASSERT(sz == 1) + return (unitOL (PUSH_G (getName v)), sz) - where - sz :: Word16 - sz = fromIntegral (idSizeW v) +pushAtom _ _ (AnnLit lit) = do + dflags <- getDynFlags + let code rep + = let size_host_words = fromIntegral (cgRepSizeW dflags rep) + in return (unitOL (PUSH_UBX (Left lit) size_host_words), + size_host_words) -pushAtom _ _ (AnnLit lit) - = case lit of + case lit of MachLabel _ _ _ -> code NonPtrArg MachWord _ -> code NonPtrArg MachInt _ -> code NonPtrArg @@ -1258,11 +1264,6 @@ pushAtom _ _ (AnnLit lit) -- representation. LitInteger {} -> panic "pushAtom: LitInteger" where - code rep - = let size_host_words = fromIntegral (cgRepSizeW rep) - in return (unitOL (PUSH_UBX (Left lit) size_host_words), - size_host_words) - pushStr s = let getMallocvilleAddr = case s of @@ -1435,8 +1436,8 @@ instance Outputable Discr where lookupBCEnv_maybe :: Id -> BCEnv -> Maybe Word lookupBCEnv_maybe = Map.lookup -idSizeW :: Id -> Int -idSizeW = cgRepSizeW . bcIdCgRep +idSizeW :: DynFlags -> Id -> Int +idSizeW dflags = cgRepSizeW dflags . bcIdCgRep bcIdCgRep :: Id -> CgRep bcIdCgRep = primRepToCgRep . bcIdPrimRep diff --git a/compiler/ghci/ByteCodeItbls.lhs b/compiler/ghci/ByteCodeItbls.lhs index b88c81226a..2564d4b797 100644 --- a/compiler/ghci/ByteCodeItbls.lhs +++ b/compiler/ghci/ByteCodeItbls.lhs @@ -27,7 +27,6 @@ import ClosureInfo import DataCon ( DataCon, dataConRepArgTys, dataConIdentity ) import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) import Type ( flattenRepType, repType ) -import Constants ( wORD_SIZE ) import CgHeapery ( mkVirtHeapOffsets ) import Util @@ -49,14 +48,14 @@ import GHC.Ptr ( Ptr(..) ) \begin{code} newtype ItblPtr = ItblPtr (Ptr ()) deriving Show -itblCode :: ItblPtr -> Ptr () -itblCode (ItblPtr ptr) - | ghciTablesNextToCode = castPtr ptr `plusPtr` conInfoTableSizeB +itblCode :: DynFlags -> ItblPtr -> Ptr () +itblCode dflags (ItblPtr ptr) + | ghciTablesNextToCode = castPtr ptr `plusPtr` conInfoTableSizeB dflags | otherwise = castPtr ptr -- XXX bogus -conInfoTableSizeB :: Int -conInfoTableSizeB = 3 * wORD_SIZE +conInfoTableSizeB :: DynFlags -> Int +conInfoTableSizeB dflags = 3 * wORD_SIZE dflags type ItblEnv = NameEnv (Name, ItblPtr) -- We need the Name in the range so we know which @@ -128,7 +127,7 @@ make_constr_itbls dflags cons } -- Make a piece of code to jump to "entry_label". -- This is the only arch-dependent bit. - addrCon <- newExec pokeConItbl conInfoTbl + addrCon <- newExecConItbl dflags conInfoTbl --putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl)) --putStrLn ("# ptrs of itbl is " ++ show ptrs) --putStrLn ("# nptrs of itbl is " ++ show nptrs_really) @@ -285,39 +284,17 @@ data StgConInfoTable = StgConInfoTable { infoTable :: StgInfoTable } -instance Storable StgConInfoTable where - sizeOf conInfoTable +sizeOfConItbl :: StgConInfoTable -> Int +sizeOfConItbl conInfoTable = sum [ sizeOf (conDesc conInfoTable) , sizeOf (infoTable conInfoTable) ] - alignment _ = SIZEOF_VOID_P - peek ptr - = evalState (castPtr ptr) $ do -#ifdef GHCI_TABLES_NEXT_TO_CODE - desc <- load -#endif - itbl <- load -#ifndef GHCI_TABLES_NEXT_TO_CODE - desc <- load -#endif - return - StgConInfoTable - { -#ifdef GHCI_TABLES_NEXT_TO_CODE - conDesc = castPtr $ ptr `plusPtr` conInfoTableSizeB `plusPtr` desc -#else - conDesc = desc -#endif - , infoTable = itbl - } - poke = error "poke(StgConInfoTable): use pokeConItbl instead" - -pokeConItbl :: Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable +pokeConItbl :: DynFlags -> Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable -> IO () -pokeConItbl wr_ptr ex_ptr itbl +pokeConItbl dflags wr_ptr ex_ptr itbl = evalState (castPtr wr_ptr) $ do #ifdef GHCI_TABLES_NEXT_TO_CODE - store (conDesc itbl `minusPtr` (ex_ptr `plusPtr` conInfoTableSizeB)) + store (conDesc itbl `minusPtr` (ex_ptr `plusPtr` conInfoTableSizeB dflags)) #endif store (infoTable itbl) #ifndef GHCI_TABLES_NEXT_TO_CODE @@ -443,12 +420,12 @@ load = do addr <- advance lift (peek addr) -newExec :: Storable a => (Ptr a -> Ptr a -> a -> IO ()) -> a -> IO (FunPtr ()) -newExec poke_fn obj +newExecConItbl :: DynFlags -> StgConInfoTable -> IO (FunPtr ()) +newExecConItbl dflags obj = alloca $ \pcode -> do - wr_ptr <- _allocateExec (fromIntegral (sizeOf obj)) pcode + wr_ptr <- _allocateExec (fromIntegral (sizeOfConItbl obj)) pcode ex_ptr <- peek pcode - poke_fn wr_ptr ex_ptr obj + pokeConItbl dflags wr_ptr ex_ptr obj return (castPtrToFunPtr ex_ptr) foreign import ccall unsafe "allocateExec" diff --git a/compiler/ghci/ByteCodeLink.lhs b/compiler/ghci/ByteCodeLink.lhs index 8ceb91cfce..8938bfe4f1 100644 --- a/compiler/ghci/ByteCodeLink.lhs +++ b/compiler/ghci/ByteCodeLink.lhs @@ -20,6 +20,7 @@ import ByteCodeItbls import ByteCodeAsm import ObjLink +import DynFlags import Name import NameEnv import PrimOp @@ -76,9 +77,9 @@ data BCO# = BCO# ByteArray# -- instrs :: Array Word16# ByteArray# -- itbls :: Array Addr# -} -linkBCO :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO HValue -linkBCO ie ce ul_bco - = do BCO bco# <- linkBCO' ie ce ul_bco +linkBCO :: DynFlags -> ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO HValue +linkBCO dflags ie ce ul_bco + = do BCO bco# <- linkBCO' dflags ie ce ul_bco -- SDM: Why do we need mkApUpd0 here? I *think* it's because -- otherwise top-level interpreted CAFs don't get updated -- after evaluation. A top-level BCO will evaluate itself and @@ -97,18 +98,18 @@ linkBCO ie ce ul_bco else case mkApUpd0# bco# of { (# final_bco #) -> return (HValue final_bco) } -linkBCO' :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO BCO -linkBCO' ie ce (UnlinkedBCO _ arity insns_barr bitmap literalsSS ptrsSS) +linkBCO' :: DynFlags -> ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO BCO +linkBCO' dflags ie ce (UnlinkedBCO _ arity insns_barr bitmap literalsSS ptrsSS) -- Raises an IO exception on failure = do let literals = ssElts literalsSS ptrs = ssElts ptrsSS - linked_literals <- mapM (lookupLiteral ie) literals + linked_literals <- mapM (lookupLiteral dflags ie) literals let n_literals = sizeSS literalsSS n_ptrs = sizeSS ptrsSS - ptrs_arr <- mkPtrsArray ie ce n_ptrs ptrs + ptrs_arr <- mkPtrsArray dflags ie ce n_ptrs ptrs let !ptrs_parr = case ptrs_arr of Array _lo _hi _n parr -> parr @@ -126,8 +127,8 @@ linkBCO' ie ce (UnlinkedBCO _ arity insns_barr bitmap literalsSS ptrsSS) -- we recursively link any sub-BCOs while making the ptrs array -mkPtrsArray :: ItblEnv -> ClosureEnv -> Word -> [BCOPtr] -> IO (Array Word HValue) -mkPtrsArray ie ce n_ptrs ptrs = do +mkPtrsArray :: DynFlags -> ItblEnv -> ClosureEnv -> Word -> [BCOPtr] -> IO (Array Word HValue) +mkPtrsArray dflags ie ce n_ptrs ptrs = do let ptrRange = if n_ptrs > 0 then (0, n_ptrs-1) else (1, 0) marr <- newArray_ ptrRange let @@ -138,7 +139,7 @@ mkPtrsArray ie ce n_ptrs ptrs = do ptr <- lookupPrimOp op unsafeWrite marr i ptr fill (BCOPtrBCO ul_bco) i = do - BCO bco# <- linkBCO' ie ce ul_bco + BCO bco# <- linkBCO' dflags ie ce ul_bco writeArrayBCO marr i bco# fill (BCOPtrBreakInfo brkInfo) i = unsafeWrite marr i (HValue (unsafeCoerce# brkInfo)) @@ -180,12 +181,12 @@ newBCO instrs lits ptrs arity bitmap (# s1, bco #) -> (# s1, BCO bco #) -lookupLiteral :: ItblEnv -> BCONPtr -> IO Word -lookupLiteral _ (BCONPtrWord lit) = return lit -lookupLiteral _ (BCONPtrLbl sym) = do Ptr a# <- lookupStaticPtr sym - return (W# (int2Word# (addr2Int# a#))) -lookupLiteral ie (BCONPtrItbl nm) = do Ptr a# <- lookupIE ie nm - return (W# (int2Word# (addr2Int# a#))) +lookupLiteral :: DynFlags -> ItblEnv -> BCONPtr -> IO Word +lookupLiteral _ _ (BCONPtrWord lit) = return lit +lookupLiteral _ _ (BCONPtrLbl sym) = do Ptr a# <- lookupStaticPtr sym + return (W# (int2Word# (addr2Int# a#))) +lookupLiteral dflags ie (BCONPtrItbl nm) = do Ptr a# <- lookupIE dflags ie nm + return (W# (int2Word# (addr2Int# a#))) lookupStaticPtr :: FastString -> IO (Ptr ()) lookupStaticPtr addr_of_label_string @@ -218,10 +219,10 @@ lookupName ce nm (# a #) -> return (HValue a) Nothing -> linkFail "ByteCodeLink.lookupCE" sym_to_find -lookupIE :: ItblEnv -> Name -> IO (Ptr a) -lookupIE ie con_nm +lookupIE :: DynFlags -> ItblEnv -> Name -> IO (Ptr a) +lookupIE dflags ie con_nm = case lookupNameEnv ie con_nm of - Just (_, a) -> return (castPtr (itblCode a)) + Just (_, a) -> return (castPtr (itblCode dflags a)) Nothing -> do -- try looking up in the object files. let sym_to_find1 = nameToCLabel con_nm "con_info" diff --git a/compiler/ghci/DebuggerUtils.hs b/compiler/ghci/DebuggerUtils.hs index 19a3cbb721..cd46ec311e 100644 --- a/compiler/ghci/DebuggerUtils.hs +++ b/compiler/ghci/DebuggerUtils.hs @@ -14,7 +14,6 @@ import Module import OccName import Name import Outputable -import Constants import MonadUtils () import Util @@ -95,7 +94,7 @@ dataConInfoPtrToName x = do getConDescAddress :: DynFlags -> Ptr StgInfoTable -> IO (Ptr Word8) getConDescAddress dflags ptr | ghciTablesNextToCode = do - offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE) + offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE dflags) return $ (ptr `plusPtr` stdInfoTableSizeB dflags) `plusPtr` (fromIntegral (offsetToString :: StgWord)) | otherwise = peek $ intPtrToPtr $ ptrToIntPtr ptr + fromIntegral (stdInfoTableSizeB dflags) diff --git a/compiler/ghci/LibFFI.hsc b/compiler/ghci/LibFFI.hsc index 9bdabda0c2..128197109b 100644 --- a/compiler/ghci/LibFFI.hsc +++ b/compiler/ghci/LibFFI.hsc @@ -24,7 +24,7 @@ import TyCon import ForeignCall import Panic -- import Outputable -import Constants +import DynFlags import Foreign import Foreign.C @@ -35,20 +35,21 @@ import Text.Printf type ForeignCallToken = C_ffi_cif prepForeignCall - :: CCallConv + :: DynFlags + -> CCallConv -> [PrimRep] -- arg types -> PrimRep -- result type -> IO (Ptr ForeignCallToken) -- token for making calls -- (must be freed by caller) -prepForeignCall cconv arg_types result_type +prepForeignCall dflags cconv arg_types result_type = do let n_args = length arg_types arg_arr <- mallocArray n_args - let init_arg (ty,n) = pokeElemOff arg_arr n (primRepToFFIType ty) + let init_arg (ty,n) = pokeElemOff arg_arr n (primRepToFFIType dflags ty) mapM_ init_arg (zip arg_types [0..]) cif <- mallocBytes (#const sizeof(ffi_cif)) let abi = convToABI cconv - let res_ty = primRepToFFIType result_type + let res_ty = primRepToFFIType dflags result_type r <- ffi_prep_cif cif abi (fromIntegral n_args) res_ty arg_arr if (r /= fFI_OK) then ghcError (InstallationError @@ -64,8 +65,8 @@ convToABI StdCallConv = fFI_STDCALL convToABI _ = fFI_DEFAULT_ABI -- c.f. DsForeign.primTyDescChar -primRepToFFIType :: PrimRep -> Ptr C_ffi_type -primRepToFFIType r +primRepToFFIType :: DynFlags -> PrimRep -> Ptr C_ffi_type +primRepToFFIType dflags r = case r of VoidRep -> ffi_type_void IntRep -> signed_word @@ -78,9 +79,9 @@ primRepToFFIType r _ -> panic "primRepToFFIType" where (signed_word, unsigned_word) - | wORD_SIZE == 4 = (ffi_type_sint32, ffi_type_uint32) - | wORD_SIZE == 8 = (ffi_type_sint64, ffi_type_uint64) - | otherwise = panic "primTyDescChar" + | wORD_SIZE dflags == 4 = (ffi_type_sint32, ffi_type_uint32) + | wORD_SIZE dflags == 8 = (ffi_type_sint64, ffi_type_uint64) + | otherwise = panic "primTyDescChar" data C_ffi_type diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 2607ca0449..565cf0b8a8 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -457,7 +457,7 @@ linkExpr hsc_env span root_ul_bco ce = closure_env pls -- Link the necessary packages and linkables - ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce [root_ul_bco] + ; (_, (root_hval:_)) <- linkSomeBCOs dflags False ie ce [root_ul_bco] ; return (pls, root_hval) }}} where @@ -665,7 +665,7 @@ linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv) = do ce = closure_env pls -- Link the necessary packages and linkables - (final_gce, _) <- linkSomeBCOs False ie ce unlinkedBCOs + (final_gce, _) <- linkSomeBCOs dflags False ie ce unlinkedBCOs let pls2 = pls { closure_env = final_gce, itbl_env = ie } return (pls2, ()) --hvals) @@ -724,7 +724,7 @@ linkModules dflags pls linkables if failed ok_flag then return (pls1, Failed) else do - pls2 <- dynLinkBCOs pls1 bcos + pls2 <- dynLinkBCOs dflags pls1 bcos return (pls2, Succeeded) @@ -804,8 +804,9 @@ rmDupLinkables already ls %************************************************************************ \begin{code} -dynLinkBCOs :: PersistentLinkerState -> [Linkable] -> IO PersistentLinkerState -dynLinkBCOs pls bcos = do +dynLinkBCOs :: DynFlags -> PersistentLinkerState -> [Linkable] + -> IO PersistentLinkerState +dynLinkBCOs dflags pls bcos = do let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos pls1 = pls { bcos_loaded = bcos_loaded' } @@ -821,7 +822,7 @@ dynLinkBCOs pls bcos = do gce = closure_env pls final_ie = foldr plusNameEnv (itbl_env pls) ies - (final_gce, _linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos + (final_gce, _linked_bcos) <- linkSomeBCOs dflags True final_ie gce ul_bcos -- XXX What happens to these linked_bcos? let pls2 = pls1 { closure_env = final_gce, @@ -830,7 +831,8 @@ dynLinkBCOs pls bcos = do return pls2 -- Link a bunch of BCOs and return them + updated closure env. -linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env +linkSomeBCOs :: DynFlags + -> Bool -- False <=> add _all_ BCOs to returned closure env -- True <=> add only toplevel BCOs to closure env -> ItblEnv -> ClosureEnv @@ -840,11 +842,11 @@ linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env -- the incoming unlinked BCOs. Each gives the -- value of the corresponding unlinked BCO -linkSomeBCOs toplevs_only ie ce_in ul_bcos +linkSomeBCOs dflags toplevs_only ie ce_in ul_bcos = do let nms = map unlinkedBCOName ul_bcos hvals <- fixIO ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs) - in mapM (linkBCO ie ce_out) ul_bcos ) + in mapM (linkBCO dflags ie ce_out) ul_bcos ) let ce_all_additions = zip nms hvals ce_top_additions = filter (isExternalName.fst) ce_all_additions ce_additions = if toplevs_only then ce_top_additions diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index f06d120bc4..bf49a98a3b 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -60,7 +60,6 @@ import PrelNames import TysWiredIn import DynFlags import Outputable as Ppr -import Constants ( wORD_SIZE ) import GHC.Arr ( Array(..) ) import GHC.Exts import GHC.IO ( IO(..) ) @@ -172,8 +171,8 @@ pAP_CODE = PAP #undef AP #undef PAP -getClosureData :: a -> IO Closure -getClosureData a = +getClosureData :: DynFlags -> a -> IO Closure +getClosureData dflags a = case unpackClosure# a of (# iptr, ptrs, nptrs #) -> do let iptr' @@ -185,7 +184,7 @@ getClosureData a = -- but the Storable instance for info tables takes -- into account the extra entry pointer when -- !ghciTablesNextToCode, so we must adjust here: - Ptr iptr `plusPtr` negate wORD_SIZE + Ptr iptr `plusPtr` negate (wORD_SIZE dflags) itbl <- peek iptr' let tipe = readCType (BCI.tipe itbl) elems = fromIntegral (BCI.ptrs itbl) @@ -224,11 +223,11 @@ isThunk ThunkSelector = True isThunk AP = True isThunk _ = False -isFullyEvaluated :: a -> IO Bool -isFullyEvaluated a = do - closure <- getClosureData a +isFullyEvaluated :: DynFlags -> a -> IO Bool +isFullyEvaluated dflags a = do + closure <- getClosureData dflags a case tipe closure of - Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure) + Constr -> do are_subs_evaluated <- amapM (isFullyEvaluated dflags) (ptrs closure) return$ and are_subs_evaluated _ -> return False where amapM f = sequence . amap' f @@ -691,6 +690,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do text "Type obtained: " <> ppr (termType term)) return term where + dflags = hsc_dflags hsc_env go :: Int -> Type -> Type -> HValue -> TcM Term -- [SPJ May 11] I don't understand the difference between my_ty and old_ty @@ -699,13 +699,13 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do go 0 my_ty _old_ty a = do traceTR (text "Gave up reconstructing a term after" <> int max_depth <> text " steps") - clos <- trIO $ getClosureData a + clos <- trIO $ getClosureData dflags a return (Suspension (tipe clos) my_ty a Nothing) go max_depth my_ty old_ty a = do let monomorphic = not(isTyVarTy my_ty) -- This ^^^ is a convention. The ancestor tests for -- monomorphism and passes a type instead of a tv - clos <- trIO $ getClosureData a + clos <- trIO $ getClosureData dflags a case tipe clos of -- Thunks we may want to force t | isThunk t && force -> traceTR (text "Forcing a " <> text (show t)) >> @@ -818,7 +818,8 @@ extractSubTerms recurse clos = liftM thirdOf3 . go 0 (nonPtrs clos) t <- appArr (recurse ty) (ptrs clos) ptr_i return (ptr_i + 1, ws, t) _ -> do - let (ws0, ws1) = splitAt (primRepSizeW rep) ws + dflags <- getDynFlags + let (ws0, ws1) = splitAt (primRepSizeW dflags rep) ws return (ptr_i, ws1, Prim ty ws0) unboxedTupleTerm ty terms = Term ty (Right (tupleCon UnboxedTuple (length terms))) @@ -855,6 +856,8 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty) return new_ty where + dflags = hsc_dflags hsc_env + -- search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m () search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <> int max_depth <> text " steps") @@ -869,7 +872,7 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do go :: Type -> HValue -> TR [(Type, HValue)] go my_ty a = do traceTR (text "go" <+> ppr my_ty) - clos <- trIO $ getClosureData a + clos <- trIO $ getClosureData dflags a case tipe clos of Blackhole -> appArr (go my_ty) (ptrs clos) 0 -- carefully, don't eval the TSO Indirection _ -> go my_ty $! (ptrs clos ! 0) diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 965b1a96c3..a319f6ed62 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -117,7 +117,7 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do -- should be). Also, the serialisation of value of type "Bin -- a" used to depend on the word size of the machine, now they -- are always 32 bits. - if wORD_SIZE == 4 + if wORD_SIZE dflags == 4 then do _ <- Binary.get bh :: IO Word32; return () else do _ <- Binary.get bh :: IO Word64; return () @@ -168,7 +168,7 @@ writeBinIface dflags hi_path mod_iface = do -- dummy 32/64-bit field before the version/way for -- compatibility with older interface file formats. -- See Note [dummy iface field] above. - if wORD_SIZE == 4 + if wORD_SIZE dflags == 4 then Binary.put_ bh (0 :: Word32) else Binary.put_ bh (0 :: Word64) diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs index 6414501310..9e77990160 100644 --- a/compiler/llvmGen/Llvm/Types.hs +++ b/compiler/llvmGen/Llvm/Types.hs @@ -11,7 +11,6 @@ import Data.Int import Data.List (intercalate) import Numeric -import Constants import DynFlags import FastString import Unique @@ -358,7 +357,7 @@ i8Ptr = pLift i8 -- | The target architectures word size llvmWord, llvmWordPtr :: DynFlags -> LlvmType -llvmWord _ = LMInt (wORD_SIZE * 8) +llvmWord dflags = LMInt (wORD_SIZE dflags * 8) llvmWordPtr dflags = pLift (llvmWord dflags) -- ----------------------------------------------------------------------------- diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index 6996ea8f91..5b944b799d 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -31,7 +31,6 @@ import LlvmCodeGen.Regs import CLabel import CgUtils ( activeStgRegs ) -import Constants import DynFlags import FastString import OldCmm @@ -103,7 +102,7 @@ llvmFunSig' dflags lbl link | otherwise = (x, []) in LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs (map (toParams . getVarType) (llvmFunArgs dflags)) - llvmFunAlign + (llvmFunAlign dflags) -- | Create a Haskell function in LLVM. mkLlvmFunc :: LlvmEnv -> CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks @@ -115,12 +114,12 @@ mkLlvmFunc env lbl link sec blks in LlvmFunction funDec funArgs llvmStdFunAttrs sec blks -- | Alignment to use for functions -llvmFunAlign :: LMAlign -llvmFunAlign = Just wORD_SIZE +llvmFunAlign :: DynFlags -> LMAlign +llvmFunAlign dflags = Just (wORD_SIZE dflags) -- | Alignment to use for into tables -llvmInfAlign :: LMAlign -llvmInfAlign = Just wORD_SIZE +llvmInfAlign :: DynFlags -> LMAlign +llvmInfAlign dflags = Just (wORD_SIZE dflags) -- | A Function's arguments llvmFunArgs :: DynFlags -> [LlvmVar] diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index b8f41f3392..448bd4d94c 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -148,9 +148,10 @@ barrier env = do -- | Memory barrier instruction for LLVM < 3.0 oldBarrier :: LlvmEnv -> UniqSM StmtData oldBarrier env = do + let dflags = getDflags env let fname = fsLit "llvm.memory.barrier" let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc LMVoid - FixedArgs (tysToParams [i1, i1, i1, i1, i1]) llvmFunAlign + FixedArgs (tysToParams [i1, i1, i1, i1, i1]) (llvmFunAlign dflags) let fty = LMFunction funSig let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing False @@ -292,7 +293,7 @@ genCall env target res args ret = do let retTy = ret_type res let argTy = tysToParams $ map arg_type args let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible - lmconv retTy FixedArgs argTy llvmFunAlign + lmconv retTy FixedArgs argTy (llvmFunAlign dflags) (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, []) diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs index d73b2eb76c..c791e85a52 100644 --- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs +++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs @@ -106,14 +106,15 @@ pprLlvmCmmDecl env count (CmmProc mb_info entry_lbl (ListGraph blks)) -- | Pretty print CmmStatic pprInfoTable :: LlvmEnv -> Int -> CLabel -> CmmStatics -> (SDoc, [LlvmVar]) pprInfoTable env count info_lbl stat - = let unres = genLlvmData env (Text, stat) + = let dflags = getDflags env + unres = genLlvmData env (Text, stat) (_, (ldata, ltypes)) = resolveLlvmData env unres setSection ((LMGlobalVar _ ty l _ _ c), d) = let sec = mkLayoutSection count ilabel = strCLabel_llvm env info_lbl `appendFS` fsLit iTableSuf - gv = LMGlobalVar ilabel ty l sec llvmInfAlign c + gv = LMGlobalVar ilabel ty l sec (llvmInfAlign dflags) c v = if l == Internal then [gv] else [] in ((gv, d), v) setSection v = (v,[]) diff --git a/compiler/main/BreakArray.hs b/compiler/main/BreakArray.hs index 91e4c96c9a..4d3145fb3a 100644 --- a/compiler/main/BreakArray.hs +++ b/compiler/main/BreakArray.hs @@ -25,62 +25,62 @@ module BreakArray #endif ) where +import DynFlags + #ifdef GHCI import Control.Monad import GHC.Exts import GHC.IO ( IO(..) ) -import Constants - data BreakArray = BA (MutableByteArray# RealWorld) breakOff, breakOn :: Word breakOn = 1 breakOff = 0 -showBreakArray :: BreakArray -> IO () -showBreakArray array = do - forM_ [0..(size array - 1)] $ \i -> do +showBreakArray :: DynFlags -> BreakArray -> IO () +showBreakArray dflags array = do + forM_ [0 .. (size dflags array - 1)] $ \i -> do val <- readBreakArray array i putStr $ ' ' : show val putStr "\n" -setBreakOn :: BreakArray -> Int -> IO Bool -setBreakOn array index - | safeIndex array index = do +setBreakOn :: DynFlags -> BreakArray -> Int -> IO Bool +setBreakOn dflags array index + | safeIndex dflags array index = do writeBreakArray array index breakOn return True | otherwise = return False -setBreakOff :: BreakArray -> Int -> IO Bool -setBreakOff array index - | safeIndex array index = do +setBreakOff :: DynFlags -> BreakArray -> Int -> IO Bool +setBreakOff dflags array index + | safeIndex dflags array index = do writeBreakArray array index breakOff return True | otherwise = return False -getBreak :: BreakArray -> Int -> IO (Maybe Word) -getBreak array index - | safeIndex array index = do +getBreak :: DynFlags -> BreakArray -> Int -> IO (Maybe Word) +getBreak dflags array index + | safeIndex dflags array index = do val <- readBreakArray array index return $ Just val | otherwise = return Nothing -safeIndex :: BreakArray -> Int -> Bool -safeIndex array index = index < size array && index >= 0 +safeIndex :: DynFlags -> BreakArray -> Int -> Bool +safeIndex dflags array index = index < size dflags array && index >= 0 -size :: BreakArray -> Int -size (BA array) = (I# (sizeofMutableByteArray# array)) `div` wORD_SIZE +size :: DynFlags -> BreakArray -> Int +size dflags (BA array) = (I# (sizeofMutableByteArray# array)) `div` wORD_SIZE dflags allocBA :: Int -> IO BreakArray allocBA (I# sz) = IO $ \s1 -> case newByteArray# sz s1 of { (# s2, array #) -> (# s2, BA array #) } -- create a new break array and initialise elements to zero -newBreakArray :: Int -> IO BreakArray -newBreakArray entries@(I# sz) = do - BA array <- allocBA (entries * wORD_SIZE) +newBreakArray :: DynFlags -> Int -> IO BreakArray +newBreakArray dflags entries@(I# sz) = do + BA array <- allocBA (entries * wORD_SIZE dflags) case breakOff of W# off -> do -- Todo: there must be a better way to write zero as a Word! let loop n | n ==# sz = return () @@ -112,8 +112,8 @@ readBreakArray (BA array) (I# i) = readBA# array i -- presumably have a different representation. data BreakArray = Unspecified -newBreakArray :: Int -> IO BreakArray -newBreakArray _ = return Unspecified +newBreakArray :: DynFlags -> Int -> IO BreakArray +newBreakArray _ _ = return Unspecified #endif /* GHCI */ diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index d07977ceea..cf1ce81a15 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -3148,8 +3148,8 @@ compilerInfo dflags #include "../includes/dist-derivedconstants/header/GHCConstantsHaskellWrappers.hs" bLOCK_SIZE_W :: DynFlags -> Int -bLOCK_SIZE_W dflags = bLOCK_SIZE dflags `quot` wORD_SIZE +bLOCK_SIZE_W dflags = bLOCK_SIZE dflags `quot` wORD_SIZE dflags wORD_SIZE_IN_BITS :: DynFlags -> Int -wORD_SIZE_IN_BITS _ = wORD_SIZE * 8 +wORD_SIZE_IN_BITS dflags = wORD_SIZE dflags * 8 diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index a797329930..806f8356e6 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -347,7 +347,8 @@ isBreakEnabled :: HscEnv -> BreakInfo -> IO Bool isBreakEnabled hsc_env inf = case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of Just hmi -> do - w <- getBreak (modBreaks_flags (getModBreaks hmi)) + w <- getBreak (hsc_dflags hsc_env) + (modBreaks_flags (getModBreaks hmi)) (breakInfo_number inf) case w of Just n -> return (n /= 0); _other -> return False _ -> diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index 367c0fbdec..1f036aa43e 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -1379,10 +1379,10 @@ coerceInt2FP fromRep toRep x = do [CmmStaticLit (CmmInt 0x43300000 W32), CmmStaticLit (CmmInt 0x80000000 W32)], XORIS itmp src (ImmInt 0x8000), - ST II32 itmp (spRel 3), + ST II32 itmp (spRel dflags 3), LIS itmp (ImmInt 0x4330), - ST II32 itmp (spRel 2), - LD FF64 ftmp (spRel 2) + ST II32 itmp (spRel dflags 2), + LD FF64 ftmp (spRel dflags 2) ] `appOL` addr_code `appOL` toOL [ LD FF64 dst addr, FSUB FF64 dst ftmp dst @@ -1404,6 +1404,7 @@ coerceInt2FP fromRep toRep x = do coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register coerceFP2Int _ toRep x = do + dflags <- getDynFlags -- the reps don't really matter: F*->FF64 and II32->I* are no-ops (src, code) <- getSomeReg x tmp <- getNewRegNat FF64 @@ -1412,7 +1413,7 @@ coerceFP2Int _ toRep x = do -- convert to int in FP reg FCTIWZ tmp src, -- store value (64bit) from FP to stack - ST FF64 tmp (spRel 2), + ST FF64 tmp (spRel dflags 2), -- read low word of value (high word is undefined) - LD II32 dst (spRel 3)] + LD II32 dst (spRel dflags 3)] return (Any (intSize toRep) code') diff --git a/compiler/nativeGen/PPC/Regs.hs b/compiler/nativeGen/PPC/Regs.hs index 7dccb6040e..d4123aca84 100644 --- a/compiler/nativeGen/PPC/Regs.hs +++ b/compiler/nativeGen/PPC/Regs.hs @@ -55,8 +55,8 @@ import CLabel ( CLabel ) import Unique import CodeGen.Platform +import DynFlags import Outputable -import Constants import FastBool import FastTypes import Platform @@ -194,10 +194,11 @@ addrOffset addr off -- temporaries and for excess call arguments. @fpRel@, where -- applicable, is the same but for the frame pointer. -spRel :: Int -- desired stack offset in words, positive or negative +spRel :: DynFlags + -> Int -- desired stack offset in words, positive or negative -> AddrMode -spRel n = AddrRegImm sp (ImmInt (n * wORD_SIZE)) +spRel dflags n = AddrRegImm sp (ImmInt (n * wORD_SIZE dflags)) -- argRegs is the set of regs which are read for an n-argument call to C. diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index 66ebf75629..b83ede89aa 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -52,7 +52,6 @@ import Outputable import Unique import FastString import FastBool ( isFastTrue ) -import Constants ( wORD_SIZE ) import DynFlags import Util @@ -1766,9 +1765,9 @@ genCCall32' dflags target dest_regs args = do -- alignment of 16n - word_size on procedure entry. Which we -- maintiain. See Note [rts/StgCRun.c : Stack Alignment on X86] sizes = map (arg_size . cmmExprType dflags . hintlessCmm) (reverse args) - raw_arg_size = sum sizes + wORD_SIZE + raw_arg_size = sum sizes + wORD_SIZE dflags arg_pad_size = (roundTo 16 $ raw_arg_size) - raw_arg_size - tot_arg_size = raw_arg_size + arg_pad_size - wORD_SIZE + tot_arg_size = raw_arg_size + arg_pad_size - wORD_SIZE dflags delta0 <- getDeltaNat setDeltaNat (delta0 - arg_pad_size) @@ -2026,14 +2025,14 @@ genCCall64' dflags target dest_regs args = do -- alignment of 16n - word_size on procedure entry. Which we -- maintiain. See Note [rts/StgCRun.c : Stack Alignment on X86] (real_size, adjust_rsp) <- - if (tot_arg_size + wORD_SIZE) `rem` 16 == 0 + if (tot_arg_size + wORD_SIZE dflags) `rem` 16 == 0 then return (tot_arg_size, nilOL) else do -- we need to adjust... delta <- getDeltaNat - setDeltaNat (delta - wORD_SIZE) - return (tot_arg_size + wORD_SIZE, toOL [ - SUB II64 (OpImm (ImmInt wORD_SIZE)) (OpReg rsp), - DELTA (delta - wORD_SIZE) ]) + setDeltaNat (delta - wORD_SIZE dflags) + return (tot_arg_size + wORD_SIZE dflags, toOL [ + SUB II64 (OpImm (ImmInt (wORD_SIZE dflags))) (OpReg rsp), + DELTA (delta - wORD_SIZE dflags) ]) -- push the stack args, right to left push_code <- push_args (reverse stack_args) nilOL @@ -2173,7 +2172,7 @@ genCCall64' dflags target dest_regs args = do let code' = code `appOL` arg_code `appOL` toOL [ SUB (intSize (wordWidth dflags)) (OpImm (ImmInt arg_size)) (OpReg rsp) , DELTA (delta-arg_size), - MOV (floatSize width) (OpReg arg_reg) (OpAddr (spRel platform 0))] + MOV (floatSize width) (OpReg arg_reg) (OpAddr (spRel dflags 0))] push_args rest code' | otherwise = do @@ -2196,7 +2195,7 @@ genCCall64' dflags target dest_regs args = do delta <- getDeltaNat setDeltaNat (delta - n * arg_size) return $ toOL [ - SUB II64 (OpImm (ImmInt (n * wORD_SIZE))) (OpReg rsp), + SUB II64 (OpImm (ImmInt (n * wORD_SIZE dflags))) (OpReg rsp), DELTA (delta - n * arg_size)] -- | We're willing to inline and unroll memcpy/memset calls that touch @@ -2288,7 +2287,7 @@ genSwitch dflags expr ids dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl (tableReg,t_code) <- getSomeReg $ dynRef let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) - (EAIndex reg wORD_SIZE) (ImmInt 0)) + (EAIndex reg (wORD_SIZE dflags)) (ImmInt 0)) return $ if target32Bit (targetPlatform dflags) then e_code `appOL` t_code `appOL` toOL [ @@ -2326,7 +2325,7 @@ genSwitch dflags expr ids = do (reg,e_code) <- getSomeReg expr lbl <- getNewLabelNat - let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg wORD_SIZE) (ImmCLbl lbl)) + let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (wORD_SIZE dflags)) (ImmCLbl lbl)) code = e_code `appOL` toOL [ JMP_TBL op ids ReadOnlyData lbl ] diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index 50f5b4c874..7f0e48e769 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -625,9 +625,9 @@ x86_mkSpillInstr dflags reg delta slot let off_w = (off - delta) `div` (if is32Bit then 4 else 8) in case targetClassOfReg platform reg of RcInteger -> MOV (archWordSize is32Bit) - (OpReg reg) (OpAddr (spRel platform off_w)) - RcDouble -> GST FF80 reg (spRel platform off_w) {- RcFloat/RcDouble -} - RcDoubleSSE -> MOV FF64 (OpReg reg) (OpAddr (spRel platform off_w)) + (OpReg reg) (OpAddr (spRel dflags off_w)) + RcDouble -> GST FF80 reg (spRel dflags off_w) {- RcFloat/RcDouble -} + RcDoubleSSE -> MOV FF64 (OpReg reg) (OpAddr (spRel dflags off_w)) _ -> panic "X86.mkSpillInstr: no match" where platform = targetPlatform dflags is32Bit = target32Bit platform @@ -646,9 +646,9 @@ x86_mkLoadInstr dflags reg delta slot let off_w = (off-delta) `div` (if is32Bit then 4 else 8) in case targetClassOfReg platform reg of RcInteger -> MOV (archWordSize is32Bit) - (OpAddr (spRel platform off_w)) (OpReg reg) - RcDouble -> GLD FF80 (spRel platform off_w) reg {- RcFloat/RcDouble -} - RcDoubleSSE -> MOV FF64 (OpAddr (spRel platform off_w)) (OpReg reg) + (OpAddr (spRel dflags off_w)) (OpReg reg) + RcDouble -> GLD FF80 (spRel dflags off_w) reg {- RcFloat/RcDouble -} + RcDoubleSSE -> MOV FF64 (OpAddr (spRel dflags off_w)) (OpReg reg) _ -> panic "X86.x86_mkLoadInstr" where platform = targetPlatform dflags is32Bit = target32Bit platform diff --git a/compiler/nativeGen/X86/Regs.hs b/compiler/nativeGen/X86/Regs.hs index c88ea98425..4eec96f5e1 100644 --- a/compiler/nativeGen/X86/Regs.hs +++ b/compiler/nativeGen/X86/Regs.hs @@ -59,7 +59,6 @@ import Outputable import Platform import FastTypes import FastBool -import Constants -- | regSqueeze_class reg @@ -196,14 +195,14 @@ addrModeRegs _ = [] -- applicable, is the same but for the frame pointer. -spRel :: Platform +spRel :: DynFlags -> Int -- ^ desired stack offset in words, positive or negative -> AddrMode -spRel platform n - | target32Bit platform - = AddrBaseIndex (EABaseReg esp) EAIndexNone (ImmInt (n * wORD_SIZE)) +spRel dflags n + | target32Bit (targetPlatform dflags) + = AddrBaseIndex (EABaseReg esp) EAIndexNone (ImmInt (n * wORD_SIZE dflags)) | otherwise - = AddrBaseIndex (EABaseReg rsp) EAIndexNone (ImmInt (n * wORD_SIZE)) + = AddrBaseIndex (EABaseReg rsp) EAIndexNone (ImmInt (n * wORD_SIZE dflags)) -- The register numbers must fit into 32 bits on x86, so that we can -- use a Word32 to represent the set of free registers in the register diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 8d79e89d97..64ef9d9730 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -1554,7 +1554,8 @@ genDerivStuff :: SrcSpan -> FixityEnv -> Class -> Name -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff) genDerivStuff loc fix_env clas name tycon comaux_maybe | className clas `elem` typeableClassNames - = return (gen_Typeable_binds loc tycon, emptyBag) + = do dflags <- getDynFlags + return (gen_Typeable_binds dflags loc tycon, emptyBag) | ck `elem` [genClassKey, gen1ClassKey] -- Special case because monadic = let gk = if ck == genClassKey then Gen0 else Gen1 -- TODO NSF: correctly identify when we're building Both instead of One diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 0566192353..e5baaeca9f 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -72,7 +72,6 @@ import Outputable import FastString import Bag import Fingerprint -import Constants import TcEnv (InstInfo) import Data.List ( partition, intersperse ) @@ -1192,8 +1191,8 @@ we generate We are passed the Typeable2 class as well as T \begin{code} -gen_Typeable_binds :: SrcSpan -> TyCon -> LHsBinds RdrName -gen_Typeable_binds loc tycon +gen_Typeable_binds :: DynFlags -> SrcSpan -> TyCon -> LHsBinds RdrName +gen_Typeable_binds dflags loc tycon = unitBag $ mk_easy_FunBind loc (mk_typeOf_RDR tycon) -- Name of appropriate type0f function @@ -1219,8 +1218,8 @@ gen_Typeable_binds loc tycon Fingerprint high low = fingerprintString hashThis int64 - | wORD_SIZE == 4 = HsWord64Prim . fromIntegral - | otherwise = HsWordPrim . fromIntegral + | wORD_SIZE dflags == 4 = HsWord64Prim . fromIntegral + | otherwise = HsWordPrim . fromIntegral mk_typeOf_RDR :: TyCon -> RdrName diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 147e16dbe1..05c0ae5be3 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -93,6 +93,7 @@ import {-# SOURCE #-} DataCon ( DataCon, isVanillaDataCon ) import Var import Class import BasicTypes +import DynFlags import ForeignCall import Name import PrelNames @@ -777,16 +778,16 @@ instance Outputable PrimRep where ppr r = text (show r) -- | Find the size of a 'PrimRep', in words -primRepSizeW :: PrimRep -> Int -primRepSizeW IntRep = 1 -primRepSizeW WordRep = 1 -primRepSizeW Int64Rep = wORD64_SIZE `quot` wORD_SIZE -primRepSizeW Word64Rep= wORD64_SIZE `quot` wORD_SIZE -primRepSizeW FloatRep = 1 -- NB. might not take a full word -primRepSizeW DoubleRep= dOUBLE_SIZE `quot` wORD_SIZE -primRepSizeW AddrRep = 1 -primRepSizeW PtrRep = 1 -primRepSizeW VoidRep = 0 +primRepSizeW :: DynFlags -> PrimRep -> Int +primRepSizeW _ IntRep = 1 +primRepSizeW _ WordRep = 1 +primRepSizeW dflags Int64Rep = wORD64_SIZE `quot` wORD_SIZE dflags +primRepSizeW dflags Word64Rep= wORD64_SIZE `quot` wORD_SIZE dflags +primRepSizeW _ FloatRep = 1 -- NB. might not take a full word +primRepSizeW dflags DoubleRep= dOUBLE_SIZE `quot` wORD_SIZE dflags +primRepSizeW _ AddrRep = 1 +primRepSizeW _ PtrRep = 1 +primRepSizeW _ VoidRep = 0 \end{code} %************************************************************************ diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 60748ba1c0..85fe889ec7 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -2589,12 +2589,13 @@ breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]") findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi () findBreakAndSet md lookupTickTree = do + dflags <- getDynFlags tickArray <- getTickArray md (breakArray, _) <- getModBreak md case lookupTickTree tickArray of Nothing -> liftIO $ putStrLn $ "No breakpoints found at that location." Just (tick, pan) -> do - success <- liftIO $ setBreakFlag True breakArray tick + success <- liftIO $ setBreakFlag dflags True breakArray tick if success then do (alreadySet, nm) <- @@ -2877,8 +2878,9 @@ deleteBreak identity = do turnOffBreak :: BreakLocation -> GHCi Bool turnOffBreak loc = do + dflags <- getDynFlags (arr, _) <- getModBreak (breakModule loc) - liftIO $ setBreakFlag False arr (breakTick loc) + liftIO $ setBreakFlag dflags False arr (breakTick loc) getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan) getModBreak m = do @@ -2888,10 +2890,10 @@ getModBreak m = do let ticks = GHC.modBreaks_locs modBreaks return (arr, ticks) -setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool -setBreakFlag toggle arr i - | toggle = GHC.setBreakOn arr i - | otherwise = GHC.setBreakOff arr i +setBreakFlag :: DynFlags -> Bool -> GHC.BreakArray -> Int -> IO Bool +setBreakFlag dflags toggle arr i + | toggle = GHC.setBreakOn dflags arr i + | otherwise = GHC.setBreakOff dflags arr i -- --------------------------------------------------------------------------- diff --git a/includes/HaskellConstants.hs b/includes/HaskellConstants.hs index 33108f2eb7..5b9a5ba1ac 100644 --- a/includes/HaskellConstants.hs +++ b/includes/HaskellConstants.hs @@ -42,11 +42,6 @@ dOUBLE_SIZE = SIZEOF_DOUBLE wORD64_SIZE :: Int wORD64_SIZE = 8 --- Size of a word, in bytes - -wORD_SIZE :: Int -wORD_SIZE = SIZEOF_HSWORD - -- Define a fixed-range integral type equivalent to the target Int/Word #if SIZEOF_HSWORD == 4 diff --git a/includes/mkDerivedConstants.c b/includes/mkDerivedConstants.c index 609c7aed31..a6d2230d6e 100644 --- a/includes/mkDerivedConstants.c +++ b/includes/mkDerivedConstants.c @@ -683,6 +683,9 @@ main(int argc, char *argv[]) // own stack check (see bug #1466). constantInt("aP_STACK_SPLIM", AP_STACK_SPLIM); + // Size of a word, in bytes + constantInt("wORD_SIZE", SIZEOF_HSWORD); + switch (mode) { case Gen_Haskell_Type: printf(" } deriving (Read, Show)\n"); |