diff options
70 files changed, 828 insertions, 813 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..0735937754 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -24,7 +24,6 @@ import qualified Stream import Hoopl import Maybes -import Constants import DynFlags import Panic import UniqSupply @@ -173,7 +172,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 +185,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 +232,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 +303,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, @@ -322,7 +322,7 @@ mkLivenessBits dflags liveness [b] -> b _ -> panic "mkLiveness" bitmap_word = fromIntegral n_bits - .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT) + .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags) lits = mkWordCLit dflags (fromIntegral n_bits) : map (mkWordCLit dflags) bitmap -- The first word is the size. The structure must match 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..bff4804fc2 100644 --- a/compiler/cmm/CmmUtils.hs +++ b/compiler/cmm/CmmUtils.hs @@ -72,7 +72,6 @@ import CLabel import Outputable import Unique import UniqSupply -import Constants( wORD_SIZE, tAG_MASK ) import DynFlags import Util @@ -272,16 +271,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 +308,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) --------------------------------------------------- -- @@ -343,8 +342,8 @@ hasNoGlobalRegs _ = False -- Tag bits mask --cmmTagBits = CmmLit (mkIntCLit tAG_BITS) cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr -cmmTagMask dflags = mkIntExpr dflags tAG_MASK -cmmPointerMask dflags = mkIntExpr dflags (complement tAG_MASK) +cmmTagMask dflags = mkIntExpr dflags (tAG_MASK dflags) +cmmPointerMask dflags = mkIntExpr dflags (complement (tAG_MASK dflags)) -- Used to untag a possibly tagged pointer -- A static label need not be untagged @@ -371,15 +370,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..bb2f189e14 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -31,7 +31,6 @@ import OldCmm import OldPprCmm () -- Utils -import Constants import CPrim import DynFlags import FastString @@ -374,7 +373,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 +479,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 +720,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 +910,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 +1058,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 +1083,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) @@ -1126,11 +1125,11 @@ pprHexVal w rep -- times values are unsigned. This also helps eliminate occasional -- warnings about integer overflow from gcc. - repsuffix W64 - | cINT_SIZE == 8 = char 'U' - | cLONG_SIZE == 8 = ptext (sLit "UL") - | cLONG_LONG_SIZE == 8 = ptext (sLit "ULL") - | otherwise = panic "pprHexVal: Can't find a 64-bit type" + repsuffix W64 = sdocWithDynFlags $ \dflags -> + if cINT_SIZE dflags == 8 then char 'U' + else if cLONG_SIZE dflags == 8 then ptext (sLit "UL") + else if cLONG_LONG_SIZE dflags == 8 then ptext (sLit "ULL") + else panic "pprHexVal: Can't find a 64-bit type" repsuffix _ = char 'U' go 0 = empty 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..834276bd7b 100644 --- a/compiler/codeGen/CgBindery.lhs +++ b/compiler/codeGen/CgBindery.lhs @@ -38,8 +38,8 @@ import CgStackery import CgUtils import CLabel import ClosureInfo -import Constants +import DynFlags import OldCmm import PprCmm ( {- instance Outputable -} ) import SMRep @@ -87,8 +87,8 @@ data CgIdInfo , cg_tag :: {-# UNPACK #-} !Int -- tag to be added in idInfoToAmode } -mkCgIdInfo :: Id -> VolatileLoc -> StableLoc -> LambdaFormInfo -> CgIdInfo -mkCgIdInfo id vol stb lf +mkCgIdInfo :: DynFlags -> Id -> VolatileLoc -> StableLoc -> LambdaFormInfo -> CgIdInfo +mkCgIdInfo dflags id vol stb lf = CgIdInfo { cg_id = id, cg_vol = vol, cg_stb = stb, cg_lf = lf, cg_rep = idCgRep id, cg_tag = tag } where @@ -100,10 +100,10 @@ mkCgIdInfo id vol stb lf If yes, we assume that the constructor is evaluated and can be tagged. -} - = tagForCon con + = tagForCon dflags con | otherwise - = funTagLFInfo lf + = funTagLFInfo dflags lf voidIdInfo :: Id -> CgIdInfo voidIdInfo id = CgIdInfo { cg_id = id, cg_vol = NoVolatileLoc @@ -120,11 +120,11 @@ data VolatileLoc -- These locations die across a call -- NB. Byte offset, because we subtract R1's -- tag from the offset. -mkTaggedCgIdInfo :: Id -> VolatileLoc -> StableLoc -> LambdaFormInfo -> DataCon +mkTaggedCgIdInfo :: DynFlags -> Id -> VolatileLoc -> StableLoc -> LambdaFormInfo -> DataCon -> CgIdInfo -mkTaggedCgIdInfo id vol stb lf con +mkTaggedCgIdInfo dflags id vol stb lf con = CgIdInfo { cg_id = id, cg_vol = vol, cg_stb = stb, - cg_lf = lf, cg_rep = idCgRep id, cg_tag = tagForCon con } + cg_lf = lf, cg_rep = idCgRep id, cg_tag = tagForCon dflags con } \end{code} @StableLoc@ encodes where an Id can be found, used by @@ -172,36 +172,38 @@ instance Outputable StableLoc where %************************************************************************ \begin{code} -stableIdInfo :: Id -> CmmExpr -> LambdaFormInfo -> CgIdInfo -stableIdInfo id amode lf_info = mkCgIdInfo id NoVolatileLoc (StableLoc amode) lf_info +stableIdInfo :: DynFlags -> Id -> CmmExpr -> LambdaFormInfo -> CgIdInfo +stableIdInfo dflags id amode lf_info = mkCgIdInfo dflags id NoVolatileLoc (StableLoc amode) lf_info -heapIdInfo :: Id -> VirtualHpOffset -> LambdaFormInfo -> CgIdInfo -heapIdInfo id offset lf_info = mkCgIdInfo id (VirHpLoc offset) NoStableLoc lf_info +heapIdInfo :: DynFlags -> Id -> VirtualHpOffset -> LambdaFormInfo -> CgIdInfo +heapIdInfo dflags id offset lf_info = mkCgIdInfo dflags id (VirHpLoc offset) NoStableLoc lf_info -letNoEscapeIdInfo :: Id -> VirtualSpOffset -> LambdaFormInfo -> CgIdInfo -letNoEscapeIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLNE sp) lf_info +letNoEscapeIdInfo :: DynFlags -> Id -> VirtualSpOffset -> LambdaFormInfo -> CgIdInfo +letNoEscapeIdInfo dflags id sp lf_info + = mkCgIdInfo dflags id NoVolatileLoc (VirStkLNE sp) lf_info -stackIdInfo :: Id -> VirtualSpOffset -> LambdaFormInfo -> CgIdInfo -stackIdInfo id sp lf_info = mkCgIdInfo id NoVolatileLoc (VirStkLoc sp) lf_info +stackIdInfo :: DynFlags -> Id -> VirtualSpOffset -> LambdaFormInfo -> CgIdInfo +stackIdInfo dflags id sp lf_info + = mkCgIdInfo dflags id NoVolatileLoc (VirStkLoc sp) lf_info -nodeIdInfo :: Id -> Int -> LambdaFormInfo -> CgIdInfo -nodeIdInfo id offset lf_info = mkCgIdInfo id (VirNodeLoc (wORD_SIZE*offset)) NoStableLoc lf_info +nodeIdInfo :: DynFlags -> Id -> Int -> LambdaFormInfo -> CgIdInfo +nodeIdInfo dflags id offset lf_info = mkCgIdInfo dflags id (VirNodeLoc (wORD_SIZE dflags * offset)) NoStableLoc lf_info -regIdInfo :: Id -> CmmReg -> LambdaFormInfo -> CgIdInfo -regIdInfo id reg lf_info = mkCgIdInfo id (RegLoc reg) NoStableLoc lf_info +regIdInfo :: DynFlags -> Id -> CmmReg -> LambdaFormInfo -> CgIdInfo +regIdInfo dflags id reg lf_info = mkCgIdInfo dflags id (RegLoc reg) NoStableLoc lf_info -taggedStableIdInfo :: Id -> CmmExpr -> LambdaFormInfo -> DataCon -> CgIdInfo -taggedStableIdInfo id amode lf_info con - = mkTaggedCgIdInfo id NoVolatileLoc (StableLoc amode) lf_info con +taggedStableIdInfo :: DynFlags -> Id -> CmmExpr -> LambdaFormInfo -> DataCon -> CgIdInfo +taggedStableIdInfo dflags id amode lf_info con + = mkTaggedCgIdInfo dflags id NoVolatileLoc (StableLoc amode) lf_info con -taggedHeapIdInfo :: Id -> VirtualHpOffset -> LambdaFormInfo -> DataCon +taggedHeapIdInfo :: DynFlags -> Id -> VirtualHpOffset -> LambdaFormInfo -> DataCon -> CgIdInfo -taggedHeapIdInfo id offset lf_info con - = mkTaggedCgIdInfo id (VirHpLoc offset) NoStableLoc lf_info con +taggedHeapIdInfo dflags id offset lf_info con + = mkTaggedCgIdInfo dflags id (VirHpLoc offset) NoStableLoc lf_info con -untagNodeIdInfo :: Id -> Int -> LambdaFormInfo -> Int -> CgIdInfo -untagNodeIdInfo id offset lf_info tag - = mkCgIdInfo id (VirNodeLoc (wORD_SIZE*offset - tag)) NoStableLoc lf_info +untagNodeIdInfo :: DynFlags -> Id -> Int -> LambdaFormInfo -> Int -> CgIdInfo +untagNodeIdInfo dflags id offset lf_info tag + = mkCgIdInfo dflags id (VirNodeLoc (wORD_SIZE dflags * offset - tag)) NoStableLoc lf_info idInfoToAmode :: CgIdInfo -> FCode CmmExpr @@ -283,7 +285,8 @@ modifyBindC name mangle_fn = do getCgIdInfo :: Id -> FCode CgIdInfo getCgIdInfo id - = do { -- Try local bindings first + = do { dflags <- getDynFlags + ; -- Try local bindings first ; local_binds <- getBinds ; case lookupVarEnv local_binds id of { Just info -> return info ; @@ -301,7 +304,7 @@ getCgIdInfo id in if isExternalName name then do let ext_lbl = CmmLit (CmmLabel (mkClosureLabel name $ idCafInfo id)) - return (stableIdInfo id ext_lbl (mkLFImported id)) + return (stableIdInfo dflags id ext_lbl (mkLFImported id)) else if isVoidArg (idCgRep id) then -- Void things are never in the environment @@ -428,9 +431,9 @@ getArgAmodes (atom:atoms) \begin{code} bindArgsToStack :: [(Id, VirtualSpOffset)] -> Code bindArgsToStack args - = mapCs bind args - where - bind(id, offset) = addBindC id (stackIdInfo id offset (mkLFArgument id)) + = do dflags <- getDynFlags + let bind (id, offset) = addBindC id (stackIdInfo dflags id offset (mkLFArgument id)) + mapCs bind args bindArgsToRegs :: [(Id, GlobalReg)] -> Code bindArgsToRegs args @@ -440,11 +443,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 @@ -456,14 +461,14 @@ bindNewToTemp id temp_reg = LocalReg uniq (argMachRep dflags (idCgRep id)) lf_info = mkLFArgument id -- Always used of things we -- know nothing about - addBindC id (regIdInfo id (CmmLocal temp_reg) lf_info) + addBindC id (regIdInfo dflags id (CmmLocal temp_reg) lf_info) return temp_reg bindNewToReg :: Id -> CmmReg -> LambdaFormInfo -> Code bindNewToReg name reg lf_info - = addBindC name info - where - info = mkCgIdInfo name (RegLoc reg) NoStableLoc lf_info + = do dflags <- getDynFlags + let info = mkCgIdInfo dflags name (RegLoc reg) NoStableLoc lf_info + addBindC name info rebindToStack :: Id -> VirtualSpOffset -> Code rebindToStack name offset @@ -497,9 +502,10 @@ Probably *naughty* to look inside monad... nukeDeadBindings :: StgLiveVars -- All the *live* variables -> Code nukeDeadBindings live_vars = do + dflags <- getDynFlags binds <- getBinds let (dead_stk_slots, bs') = - dead_slots live_vars + dead_slots dflags live_vars [] [] [ (cg_id b, b) | b <- varEnvElts binds ] setBinds $ mkVarEnv bs' @@ -509,7 +515,8 @@ nukeDeadBindings live_vars = do Several boring auxiliary functions to do the dirty work. \begin{code} -dead_slots :: StgLiveVars +dead_slots :: DynFlags + -> StgLiveVars -> [(Id,CgIdInfo)] -> [VirtualSpOffset] -> [(Id,CgIdInfo)] @@ -517,12 +524,12 @@ dead_slots :: StgLiveVars -- dead_slots carries accumulating parameters for -- filtered bindings, dead slots -dead_slots _ fbs ds [] +dead_slots _ _ fbs ds [] = (ds, reverse fbs) -- Finished; rm the dups, if any -dead_slots live_vars fbs ds ((v,i):bs) +dead_slots dflags live_vars fbs ds ((v,i):bs) | v `elementOfUniqSet` live_vars - = dead_slots live_vars ((v,i):fbs) ds bs + = dead_slots dflags live_vars ((v,i):fbs) ds bs -- Live, so don't record it in dead slots -- Instead keep it in the filtered bindings @@ -530,12 +537,12 @@ dead_slots live_vars fbs ds ((v,i):bs) = case cg_stb i of VirStkLoc offset | size > 0 - -> dead_slots live_vars fbs ([offset-size+1 .. offset] ++ ds) bs + -> dead_slots dflags live_vars fbs ([offset-size+1 .. offset] ++ ds) bs - _ -> dead_slots live_vars fbs ds bs + _ -> dead_slots dflags live_vars fbs ds bs where size :: WordOff - size = cgRepSizeW (cg_rep i) + size = cgRepSizeW dflags (cg_rep i) getLiveStackSlots :: FCode [VirtualSpOffset] -- Return the offsets of slots in stack containig live pointers diff --git a/compiler/codeGen/CgCallConv.hs b/compiler/codeGen/CgCallConv.hs index 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..11a5091c07 100644 --- a/compiler/codeGen/CgClosure.lhs +++ b/compiler/codeGen/CgClosure.lhs @@ -84,7 +84,7 @@ cgTopRhsClosure id ccs binder_info upd_flag args body = do ; let descr = closureDescription dflags mod_name name closure_info = mkClosureInfo dflags True id lf_info 0 0 srt_info descr closure_label = mkLocalClosureLabel name $ idCafInfo id - cg_id_info = stableIdInfo id (mkLblExpr closure_label) lf_info + cg_id_info = stableIdInfo dflags id (mkLblExpr closure_label) lf_info closure_rep = mkStaticClosureFields dflags closure_info ccs True [] -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY) @@ -136,7 +136,7 @@ cgStdRhsClosure bndr _cc _bndr_info _fvs _args _body lf_info payload ; heap_offset <- allocDynClosure closure_info curCCS curCCS amodes_w_offsets -- RETURN - ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) } + ; returnFC (bndr, heapIdInfo dflags bndr heap_offset lf_info) } \end{code} Here's the general case. @@ -188,7 +188,7 @@ cgRhsClosure bndr cc bndr_info fvs upd_flag args body = do let -- A function closure pointer may be tagged, so we -- must take it into account when accessing the free variables. - mbtag = tagForArity (length args) + mbtag = tagForArity dflags (length args) bind_fv (info, offset) | Just tag <- mbtag = bindNewToUntagNode (cgIdInfoId info) offset (cgIdInfoLF info) tag @@ -211,7 +211,7 @@ cgRhsClosure bndr cc bndr_info fvs upd_flag args body = do ; heap_offset <- allocDynClosure closure_info curCCS curCCS amodes_w_offsets -- RETURN - ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) } + ; returnFC (bndr, heapIdInfo dflags bndr heap_offset lf_info) } mkClosureLFInfo :: Id -- The binder @@ -279,7 +279,7 @@ closureCodeBody _binder_info cl_info cc args body -- eg. if we're compiling a let-no-escape). ; vSp <- getVirtSp ; let (reg_args, other_args) = assignCallRegs dflags (addIdReps args) - (sp_top, stk_args) = mkVirtStkOffsets vSp other_args + (sp_top, stk_args) = mkVirtStkOffsets dflags vSp other_args -- Allocate the global ticky counter ; let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) (clHasCafRefs cl_info) @@ -324,7 +324,7 @@ mkFunEntryCode cl_info cc reg_args stk_args sp_top reg_save_code body = do ; tickyEnterFun cl_info ; enterCostCentreFun cc (CmmMachOp (mo_wordSub dflags) [ CmmReg nodeReg - , mkIntExpr dflags (funTag cl_info) ]) + , mkIntExpr dflags (funTag dflags cl_info) ]) (node : map snd reg_args) -- live regs ; cgExpr body } @@ -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..aeb87235e3 100644 --- a/compiler/codeGen/CgCon.lhs +++ b/compiler/codeGen/CgCon.lhs @@ -98,7 +98,7 @@ cgTopRhsCon id con args ; emitDataLits closure_label closure_rep -- RETURN - ; returnFC (id, taggedStableIdInfo id (mkLblExpr closure_label) lf_info con) } + ; returnFC (id, taggedStableIdInfo dflags id (mkLblExpr closure_label) lf_info con) } \end{code} %************************************************************************ @@ -148,8 +148,8 @@ which have exclusively size-zero (VoidRep) args, we generate no code at all. \begin{code} -buildDynCon' _ _ binder _ con [] - = returnFC (taggedStableIdInfo binder +buildDynCon' dflags _ binder _ con [] + = returnFC (taggedStableIdInfo dflags binder (mkLblExpr (mkClosureLabel (dataConName con) (idCafInfo binder))) (mkConLFInfo con) @@ -192,8 +192,8 @@ 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) - ; returnFC (taggedStableIdInfo binder intlike_amode (mkConLFInfo con) con) } + intlike_amode = CmmLit (cmmLabelOffW dflags intlike_lbl offsetW) + ; returnFC (taggedStableIdInfo dflags binder intlike_amode (mkConLFInfo con) con) } buildDynCon' dflags platform binder _ con [arg_amode] | maybeCharLikeCon con @@ -204,8 +204,8 @@ 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) - ; returnFC (taggedStableIdInfo binder charlike_amode (mkConLFInfo con) con) } + charlike_amode = CmmLit (cmmLabelOffW dflags charlike_lbl offsetW) + ; returnFC (taggedStableIdInfo dflags binder charlike_amode (mkConLFInfo con) con) } \end{code} @@ -218,7 +218,7 @@ buildDynCon' dflags _ binder ccs con args (closure_info, amodes_w_offsets) = layOutDynConstr dflags con args ; hp_off <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets - ; returnFC (taggedHeapIdInfo binder hp_off lf_info con) } + ; returnFC (taggedHeapIdInfo dflags binder hp_off lf_info con) } where lf_info = mkConLFInfo con @@ -249,7 +249,7 @@ bindConArgs con args let -- The binding below forces the masking out of the tag bits -- when accessing the constructor field. - bind_arg (arg, offset) = bindNewToUntagNode arg offset (mkLFArgument arg) (tagForCon con) + bind_arg (arg, offset) = bindNewToUntagNode arg offset (mkLFArgument arg) (tagForCon dflags con) (_, args_w_offsets) = layOutDynConstr dflags con (addIdReps args) -- ASSERT(not (isUnboxedTupleCon con)) return () @@ -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 @@ -418,7 +418,8 @@ closures predeclared. \begin{code} cgTyCon :: TyCon -> FCode CmmGroup -- each constructor gets a separate CmmGroup cgTyCon tycon - = do { constrs <- mapM (getCmm . cgDataCon) (tyConDataCons tycon) + = do { dflags <- getDynFlags + ; constrs <- mapM (getCmm . cgDataCon) (tyConDataCons tycon) -- Generate a table of static closures for an enumeration type -- Put the table after the data constructor decls, because the @@ -431,7 +432,7 @@ cgTyCon tycon ; extra <- if isEnumerationTyCon tycon then do tbl <- getCmm (emitRODataLits "cgTyCon" (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs) - [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs) (tagForCon con) + [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs) (tagForCon dflags con) | con <- tyConDataCons tycon]) return [tbl] else 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..e2a3aa2efd 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -43,7 +43,6 @@ import CLabel import Name import Unique -import Constants import DynFlags import Util import Outputable @@ -94,16 +93,17 @@ emitReturnTarget -> CgStmts -- The direct-return code (if any) -> FCode CLabel emitReturnTarget name stmts - = do { srt_info <- getSRTInfo - ; blks <- cgStmtsToBlocks stmts - ; frame <- mkStackLayout - ; let smrep = mkStackRep (mkLiveness frame) - info = CmmInfoTable { cit_lbl = info_lbl - , cit_prof = NoProfilingInfo - , cit_rep = smrep - , cit_srt = srt_info } - ; emitInfoTableAndCode entry_lbl info args blks - ; return info_lbl } + = do dflags <- getDynFlags + srt_info <- getSRTInfo + blks <- cgStmtsToBlocks stmts + frame <- mkStackLayout + let smrep = mkStackRep (mkLiveness dflags frame) + info = CmmInfoTable { cit_lbl = info_lbl + , cit_prof = NoProfilingInfo + , cit_rep = smrep + , cit_srt = srt_info } + emitInfoTableAndCode entry_lbl info args blks + return info_lbl where args = {- trace "emitReturnTarget: missing args" -} [] uniq = getUnique name @@ -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) @@ -217,7 +217,7 @@ emitAlgReturnTarget name branches mb_deflt fam_sz = do { blks <- getCgStmts $ do -- is the constructor tag in the node reg? dflags <- getDynFlags - if isSmallFamily fam_sz + if isSmallFamily dflags fam_sz then do -- yes, node has constr. tag let tag_expr = cmmConstrTag1 dflags (CmmReg nodeReg) branches' = [(tag+1,branch)|(tag,branch)<-branches] @@ -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/CgLetNoEscape.lhs b/compiler/codeGen/CgLetNoEscape.lhs index 2fb603baed..610869ad89 100644 --- a/compiler/codeGen/CgLetNoEscape.lhs +++ b/compiler/codeGen/CgLetNoEscape.lhs @@ -162,7 +162,8 @@ cgLetNoEscapeClosure in -- saveVolatileVarsAndRegs done earlier in cgExpr. - do { (vSp, _) <- forkEvalHelp rhs_eob_info + do { dflags <- getDynFlags + ; (vSp, _) <- forkEvalHelp rhs_eob_info (do { allocStackTop retAddrSizeW ; nukeDeadBindings full_live_in_rhss }) @@ -176,7 +177,7 @@ cgLetNoEscapeClosure ; _ <- emitReturnTarget (idName bndr) abs_c ; return () }) - ; returnFC (bndr, letNoEscapeIdInfo bndr vSp lf_info) } + ; returnFC (bndr, letNoEscapeIdInfo dflags bndr vSp lf_info) } \end{code} \begin{code} diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs index 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..6d87ee7127 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 @@ -284,8 +285,8 @@ ldvRecordCreate closure = do dflags <- getDynFlags ldvEnterClosure :: ClosureInfo -> Code ldvEnterClosure closure_info = do dflags <- getDynFlags + let tag = funTag dflags closure_info ldvEnter (cmmOffsetB dflags (CmmReg nodeReg) (-tag)) - where tag = funTag closure_info -- don't forget to substract node's tag ldvEnter :: CmmExpr -> Code 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..c52c8a8c99 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -53,7 +53,6 @@ import TyCon import DataCon import Id import IdInfo -import Constants import SMRep import OldCmm import OldCmmUtils @@ -142,20 +141,20 @@ mkLtOp dflags lit = MO_U_Lt (typeWidth (cmmLitType dflags (mkSimpleLi Big families only use the tag value 1 to represent evaluatedness. -} -isSmallFamily :: Int -> Bool -isSmallFamily fam_size = fam_size <= mAX_PTR_TAG +isSmallFamily :: DynFlags -> Int -> Bool +isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags -tagForCon :: DataCon -> ConTagZ -tagForCon con = tag +tagForCon :: DynFlags -> DataCon -> ConTagZ +tagForCon dflags con = tag where con_tag = dataConTagZ con fam_size = tyConFamilySize (dataConTyCon con) - tag | isSmallFamily fam_size = con_tag + 1 - | otherwise = 1 + tag | isSmallFamily dflags fam_size = con_tag + 1 + | otherwise = 1 --Tag an expression, to do: refactor, this appears in some other module. tagCons :: DynFlags -> DataCon -> CmmExpr -> CmmExpr -tagCons dflags con expr = cmmOffsetB dflags expr (tagForCon con) +tagCons dflags con expr = cmmOffsetB dflags expr (tagForCon dflags con) -------------------------------------------------------------------------- -- @@ -800,7 +799,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..7a72a00602 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 dflags DoubleArg = dOUBLE_SIZE dflags +cgRepSizeB _ LongArg = wORD64_SIZE +cgRepSizeB _ VoidArg = 0 +cgRepSizeB dflags _ = wORD_SIZE dflags + +cgRepSizeW :: DynFlags -> CgRep -> ByteOff +cgRepSizeW dflags DoubleArg = dOUBLE_SIZE dflags `quot` wORD_SIZE dflags +cgRepSizeW dflags LongArg = wORD64_SIZE `quot` wORD_SIZE dflags +cgRepSizeW _ VoidArg = 0 +cgRepSizeW _ _ = 1 retAddrSizeW :: WordOff retAddrSizeW = 1 -- One word @@ -927,25 +927,27 @@ lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr) lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc) lfFunInfo _ = Nothing -funTag :: ClosureInfo -> Int -funTag (ClosureInfo { closureLFInfo = lf_info }) = funTagLFInfo lf_info -funTag _ = 0 +funTag :: DynFlags -> ClosureInfo -> Int +funTag dflags (ClosureInfo { closureLFInfo = lf_info }) + = funTagLFInfo dflags lf_info +funTag _ _ = 0 -- maybe this should do constructor tags too? -funTagLFInfo :: LambdaFormInfo -> Int -funTagLFInfo lf +funTagLFInfo :: DynFlags -> LambdaFormInfo -> Int +funTagLFInfo dflags lf -- A function is tagged with its arity | Just (arity,_) <- lfFunInfo lf, - Just tag <- tagForArity arity + Just tag <- tagForArity dflags arity = tag -- other closures (and unknown ones) are not tagged | otherwise = 0 -tagForArity :: RepArity -> Maybe Int -tagForArity i | i <= mAX_PTR_TAG = Just i - | otherwise = Nothing +tagForArity :: DynFlags -> RepArity -> Maybe Int +tagForArity dflags i + | i <= mAX_PTR_TAG dflags = Just i + | otherwise = Nothing clHasCafRefs :: ClosureInfo -> CafInfo clHasCafRefs (ClosureInfo {closureSRT = srt}) = diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index 65e0103099..f1022e5280 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -205,9 +205,10 @@ mkModuleInit cost_centre_info this_mod hpc_info cgEnumerationTyCon :: TyCon -> FCode () cgEnumerationTyCon tycon - = emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs) + = do dflags <- getDynFlags + emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs) [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs) - (tagForCon con) + (tagForCon dflags con) | con <- tyConDataCons tycon] @@ -236,7 +237,7 @@ cgDataCon data_con ; ldvEnter (CmmReg nodeReg) ; tickyReturnOldCon (length arg_things) ; void $ emitReturn [cmmOffsetB dflags (CmmReg nodeReg) - (tagForCon data_con)] + (tagForCon dflags data_con)] } -- The case continuation code expects a tagged pointer diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index aac1abfe0c..02d3d0246f 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -43,7 +43,6 @@ import Module import ListSetOps import Util import BasicTypes -import Constants import Outputable import FastString import Maybes @@ -460,7 +459,7 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details ; enterCostCentreFun cc (CmmMachOp (mo_wordSub dflags) [ CmmReg nodeReg - , mkIntExpr dflags (funTag cl_info) ]) + , mkIntExpr dflags (funTag dflags cl_info) ]) ; whenC node_points (ldvEnterClosure cl_info) ; granYield arg_regs node_points @@ -483,8 +482,8 @@ bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) } load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, WordOff)] -> FCode () load_fvs node lf_info = mapM_ (\ (reg, off) -> do dflags <- getDynFlags + let tag = lfDynTag dflags lf_info emit $ mkTaggedObjectLoad dflags reg node off tag) - where tag = lfDynTag lf_info ----------------------------------------- -- The "slow entry" code for a function. This entry point takes its @@ -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/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index b944208a07..85346da205 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -86,7 +86,6 @@ import TcType import TyCon import BasicTypes import Outputable -import Constants import DynFlags import Util @@ -299,32 +298,33 @@ Big families only use the tag value 1 to represent evaluatedness. We don't have very many tag bits: for example, we have 2 bits on x86-32 and 3 bits on x86-64. -} -isSmallFamily :: Int -> Bool -isSmallFamily fam_size = fam_size <= mAX_PTR_TAG +isSmallFamily :: DynFlags -> Int -> Bool +isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags -- We keep the *zero-indexed* tag in the srt_len field of the info -- table of a data constructor. dataConTagZ :: DataCon -> ConTagZ dataConTagZ con = dataConTag con - fIRST_TAG -tagForCon :: DataCon -> DynTag -tagForCon con - | isSmallFamily fam_size = con_tag + 1 - | otherwise = 1 +tagForCon :: DynFlags -> DataCon -> DynTag +tagForCon dflags con + | isSmallFamily dflags fam_size = con_tag + 1 + | otherwise = 1 where con_tag = dataConTagZ con fam_size = tyConFamilySize (dataConTyCon con) -tagForArity :: RepArity -> DynTag -tagForArity arity | isSmallFamily arity = arity - | otherwise = 0 +tagForArity :: DynFlags -> RepArity -> DynTag +tagForArity dflags arity + | isSmallFamily dflags arity = arity + | otherwise = 0 -lfDynTag :: LambdaFormInfo -> DynTag +lfDynTag :: DynFlags -> LambdaFormInfo -> DynTag -- Return the tag in the low order bits of a variable bound -- to this LambdaForm -lfDynTag (LFCon con) = tagForCon con -lfDynTag (LFReEntrant _ arity _ _) = tagForArity arity -lfDynTag _other = 0 +lfDynTag dflags (LFCon con) = tagForCon dflags con +lfDynTag dflags (LFReEntrant _ arity _ _) = tagForArity dflags arity +lfDynTag _ _other = 0 ----------------------------------------------------------------------------- @@ -755,8 +755,9 @@ lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr) lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc) lfFunInfo _ = Nothing -funTag :: ClosureInfo -> DynTag -funTag (ClosureInfo { closureLFInfo = lf_info }) = lfDynTag lf_info +funTag :: DynFlags -> ClosureInfo -> DynTag +funTag dflags (ClosureInfo { closureLFInfo = lf_info }) + = lfDynTag dflags lf_info isToplevClosure :: ClosureInfo -> Bool isToplevClosure (ClosureInfo { closureLFInfo = lf_info }) diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index 0e0f2f13f8..c822a64e2c 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) } @@ -246,17 +246,15 @@ bindConArgs (DataAlt con) base args = ASSERT(not (isUnboxedTupleCon con)) do dflags <- getDynFlags let (_, _, args_w_offsets) = mkVirtConstrOffsets dflags (addIdReps args) + tag = tagForCon dflags con + + -- The binding below forces the masking out of the tag bits + -- when accessing the constructor field. + bind_arg :: (NonVoid Id, VirtualHpOffset) -> FCode LocalReg + bind_arg (arg, offset) + = do emit $ mkTaggedObjectLoad dflags (idToReg dflags arg) base offset tag + bindArgToReg arg mapM bind_arg args_w_offsets - where - tag = tagForCon con - - -- The binding below forces the masking out of the tag bits - -- when accessing the constructor field. - bind_arg :: (NonVoid Id, VirtualHpOffset) -> FCode LocalReg - bind_arg (arg, offset) - = do { dflags <- getDynFlags - ; emit $ mkTaggedObjectLoad dflags (idToReg dflags arg) base offset tag - ; bindArgToReg arg } bindConArgs _other_con _base args = ASSERT( null args ) return [] diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs index 664a606091..5106b971b1 100644 --- a/compiler/codeGen/StgCmmEnv.hs +++ b/compiler/codeGen/StgCmmEnv.hs @@ -76,11 +76,11 @@ nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidRep (idPrimRep id))] -- Manipulating CgIdInfo ------------------------------------- -mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo -mkCgIdInfo id lf expr +mkCgIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo +mkCgIdInfo dflags id lf expr = CgIdInfo { cg_id = id, cg_lf = lf , cg_loc = CmmLoc expr, - cg_tag = lfDynTag lf } + cg_tag = lfDynTag dflags lf } litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo litIdInfo dflags id lf lit @@ -88,13 +88,13 @@ litIdInfo dflags id lf lit , cg_loc = CmmLoc (addDynTag dflags (CmmLit lit) tag) , cg_tag = tag } where - tag = lfDynTag lf + tag = lfDynTag dflags lf lneIdInfo :: DynFlags -> Id -> [NonVoid Id] -> CgIdInfo lneIdInfo dflags id regs = CgIdInfo { cg_id = id, cg_lf = lf , cg_loc = LneLoc blk_id (map (idToReg dflags) regs) - , cg_tag = lfDynTag lf } + , cg_tag = lfDynTag dflags lf } where lf = mkLFLetNoEscape blk_id = mkBlockId (idUnique id) @@ -104,11 +104,11 @@ rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg) rhsIdInfo id lf_info = do dflags <- getDynFlags reg <- newTemp (gcWord dflags) - return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg) + return (mkCgIdInfo dflags id lf_info (CmmReg (CmmLocal reg)), reg) mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph mkRhsInit dflags reg lf_info expr - = mkAssign (CmmLocal reg) (addDynTag dflags expr (lfDynTag lf_info)) + = mkAssign (CmmLocal reg) (addDynTag dflags expr (lfDynTag dflags lf_info)) idInfoToAmode :: CgIdInfo -> CmmExpr -- Returns a CmmExpr for the *tagged* pointer @@ -217,7 +217,7 @@ bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg bindToReg nvid@(NonVoid id) lf_info = do dflags <- getDynFlags let reg = idToReg dflags nvid - addBindC id (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg))) + addBindC id (mkCgIdInfo dflags id lf_info (CmmReg (CmmLocal reg))) return reg rebindToReg :: NonVoid Id -> FCode LocalReg diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index ccd7d96231..307d3715b3 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -512,7 +512,7 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts bndr_reg = CmmLocal (idToReg dflags bndr) -- Is the constructor tag in the node reg? - ; if isSmallFamily fam_sz + ; if isSmallFamily dflags fam_sz then do let -- Yes, bndr_reg has constr. tag in ls bits tag_expr = cmmConstrTag1 dflags (CmmReg bndr_reg) 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..142100e109 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -219,7 +219,7 @@ direct_call caller call_conv lbl arity args emitCallWithExtraStack (call_conv, NativeReturn) target (nonVArgs fast_args) - (mkStkOffsets (stack_args dflags)) + (mkStkOffsets dflags (stack_args dflags)) where target = CmmLit (CmmLabel lbl) (fast_args, rest_args) = splitAt real_arity args @@ -329,10 +329,11 @@ slowCallPattern [] = (fsLit "stg_ap_0", 0) -- See Note [over-saturated calls]. mkStkOffsets - :: [(ArgRep, Maybe CmmExpr)] -- things to make offsets for + :: DynFlags + -> [(ArgRep, Maybe CmmExpr)] -- things to make offsets for -> ( ByteOff -- OUTPUTS: Topmost allocated word , [(CmmExpr, ByteOff)] ) -- things with offsets (voids filtered out) -mkStkOffsets things +mkStkOffsets dflags things = loop 0 [] (reverse things) where loop offset offs [] = (offset,offs) @@ -341,7 +342,7 @@ mkStkOffsets things loop offset offs ((rep,Just thing):things) = loop thing_off ((thing, thing_off):offs) things where - thing_off = offset + argRepSizeW rep * wORD_SIZE + thing_off = offset + argRepSizeW dflags rep * wORD_SIZE dflags -- offset of thing is offset+size, because we're -- growing the stack *downwards* as the offsets increase. @@ -382,13 +383,13 @@ isNonV :: ArgRep -> Bool isNonV V = False isNonV _ = True -argRepSizeW :: ArgRep -> WordOff -- Size in words -argRepSizeW N = 1 -argRepSizeW P = 1 -argRepSizeW F = 1 -argRepSizeW L = wORD64_SIZE `quot` wORD_SIZE -argRepSizeW D = dOUBLE_SIZE `quot` wORD_SIZE -argRepSizeW V = 0 +argRepSizeW :: DynFlags -> ArgRep -> WordOff -- Size in words +argRepSizeW _ N = 1 +argRepSizeW _ P = 1 +argRepSizeW _ F = 1 +argRepSizeW dflags L = wORD64_SIZE `quot` wORD_SIZE dflags +argRepSizeW dflags D = dOUBLE_SIZE dflags `quot` wORD_SIZE dflags +argRepSizeW _ V = 0 idArgRep :: Id -> ArgRep idArgRep = toArgRep . idPrimRep @@ -405,8 +406,9 @@ hpRel hp off = off - hp getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr getHpRelOffset virtual_offset - = do { hp_usg <- getHpUsage - ; return (cmmRegOffW hpReg (hpRel (realHp hp_usg) virtual_offset)) } + = do dflags <- getDynFlags + hp_usg <- getHpUsage + return (cmmRegOffW dflags hpReg (hpRel (realHp hp_usg) virtual_offset)) mkVirtHeapOffsets :: DynFlags @@ -438,7 +440,7 @@ mkVirtHeapOffsets dflags is_thunk things | otherwise = fixedHdrSize dflags computeOffset wds_so_far (rep, thing) - = (wds_so_far + argRepSizeW (toArgRep rep), + = (wds_so_far + argRepSizeW dflags (toArgRep rep), (NonVoid thing, hdr_size + wds_so_far)) mkVirtConstrOffsets :: DynFlags -> [(PrimRep,a)] -> (WordOff, WordOff, [(NonVoid a, VirtualHpOffset)]) @@ -462,19 +464,20 @@ mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags False #include "../includes/rts/storage/FunTypes.h" mkArgDescr :: Name -> [Id] -> FCode ArgDescr -mkArgDescr _nm args - = case stdPattern arg_reps of - Just spec_id -> return (ArgSpec spec_id) - Nothing -> return (ArgGen arg_bits) - where - arg_bits = argBits arg_reps - arg_reps = filter isNonV (map idArgRep args) - -- Getting rid of voids eases matching of standard patterns - -argBits :: [ArgRep] -> [Bool] -- True for non-ptr, False for ptr -argBits [] = [] -argBits (P : args) = False : argBits args -argBits (arg : args) = take (argRepSizeW arg) (repeat True) ++ argBits args +mkArgDescr _nm args + = do dflags <- getDynFlags + let arg_bits = argBits dflags arg_reps + arg_reps = filter isNonV (map idArgRep args) + -- Getting rid of voids eases matching of standard patterns + case stdPattern arg_reps of + Just spec_id -> return (ArgSpec spec_id) + Nothing -> return (ArgGen arg_bits) + +argBits :: DynFlags -> [ArgRep] -> [Bool] -- True for non-ptr, False for ptr +argBits _ [] = [] +argBits dflags (P : args) = False : argBits dflags args +argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True) + ++ argBits dflags args ---------------------- stdPattern :: [ArgRep] -> Maybe StgHalfWord @@ -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..e6e9899040 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -54,7 +54,6 @@ import CostCentre import DynFlags import FastString import Module -import Constants -- Lots of field offsets import Outputable import Control.Monad @@ -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 @@ -348,8 +347,8 @@ ldvRecordCreate closure = do dflags <- getDynFlags -- ldvEnterClosure :: ClosureInfo -> FCode () ldvEnterClosure closure_info = do dflags <- getDynFlags + let tag = funTag dflags closure_info ldvEnter (cmmOffsetB dflags (CmmReg nodeReg) (-tag)) - where tag = funTag closure_info -- don't forget to substract node's tag ldvEnter :: CmmExpr -> FCode () 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 59dfbc896e..af7a06876d 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -22,7 +22,9 @@ import ByteCodeAsm import ByteCodeLink import LibFFI +import DynFlags import Outputable +import Platform import Name import MkId import Id @@ -40,7 +42,6 @@ import TyCon import Util import VarSet import TysPrim -import DynFlags import ErrUtils import Unique import FastString @@ -164,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, @@ -179,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 @@ -206,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 @@ -291,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 @@ -398,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 @@ -449,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) @@ -791,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 @@ -825,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... @@ -926,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 @@ -945,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) @@ -973,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 @@ -1032,8 +1033,8 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l void marshall_code ( StgWord* ptr_to_top_of_stack ) -} -- resolve static address - get_target_info - = case target of + get_target_info = do + case target of DynamicTarget -> return (False, panic "ByteCodeGen.generateCCall(dyn)") @@ -1044,11 +1045,10 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l return (True, res) where stdcall_adj_target -#ifdef mingw32_TARGET_OS - | StdCallConv <- cconv - = let size = fromIntegral a_reps_sizeW * wORD_SIZE in + | OSMinGW32 <- platformOS (targetPlatform dflags) + , StdCallConv <- cconv + = let size = fromIntegral a_reps_sizeW * wORD_SIZE dflags in mkFastString (unpackFS target ++ '@':show size) -#endif | otherwise = target @@ -1072,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 @@ -1090,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)) @@ -1217,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 -- @@ -1230,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 @@ -1256,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 @@ -1433,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 35de40bdc4..9e77990160 100644 --- a/compiler/llvmGen/Llvm/Types.hs +++ b/compiler/llvmGen/Llvm/Types.hs @@ -11,7 +11,7 @@ import Data.Int import Data.List (intercalate) import Numeric -import Constants +import DynFlags import FastString import Unique @@ -325,21 +325,21 @@ isGlobal (LMGlobalVar _ _ _ _ _ _) = True isGlobal _ = False -- | Width in bits of an 'LlvmType', returns 0 if not applicable -llvmWidthInBits :: LlvmType -> Int -llvmWidthInBits (LMInt n) = n -llvmWidthInBits (LMFloat) = 32 -llvmWidthInBits (LMDouble) = 64 -llvmWidthInBits (LMFloat80) = 80 -llvmWidthInBits (LMFloat128) = 128 +llvmWidthInBits :: DynFlags -> LlvmType -> Int +llvmWidthInBits _ (LMInt n) = n +llvmWidthInBits _ (LMFloat) = 32 +llvmWidthInBits _ (LMDouble) = 64 +llvmWidthInBits _ (LMFloat80) = 80 +llvmWidthInBits _ (LMFloat128) = 128 -- Could return either a pointer width here or the width of what -- it points to. We will go with the former for now. -llvmWidthInBits (LMPointer _) = llvmWidthInBits llvmWord -llvmWidthInBits (LMArray _ _) = llvmWidthInBits llvmWord -llvmWidthInBits LMLabel = 0 -llvmWidthInBits LMVoid = 0 -llvmWidthInBits (LMStruct tys) = sum $ map llvmWidthInBits tys -llvmWidthInBits (LMFunction _) = 0 -llvmWidthInBits (LMAlias (_,t)) = llvmWidthInBits t +llvmWidthInBits dflags (LMPointer _) = llvmWidthInBits dflags (llvmWord dflags) +llvmWidthInBits dflags (LMArray _ _) = llvmWidthInBits dflags (llvmWord dflags) +llvmWidthInBits _ LMLabel = 0 +llvmWidthInBits _ LMVoid = 0 +llvmWidthInBits dflags (LMStruct tys) = sum $ map (llvmWidthInBits dflags) tys +llvmWidthInBits _ (LMFunction _) = 0 +llvmWidthInBits dflags (LMAlias (_,t)) = llvmWidthInBits dflags t -- ----------------------------------------------------------------------------- @@ -356,9 +356,9 @@ i1 = LMInt 1 i8Ptr = pLift i8 -- | The target architectures word size -llvmWord, llvmWordPtr :: LlvmType -llvmWord = LMInt (wORD_SIZE * 8) -llvmWordPtr = pLift llvmWord +llvmWord, llvmWordPtr :: DynFlags -> LlvmType +llvmWord dflags = LMInt (wORD_SIZE dflags * 8) +llvmWordPtr dflags = pLift (llvmWord dflags) -- ----------------------------------------------------------------------------- -- * LLVM Function Types diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index 00c2129ed9..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 @@ -99,33 +98,33 @@ llvmFunSig env lbl link llvmFunSig' :: DynFlags -> LMString -> LlvmLinkageType -> LlvmFunctionDecl llvmFunSig' dflags lbl link - = let platform = targetPlatform dflags - toParams x | isPointer x = (x, [NoAlias, NoCapture]) + = let toParams x | isPointer x = (x, [NoAlias, NoCapture]) | otherwise = (x, []) in LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs - (map (toParams . getVarType) (llvmFunArgs platform)) - llvmFunAlign + (map (toParams . getVarType) (llvmFunArgs dflags)) + (llvmFunAlign dflags) -- | Create a Haskell function in LLVM. mkLlvmFunc :: LlvmEnv -> CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks -> LlvmFunction mkLlvmFunc env lbl link sec blks - = let platform = targetPlatform $ getDflags env + = let dflags = getDflags env funDec = llvmFunSig env lbl link - funArgs = map (fsLit . getPlainName) (llvmFunArgs platform) + funArgs = map (fsLit . getPlainName) (llvmFunArgs dflags) 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 :: Platform -> [LlvmVar] -llvmFunArgs platform = map lmGlobalRegArg (activeStgRegs platform) +llvmFunArgs :: DynFlags -> [LlvmVar] +llvmFunArgs dflags = map (lmGlobalRegArg dflags) (activeStgRegs platform) + where platform = targetPlatform dflags -- | Llvm standard fun attributes llvmStdFunAttrs :: [LlvmFuncAttr] @@ -169,19 +168,19 @@ type LlvmEnvMap = UniqFM LlvmType -- | Get initial Llvm environment. initLlvmEnv :: DynFlags -> LlvmEnv initLlvmEnv dflags = LlvmEnv (initFuncs, emptyUFM, defaultLlvmVersion, dflags) - where initFuncs = listToUFM $ [ (n, LMFunction ty) | (n, ty) <- ghcInternalFunctions ] + where initFuncs = listToUFM $ [ (n, LMFunction ty) | (n, ty) <- ghcInternalFunctions dflags ] -- | Here we pre-initialise some functions that are used internally by GHC -- so as to make sure they have the most general type in the case that -- user code also uses these functions but with a different type than GHC -- internally. (Main offender is treating return type as 'void' instead of -- 'void *'. Fixes trac #5486. -ghcInternalFunctions :: [(LMString, LlvmFunctionDecl)] -ghcInternalFunctions = - [ mk "memcpy" i8Ptr [i8Ptr, i8Ptr, llvmWord] - , mk "memmove" i8Ptr [i8Ptr, i8Ptr, llvmWord] - , mk "memset" i8Ptr [i8Ptr, llvmWord, llvmWord] - , mk "newSpark" llvmWord [i8Ptr, i8Ptr] +ghcInternalFunctions :: DynFlags -> [(LMString, LlvmFunctionDecl)] +ghcInternalFunctions dflags = + [ mk "memcpy" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags] + , mk "memmove" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags] + , mk "memset" i8Ptr [i8Ptr, llvmWord dflags, llvmWord dflags] + , mk "newSpark" (llvmWord dflags) [i8Ptr, i8Ptr] ] where mk n ret args = @@ -244,12 +243,12 @@ strCLabel_llvm env l = {-# SCC "llvm_strCLabel" #-} -- | Create an external definition for a 'CLabel' defined in another module. genCmmLabelRef :: LlvmEnv -> CLabel -> LMGlobal -genCmmLabelRef env = genStringLabelRef . strCLabel_llvm env +genCmmLabelRef env = genStringLabelRef (getDflags env) . strCLabel_llvm env -- | As above ('genCmmLabelRef') but taking a 'LMString', not 'CLabel'. -genStringLabelRef :: LMString -> LMGlobal -genStringLabelRef cl - = let ty = LMPointer $ LMArray 0 llvmWord +genStringLabelRef :: DynFlags -> LMString -> LMGlobal +genStringLabelRef dflags cl + = let ty = LMPointer $ LMArray 0 (llvmWord dflags) in (LMGlobalVar cl ty External Nothing Nothing False, Nothing) -- ---------------------------------------------------------------------------- diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index f80a4f2b4c..448bd4d94c 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -55,11 +55,11 @@ basicBlocksCodeGen :: LlvmEnv -> ( [LlvmBasicBlock] , [LlvmCmmDecl] ) -> UniqSM (LlvmEnv, [LlvmBasicBlock] , [LlvmCmmDecl] ) basicBlocksCodeGen env ([]) (blocks, tops) - = do let platform = targetPlatform $ getDflags env + = do let dflags = getDflags env let (blocks', allocs) = mapAndUnzip dominateAllocs blocks let allocs' = concat allocs let ((BasicBlock id fstmts):rblks) = blocks' - let fblocks = (BasicBlock id $ funPrologue platform ++ allocs' ++ fstmts):rblks + let fblocks = (BasicBlock id $ funPrologue dflags ++ allocs' ++ fstmts):rblks return (env, fblocks, tops) basicBlocksCodeGen env (block:blocks) (lblocks', ltops') @@ -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 @@ -185,7 +186,8 @@ genCall env (CmmPrim MO_WriteBarrier _) _ _ _ -- i8 range. So we must handle conversions from i32 to i8 explicitly as LLVM -- is strict about types. genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do - let width = widthToLlvmInt w + let dflags = getDflags env + width = widthToLlvmInt w dstTy = cmmToLlvmType $ localRegType dst funTy = \n -> LMFunction $ LlvmFunctionDecl n ExternallyVisible CC_Ccc width FixedArgs (tysToParams [width]) Nothing @@ -193,9 +195,9 @@ genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do (env2, argsV, stmts2, top2) <- arg_vars env1 args ([], nilOL, []) (env3, fptr, stmts3, top3) <- getFunPtr env2 funTy t - (argsV', stmts4) <- castVars $ zip argsV [width] + (argsV', stmts4) <- castVars dflags $ zip argsV [width] (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] - ([retV'], stmts5) <- castVars [(retV,dstTy)] + ([retV'], stmts5) <- castVars dflags [(retV,dstTy)] let s2 = Store retV' dstV let stmts = stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` @@ -208,17 +210,18 @@ genCall env t@(CmmPrim op _) [] args' CmmMayReturn | op == MO_Memcpy || op == MO_Memset || op == MO_Memmove = do - let (args, alignVal) = splitAlignVal args' + let dflags = getDflags env + (args, alignVal) = splitAlignVal args' (isVolTy, isVolVal) = if getLlvmVer env >= 28 then ([i1], [mkIntLit i1 0]) else ([], []) - argTy | op == MO_Memset = [i8Ptr, i8, llvmWord, i32] ++ isVolTy - | otherwise = [i8Ptr, i8Ptr, llvmWord, i32] ++ isVolTy + argTy | op == MO_Memset = [i8Ptr, i8, llvmWord dflags, i32] ++ isVolTy + | otherwise = [i8Ptr, i8Ptr, llvmWord dflags, i32] ++ isVolTy funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, []) (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy t - (argVars', stmts3) <- castVars $ zip argVars argTy + (argVars', stmts3) <- castVars dflags $ zip argVars argTy let arguments = argVars' ++ (alignVal:isVolVal) call = Expr $ Call StdCall fptr arguments [] @@ -290,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, []) @@ -415,16 +418,17 @@ arg_vars env (CmmHinted e _:rest) (vars, stmts, tops) -- | Cast a collection of LLVM variables to specific types. -castVars :: [(LlvmVar, LlvmType)] +castVars :: DynFlags -> [(LlvmVar, LlvmType)] -> UniqSM ([LlvmVar], LlvmStatements) -castVars vars = do - done <- mapM (uncurry castVar) vars +castVars dflags vars = do + done <- mapM (uncurry (castVar dflags)) vars let (vars', stmts) = unzip done return (vars', toOL stmts) -- | Cast an LLVM variable to a specific type, panicing if it can't be done. -castVar :: LlvmVar -> LlvmType -> UniqSM (LlvmVar, LlvmStatement) -castVar v t | getVarType v == t +castVar :: DynFlags -> LlvmVar -> LlvmType -> UniqSM (LlvmVar, LlvmStatement) +castVar dflags v t + | getVarType v == t = return (v, Nop) | otherwise @@ -432,7 +436,7 @@ castVar v t | getVarType v == t (LMInt n, LMInt m) -> if n < m then LM_Sext else LM_Trunc (vt, _) | isFloat vt && isFloat t - -> if llvmWidthInBits vt < llvmWidthInBits t + -> if llvmWidthInBits dflags vt < llvmWidthInBits dflags t then LM_Fpext else LM_Fptrunc (vt, _) | isInt vt && isFloat t -> LM_Sitofp (vt, _) | isFloat vt && isInt t -> LM_Fptosi @@ -498,10 +502,11 @@ cmmPrimOpFunctions env mop MO_Touch -> unsupported where + dflags = getDflags env intrinTy1 = (if getLlvmVer env >= 28 - then "p0i8.p0i8." else "") ++ show llvmWord + then "p0i8.p0i8." else "") ++ show (llvmWord dflags) intrinTy2 = (if getLlvmVer env >= 28 - then "p0i8." else "") ++ show llvmWord + then "p0i8." else "") ++ show (llvmWord dflags) unsupported = panic ("cmmPrimOpFunctions: " ++ show mop ++ " not supported here") @@ -543,12 +548,13 @@ genJump env expr live = do -- these with registers when possible. genAssign :: LlvmEnv -> CmmReg -> CmmExpr -> UniqSM StmtData genAssign env reg val = do - let (env1, vreg, stmts1, top1) = getCmmReg env reg + let dflags = getDflags env + (env1, vreg, stmts1, top1) = getCmmReg env reg (env2, vval, stmts2, top2) <- exprToVar env1 val let stmts = stmts1 `appOL` stmts2 let ty = (pLower . getVarType) vreg - case isPointer ty && getVarType vval == llvmWord of + case isPointer ty && getVarType vval == llvmWord dflags of -- Some registers are pointer types, so need to cast value to pointer True -> do (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty @@ -594,10 +600,11 @@ genStore env addr val = genStore_slow env addr val [other] genStore_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmExpr -> UniqSM StmtData genStore_fast env addr r n val - = let gr = lmGlobalRegVar r + = let dflags = getDflags env + gr = lmGlobalRegVar (getDflags env) r meta = [getTBAA r] grt = (pLower . getVarType) gr - (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8) + (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) in case isPointer grt && rem == 0 of True -> do (env', vval, stmts, top) <- exprToVar env val @@ -634,7 +641,7 @@ genStore_slow env addr val meta = do let stmts = stmts1 `appOL` stmts2 case getVarType vaddr of -- sometimes we need to cast an int to a pointer before storing - LMPointer ty@(LMPointer _) | getVarType vval == llvmWord -> do + LMPointer ty@(LMPointer _) | getVarType vval == llvmWord dflags -> do (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty let s2 = MetaStmt meta $ Store v vaddr return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) @@ -643,7 +650,7 @@ genStore_slow env addr val meta = do let s1 = MetaStmt meta $ Store vval vaddr return (env2, stmts `snocOL` s1, top1 ++ top2) - i@(LMInt _) | i == llvmWord -> do + i@(LMInt _) | i == llvmWord dflags -> do let vty = pLift $ getVarType vval (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty let s2 = MetaStmt meta $ Store vval vptr @@ -653,7 +660,7 @@ genStore_slow env addr val meta = do pprPanic "genStore: ptr not right type!" (PprCmm.pprExpr addr <+> text ( "Size of Ptr: " ++ show (llvmPtrBits dflags) ++ - ", Size of var: " ++ show (llvmWidthInBits other) ++ + ", Size of var: " ++ show (llvmWidthInBits dflags other) ++ ", Var: " ++ show vaddr)) where dflags = getDflags env @@ -723,14 +730,14 @@ data EOption = EOption { i1Option :: EOption i1Option = EOption (Just i1) -wordOption :: EOption -wordOption = EOption (Just llvmWord) +wordOption :: DynFlags -> EOption +wordOption dflags = EOption (Just (llvmWord dflags)) -- | Convert a CmmExpr to a list of LlvmStatements with the result of the -- expression being stored in the returned LlvmVar. exprToVar :: LlvmEnv -> CmmExpr -> UniqSM ExprData -exprToVar env = exprToVarOpt env wordOption +exprToVar env = exprToVarOpt env (wordOption (getDflags env)) exprToVarOpt :: LlvmEnv -> EOption -> CmmExpr -> UniqSM ExprData exprToVarOpt env opt e = case e of @@ -749,7 +756,7 @@ exprToVarOpt env opt e = case e of case (isPointer . getVarType) v1 of True -> do -- Cmm wants the value, so pointer types must be cast to ints - (v2, s2) <- doExpr llvmWord $ Cast LM_Ptrtoint v1 llvmWord + (v2, s2) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint v1 (llvmWord dflags) return (env', v2, stmts `snocOL` s1 `snocOL` s2, top) False -> return (env', v1, stmts `snocOL` s1, top) @@ -837,6 +844,8 @@ genMachOp env _ op [x] = case op of MO_S_Shr _ -> panicOp where + dflags = getDflags env + negate ty v2 negOp = do (env', vx, stmts, top) <- exprToVar env x (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx @@ -852,7 +861,7 @@ genMachOp env _ op [x] = case op of let sameConv' op = do (v1, s1) <- doExpr ty $ Cast op vx ty return (env', v1, stmts `snocOL` s1, top) - let toWidth = llvmWidthInBits ty + let toWidth = llvmWidthInBits dflags ty -- LLVM doesn't like trying to convert to same width, so -- need to check for that as we do get Cmm code doing it. case widthInBits from of @@ -880,14 +889,15 @@ genMachOp env opt op e = genMachOp_slow env opt op e genMachOp_fast :: LlvmEnv -> EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr] -> UniqSM ExprData genMachOp_fast env opt op r n e - = let gr = lmGlobalRegVar r + = let dflags = getDflags env + gr = lmGlobalRegVar dflags r grt = (pLower . getVarType) gr - (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8) + (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) in case isPointer grt && rem == 0 of True -> do (gv, s1) <- doExpr grt $ Load gr (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix] - (var, s3) <- doExpr llvmWord $ Cast LM_Ptrtoint ptr llvmWord + (var, s3) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint ptr (llvmWord dflags) return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3, []) False -> genMachOp_slow env opt op e @@ -957,6 +967,8 @@ genMachOp_slow env opt op [x, y] = case op of MO_FF_Conv _ _ -> panicOp where + dflags = getDflags env + binLlvmOp ty binOp = do (env1, vx, stmts1, top1) <- exprToVar env x (env2, vy, stmts2, top2) <- exprToVar env1 y @@ -1017,10 +1029,10 @@ genMachOp_slow env opt op [x, y] = case op of (env2, vy, stmts2, top2) <- exprToVar env1 y let word = getVarType vx - let word2 = LMInt $ 2 * (llvmWidthInBits $ getVarType vx) - let shift = llvmWidthInBits word - let shift1 = toIWord (shift - 1) - let shift2 = toIWord shift + let word2 = LMInt $ 2 * (llvmWidthInBits dflags $ getVarType vx) + let shift = llvmWidthInBits dflags word + let shift1 = toIWord dflags (shift - 1) + let shift2 = toIWord dflags shift if isInt word then do @@ -1081,11 +1093,12 @@ genLoad env e ty = genLoad_slow env e ty [other] genLoad_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmType -> UniqSM ExprData genLoad_fast env e r n ty = - let gr = lmGlobalRegVar r + let dflags = getDflags env + gr = lmGlobalRegVar dflags r meta = [getTBAA r] grt = (pLower . getVarType) gr ty' = cmmToLlvmType ty - (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8) + (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) in case isPointer grt && rem == 0 of True -> do (gv, s1) <- doExpr grt $ Load gr @@ -1122,7 +1135,7 @@ genLoad_slow env e ty meta = do (MetaExpr meta $ Load iptr) return (env', dvar, stmts `snocOL` load, tops) - i@(LMInt _) | i == llvmWord -> do + i@(LMInt _) | i == llvmWord dflags -> do let pty = LMPointer $ cmmToLlvmType ty (ptr, cast) <- doExpr pty $ Cast LM_Inttoptr iptr pty (dvar, load) <- doExpr (cmmToLlvmType ty) @@ -1132,7 +1145,7 @@ genLoad_slow env e ty meta = do other -> pprPanic "exprToVar: CmmLoad expression is not right type!" (PprCmm.pprExpr e <+> text ( "Size of Ptr: " ++ show (llvmPtrBits dflags) ++ - ", Size of var: " ++ show (llvmWidthInBits other) ++ + ", Size of var: " ++ show (llvmWidthInBits dflags other) ++ ", Var: " ++ show iptr)) where dflags = getDflags env @@ -1150,7 +1163,7 @@ getCmmReg env r@(CmmLocal (LocalReg un _)) Just ety -> (env, (LMLocalVar un $ pLift ety), nilOL, []) Nothing -> (nenv, newv, stmts, []) -getCmmReg env (CmmGlobal g) = (env, lmGlobalRegVar g, nilOL, []) +getCmmReg env (CmmGlobal g) = (env, lmGlobalRegVar (getDflags env) g, nilOL, []) -- | Allocate a CmmReg on the stack @@ -1182,10 +1195,10 @@ genLit env cmm@(CmmLabel l) in case ty of -- Make generic external label definition and then pointer to it Nothing -> do - let glob@(var, _) = genStringLabelRef label + let glob@(var, _) = genStringLabelRef dflags label let ldata = [CmmData Data [([glob], [])]] let env' = funInsert label (pLower $ getVarType var) env - (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var llvmWord + (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags) return (env', v1, unitOL s1, ldata) -- Referenced data exists in this module, retrieve type and make @@ -1193,23 +1206,25 @@ genLit env cmm@(CmmLabel l) Just ty' -> do let var = LMGlobalVar label (LMPointer ty') ExternallyVisible Nothing Nothing False - (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var llvmWord + (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags) return (env, v1, unitOL s1, []) genLit env (CmmLabelOff label off) = do + let dflags = getDflags env (env', vlbl, stmts, stat) <- genLit env (CmmLabel label) - let voff = toIWord off + let voff = toIWord dflags off (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff return (env', v1, stmts `snocOL` s1, stat) genLit env (CmmLabelDiffOff l1 l2 off) = do + let dflags = getDflags env (env1, vl1, stmts1, stat1) <- genLit env (CmmLabel l1) (env2, vl2, stmts2, stat2) <- genLit env1 (CmmLabel l2) - let voff = toIWord off + let voff = toIWord dflags off let ty1 = getVarType vl1 let ty2 = getVarType vl2 if (isInt ty1) && (isInt ty2) - && (llvmWidthInBits ty1 == llvmWidthInBits ty2) + && (llvmWidthInBits dflags ty1 == llvmWidthInBits dflags ty2) then do (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2 @@ -1232,11 +1247,12 @@ genLit _ CmmHighStackMark -- -- | Function prologue. Load STG arguments into variables for function. -funPrologue :: Platform -> [LlvmStatement] -funPrologue platform = concat $ map getReg $ activeStgRegs platform - where getReg rr = - let reg = lmGlobalRegVar rr - arg = lmGlobalRegArg rr +funPrologue :: DynFlags -> [LlvmStatement] +funPrologue dflags = concat $ map getReg $ activeStgRegs platform + where platform = targetPlatform dflags + getReg rr = + let reg = lmGlobalRegVar dflags rr + arg = lmGlobalRegArg dflags rr alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1 in [alloc, Store arg reg] @@ -1254,11 +1270,11 @@ funEpilogue env (Just live) | dopt Opt_RegLiveness dflags = do dflags = getDflags env platform = targetPlatform dflags loadExpr r | r `elem` alwaysLive || r `elem` live = do - let reg = lmGlobalRegVar r + let reg = lmGlobalRegVar dflags r (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg return (v, unitOL s) loadExpr r = do - let ty = (pLower . getVarType $ lmGlobalRegVar r) + let ty = (pLower . getVarType $ lmGlobalRegVar dflags r) return (LMLitVar $ LMUndefLit ty, unitOL Nop) -- don't do liveness optimisation @@ -1270,7 +1286,7 @@ funEpilogue env _ = do dflags = getDflags env platform = targetPlatform dflags loadExpr r = do - let reg = lmGlobalRegVar r + let reg = lmGlobalRegVar dflags r (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg return (v, unitOL s) @@ -1290,7 +1306,7 @@ trashStmts :: DynFlags -> LlvmStatements trashStmts dflags = concatOL $ map trashReg $ activeStgRegs platform where platform = targetPlatform dflags trashReg r = - let reg = lmGlobalRegVar r + let reg = lmGlobalRegVar dflags r ty = (pLower . getVarType) reg trash = unitOL $ Store (LMLitVar $ LMUndefLit ty) reg in case callerSaves (targetPlatform dflags) r of @@ -1361,9 +1377,11 @@ mkIntLit :: Integral a => LlvmType -> a -> LlvmVar mkIntLit ty i = LMLitVar $ LMIntLit (toInteger i) ty -- | Convert int type to a LLvmVar of word or i32 size -toI32, toIWord :: Integral a => a -> LlvmVar +toI32 :: Integral a => a -> LlvmVar toI32 = mkIntLit i32 -toIWord = mkIntLit llvmWord + +toIWord :: Integral a => DynFlags -> a -> LlvmVar +toIWord dflags = mkIntLit (llvmWord dflags) -- | Error functions diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs index eae8246138..9c57ab3cd4 100644 --- a/compiler/llvmGen/LlvmCodeGen/Data.hs +++ b/compiler/llvmGen/LlvmCodeGen/Data.hs @@ -114,7 +114,7 @@ resData env (Left cmm@(CmmLabel l)) = in case ty of -- Make generic external label defenition and then pointer to it Nothing -> - let glob@(var, _) = genStringLabelRef label + let glob@(var, _) = genStringLabelRef dflags label env' = funInsert label (pLower $ getVarType var) env ptr = LMStaticPointer var in (env', LMPtoI ptr lmty, [glob]) @@ -127,15 +127,17 @@ resData env (Left cmm@(CmmLabel l)) = in (env, LMPtoI ptr lmty, []) resData env (Left (CmmLabelOff label off)) = - let (env', var, glob) = resData env (Left (CmmLabel label)) - offset = LMStaticLit $ LMIntLit (toInteger off) llvmWord + let dflags = getDflags env + (env', var, glob) = resData env (Left (CmmLabel label)) + offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags) in (env', LMAdd var offset, glob) resData env (Left (CmmLabelDiffOff l1 l2 off)) = - let (env1, var1, glob1) = resData env (Left (CmmLabel l1)) + let dflags = getDflags env + (env1, var1, glob1) = resData env (Left (CmmLabel l1)) (env2, var2, glob2) = resData env1 (Left (CmmLabel l2)) var = LMSub var1 var2 - offset = LMStaticLit $ LMIntLit (toInteger off) llvmWord + offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags) in (env2, LMAdd var offset, glob1 ++ glob2) resData _ _ = panic "resData: Non CLabel expr as left type!" diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs index cf78b3730a..c791e85a52 100644 --- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs +++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs @@ -28,10 +28,10 @@ import Unique -- | Header code for LLVM modules pprLlvmHeader :: SDoc -pprLlvmHeader = +pprLlvmHeader = sdocWithDynFlags $ \dflags -> moduleLayout $+$ text "" - $+$ ppLlvmFunctionDecls (map snd ghcInternalFunctions) + $+$ ppLlvmFunctionDecls (map snd (ghcInternalFunctions dflags)) $+$ ppLlvmMetas stgTBAA $+$ text "" @@ -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/llvmGen/LlvmCodeGen/Regs.hs b/compiler/llvmGen/LlvmCodeGen/Regs.hs index b7ff9f008e..49c900d5e0 100644 --- a/compiler/llvmGen/LlvmCodeGen/Regs.hs +++ b/compiler/llvmGen/LlvmCodeGen/Regs.hs @@ -12,23 +12,24 @@ module LlvmCodeGen.Regs ( import Llvm import CmmExpr +import DynFlags import FastString import Outputable ( panic ) -- | Get the LlvmVar function variable storing the real register -lmGlobalRegVar :: GlobalReg -> LlvmVar -lmGlobalRegVar = (pVarLift . lmGlobalReg "_Var") +lmGlobalRegVar :: DynFlags -> GlobalReg -> LlvmVar +lmGlobalRegVar dflags = pVarLift . lmGlobalReg dflags "_Var" -- | Get the LlvmVar function argument storing the real register -lmGlobalRegArg :: GlobalReg -> LlvmVar -lmGlobalRegArg = lmGlobalReg "_Arg" +lmGlobalRegArg :: DynFlags -> GlobalReg -> LlvmVar +lmGlobalRegArg dflags = lmGlobalReg dflags "_Arg" {- Need to make sure the names here can't conflict with the unique generated names. Uniques generated names containing only base62 chars. So using say the '_' char guarantees this. -} -lmGlobalReg :: String -> GlobalReg -> LlvmVar -lmGlobalReg suf reg +lmGlobalReg :: DynFlags -> String -> GlobalReg -> LlvmVar +lmGlobalReg dflags suf reg = case reg of BaseReg -> ptrGlobal $ "Base" ++ suf Sp -> ptrGlobal $ "Sp" ++ suf @@ -53,8 +54,8 @@ lmGlobalReg suf reg -- LongReg, HpLim, CCSS, CurrentTSO, CurrentNusery, HpAlloc -- EagerBlackholeInfo, GCEnter1, GCFun, BaseReg, PicBaseReg where - wordGlobal name = LMNLocalVar (fsLit name) llvmWord - ptrGlobal name = LMNLocalVar (fsLit name) llvmWordPtr + wordGlobal name = LMNLocalVar (fsLit name) (llvmWord dflags) + ptrGlobal name = LMNLocalVar (fsLit name) (llvmWordPtr dflags) floatGlobal name = LMNLocalVar (fsLit name) LMFloat doubleGlobal name = LMNLocalVar (fsLit name) LMDouble 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..d4c3d535d6 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -120,6 +120,8 @@ module DynFlags ( #include "../includes/dist-derivedconstants/header/GHCConstantsHaskellExports.hs" bLOCK_SIZE_W, wORD_SIZE_IN_BITS, + tAG_MASK, + mAX_PTR_TAG, ) where #include "HsVersions.h" @@ -151,6 +153,7 @@ import System.IO.Unsafe ( unsafePerformIO ) import Data.IORef import Control.Monad +import Data.Bits import Data.Char import Data.List import Data.Map (Map) @@ -3148,8 +3151,14 @@ 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 + +tAG_MASK :: DynFlags -> Int +tAG_MASK dflags = (1 `shiftL` tAG_BITS dflags) - 1 + +mAX_PTR_TAG :: DynFlags -> Int +mAX_PTR_TAG = tAG_MASK 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..06fef36102 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 dflags `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..4ad7deef19 100644 --- a/includes/HaskellConstants.hs +++ b/includes/HaskellConstants.hs @@ -1,5 +1,4 @@ -import Data.Bits (shiftL) import Data.Word import Data.Int @@ -34,19 +33,9 @@ mAX_CONTEXT_REDUCTION_DEPTH :: Int mAX_CONTEXT_REDUCTION_DEPTH = 200 -- Increase to 200; see Trac #5395 --- Size of a double in StgWords. - -dOUBLE_SIZE :: Int -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 @@ -67,30 +56,3 @@ tARGET_MAX_WORD = fromIntegral (maxBound :: TargetWord) tARGET_MAX_CHAR :: Int tARGET_MAX_CHAR = 0x10ffff --- Amount of pointer bits used for semi-tagging constructor closures - -tAG_BITS :: Int -tAG_BITS = TAG_BITS - -tAG_MASK :: Int -tAG_MASK = (1 `shiftL` tAG_BITS) - 1 - -mAX_PTR_TAG :: Int -mAX_PTR_TAG = tAG_MASK - --- Size of a C int, in bytes. May be smaller than wORD_SIZE. - -cINT_SIZE :: Int -cINT_SIZE = SIZEOF_INT - -cLONG_SIZE :: Int -cLONG_SIZE = SIZEOF_LONG - -cLONG_LONG_SIZE :: Int -cLONG_LONG_SIZE = SIZEOF_LONG_LONG - --- Number of bits to shift a bitfield left by in an info table. - -bITMAP_BITS_SHIFT :: Int -bITMAP_BITS_SHIFT = BITMAP_BITS_SHIFT - diff --git a/includes/mkDerivedConstants.c b/includes/mkDerivedConstants.c index 609c7aed31..558d709f94 100644 --- a/includes/mkDerivedConstants.c +++ b/includes/mkDerivedConstants.c @@ -683,6 +683,23 @@ 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); + + // Size of a double in StgWords. + constantInt("dOUBLE_SIZE", SIZEOF_DOUBLE); + + // Size of a C int, in bytes. May be smaller than wORD_SIZE. + constantInt("cINT_SIZE", SIZEOF_INT); + constantInt("cLONG_SIZE", SIZEOF_LONG); + constantInt("cLONG_LONG_SIZE", SIZEOF_LONG_LONG); + + // Number of bits to shift a bitfield left by in an info table. + constantInt("bITMAP_BITS_SHIFT", BITMAP_BITS_SHIFT); + + // Amount of pointer bits used for semi-tagging constructor closures + constantInt("tAG_BITS", TAG_BITS); + switch (mode) { case Gen_Haskell_Type: printf(" } deriving (Read, Show)\n"); |