Merge PrelRules refactoring (#7014)
authorPaolo Capriotti <p.capriotti@gmail.com>
Thu, 26 Jul 2012 20:50:56 +0000 (21:50 +0100)
committerPaolo Capriotti <p.capriotti@gmail.com>
Thu, 26 Jul 2012 20:50:59 +0000 (21:50 +0100)
59 files changed:
compiler/cmm/CmmInfo.hs
compiler/cmm/CmmLayoutStack.hs
compiler/cmm/CmmParse.y
compiler/cmm/CmmPipeline.hs
compiler/cmm/SMRep.lhs
compiler/codeGen/CgCallConv.hs
compiler/codeGen/CgCase.lhs
compiler/codeGen/CgClosure.lhs
compiler/codeGen/CgCon.lhs
compiler/codeGen/CgExpr.lhs
compiler/codeGen/CgExtCode.hs
compiler/codeGen/CgForeignCall.hs
compiler/codeGen/CgHeapery.lhs
compiler/codeGen/CgInfoTbls.hs
compiler/codeGen/CgPrimOp.hs
compiler/codeGen/CgProf.hs
compiler/codeGen/CgStackery.lhs
compiler/codeGen/CgTailCall.lhs
compiler/codeGen/CgTicky.hs
compiler/codeGen/ClosureInfo.lhs
compiler/codeGen/CodeGen.lhs
compiler/codeGen/StgCmm.hs
compiler/codeGen/StgCmmBind.hs
compiler/codeGen/StgCmmClosure.hs
compiler/codeGen/StgCmmCon.hs
compiler/codeGen/StgCmmExpr.hs
compiler/codeGen/StgCmmForeign.hs
compiler/codeGen/StgCmmHeap.hs
compiler/codeGen/StgCmmLayout.hs
compiler/codeGen/StgCmmPrim.hs
compiler/codeGen/StgCmmProf.hs
compiler/codeGen/StgCmmTicky.hs
compiler/deSugar/Coverage.lhs
compiler/deSugar/Desugar.lhs
compiler/ghci/ByteCodeAsm.lhs
compiler/ghci/ByteCodeGen.lhs
compiler/ghci/ByteCodeItbls.lhs
compiler/ghci/DebuggerUtils.hs
compiler/iface/FlagChecker.hs
compiler/main/DynFlags.hs
compiler/main/HscMain.hs
compiler/main/StaticFlagParser.hs
compiler/main/StaticFlags.hs
compiler/nativeGen/AsmCodeGen.lhs
compiler/nativeGen/PPC/Ppr.hs
compiler/nativeGen/SPARC/Ppr.hs
compiler/nativeGen/X86/Ppr.hs
compiler/parser/Lexer.x
compiler/parser/Parser.y.pp
compiler/profiling/ProfInit.hs
compiler/stgSyn/StgSyn.lhs
compiler/utils/Platform.hs
ghc.mk
mk/validate-settings.mk
packages
rts/Capability.c
rts/Task.c
rts/Task.h
rules/distdir-way-opts.mk

index a171faa..3970f24 100644 (file)
@@ -24,8 +24,8 @@ import qualified Stream
 
 import Maybes
 import Constants
+import DynFlags
 import Panic
-import Platform
 import StaticFlags
 import UniqSupply
 import MonadUtils
@@ -42,12 +42,12 @@ mkEmptyContInfoTable info_lbl
                  , cit_prof = NoProfilingInfo
                  , cit_srt  = NoC_SRT }
 
-cmmToRawCmm :: Platform -> Stream IO Old.CmmGroup ()
+cmmToRawCmm :: DynFlags -> Stream IO Old.CmmGroup ()
             -> IO (Stream IO Old.RawCmmGroup ())
-cmmToRawCmm platform cmms
+cmmToRawCmm dflags cmms
   = do { uniqs <- mkSplitUniqSupply 'i'
        ; let do_one uniqs cmm = do
-                case initUs uniqs $ concatMapM (mkInfoTable platform) cmm of
+                case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of
                   (b,uniqs') -> return (uniqs',b)
                   -- NB. strictness fixes a space leak.  DO NOT REMOVE.
        ; return (Stream.mapAccumL do_one uniqs cmms >> return ())
@@ -86,16 +86,16 @@ cmmToRawCmm platform cmms
 --
 --  * The SRT slot is only there if there is SRT info to record
 
-mkInfoTable :: Platform -> CmmDecl -> UniqSM [RawCmmDecl]
+mkInfoTable :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl]
 mkInfoTable _ (CmmData sec dat) 
   = return [CmmData sec dat]
 
-mkInfoTable platform (CmmProc info entry_label blocks)
+mkInfoTable dflags (CmmProc info entry_label blocks)
   | CmmNonInfoTable <- info   -- Code without an info table.  Easy.
   = return [CmmProc Nothing entry_label blocks]
                                
   | CmmInfoTable { cit_lbl = info_lbl } <- info
-  = do { (top_decls, info_cts) <- mkInfoTableContents platform info Nothing
+  = do { (top_decls, info_cts) <- mkInfoTableContents dflags info Nothing
        ; return (top_decls  ++
                  mkInfoTableAndCode info_lbl info_cts
                                     entry_label blocks) }
@@ -107,20 +107,20 @@ type InfoTableContents = ( [CmmLit]            -- The standard part
                          , [CmmLit] )       -- The "extra bits"
 -- These Lits have *not* had mkRelativeTo applied to them
 
-mkInfoTableContents :: Platform
+mkInfoTableContents :: DynFlags
                     -> CmmInfoTable
                     -> Maybe StgHalfWord    -- Override default RTS type tag?
                     -> UniqSM ([RawCmmDecl],             -- Auxiliary top decls
                                InfoTableContents)      -- Info tbl + extra bits
 
-mkInfoTableContents platform
+mkInfoTableContents dflags
                     info@(CmmInfoTable { cit_lbl  = info_lbl
                                        , cit_rep  = smrep
                                        , cit_prof = prof
                                        , cit_srt = srt }) 
                     mb_rts_tag
   | RTSRep rts_tag rep <- smrep
-  = mkInfoTableContents platform info{cit_rep = rep} (Just rts_tag)
+  = mkInfoTableContents dflags info{cit_rep = rep} (Just rts_tag)
     -- Completely override the rts_tag that mkInfoTableContents would
     -- otherwise compute, with the rts_tag stored in the RTSRep
     -- (which in turn came from a handwritten .cmm file)
@@ -130,7 +130,7 @@ mkInfoTableContents platform
        ; let (srt_label, srt_bitmap) = mkSRTLit srt
        ; (liveness_lit, liveness_data) <- mkLivenessBits frame
        ; let
-             std_info = mkStdInfoTable prof_lits rts_tag srt_bitmap liveness_lit
+             std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit
              rts_tag | Just tag <- mb_rts_tag = tag
                      | null liveness_data     = rET_SMALL -- Fits in extra_bits
                      | otherwise              = rET_BIG   -- Does not; extra_bits is
@@ -143,7 +143,7 @@ mkInfoTableContents platform
        ; let (srt_label, srt_bitmap) = mkSRTLit srt
        ; (mb_srt_field, mb_layout, extra_bits, ct_data)
                                 <- mk_pieces closure_type srt_label
-       ; let std_info = mkStdInfoTable prof_lits
+       ; let std_info = mkStdInfoTable dflags prof_lits
                                        (mb_rts_tag   `orElse` rtsClosureType smrep)
                                        (mb_srt_field `orElse` srt_bitmap)
                                        (mb_layout    `orElse` layout)
@@ -326,13 +326,14 @@ mkLivenessBits liveness
 -- so we can't use constant offsets from Constants
 
 mkStdInfoTable
-   :: (CmmLit,CmmLit)  -- Closure type descr and closure descr  (profiling)
+   :: DynFlags
+   -> (CmmLit,CmmLit)  -- Closure type descr and closure descr  (profiling)
    -> StgHalfWord      -- Closure RTS tag 
    -> StgHalfWord      -- SRT length
    -> CmmLit           -- layout field
    -> [CmmLit]
 
-mkStdInfoTable (type_descr, closure_descr) cl_type srt_len layout_lit
+mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt_len layout_lit
  =     -- Parallel revertible-black hole field
     prof_info
        -- Ticky info (none at present)
@@ -341,8 +342,8 @@ mkStdInfoTable (type_descr, closure_descr) cl_type srt_len layout_lit
 
  where  
     prof_info 
-       | opt_SccProfilingOn = [type_descr, closure_descr]
-       | otherwise          = []
+       | dopt Opt_SccProfilingOn dflags = [type_descr, closure_descr]
+       | otherwise = []
 
     type_lit = packHalfWordsCLit cl_type srt_len
 
index 209ef8f..5f44013 100644 (file)
@@ -23,6 +23,7 @@ import Maybes
 import UniqFM
 import Util
 
+import DynFlags
 import FastString
 import Outputable
 import Data.Map (Map)
@@ -103,9 +104,9 @@ instance Outputable StackMap where
      text "sm_regs = " <> ppr (eltsUFM sm_regs)
 
 
-cmmLayoutStack :: ProcPointSet -> ByteOff -> CmmGraph
+cmmLayoutStack :: DynFlags -> ProcPointSet -> ByteOff -> CmmGraph
                -> UniqSM (CmmGraph, BlockEnv StackMap)
-cmmLayoutStack procpoints entry_args
+cmmLayoutStack dflags procpoints entry_args
                graph0@(CmmGraph { g_entry = entry })
   = do
     -- pprTrace "cmmLayoutStack" (ppr entry_args) $ return ()
@@ -118,7 +119,7 @@ cmmLayoutStack procpoints entry_args
             layout procpoints liveness entry entry_args
                    rec_stackmaps rec_high_sp blocks
 
-    new_blocks' <- mapM lowerSafeForeignCall new_blocks
+    new_blocks' <- mapM (lowerSafeForeignCall dflags) new_blocks
 
     -- pprTrace ("Sp HWM") (ppr _final_high_sp) $ return ()
     return (ofBlockList entry new_blocks', final_stackmaps)
@@ -870,8 +871,8 @@ Note the copyOut, which saves the results in the places that L1 is
 expecting them (see Note {safe foreign call convention]).
 -}
 
-lowerSafeForeignCall :: CmmBlock -> UniqSM CmmBlock
-lowerSafeForeignCall block
+lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock
+lowerSafeForeignCall dflags block
   | (entry, middle, CmmForeignCall { .. }) <- blockSplit block
   = do
     -- Both 'id' and 'new_base' are KindNonPtr because they're
@@ -881,7 +882,7 @@ lowerSafeForeignCall block
     let (caller_save, caller_load) = callerSaveVolatileRegs
     load_tso <- newTemp gcWord
     load_stack <- newTemp gcWord
-    let suspend = saveThreadState <*>
+    let suspend = saveThreadState dflags <*>
                   caller_save <*>
                   mkMiddle (callSuspendThread id intrbl)
         midCall = mkUnsafeCall tgt res args
@@ -890,7 +891,7 @@ lowerSafeForeignCall block
                   -- might now have a different Capability!
                   mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <*>
                   caller_load <*>
-                  loadThreadState load_tso load_stack
+                  loadThreadState dflags load_tso load_stack
         -- Note: The successor must be a procpoint, and we have already split,
         --       so we use a jump, not a branch.
         succLbl = CmmLit (CmmLabel (infoTblLbl succ))
index f46d49e..0d1c788 100644 (file)
@@ -216,12 +216,13 @@ static    :: { ExtFCode [CmmStatic] }
                                                (widthInBytes (typeWidth $1) * 
                                                        fromIntegral $3)] }
        | 'CLOSURE' '(' NAME lits ')'
-               { do lits <- sequence $4;
-                    return $ map CmmStaticLit $
-                       mkStaticClosure (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)
+               { do { lits <- sequence $4
+             ; dflags <- getDynFlags
+                    ; return $ map CmmStaticLit $
+                        mkStaticClosure dflags (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)
                          -- mkForeignLabel because these are only used
                          -- for CHARLIKE and INTLIKE closures in the RTS.
-                        dontCareCCS (map getLit lits) [] [] [] }
+                        dontCareCCS (map getLit lits) [] [] [] } }
        -- arrays of closures required for the CHARLIKE & INTLIKE arrays
 
 lits   :: { [ExtFCode CmmExpr] }
@@ -260,9 +261,10 @@ info       :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
        : 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
                -- ptrs, nptrs, closure type, description, type
                {% withThisPackage $ \pkg ->
-                  do let prof = profilingInfo $11 $13
+                   do dflags <- getDynFlags
+                      let prof = profilingInfo dflags $11 $13
                           rep  = mkRTSRep (fromIntegral $9) $
-                                   mkHeapRep False (fromIntegral $5)
+                                   mkHeapRep dflags False (fromIntegral $5)
                                                    (fromIntegral $7) Thunk
                               -- not really Thunk, but that makes the info table
                               -- we want.
@@ -275,11 +277,12 @@ info      :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
        | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
                -- ptrs, nptrs, closure type, description, type, fun type
                {% withThisPackage $ \pkg -> 
-                  do let prof = profilingInfo $11 $13
+                   do dflags <- getDynFlags
+                      let prof = profilingInfo dflags $11 $13
                           ty   = Fun 0 (ArgSpec (fromIntegral $15))
                                 -- Arity zero, arg_type $15
                           rep = mkRTSRep (fromIntegral $9) $
-                                    mkHeapRep False (fromIntegral $5)
+                                    mkHeapRep dflags False (fromIntegral $5)
                                                     (fromIntegral $7) ty
                       return (mkCmmEntryLabel pkg $3,
                              CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
@@ -292,11 +295,12 @@ info      :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
         | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
                -- ptrs, nptrs, tag, closure type, description, type
                {% withThisPackage $ \pkg ->
-                  do let prof = profilingInfo $13 $15
+                   do dflags <- getDynFlags
+                      let prof = profilingInfo dflags $13 $15
                           ty  = Constr (fromIntegral $9)  -- Tag
                                        (stringToWord8s $13)
                           rep = mkRTSRep (fromIntegral $11) $
-                                  mkHeapRep False (fromIntegral $5)
+                                  mkHeapRep dflags False (fromIntegral $5)
                                                   (fromIntegral $7) ty
                       return (mkCmmEntryLabel pkg $3,
                              CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
@@ -310,10 +314,11 @@ info      :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
        | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
                -- selector, closure type, description, type
                {% withThisPackage $ \pkg ->
-                  do let prof = profilingInfo $9 $11
+                   do dflags <- getDynFlags
+                      let prof = profilingInfo dflags $9 $11
                           ty  = ThunkSelector (fromIntegral $5)
                           rep = mkRTSRep (fromIntegral $7) $
-                                   mkHeapRep False 0 0 ty
+                                   mkHeapRep dflags False 0 0 ty
                       return (mkCmmEntryLabel pkg $3,
                              CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
                                           , cit_rep = rep
@@ -639,8 +644,9 @@ nameToMachOp name =
        Just m  -> return m
 
 exprOp :: FastString -> [ExtFCode CmmExpr] -> P (ExtFCode CmmExpr)
-exprOp name args_code =
-  case lookupUFM exprMacros name of
+exprOp name args_code = do
+  dflags <- getDynFlags
+  case lookupUFM (exprMacros dflags) name of
      Just f  -> return $ do
         args <- sequence args_code
        return (f args)
@@ -648,18 +654,18 @@ exprOp name args_code =
        mo <- nameToMachOp name
        return $ mkMachOp mo args_code
 
-exprMacros :: UniqFM ([CmmExpr] -> CmmExpr)
-exprMacros = listToUFM [
+exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr)
+exprMacros dflags = listToUFM [
   ( fsLit "ENTRY_CODE",   \ [x] -> entryCode x ),
   ( fsLit "INFO_PTR",     \ [x] -> closureInfoPtr x ),
-  ( fsLit "STD_INFO",     \ [x] -> infoTable x ),
-  ( fsLit "FUN_INFO",     \ [x] -> funInfoTable x ),
+  ( fsLit "STD_INFO",     \ [x] -> infoTable dflags x ),
+  ( fsLit "FUN_INFO",     \ [x] -> funInfoTable dflags x ),
   ( fsLit "GET_ENTRY",    \ [x] -> entryCode (closureInfoPtr x) ),
-  ( fsLit "GET_STD_INFO", \ [x] -> infoTable (closureInfoPtr x) ),
-  ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable (closureInfoPtr x) ),
-  ( fsLit "INFO_TYPE",    \ [x] -> infoTableClosureType x ),
-  ( fsLit "INFO_PTRS",    \ [x] -> infoTablePtrs x ),
-  ( fsLit "INFO_NPTRS",   \ [x] -> infoTableNonPtrs x )
+  ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr x) ),
+  ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr x) ),
+  ( fsLit "INFO_TYPE",    \ [x] -> infoTableClosureType dflags x ),
+  ( fsLit "INFO_PTRS",    \ [x] -> infoTablePtrs dflags x ),
+  ( fsLit "INFO_NPTRS",   \ [x] -> infoTableNonPtrs dflags x )
   ]
 
 -- we understand a subset of C-- primitives:
@@ -824,15 +830,17 @@ stmtMacros = listToUFM [
  ]
 
 
-profilingInfo desc_str ty_str 
-  | not opt_SccProfilingOn = NoProfilingInfo
-  | otherwise              = ProfilingInfo (stringToWord8s desc_str)
-                                           (stringToWord8s ty_str)
+profilingInfo dflags desc_str ty_str 
+  = if not (dopt Opt_SccProfilingOn dflags)
+    then NoProfilingInfo
+    else ProfilingInfo (stringToWord8s desc_str)
+                       (stringToWord8s ty_str)
 
 staticClosure :: PackageId -> FastString -> FastString -> [CmmLit] -> ExtCode
 staticClosure pkg cl_label info payload
-  = code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits
-  where  lits = mkStaticClosure (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
+  = do dflags <- getDynFlags
+       let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
+       code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits
 
 foreignCall
        :: String
@@ -1036,12 +1044,12 @@ doSwitch mb_range scrut arms deflt
 
 -- The initial environment: we define some constants that the compiler
 -- knows about here.
-initEnv :: Env
-initEnv = listToUFM [
+initEnv :: DynFlags -> Env
+initEnv dflags = listToUFM [
   ( fsLit "SIZEOF_StgHeader", 
-    VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordWidth) )),
+    VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags * wORD_SIZE)) wordWidth) )),
   ( fsLit "SIZEOF_StgInfoTable",
-    VarN (CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordWidth) ))
+    VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) wordWidth) ))
   ]
 
 parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)
@@ -1059,7 +1067,7 @@ parseCmmFile dflags filename = do
         return ((emptyBag, unitBag msg), Nothing)
     POk pst code -> do
         st <- initC
-        let (cmm,_) = runC dflags no_module st (getCmm (unEC code initEnv [] >> return ()))
+        let (cmm,_) = runC dflags no_module st (getCmm (unEC code (initEnv dflags) [] >> return ()))
         let ms = getMessages pst
         if (errorsFound dflags ms)
          then return (ms, Nothing)
index f2a2855..9aac09f 100644 (file)
@@ -72,7 +72,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
        ----------- Layout the stack and manifest Sp ---------------
        -- (also does: removeDeadAssignments, and lowerSafeForeignCalls)
        (g, stackmaps) <- {-# SCC "layoutStack" #-}
-                         runUniqSM $ cmmLayoutStack procPoints entry_off g
+                         runUniqSM $ cmmLayoutStack dflags procPoints entry_off g
        dump Opt_D_dump_cmmz_sp "Layout Stack" g
 
        g <- if optLevel dflags >= 99
index 8b3308e..1d5574a 100644 (file)
@@ -9,25 +9,18 @@ This is here, rather than in ClosureInfo, just to keep nhc happy.
 Other modules should access this info through ClosureInfo.
 
 \begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
 module SMRep (
         -- * Words and bytes
-       StgWord, StgHalfWord, 
-       hALF_WORD_SIZE, hALF_WORD_SIZE_IN_BITS,
-       WordOff, ByteOff,
+        StgWord, StgHalfWord,
+        hALF_WORD_SIZE, hALF_WORD_SIZE_IN_BITS,
+        WordOff, ByteOff,
         roundUpToWords,
 
         -- * Closure repesentation
-        SMRep(..),     -- CmmInfo sees the rep; no one else does
-        IsStatic, 
+        SMRep(..), -- CmmInfo sees the rep; no one else does
+        IsStatic,
         ClosureTypeInfo(..), ArgDescr(..), Liveness,
-        ConstrDescription, 
+        ConstrDescription,
 
         -- ** Construction
         mkHeapRep, blackHoleRep, mkStackRep, mkRTSRep,
@@ -45,13 +38,13 @@ module SMRep (
         aRG_GEN, aRG_GEN_BIG,
 
         -- * Operations over [Word8] strings that don't belong here
-       pprWord8String, stringToWord8s
+        pprWord8String, stringToWord8s
     ) where
 
 #include "../HsVersions.h"
 #include "../includes/MachDeps.h"
 
-import StaticFlags
+import DynFlags
 import Constants
 import Outputable
 import FastString
@@ -63,14 +56,14 @@ import Data.Bits
 
 
 %************************************************************************
-%*                                                                     *
-               Words and bytes
-%*                                                                     *
+%*                                                                      *
+                Words and bytes
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
-type WordOff = Int     -- Word offset, or word count
-type ByteOff = Int     -- Byte offset, or byte count
+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))
@@ -100,9 +93,9 @@ hALF_WORD_SIZE_IN_BITS = 32
 
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \subsubsection[SMRep-datatype]{@SMRep@---storage manager representation}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
@@ -146,10 +139,10 @@ type SelectorOffset    = StgWord
 -- We represent liveness bitmaps as a Bitmap (whose internal
 -- representation really is a bitmap).  These are pinned onto case return
 -- vectors to indicate the state of the stack for the garbage collector.
--- 
+--
 -- In the compiled program, liveness bitmaps that fit inside a single
 -- word (StgWord) are stored as a single word, while larger bitmaps are
--- stored as a pointer to an array of words. 
+-- stored as a pointer to an array of words.
 
 type Liveness = [Bool]   -- One Bool per word; True  <=> non-ptr or dead
                          --                    False <=> ptr
@@ -158,18 +151,19 @@ type Liveness = [Bool]   -- One Bool per word; True  <=> non-ptr or dead
 -- An ArgDescr describes the argument pattern of a function
 
 data ArgDescr
-  = ArgSpec            -- Fits one of the standard patterns
-       !StgHalfWord    -- RTS type identifier ARG_P, ARG_N, ...
+  = ArgSpec             -- Fits one of the standard patterns
+        !StgHalfWord    -- RTS type identifier ARG_P, ARG_N, ...
 
-  | ArgGen             -- General case
-       Liveness        -- Details about the arguments
+  | ArgGen              -- General case
+        Liveness        -- Details about the arguments
 
 
 -----------------------------------------------------------------------------
 -- Construction
 
-mkHeapRep :: IsStatic -> WordOff -> WordOff -> ClosureTypeInfo -> SMRep
-mkHeapRep is_static ptr_wds nonptr_wds cl_type_info
+mkHeapRep :: DynFlags -> IsStatic -> WordOff -> WordOff -> ClosureTypeInfo
+          -> SMRep
+mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type_info
   = HeapRep is_static
             ptr_wds
             (nonptr_wds + slop_wds)
@@ -177,9 +171,9 @@ mkHeapRep is_static ptr_wds nonptr_wds cl_type_info
   where
      slop_wds
       | is_static = 0
-      | otherwise = max 0 (minClosureSize - (hdr_size + payload_size))
+      | otherwise = max 0 (minClosureSize dflags - (hdr_size + payload_size))
 
-     hdr_size     = closureTypeHdrSize cl_type_info
+     hdr_size     = closureTypeHdrSize dflags cl_type_info
      payload_size = ptr_wds + nonptr_wds
 
 mkRTSRep :: StgHalfWord -> SMRep -> SMRep
@@ -224,30 +218,34 @@ isStaticNoCafCon _                           = False
 -- Size-related things
 
 -- | Size of a closure header (StgHeader in includes/rts/storage/Closures.h)
-fixedHdrSize :: WordOff
-fixedHdrSize = sTD_HDR_SIZE + profHdrSize
+fixedHdrSize :: DynFlags -> WordOff
+fixedHdrSize dflags = sTD_HDR_SIZE + profHdrSize dflags
 
 -- | Size of the profiling part of a closure header
 -- (StgProfHeader in includes/rts/storage/Closures.h)
-profHdrSize  :: WordOff
-profHdrSize  | opt_SccProfilingOn   = pROF_HDR_SIZE
-            | otherwise            = 0
+profHdrSize  :: DynFlags -> WordOff
+profHdrSize dflags
+ | dopt Opt_SccProfilingOn dflags = pROF_HDR_SIZE
+ | otherwise                      = 0
 
--- | The garbage collector requires that every closure is at least as big as this.
-minClosureSize :: WordOff
-minClosureSize = fixedHdrSize + mIN_PAYLOAD_SIZE
+-- | The garbage collector requires that every closure is at least as
+--   big as this.
+minClosureSize :: DynFlags -> WordOff
+minClosureSize dflags = fixedHdrSize dflags + mIN_PAYLOAD_SIZE
 
-arrWordsHdrSize   :: ByteOff
-arrWordsHdrSize   = fixedHdrSize*wORD_SIZE + sIZEOF_StgArrWords_NoHdr
+arrWordsHdrSize :: DynFlags -> ByteOff
+arrWordsHdrSize dflags
+ = fixedHdrSize dflags * wORD_SIZE + sIZEOF_StgArrWords_NoHdr
 
-arrPtrsHdrSize    :: ByteOff
-arrPtrsHdrSize    = fixedHdrSize*wORD_SIZE + sIZEOF_StgMutArrPtrs_NoHdr
+arrPtrsHdrSize :: DynFlags -> ByteOff
+arrPtrsHdrSize dflags
+ = fixedHdrSize dflags * wORD_SIZE + sIZEOF_StgMutArrPtrs_NoHdr
 
--- Thunks have an extra header word on SMP, so the update doesn't 
+-- Thunks have an extra header word on SMP, so the update doesn't
 -- splat the payload.
-thunkHdrSize :: WordOff
-thunkHdrSize = fixedHdrSize + smp_hdr
-       where smp_hdr = sIZEOF_StgSMPThunkHeader `quot` wORD_SIZE
+thunkHdrSize :: DynFlags -> WordOff
+thunkHdrSize dflags = fixedHdrSize dflags + smp_hdr
+        where smp_hdr = sIZEOF_StgSMPThunkHeader `quot` wORD_SIZE
 
 
 nonHdrSize :: SMRep -> WordOff
@@ -255,21 +253,22 @@ nonHdrSize (HeapRep _ p np _) = p + np
 nonHdrSize (StackRep bs)      = length bs
 nonHdrSize (RTSRep _ rep)     = nonHdrSize rep
 
-heapClosureSize :: SMRep -> WordOff
-heapClosureSize (HeapRep _ p np ty) = closureTypeHdrSize ty + p + np
-heapClosureSize _ = panic "SMRep.heapClosureSize"
-
-closureTypeHdrSize :: ClosureTypeInfo -> WordOff
-closureTypeHdrSize ty = case ty of
-                  Thunk{}         -> thunkHdrSize
-                  ThunkSelector{} -> thunkHdrSize
-                  BlackHole{}     -> thunkHdrSize
-                  _               -> fixedHdrSize
-       -- All thunks use thunkHdrSize, even if they are non-updatable.
-       -- this is because we don't have separate closure types for
-       -- updatable vs. non-updatable thunks, so the GC can't tell the
-       -- difference.  If we ever have significant numbers of non-
-       -- updatable thunks, it might be worth fixing this.
+heapClosureSize :: DynFlags -> SMRep -> WordOff
+heapClosureSize dflags (HeapRep _ p np ty)
+ = closureTypeHdrSize dflags ty + p + np
+heapClosureSize _ _ = panic "SMRep.heapClosureSize"
+
+closureTypeHdrSize :: DynFlags -> ClosureTypeInfo -> WordOff
+closureTypeHdrSize dflags ty = case ty of
+                  Thunk{}         -> thunkHdrSize dflags
+                  ThunkSelector{} -> thunkHdrSize dflags
+                  BlackHole{}     -> thunkHdrSize dflags
+                  _               -> fixedHdrSize dflags
+        -- All thunks use thunkHdrSize, even if they are non-updatable.
+        -- this is because we don't have separate closure types for
+        -- updatable vs. non-updatable thunks, so the GC can't tell the
+        -- difference.  If we ever have significant numbers of non-
+        -- updatable thunks, it might be worth fixing this.
 
 -----------------------------------------------------------------------------
 -- deriving the RTS closure type from an SMRep
@@ -326,20 +325,20 @@ aRG_GEN_BIG = ARG_GEN_BIG
 
 Note [Static NoCaf constructors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we know that a top-level binding 'x' is not Caffy (ie no CAFs are 
+If we know that a top-level binding 'x' is not Caffy (ie no CAFs are
 reachable from 'x'), then a statically allocated constructor (Just x)
 is also not Caffy, and the garbage collector need not follow its
 argument fields.  Exploiting this would require two static info tables
 for Just, for the two cases where the argument was Caffy or non-Caffy.
 
-Currently we don't do this; instead we treat nullary constructors 
+Currently we don't do this; instead we treat nullary constructors
 as non-Caffy, and the others as potentially Caffy.
 
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
              Pretty printing of SMRep and friends
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
@@ -364,19 +363,19 @@ instance Outputable SMRep where
 instance Outputable ArgDescr where
   ppr (ArgSpec n) = ptext (sLit "ArgSpec") <+> integer (toInteger n)
   ppr (ArgGen ls) = ptext (sLit "ArgGen") <+> ppr ls
-  
+
 pprTypeInfo :: ClosureTypeInfo -> SDoc
 pprTypeInfo (Constr tag descr)
-  = ptext (sLit "Con") <+> 
+  = ptext (sLit "Con") <+>
     braces (sep [ ptext (sLit "tag:") <+> integer (toInteger tag)
                 , ptext (sLit "descr:") <> text (show descr) ])
 
 pprTypeInfo (Fun arity args)
-  = ptext (sLit "Fun") <+> 
+  = ptext (sLit "Fun") <+>
     braces (sep [ ptext (sLit "arity:") <+> integer (toInteger arity)
                 , ptext (sLit ("fun_type:")) <+> ppr args ])
 
-pprTypeInfo (ThunkSelector offset) 
+pprTypeInfo (ThunkSelector offset)
   = ptext (sLit "ThunkSel") <+> integer (toInteger offset)
 
 pprTypeInfo Thunk     = ptext (sLit "Thunk")
index c65194b..332ec07 100644 (file)
@@ -42,6 +42,7 @@ import Maybes
 import Id
 import Name
 import Util
+import DynFlags
 import StaticFlags
 import Module
 import FastString
@@ -159,11 +160,11 @@ constructSlowCall amodes
 -- | 'slowArgs' takes a list of function arguments and prepares them for
 -- pushing on the stack for "extra" arguments to a function which requires
 -- fewer arguments than we currently have.
-slowArgs :: [(CgRep,CmmExpr)] -> [(CgRep,CmmExpr)]
-slowArgs [] = []
-slowArgs amodes
-  | opt_SccProfilingOn = save_cccs ++ this_pat ++ slowArgs rest
-  | otherwise          =              this_pat ++ slowArgs rest
+slowArgs :: DynFlags -> [(CgRep,CmmExpr)] -> [(CgRep,CmmExpr)]
+slowArgs [] = []
+slowArgs dflags amodes
+  | dopt Opt_SccProfilingOn dflags = save_cccs ++ this_pat ++ slowArgs dflags rest
+  | otherwise                      =              this_pat ++ slowArgs dflags rest
   where
     (arg_pat, args, rest) = matchSlowPattern amodes
     stg_ap_pat = mkCmmRetInfoLabel rtsPackageId arg_pat
index 745bf47..ef51aaa 100644 (file)
@@ -32,8 +32,8 @@ import ClosureInfo
 import OldCmmUtils
 import OldCmm
 
+import DynFlags
 import StgSyn
-import StaticFlags
 import Id
 import ForeignCall
 import VarSet
@@ -650,13 +650,13 @@ saveCurrentCostCentre ::
                CmmStmts)                -- Assignment to save it
 
 saveCurrentCostCentre
-  | not opt_SccProfilingOn
-  = returnFC (Nothing, noStmts)
-  | otherwise
-  = do  { slot <- allocPrimStack PtrArg
-        ; sp_rel <- getSpRelOffset slot
-        ; returnFC (Just slot,
-                    oneStmt (CmmStore sp_rel curCCS)) }
+  = do dflags <- getDynFlags
+       if not (dopt Opt_SccProfilingOn dflags)
+           then returnFC (Nothing, noStmts)
+           else do slot <- allocPrimStack PtrArg
+                   sp_rel <- getSpRelOffset slot
+                   returnFC (Just slot,
+                             oneStmt (CmmStore sp_rel curCCS))
 
 -- Sometimes we don't free the slot containing the cost centre after restoring it
 -- (see CgLetNoEscape.cgLetNoEscapeBody).
index 8f98a5f..7229fbd 100644 (file)
@@ -49,7 +49,6 @@ import Module
 import ListSetOps
 import Util
 import BasicTypes
-import StaticFlags
 import DynFlags
 import Outputable
 import FastString
@@ -83,10 +82,10 @@ cgTopRhsClosure id ccs binder_info upd_flag args body = do
   ; mod_name <- getModuleName
   ; dflags   <- getDynFlags
   ; let descr         = closureDescription dflags mod_name name
-       closure_info  = mkClosureInfo True id lf_info 0 0 srt_info descr
+       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
-       closure_rep   = mkStaticClosureFields closure_info ccs True []
+       closure_rep   = mkStaticClosureFields dflags closure_info ccs True []
 
         -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
   ; emitDataLits closure_label closure_rep
@@ -123,10 +122,10 @@ cgStdRhsClosure bndr _cc _bndr_info _fvs _args _body lf_info payload
   ; mod_name <- getModuleName
   ; dflags <- getDynFlags
   ; let (tot_wds, ptr_wds, amodes_w_offsets) 
-           = mkVirtHeapOffsets (isLFThunk lf_info) amodes
+           = mkVirtHeapOffsets dflags (isLFThunk lf_info) amodes
 
        descr        = closureDescription dflags mod_name (idName bndr)
-       closure_info = mkClosureInfo False      -- Not static
+       closure_info = mkClosureInfo dflags False       -- Not static
                                     bndr lf_info tot_wds ptr_wds 
                                     NoC_SRT    -- No SRT for a std-form closure
                                     descr
@@ -174,12 +173,12 @@ cgRhsClosure bndr cc bndr_info fvs upd_flag args body = do
   ; dflags <- getDynFlags
   ; let        bind_details :: [(CgIdInfo, VirtualHpOffset)]
        (tot_wds, ptr_wds, bind_details) 
-          = mkVirtHeapOffsets (isLFThunk lf_info) (map add_rep fv_infos)
+          = mkVirtHeapOffsets dflags (isLFThunk lf_info) (map add_rep fv_infos)
 
        add_rep info = (cgIdInfoArgRep info, info)
 
        descr        = closureDescription dflags mod_name name
-       closure_info = mkClosureInfo False      -- Not static
+       closure_info = mkClosureInfo dflags False       -- Not static
                                     bndr lf_info tot_wds ptr_wds
                                     srt_info descr
 
@@ -392,7 +391,8 @@ mkSlowEntryCode cl_info reg_args
 \begin{code}
 thunkWrapper:: ClosureInfo -> Code -> Code
 thunkWrapper closure_info thunk_code = do
-  { let node_points = nodeMustPointToIt (closureLFInfo closure_info)
+  { dflags <- getDynFlags
+  ; let node_points = nodeMustPointToIt dflags (closureLFInfo closure_info)
 
     -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
     -- (we prefer fetchAndReschedule-style context switches to yield ones)
@@ -416,7 +416,8 @@ funWrapper :: ClosureInfo   -- Closure whose code body this is
           -> Code              -- Body of function being compiled
           -> Code
 funWrapper closure_info arg_regs reg_save_code fun_body = do
-  { let node_points = nodeMustPointToIt (closureLFInfo closure_info)
+  { dflags <- getDynFlags
+  ; let node_points = nodeMustPointToIt dflags (closureLFInfo closure_info)
         live        = Just $ map snd arg_regs
 
   {-
@@ -477,7 +478,7 @@ emitBlackHoleCode is_single_entry = do
   -- Note the eager-blackholing check is here rather than in blackHoleOnEntry,
   -- because emitBlackHoleCode is called from CmmParse.
 
-  let  eager_blackholing =  not opt_SccProfilingOn
+  let  eager_blackholing =  not (dopt Opt_SccProfilingOn dflags)
                          && dopt Opt_EagerBlackHoling dflags
              -- Profiling needs slop filling (to support LDV
              -- profiling), so currently eager blackholing doesn't
@@ -486,7 +487,7 @@ emitBlackHoleCode is_single_entry = do
   whenC eager_blackholing $ do
     tickyBlackHole (not is_single_entry)
     stmtsC [
-       CmmStore (cmmOffsetW (CmmReg nodeReg) fixedHdrSize)
+       CmmStore (cmmOffsetW (CmmReg nodeReg) (fixedHdrSize dflags))
                 (CmmReg (CmmGlobal CurrentTSO)),
        CmmCall (CmmPrim MO_WriteBarrier Nothing) [] [] CmmMayReturn,
        CmmStore (CmmReg nodeReg) (CmmReg (CmmGlobal EagerBlackholeInfo))
@@ -510,7 +511,8 @@ setupUpdate closure_info code
           tickyPushUpdateFrame
           dflags <- getDynFlags
           if blackHoleOnEntry closure_info &&
-             not opt_SccProfilingOn && dopt Opt_EagerBlackHoling dflags
+             not (dopt Opt_SccProfilingOn dflags) &&
+             dopt Opt_EagerBlackHoling dflags
                then pushBHUpdateFrame (CmmReg nodeReg) code
                else pushUpdateFrame   (CmmReg nodeReg) code
   
@@ -575,7 +577,9 @@ link_caf cl_info _is_upd = do
   ; let        use_cc   = costCentreFrom (CmmReg nodeReg)
         blame_cc = use_cc
         tso      = CmmReg (CmmGlobal CurrentTSO)
-  ; hp_offset <- allocDynClosure bh_cl_info use_cc blame_cc [(tso,fixedHdrSize)]
+  ; dflags    <- getDynFlags
+  ; hp_offset <- allocDynClosure bh_cl_info use_cc blame_cc
+                                 [(tso, fixedHdrSize dflags)]
   ; hp_rel    <- getHpRelOffset hp_offset
 
        -- Call the RTS function newCAF to add the CAF to the CafList
index 78c1934..86e6ff8 100644 (file)
@@ -50,7 +50,6 @@ import Module
 import DynFlags
 import FastString
 import Platform
-import StaticFlags
 
 import Control.Monad
 \end{code}
@@ -82,8 +81,9 @@ cgTopRhsCon id con args
             lf_info       = mkConLFInfo con
             closure_label = mkClosureLabel name $ idCafInfo id
             caffy         = any stgArgHasCafRefs args
-            (closure_info, amodes_w_offsets) = layOutStaticConstr con amodes
+            (closure_info, amodes_w_offsets) = layOutStaticConstr dflags con amodes
             closure_rep = mkStaticClosureFields
+                             dflags
                              closure_info
                              dontCareCCS                -- Because it's static data
                              caffy                      -- Has CAF refs
@@ -191,7 +191,7 @@ buildDynCon' dflags platform binder _ con [arg_amode]
   , let val_int = (fromIntegral val) :: Int
   , val_int <= mAX_INTLIKE && val_int >= mIN_INTLIKE
   = do  { let intlike_lbl   = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_INTLIKE_closure")
-              offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize + 1)
+              offsetW = (val_int - mIN_INTLIKE) * (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) }
@@ -203,7 +203,7 @@ buildDynCon' dflags platform binder _ con [arg_amode]
   , let val_int = (fromIntegral val) :: Int
   , val_int <= mAX_CHARLIKE && val_int >= mIN_CHARLIKE
   = do  { let charlike_lbl   = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_CHARLIKE_closure")
-              offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize + 1)
+              offsetW = (val_int - mIN_CHARLIKE) * (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) }
@@ -213,10 +213,10 @@ buildDynCon' dflags platform binder _ con [arg_amode]
 Now the general case.
 
 \begin{code}
-buildDynCon' _ _ binder ccs con args
+buildDynCon' dflags _ binder ccs con args
   = do  {
         ; let
-            (closure_info, amodes_w_offsets) = layOutDynConstr 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) }
@@ -246,12 +246,12 @@ found a $con$.
 \begin{code}
 bindConArgs :: DataCon -> [Id] -> Code
 bindConArgs con args
-  = do
+  = do dflags <- getDynFlags
        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)
-          (_, args_w_offsets)    = layOutDynConstr con (addIdReps args)
+          (_, args_w_offsets)    = layOutDynConstr dflags con (addIdReps args)
         --
        ASSERT(not (isUnboxedTupleCon con)) return ()
        mapCs bind_arg args_w_offsets
@@ -318,14 +318,14 @@ sure the @amodes@ passed don't conflict with each other.
 \begin{code}
 cgReturnDataCon :: DataCon -> [(CgRep, CmmExpr)] -> Code
 
-cgReturnDataCon con amodes
-  | isUnboxedTupleCon con = returnUnboxedTuple amodes
-      -- when profiling we can't shortcut here, we have to enter the closure
-      -- for it to be marked as "used" for LDV profiling.
-  | opt_SccProfilingOn    = build_it_then enter_it
-  | otherwise
-  = ASSERT( amodes `lengthIs` dataConRepRepArity con )
-    do  { EndOfBlockInfo _ sequel <- getEndOfBlockInfo
+cgReturnDataCon con amodes = do
+  dflags <- getDynFlags
+  if isUnboxedTupleCon con then returnUnboxedTuple amodes
+  -- when profiling we can't shortcut here, we have to enter the closure
+  -- for it to be marked as "used" for LDV profiling.
+   else if dopt Opt_SccProfilingOn dflags then build_it_then enter_it
+   else ASSERT( amodes `lengthIs` dataConRepRepArity con )
+     do { EndOfBlockInfo _ sequel <- getEndOfBlockInfo
         ; case sequel of
             CaseAlts _ (Just (alts, deflt_lbl)) bndr
               ->    -- Ho! We know the constructor so we can
@@ -445,7 +445,8 @@ static closure, for a constructor.
 \begin{code}
 cgDataCon :: DataCon -> Code
 cgDataCon data_con
-  = do  {     -- Don't need any dynamic closure code for zero-arity constructors
+  = do  { dflags <- getDynFlags
+        -- Don't need any dynamic closure code for zero-arity constructors
 
         ; let
             -- To allow the debuggers, interpreters, etc to cope with
@@ -453,10 +454,10 @@ cgDataCon data_con
             -- time), we take care that info-table contains the
             -- information we need.
             (static_cl_info, _) =
-                layOutStaticConstr data_con arg_reps
+                layOutStaticConstr dflags data_con arg_reps
 
             (dyn_cl_info, arg_things) =
-                layOutDynConstr    data_con arg_reps
+                layOutDynConstr    dflags data_con arg_reps
 
             emit_info cl_info ticky_code
                 = do { code_blks <- getCgStmts the_code
index f935f95..0a44662 100644 (file)
@@ -48,8 +48,8 @@ import Maybes
 import ListSetOps
 import BasicTypes
 import Util
+import DynFlags
 import Outputable
-import StaticFlags
 \end{code}
 
 This module provides the support code for @StgToAbstractC@ to deal
@@ -117,6 +117,7 @@ re-enters the RTS the stack is in a sane state.
 
 \begin{code}
 cgExpr (StgOpApp (StgFCallOp fcall _) stg_args res_ty) = do
+    dflags <- getDynFlags
     {-
        First, copy the args into temporaries.  We're going to push
        a return address right before doing the call, so the args
@@ -125,7 +126,7 @@ cgExpr (StgOpApp (StgFCallOp fcall _) stg_args res_ty) = do
     reps_n_amodes <- getArgAmodes stg_args
     let 
        -- Get the *non-void* args, and jiggle them with shimForeignCall
-       arg_exprs = [ (shimForeignCallArg stg_arg expr, stg_arg)
+       arg_exprs = [ (shimForeignCallArg dflags stg_arg expr, stg_arg)
                    | (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes, 
                      nonVoidArg rep]
 
@@ -310,7 +311,8 @@ cgRhs name (StgRhsCon maybe_cc con args)
        ; returnFC (name, idinfo) }
 
 cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body)
-  = setSRT srt $ mkRhsClosure name cc bi fvs upd_flag args body
+  = do dflags <- getDynFlags
+       setSRT srt $ mkRhsClosure dflags name cc bi fvs upd_flag args body
 \end{code}
 
 mkRhsClosure looks for two special forms of the right-hand side:
@@ -333,10 +335,10 @@ form:
 
 
 \begin{code}
-mkRhsClosure :: Id -> CostCentreStack -> StgBinderInfo
+mkRhsClosure :: DynFlags -> Id -> CostCentreStack -> StgBinderInfo
              -> [Id] -> UpdateFlag -> [Id] -> GenStgExpr Id Id
              -> FCode (Id, CgIdInfo)
-mkRhsClosure   bndr cc bi
+mkRhsClosure   dflags bndr cc bi
                [the_fv]                -- Just one free var
                upd_flag                -- Updatable thunk
                []                      -- A thunk
@@ -358,11 +360,11 @@ mkRhsClosure      bndr cc bi
   where
     lf_info              = mkSelectorLFInfo bndr offset_into_int
                                 (isUpdatable upd_flag)
-    (_, params_w_offsets) = layOutDynConstr con (addIdReps params)
+    (_, params_w_offsets) = layOutDynConstr dflags con (addIdReps params)
                        -- Just want the layout
     maybe_offset         = assocMaybe params_w_offsets selectee
     Just the_offset      = maybe_offset
-    offset_into_int       = the_offset - fixedHdrSize
+    offset_into_int       = the_offset - fixedHdrSize dflags
 \end{code}
 
 Ap thunks
@@ -382,7 +384,7 @@ We only generate an Ap thunk if all the free variables are pointers,
 for semi-obvious reasons.
 
 \begin{code}
-mkRhsClosure    bndr cc bi
+mkRhsClosure dflags bndr cc bi
                fvs
                upd_flag
                []                      -- No args; a thunk
@@ -392,7 +394,8 @@ mkRhsClosure    bndr cc bi
        && all isFollowableArg (map idCgRep fvs) 
        && isUpdatable upd_flag
        && arity <= mAX_SPEC_AP_SIZE 
-        && not opt_SccProfilingOn -- not when profiling: we don't want to
+        && not (dopt Opt_SccProfilingOn dflags)
+                                  -- not when profiling: we don't want to
                                   -- lose information about this particular
                                   -- thunk (e.g. its type) (#949)
 
@@ -410,7 +413,7 @@ mkRhsClosure    bndr cc bi
 The default case
 ~~~~~~~~~~~~~~~~
 \begin{code}
-mkRhsClosure bndr cc bi fvs upd_flag args body
+mkRhsClosure bndr cc bi fvs upd_flag args body
   = cgRhsClosure bndr cc bi fvs upd_flag args body
 \end{code}
 
index c94f237..a651319 100644 (file)
@@ -50,6 +50,7 @@ import OldCmm hiding( ClosureTypeInfo(..) )
 
 -- import BasicTypes
 import BlockId
+import DynFlags
 import FastString
 import Module
 import UniqFM
@@ -87,6 +88,10 @@ instance Monad ExtFCode where
   (>>=) = thenExtFC
   return = returnExtFC
 
+instance HasDynFlags ExtFCode where
+    getDynFlags = EC (\_ d -> do dflags <- getDynFlags
+                                 return (d, dflags))
+
 
 -- | Takes the variable decarations and imports from the monad
 --     and makes an environment, which is looped back into the computation.  
index e957b90..4a83d86 100644 (file)
@@ -31,7 +31,7 @@ import OldCmmUtils
 import SMRep
 import ForeignCall
 import Constants
-import StaticFlags
+import DynFlags
 import Outputable
 import Module
 import FastString
@@ -51,9 +51,10 @@ cgForeignCall
 cgForeignCall results fcall stg_args live
   = do
   reps_n_amodes <- getArgAmodes stg_args
+  dflags <- getDynFlags
   let
         -- Get the *non-void* args, and jiggle them with shimForeignCall
-        arg_exprs = [ shimForeignCallArg stg_arg expr
+        arg_exprs = [ shimForeignCallArg dflags stg_arg expr
                     | (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes,
                        nonVoidArg rep]
 
@@ -206,13 +207,14 @@ maybe_assign_temp e
 
 emitSaveThreadState :: Code
 emitSaveThreadState = do
+  dflags <- getDynFlags
   -- CurrentTSO->stackobj->sp = Sp;
-  stmtC $ CmmStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO tso_stackobj) bWord)
-                              stack_SP) stgSp
+  stmtC $ CmmStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO (tso_stackobj dflags)) bWord)
+                              (stack_SP dflags)) stgSp
   emitCloseNursery
   -- and save the current cost centre stack in the TSO when profiling:
-  when opt_SccProfilingOn $
-        stmtC (CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
+  when (dopt Opt_SccProfilingOn dflags) $
+        stmtC (CmmStore (cmmOffset stgCurrentTSO (tso_CCCS dflags)) curCCS)
 
    -- CurrentNursery->free = Hp+1;
 emitCloseNursery :: Code
@@ -220,18 +222,19 @@ emitCloseNursery = stmtC $ CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
 
 emitLoadThreadState :: Code
 emitLoadThreadState = do
+  dflags <- getDynFlags
   tso <- newTemp bWord -- TODO FIXME NOW
   stack <- newTemp bWord -- TODO FIXME NOW
   stmtsC [
         -- tso = CurrentTSO
         CmmAssign (CmmLocal tso) stgCurrentTSO,
         -- stack = tso->stackobj
-        CmmAssign (CmmLocal stack) (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_stackobj) bWord),
+        CmmAssign (CmmLocal stack) (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) bWord),
         -- Sp = stack->sp;
-        CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal stack)) stack_SP)
+        CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal stack)) (stack_SP dflags))
                               bWord),
         -- SpLim = stack->stack + RESERVED_STACK_WORDS;
-        CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal stack)) stack_STACK)
+        CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal stack)) (stack_STACK dflags))
                                     rESERVED_STACK_WORDS),
         -- HpAlloc = 0;
         --   HpAlloc is assumed to be set to non-zero only by a failed
@@ -240,9 +243,9 @@ emitLoadThreadState = do
     ]
   emitOpenNursery
   -- and load the current cost centre stack from the TSO when profiling:
-  when opt_SccProfilingOn $
+  when (dopt Opt_SccProfilingOn dflags) $
         stmtC $ storeCurCCS $
-                  CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) bWord
+                  CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) bWord
 
 emitOpenNursery :: Code
 emitOpenNursery = stmtsC [
@@ -270,14 +273,14 @@ nursery_bdescr_free   = cmmOffset stgCurrentNursery oFFSET_bdescr_free
 nursery_bdescr_start  = cmmOffset stgCurrentNursery oFFSET_bdescr_start
 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
 
-tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: ByteOff
-tso_stackobj = closureField oFFSET_StgTSO_stackobj
-tso_CCCS     = closureField oFFSET_StgTSO_cccs
-stack_STACK  = closureField oFFSET_StgStack_stack
-stack_SP     = closureField oFFSET_StgStack_sp
+tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: DynFlags -> ByteOff
+tso_stackobj dflags = closureField dflags oFFSET_StgTSO_stackobj
+tso_CCCS     dflags = closureField dflags oFFSET_StgTSO_cccs
+stack_STACK  dflags = closureField dflags oFFSET_StgStack_stack
+stack_SP     dflags = closureField dflags oFFSET_StgStack_sp
 
-closureField :: ByteOff -> ByteOff
-closureField off = off + fixedHdrSize * wORD_SIZE
+closureField :: DynFlags -> ByteOff -> ByteOff
+closureField dflags off = off + fixedHdrSize dflags * wORD_SIZE
 
 stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
 stgSp             = CmmReg sp
@@ -299,13 +302,13 @@ hpAlloc           = CmmGlobal HpAlloc
 -- value passed to the call.  For ByteArray#/Array# we pass the
 -- address of the actual array, not the address of the heap object.
 
-shimForeignCallArg :: StgArg -> CmmExpr -> CmmExpr
-shimForeignCallArg arg expr
+shimForeignCallArg :: DynFlags -> StgArg -> CmmExpr -> CmmExpr
+shimForeignCallArg dflags arg expr
   | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
-        = cmmOffsetB expr arrPtrsHdrSize
+        = cmmOffsetB expr (arrPtrsHdrSize dflags)
 
   | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
-        = cmmOffsetB expr arrWordsHdrSize
+        = cmmOffsetB expr (arrWordsHdrSize dflags)
 
   | otherwise = expr
   where
index fd27cff..c0c1513 100644 (file)
@@ -44,6 +44,7 @@ import Util
 import Module
 import Constants
 import Outputable
+import DynFlags
 import FastString
 
 import Data.List
@@ -115,7 +116,8 @@ getHpRelOffset virtual_offset
 
 \begin{code}
 layOutDynConstr, layOutStaticConstr
-        :: DataCon
+        :: DynFlags
+        -> DataCon
         -> [(CgRep,a)]
         -> (ClosureInfo,
             [(a,VirtualHpOffset)])
@@ -123,15 +125,15 @@ layOutDynConstr, layOutStaticConstr
 layOutDynConstr    = layOutConstr False
 layOutStaticConstr = layOutConstr True
 
-layOutConstr :: Bool -> DataCon -> [(CgRep, a)]
+layOutConstr :: Bool -> DynFlags -> DataCon -> [(CgRep, a)]
              -> (ClosureInfo, [(a, VirtualHpOffset)])
-layOutConstr is_static data_con args
-   = (mkConInfo is_static data_con tot_wds ptr_wds,
+layOutConstr is_static dflags data_con args
+   = (mkConInfo dflags is_static data_con tot_wds ptr_wds,
       things_w_offsets)
   where
     (tot_wds,            --  #ptr_wds + #nonptr_wds
      ptr_wds,            --  #ptr_wds
-     things_w_offsets) = mkVirtHeapOffsets False{-not a thunk-} args
+     things_w_offsets) = mkVirtHeapOffsets dflags False{-not a thunk-} args
 \end{code}
 
 @mkVirtHeapOffsets@ always returns boxed things with smaller offsets
@@ -140,7 +142,8 @@ list
 
 \begin{code}
 mkVirtHeapOffsets
-          :: Bool               -- True <=> is a thunk
+          :: DynFlags
+          -> Bool               -- True <=> is a thunk
           -> [(CgRep,a)]        -- Things to make offsets for
           -> (WordOff,          -- _Total_ number of words allocated
               WordOff,          -- Number of words allocated for *pointers*
@@ -150,7 +153,7 @@ mkVirtHeapOffsets
 
 -- First in list gets lowest offset, which is initial offset + 1.
 
-mkVirtHeapOffsets is_thunk things
+mkVirtHeapOffsets dflags is_thunk things
   = let non_void_things               = filterOut (isVoidArg . fst) things
         (ptrs, non_ptrs)              = separateByPtrFollowness non_void_things
         (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs
@@ -158,8 +161,8 @@ mkVirtHeapOffsets is_thunk things
     in
     (tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets)
   where
-    hdr_size    | is_thunk   = thunkHdrSize
-                | otherwise  = fixedHdrSize
+    hdr_size    | is_thunk   = thunkHdrSize dflags
+                | otherwise  = fixedHdrSize dflags
 
     computeOffset wds_so_far (rep, thing)
       = (wds_so_far + cgRepSizeW rep, (thing, hdr_size + wds_so_far))
@@ -177,13 +180,14 @@ and adding a static link field if necessary.
 
 \begin{code}
 mkStaticClosureFields
-        :: ClosureInfo
+        :: DynFlags
+        -> ClosureInfo
         -> CostCentreStack
         -> Bool                 -- Has CAF refs
         -> [CmmLit]             -- Payload
         -> [CmmLit]             -- The full closure
-mkStaticClosureFields cl_info ccs caf_refs payload
-  = mkStaticClosure info_lbl ccs payload padding_wds
+mkStaticClosureFields dflags cl_info ccs caf_refs payload
+  = mkStaticClosure dflags info_lbl ccs payload padding_wds
         static_link_field saved_info_field
   where
     info_lbl = infoTableLabelFromCI cl_info
@@ -221,9 +225,9 @@ mkStaticClosureFields cl_info ccs caf_refs payload
         | caf_refs      = mkIntCLit 0
         | otherwise     = mkIntCLit 1
 
-mkStaticClosure :: CLabel -> CostCentreStack -> [CmmLit]
+mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit]
   -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]
-mkStaticClosure info_lbl ccs payload padding_wds static_link_field saved_info_field
+mkStaticClosure dflags info_lbl ccs payload padding_wds static_link_field saved_info_field
   =  [CmmLabel info_lbl]
   ++ variable_header_words
   ++ concatMap padLitToWord payload
@@ -234,7 +238,7 @@ mkStaticClosure info_lbl ccs payload padding_wds static_link_field saved_info_fi
     variable_header_words
         =  staticGranHdr
         ++ staticParHdr
-        ++ staticProfHdr ccs
+        ++ staticProfHdr dflags ccs
         ++ staticTickyHdr
 
 padLitToWord :: CmmLit -> [CmmLit]
@@ -290,24 +294,29 @@ hpStkCheck cl_info is_fun reg_save_code live code
             {   -- Emit heap checks, but be sure to do it lazily so
                 -- that the conditionals on hpHw don't cause a black hole
               codeOnly $ do
-                { do_checks stk_words hpHw full_save_code rts_label full_live
-                ; tickyAllocHeap hpHw }
+
+                dflags <- getDynFlags
+
+                let (node_asst, full_live)
+                        | nodeMustPointToIt dflags (closureLFInfo cl_info)
+                        = (noStmts, live)
+                        | otherwise
+                        = (oneStmt (CmmAssign nodeReg (CmmLit (CmmLabel closure_lbl)))
+                          ,Just $ node : fromMaybe [] live)
+                        -- Strictly speaking, we should tag node here.  But if
+                        -- node doesn't point to the closure, the code for the closure
+                        -- cannot depend on the value of R1 anyway, so we're safe.
+
+                    full_save_code = node_asst `plusStmts` reg_save_code
+
+                do_checks stk_words hpHw full_save_code rts_label full_live
+                tickyAllocHeap hpHw
             ; setRealHp hpHw
             ; code }
         }
   where
-    (node_asst, full_live)
-        | nodeMustPointToIt (closureLFInfo cl_info)
-        = (noStmts, live)
-        | otherwise
-        = (oneStmt (CmmAssign nodeReg (CmmLit (CmmLabel closure_lbl)))
-          ,Just $ node : fromMaybe [] live)
-        -- Strictly speaking, we should tag node here.  But if
-        -- node doesn't point to the closure, the code for the closure
-        -- cannot depend on the value of R1 anyway, so we're safe.
     closure_lbl = closureLabelFromCI cl_info
 
-    full_save_code = node_asst `plusStmts` reg_save_code
 
     rts_label | is_fun    = CmmReg (CmmGlobal GCFun)
                                 -- Function entry point
@@ -578,6 +587,7 @@ allocDynClosure cl_info use_cc _blame_cc amodes_with_offsets
   = do  { virt_hp <- getVirtHp
 
         -- FIND THE OFFSET OF THE INFO-PTR WORD
+        ; dflags <- getDynFlags
         ; let   info_offset = virt_hp + 1
                 -- info_offset is the VirtualHpOffset of the first
                 -- word of the new object
@@ -585,7 +595,7 @@ allocDynClosure cl_info use_cc _blame_cc amodes_with_offsets
                 -- ie 1 *before* the info-ptr word of new object.
 
                 info_ptr = CmmLit (CmmLabel (infoTableLabelFromCI cl_info))
-                hdr_w_offsets = initDynHdr info_ptr use_cc `zip` [0..]
+                hdr_w_offsets = initDynHdr dflags info_ptr use_cc `zip` [0..]
 
         -- SAY WHAT WE ARE ABOUT TO DO
         ; profDynAlloc cl_info use_cc
@@ -596,20 +606,21 @@ allocDynClosure cl_info use_cc _blame_cc amodes_with_offsets
         ; hpStore base (hdr_w_offsets ++ amodes_with_offsets)
 
         -- BUMP THE VIRTUAL HEAP POINTER
-        ; setVirtHp (virt_hp + closureSize cl_info)
+        ; setVirtHp (virt_hp + closureSize dflags cl_info)
 
         -- RETURN PTR TO START OF OBJECT
         ; returnFC info_offset }
 
 
-initDynHdr :: CmmExpr
+initDynHdr :: DynFlags
+           -> CmmExpr
            -> CmmExpr           -- Cost centre to put in object
            -> [CmmExpr]
-initDynHdr info_ptr cc
+initDynHdr dflags info_ptr cc
   =  [info_ptr]
         -- ToDo: Gransim stuff
         -- ToDo: Parallel stuff
-  ++ dynProfHdr cc
+  ++ dynProfHdr dflags cc
         -- No ticky header
 
 hpStore :: CmmExpr -> [(CmmExpr, VirtualHpOffset)] -> Code
@@ -620,5 +631,6 @@ hpStore base es
 
 emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> Code
 emitSetDynHdr base info_ptr ccs
-  = hpStore base (zip (initDynHdr info_ptr ccs) [0..])
+  = do dflags <- getDynFlags
+       hpStore base (zip (initDynHdr dflags info_ptr ccs) [0..])
 \end{code}
index 7cdb1b6..80b3b06 100644 (file)
@@ -45,6 +45,7 @@ import Unique
 import StaticFlags
 
 import Constants
+import DynFlags
 import Util
 import Outputable
 
@@ -68,13 +69,14 @@ emitClosureCodeAndInfoTable cl_info args body
 -- Not used for return points.  (The 'smRepClosureTypeInt' call would panic.)
 mkCmmInfo :: ClosureInfo -> FCode CmmInfoTable
 mkCmmInfo cl_info
-  = return (CmmInfoTable { cit_lbl  = infoTableLabelFromCI cl_info,
-                          cit_rep  = closureSMRep cl_info,
-                          cit_prof = prof,
-                          cit_srt  = closureSRT cl_info })
+  = do dflags <- getDynFlags
+       return (CmmInfoTable { cit_lbl  = infoTableLabelFromCI cl_info,
+                              cit_rep  = closureSMRep cl_info,
+                              cit_prof = prof dflags,
+                              cit_srt  = closureSRT cl_info })
   where
-    prof | not opt_SccProfilingOn = NoProfilingInfo
-         | otherwise = ProfilingInfo ty_descr_w8 val_descr_w8
+    prof dflags | not (dopt Opt_SccProfilingOn dflags) = NoProfilingInfo
+                | otherwise = ProfilingInfo ty_descr_w8 val_descr_w8
     ty_descr_w8  = stringToWord8s (closureTypeDescr cl_info)
     val_descr_w8 = stringToWord8s (closureValDescr cl_info)
 
@@ -218,10 +220,11 @@ emitAlgReturnTarget name branches mb_deflt fam_sz
                               branches' = [(tag+1,branch)|(tag,branch)<-branches]
                           emitSwitch tag_expr branches' mb_deflt 1 fam_sz
                         else do -- no, get tag from info table
+                          dflags <- getDynFlags
                           let -- Note that ptr _always_ has tag 1
                               -- when the family size is big enough
                               untagged_ptr = cmmRegOffB nodeReg (-1)
-                              tag_expr = getConstrTag (untagged_ptr)
+                              tag_expr = getConstrTag dflags untagged_ptr
                           emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1)
        ; lbl <- emitReturnTarget name blks
        ; return (lbl, Nothing) }
@@ -240,32 +243,32 @@ emitReturnInstr live
 --
 -----------------------------------------------------------------------------
        
-stdInfoTableSizeW :: WordOff
+stdInfoTableSizeW :: DynFlags -> WordOff
 -- The size of a standard info table varies with profiling/ticky etc,
 -- so we can't get it from Constants
 -- It must vary in sync with mkStdInfoTable
-stdInfoTableSizeW
+stdInfoTableSizeW dflags
   = size_fixed + size_prof
   where
     size_fixed = 2     -- layout, type
-    size_prof | opt_SccProfilingOn = 2
-             | otherwise          = 0
+    size_prof | dopt Opt_SccProfilingOn dflags = 2
+              | otherwise                      = 0
 
-stdInfoTableSizeB :: ByteOff
-stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE
+stdInfoTableSizeB :: DynFlags -> ByteOff
+stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE
 
-stdSrtBitmapOffset :: ByteOff
+stdSrtBitmapOffset :: DynFlags -> ByteOff
 -- Byte offset of the SRT bitmap half-word which is 
 -- in the *higher-addressed* part of the type_lit
-stdSrtBitmapOffset = stdInfoTableSizeB - hALF_WORD_SIZE
+stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE
 
-stdClosureTypeOffset :: ByteOff
+stdClosureTypeOffset :: DynFlags -> ByteOff
 -- Byte offset of the closure type half-word 
-stdClosureTypeOffset = stdInfoTableSizeB - wORD_SIZE
+stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE
 
-stdPtrsOffset, stdNonPtrsOffset :: ByteOff
-stdPtrsOffset    = stdInfoTableSizeB - 2*wORD_SIZE
-stdNonPtrsOffset = stdInfoTableSizeB - 2*wORD_SIZE + hALF_WORD_SIZE
+stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff
+stdPtrsOffset    dflags = stdInfoTableSizeB dflags - 2*wORD_SIZE
+stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2*wORD_SIZE + hALF_WORD_SIZE
 
 -------------------------------------------------------------------------
 --
@@ -283,66 +286,66 @@ entryCode :: CmmExpr -> CmmExpr
 entryCode e | tablesNextToCode = e
            | otherwise        = CmmLoad e bWord
 
-getConstrTag :: CmmExpr -> CmmExpr
+getConstrTag :: DynFlags -> CmmExpr -> CmmExpr
 -- Takes a closure pointer, and return the *zero-indexed*
 -- constructor tag obtained from the info table
 -- This lives in the SRT field of the info table
 -- (constructors don't need SRTs).
-getConstrTag closure_ptr 
-  = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableConstrTag info_table]
+getConstrTag dflags closure_ptr
+  = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableConstrTag dflags info_table]
   where
-    info_table = infoTable (closureInfoPtr closure_ptr)
+    info_table = infoTable dflags (closureInfoPtr closure_ptr)
 
-cmmGetClosureType :: CmmExpr -> CmmExpr
+cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr
 -- Takes a closure pointer, and return the closure type
 -- obtained from the info table
-cmmGetClosureType closure_ptr 
-  = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableClosureType info_table]
+cmmGetClosureType dflags closure_ptr
+  = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableClosureType dflags info_table]
   where
-    info_table = infoTable (closureInfoPtr closure_ptr)
+    info_table = infoTable dflags (closureInfoPtr closure_ptr)
 
-infoTable :: CmmExpr -> CmmExpr
+infoTable :: DynFlags -> CmmExpr -> CmmExpr
 -- Takes an info pointer (the first word of a closure)
 -- and returns a pointer to the first word of the standard-form
 -- info table, excluding the entry-code word (if present)
-infoTable info_ptr
-  | tablesNextToCode = cmmOffsetB info_ptr (- stdInfoTableSizeB)
+infoTable dflags info_ptr
+  | tablesNextToCode = cmmOffsetB info_ptr (- stdInfoTableSizeB dflags)
   | otherwise       = cmmOffsetW info_ptr 1    -- Past the entry code pointer
 
-infoTableConstrTag :: CmmExpr -> CmmExpr
+infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr
 -- Takes an info table pointer (from infoTable) and returns the constr tag
 -- field of the info table (same as the srt_bitmap field)
 infoTableConstrTag = infoTableSrtBitmap
 
-infoTableSrtBitmap :: CmmExpr -> CmmExpr
+infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr
 -- Takes an info table pointer (from infoTable) and returns the srt_bitmap
 -- field of the info table
-infoTableSrtBitmap info_tbl
-  = CmmLoad (cmmOffsetB info_tbl stdSrtBitmapOffset) bHalfWord
+infoTableSrtBitmap dflags info_tbl
+  = CmmLoad (cmmOffsetB info_tbl (stdSrtBitmapOffset dflags)) bHalfWord
 
-infoTableClosureType :: CmmExpr -> CmmExpr
+infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr
 -- Takes an info table pointer (from infoTable) and returns the closure type
 -- field of the info table.
-infoTableClosureType info_tbl 
-  = CmmLoad (cmmOffsetB info_tbl stdClosureTypeOffset) bHalfWord
+infoTableClosureType dflags info_tbl
+  = CmmLoad (cmmOffsetB info_tbl (stdClosureTypeOffset dflags)) bHalfWord
 
-infoTablePtrs :: CmmExpr -> CmmExpr
-infoTablePtrs info_tbl 
-  = CmmLoad (cmmOffsetB info_tbl stdPtrsOffset) bHalfWord
+infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr
+infoTablePtrs dflags info_tbl
+  = CmmLoad (cmmOffsetB info_tbl (stdPtrsOffset dflags)) bHalfWord
 
-infoTableNonPtrs :: CmmExpr -> CmmExpr
-infoTableNonPtrs info_tbl 
-  = CmmLoad (cmmOffsetB info_tbl stdNonPtrsOffset) bHalfWord
+infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr
+infoTableNonPtrs dflags info_tbl
+  = CmmLoad (cmmOffsetB info_tbl (stdNonPtrsOffset dflags)) bHalfWord
 
-funInfoTable :: CmmExpr -> CmmExpr
+funInfoTable :: DynFlags -> CmmExpr -> CmmExpr
 -- Takes the info pointer of a function,
 -- and returns a pointer to the first word of the StgFunInfoExtra struct
 -- in the info table.
-funInfoTable info_ptr
+funInfoTable dflags info_ptr
   | tablesNextToCode
-  = cmmOffsetB info_ptr (- stdInfoTableSizeB - sIZEOF_StgFunInfoExtraRev)
+  = cmmOffsetB info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev)
   | otherwise
-  = cmmOffsetW info_ptr (1 + stdInfoTableSizeW)
+  = cmmOffsetW info_ptr (1 + stdInfoTableSizeW dflags)
                                -- Past the entry code pointer
 
 -------------------------------------------------------------------------
index 641cd5d..a2e50e0 100644 (file)
@@ -30,8 +30,8 @@ import SMRep
 import Module
 import Constants
 import Outputable
+import DynFlags
 import FastString
-import StaticFlags
 
 import Control.Monad
 
@@ -154,20 +154,23 @@ emitPrimOp [res] SparkOp [arg] live = do
         newspark = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark")))
 
 emitPrimOp [res] GetCCSOfOp [arg] _live
-  = stmtC (CmmAssign (CmmLocal res) val)
+  = do dflags <- getDynFlags
+       stmtC (CmmAssign (CmmLocal res) (val dflags))
   where
-    val | opt_SccProfilingOn = costCentreFrom (cmmUntag arg)
-        | otherwise          = CmmLit zeroCLit
+    val dflags
+     | dopt Opt_SccProfilingOn dflags = costCentreFrom (cmmUntag arg)
+     | otherwise                      = CmmLit zeroCLit
 
 emitPrimOp [res] GetCurrentCCSOp [_dummy_arg] _live
    = stmtC (CmmAssign (CmmLocal res) curCCS)
 
 emitPrimOp [res] ReadMutVarOp [mutv] _
-   = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW mutv fixedHdrSize gcWord))
+   = do dflags <- getDynFlags
+        stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW mutv (fixedHdrSize dflags) gcWord))
 
 emitPrimOp [] WriteMutVarOp [mutv,var] live
-   = do
-        stmtC (CmmStore (cmmOffsetW mutv fixedHdrSize) var)
+   = do dflags <- getDynFlags
+        stmtC (CmmStore (cmmOffsetW mutv (fixedHdrSize dflags)) var)
         vols <- getVolatileRegs live
         emitForeignCall' PlayRisky
                 [{-no results-}]
@@ -182,8 +185,10 @@ emitPrimOp [] WriteMutVarOp [mutv,var] live
 --  #define sizzeofByteArrayzh(r,a) \
 --     r = ((StgArrWords *)(a))->bytes
 emitPrimOp [res] SizeofByteArrayOp [arg] _
-   = stmtC $
-        CmmAssign (CmmLocal res) (cmmLoadIndexW arg fixedHdrSize bWord)
+   = do dflags <- getDynFlags
+        stmtC $
+            CmmAssign (CmmLocal res)
+                      (cmmLoadIndexW arg (fixedHdrSize dflags) bWord)
 
 --  #define sizzeofMutableByteArrayzh(r,a) \
 --      r = ((StgArrWords *)(a))->bytes
@@ -197,18 +202,21 @@ emitPrimOp [] TouchOp [_] _
 
 --  #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
 emitPrimOp [res] ByteArrayContents_Char [arg] _
-   = stmtC (CmmAssign (CmmLocal res) (cmmOffsetB arg arrWordsHdrSize))
+   = do dflags <- getDynFlags
+        stmtC (CmmAssign (CmmLocal res) (cmmOffsetB arg (arrWordsHdrSize dflags)))
 
 --  #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)
 emitPrimOp [res] StableNameToIntOp [arg] _
-   = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW arg fixedHdrSize bWord))
+   = do dflags <- getDynFlags
+        stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW arg (fixedHdrSize dflags) bWord))
 
 --  #define eqStableNamezh(r,sn1,sn2)                                   \
 --    (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
 emitPrimOp [res] EqStableNameOp [arg1,arg2] _
-   = stmtC (CmmAssign (CmmLocal res) (CmmMachOp mo_wordEq [
-                                cmmLoadIndexW arg1 fixedHdrSize bWord,
-                                cmmLoadIndexW arg2 fixedHdrSize bWord
+   = do dflags <- getDynFlags
+        stmtC (CmmAssign (CmmLocal res) (CmmMachOp mo_wordEq [
+                                cmmLoadIndexW arg1 (fixedHdrSize dflags) bWord,
+                                cmmLoadIndexW arg2 (fixedHdrSize dflags) bWord
                          ]))
 
 
@@ -222,7 +230,8 @@ emitPrimOp [res] AddrToAnyOp [arg] _
 --  #define dataToTagzh(r,a)  r=(GET_TAG(((StgClosure *)a)->header.info))
 --  Note: argument may be tagged!
 emitPrimOp [res] DataToTagOp [arg] _
-   = stmtC (CmmAssign (CmmLocal res) (getConstrTag (cmmUntag arg)))
+   = do dflags <- getDynFlags
+        stmtC (CmmAssign (CmmLocal res) (getConstrTag dflags (cmmUntag arg)))
 
 {- Freezing arrays-of-ptrs requires changing an info table, for the
    benefit of the generational collector.  It needs to scavenge mutable
@@ -281,8 +290,9 @@ emitPrimOp []  WriteArrayArrayOp_ArrayArray        [obj,ix,v] _  = doWritePtrArr
 emitPrimOp []  WriteArrayArrayOp_MutableArrayArray [obj,ix,v] _  = doWritePtrArrayOp obj ix v
 
 emitPrimOp [res] SizeofArrayOp [arg] _
-   = stmtC $
-       CmmAssign (CmmLocal res) (cmmLoadIndexW arg (fixedHdrSize + oFFSET_StgMutArrPtrs_ptrs) bWord)
+   = do dflags <- getDynFlags
+        stmtC $ CmmAssign (CmmLocal res)
+                          (cmmLoadIndexW arg (fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs) bWord)
 emitPrimOp [res] SizeofMutableArrayOp [arg] live
    = emitPrimOp [res] SizeofArrayOp [arg] live
 emitPrimOp [res] SizeofArrayArrayOp [arg] live
@@ -797,13 +807,15 @@ doIndexOffAddrOp _ _ _ _
    = panic "CgPrimOp: doIndexOffAddrOp"
 
 doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]
-   = mkBasicIndexedRead arrWordsHdrSize maybe_post_read_cast rep res addr idx
+   = do dflags <- getDynFlags
+        mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx
 doIndexByteArrayOp _ _ _ _
    = panic "CgPrimOp: doIndexByteArrayOp"
 
 doReadPtrArrayOp :: LocalReg -> CmmExpr -> CmmExpr -> Code
 doReadPtrArrayOp res addr idx
-   = mkBasicIndexedRead arrPtrsHdrSize Nothing gcWord res addr idx
+   = do dflags <- getDynFlags
+        mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing gcWord res addr idx
 
 
 doWriteOffAddrOp, doWriteByteArrayOp
@@ -815,27 +827,29 @@ doWriteOffAddrOp _ _ _ _
    = panic "CgPrimOp: doWriteOffAddrOp"
 
 doWriteByteArrayOp maybe_pre_write_cast rep [] [addr,idx,val]
-   = mkBasicIndexedWrite arrWordsHdrSize maybe_pre_write_cast rep addr idx val
+   = do dflags <- getDynFlags
+        mkBasicIndexedWrite (arrWordsHdrSize dflags) maybe_pre_write_cast rep addr idx val
 doWriteByteArrayOp _ _ _ _
    = panic "CgPrimOp: doWriteByteArrayOp"
 
 doWritePtrArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> Code
 doWritePtrArrayOp addr idx val
-   = do mkBasicIndexedWrite arrPtrsHdrSize Nothing bWord addr idx val
+   = do dflags <- getDynFlags
+        mkBasicIndexedWrite (arrPtrsHdrSize dflags) Nothing bWord addr idx val
         stmtC (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
    -- the write barrier.  We must write a byte into the mark table:
    -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]
         stmtC $ CmmStore (
           cmmOffsetExpr
-           (cmmOffsetExprW (cmmOffsetB addr arrPtrsHdrSize)
-                          (loadArrPtrsSize addr))
+           (cmmOffsetExprW (cmmOffsetB addr (arrPtrsHdrSize dflags))
+                          (loadArrPtrsSize dflags addr))
            (CmmMachOp mo_wordUShr [idx,
                                    CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)])
           ) (CmmLit (CmmInt 1 W8))
 
-loadArrPtrsSize :: CmmExpr -> CmmExpr
-loadArrPtrsSize addr = CmmLoad (cmmOffsetB addr off) bWord
- where off = fixedHdrSize*wORD_SIZE + oFFSET_StgMutArrPtrs_ptrs
+loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr
+loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB addr off) bWord
+ where off = fixedHdrSize dflags * wORD_SIZE + oFFSET_StgMutArrPtrs_ptrs
 
 mkBasicIndexedRead :: ByteOff -> Maybe MachOp -> CmmType
                    -> LocalReg -> CmmExpr -> CmmExpr -> Code
@@ -905,8 +919,9 @@ emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
                   -> StgLiveVars
                   -> Code
 emitCopyByteArray copy src src_off dst dst_off n live = do
-    dst_p <- assignTemp $ cmmOffsetExpr (cmmOffsetB dst arrWordsHdrSize) dst_off
-    src_p <- assignTemp $ cmmOffsetExpr (cmmOffsetB src arrWordsHdrSize) src_off
+    dflags <- getDynFlags
+    dst_p <- assignTemp $ cmmOffsetExpr (cmmOffsetB dst (arrWordsHdrSize dflags)) dst_off
+    src_p <- assignTemp $ cmmOffsetExpr (cmmOffsetB src (arrWordsHdrSize dflags)) src_off
     copy src dst dst_p src_p n live
 
 -- ----------------------------------------------------------------------------
@@ -918,7 +933,8 @@ emitCopyByteArray copy src src_off dst dst_off n live = do
 doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
                  -> StgLiveVars -> Code
 doSetByteArrayOp ba off len c live
-    = do p <- assignTemp $ cmmOffsetExpr (cmmOffsetB ba arrWordsHdrSize) off
+    = do dflags <- getDynFlags
+         p <- assignTemp $ cmmOffsetExpr (cmmOffsetB ba (arrWordsHdrSize dflags)) off
          emitMemsetCall p c len (CmmLit (mkIntCLit 1)) live
 
 -- ----------------------------------------------------------------------------
@@ -966,6 +982,7 @@ emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
               -> StgLiveVars
               -> Code
 emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 live = do
+    dflags <- getDynFlags
     -- Assign the arguments to temporaries so the code generator can
     -- calculate liveness for us.
     src <- assignTemp_ src0
@@ -977,15 +994,15 @@ emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 live = do
     -- Set the dirty bit in the header.
     stmtC (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
 
-    dst_elems_p <- assignTemp $ cmmOffsetB dst arrPtrsHdrSize
+    dst_elems_p <- assignTemp $ cmmOffsetB dst (arrPtrsHdrSize dflags)
     dst_p <- assignTemp $ cmmOffsetExprW dst_elems_p dst_off
-    src_p <- assignTemp $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize) src_off
+    src_p <- assignTemp $ cmmOffsetExprW (cmmOffsetB src (arrPtrsHdrSize dflags)) src_off
     bytes <- assignTemp $ cmmMulWord n (CmmLit (mkIntCLit wORD_SIZE))
 
     copy src dst dst_p src_p bytes live
 
     -- The base address of the destination card table
-    dst_cards_p <- assignTemp $ cmmOffsetExprW dst_elems_p (loadArrPtrsSize dst)
+    dst_cards_p <- assignTemp $ cmmOffsetExprW dst_elems_p (loadArrPtrsSize dflags dst)
 
     emitSetCards dst_off dst_cards_p n live
 
@@ -996,6 +1013,7 @@ emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 live = do
 emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> CmmExpr
                -> StgLiveVars -> Code
 emitCloneArray info_p res_r src0 src_off0 n0 live = do
+    dflags <- getDynFlags
     -- Assign the arguments to temporaries so the code generator can
     -- calculate liveness for us.
     src <- assignTemp_ src0
@@ -1006,22 +1024,22 @@ emitCloneArray info_p res_r src0 src_off0 n0 live = do
                                 (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)))
                   `cmmAddWord` CmmLit (mkIntCLit 1)
     size <- assignTemp $ n `cmmAddWord` card_words
-    words <- assignTemp $ arrPtrsHdrSizeW `cmmAddWord` size
+    words <- assignTemp $ arrPtrsHdrSizeW dflags `cmmAddWord` size
 
     arr_r <- newTemp bWord
     emitAllocateCall arr_r myCapability words live
-    tickyAllocPrim (CmmLit (mkIntCLit arrPtrsHdrSize)) (n `cmmMulWord` wordSize)
+    tickyAllocPrim (CmmLit (mkIntCLit (arrPtrsHdrSize dflags))) (n `cmmMulWord` wordSize)
         (CmmLit $ mkIntCLit 0)
 
     let arr = CmmReg (CmmLocal arr_r)
     emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCS
-    stmtC $ CmmStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE +
+    stmtC $ CmmStore (cmmOffsetB arr (fixedHdrSize dflags * wORD_SIZE +
                                       oFFSET_StgMutArrPtrs_ptrs)) n
-    stmtC $ CmmStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE +
+    stmtC $ CmmStore (cmmOffsetB arr (fixedHdrSize dflags * wORD_SIZE +
                                       oFFSET_StgMutArrPtrs_size)) size
 
-    dst_p <- assignTemp $ cmmOffsetB arr arrPtrsHdrSize
-    src_p <- assignTemp $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize)
+    dst_p <- assignTemp $ cmmOffsetB arr (arrPtrsHdrSize dflags)
+    src_p <- assignTemp $ cmmOffsetExprW (cmmOffsetB src (arrPtrsHdrSize dflags))
              src_off
 
     emitMemcpyCall dst_p src_p (n `cmmMulWord` wordSize)
@@ -1034,8 +1052,8 @@ emitCloneArray info_p res_r src0 src_off0 n0 live = do
         live
     stmtC $ CmmAssign (CmmLocal res_r) arr
   where
-    arrPtrsHdrSizeW = CmmLit $ mkIntCLit $ fixedHdrSize +
-                      (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE)
+    arrPtrsHdrSizeW dflags = CmmLit $ mkIntCLit $ fixedHdrSize dflags +
+                                 (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE)
     wordSize = CmmLit (mkIntCLit wORD_SIZE)
     myCapability = CmmReg baseReg `cmmSubWord`
                    CmmLit (mkIntCLit oFFSET_Capability_r)
index 1a5f916..2eccae7 100644 (file)
@@ -49,7 +49,7 @@ import CLabel
 
 import qualified Module
 import CostCentre
-import StaticFlags
+import DynFlags
 import FastString
 import Module
 import Constants       -- Lots of field offsets
@@ -81,15 +81,15 @@ costCentreFrom :: CmmExpr   -- A closure pointer
               -> CmmExpr       -- The cost centre from that closure
 costCentreFrom cl = CmmLoad (cmmOffsetB cl oFFSET_StgHeader_ccs) bWord
 
-staticProfHdr :: CostCentreStack -> [CmmLit]
+staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit]
 -- The profiling header words in a static closure
 -- Was SET_STATIC_PROF_HDR
-staticProfHdr ccs = ifProfilingL [mkCCostCentreStack ccs, 
-                                 staticLdvInit]
+staticProfHdr dflags ccs = ifProfilingL dflags [mkCCostCentreStack ccs,
+                                                staticLdvInit]
 
-dynProfHdr :: CmmExpr -> [CmmExpr]
+dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr]
 -- Profiling header words in a dynamic closure
-dynProfHdr ccs = ifProfilingL [ccs, dynLdvInit]
+dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit]
 
 initUpdFrameProf :: CmmExpr -> Code
 -- Initialise the profiling field of an update frame
@@ -107,7 +107,8 @@ initUpdFrameProf frame_amode
 profDynAlloc :: ClosureInfo -> CmmExpr -> Code
 profDynAlloc cl_info ccs
   = ifProfiling $
-    profAlloc (CmmLit (mkIntCLit (closureSize cl_info))) ccs
+    do dflags <- getDynFlags
+       profAlloc (CmmLit (mkIntCLit (closureSize dflags cl_info))) ccs
 
 -- | Record the allocation of a closure (size is given by a CmmExpr)
 -- The size must be in words, because the allocation counter in a CCS counts
@@ -118,13 +119,14 @@ profDynAlloc cl_info ccs
 profAlloc :: CmmExpr -> CmmExpr -> Code
 profAlloc words ccs
   = ifProfiling $
-    stmtC (addToMemE alloc_rep
-               (cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc)
-               (CmmMachOp (MO_UU_Conv wordWidth alloc_rep) $
-                 [CmmMachOp mo_wordSub [words, 
-                                        CmmLit (mkIntCLit profHdrSize)]]))
-               -- subtract the "profiling overhead", which is the
-               -- profiling header in a closure.
+    do dflags <- getDynFlags
+       stmtC (addToMemE alloc_rep
+                   (cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc)
+                   (CmmMachOp (MO_UU_Conv wordWidth alloc_rep) $
+                     [CmmMachOp mo_wordSub [words,
+                                            CmmLit (mkIntCLit (profHdrSize dflags))]]))
+                   -- subtract the "profiling overhead", which is the
+                   -- profiling header in a closure.
  where 
    alloc_rep = typeWidth REP_CostCentreStack_mem_alloc
 
@@ -147,13 +149,13 @@ enterCostCentreFun ccs closure vols =
 
 ifProfiling :: Code -> Code
 ifProfiling code
-  | opt_SccProfilingOn = code
-  | otherwise         = nopC
+    = do dflags <- getDynFlags
+         if dopt Opt_SccProfilingOn dflags then code else nopC
 
-ifProfilingL :: [a] -> [a]
-ifProfilingL xs
-  | opt_SccProfilingOn = xs
-  | otherwise         = []
+ifProfilingL :: DynFlags -> [a] -> [a]
+ifProfilingL dflags xs
+  | dopt Opt_SccProfilingOn dflags = xs
+  | otherwise                      = []
 
 -- ---------------------------------------------------------------------------
 -- Initialising Cost Centres & CCSs
@@ -226,12 +228,13 @@ sizeof_ccs_words
 
 emitSetCCC :: CostCentre -> Bool -> Bool -> Code
 emitSetCCC cc tick push
-  | not opt_SccProfilingOn = nopC
-  | otherwise = do 
-    tmp <- newTemp bWord -- TODO FIXME NOW
-    pushCostCentre tmp curCCS cc
-    when tick $ stmtC (bumpSccCount (CmmReg (CmmLocal tmp)))
-    when push $ stmtC (storeCurCCS (CmmReg (CmmLocal tmp)))
+ = do dflags <- getDynFlags
+      if dopt Opt_SccProfilingOn dflags
+          then do tmp <- newTemp bWord -- TODO FIXME NOW
+                  pushCostCentre tmp curCCS cc
+                  when tick $ stmtC (bumpSccCount (CmmReg (CmmLocal tmp)))
+                  when push $ stmtC (storeCurCCS (CmmReg (CmmLocal tmp)))
+          else nopC
 
 pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> Code
 pushCostCentre result ccs cc
index a869795..217586a 100644 (file)
@@ -38,6 +38,7 @@ import OldCmm
 import OldCmmUtils
 import CLabel
 import Constants
+import DynFlags
 import Util
 import OrdList
 import Outputable
@@ -286,7 +287,8 @@ pushSpecUpdateFrame lbl updatee code
       when debugIsOn $ do
        { EndOfBlockInfo _ sequel <- getEndOfBlockInfo ;
        ; MASSERT(case sequel of { OnStack -> True; _ -> False}) }
-       ; allocStackTop (fixedHdrSize + 
+       ; dflags <- getDynFlags
+       ; allocStackTop (fixedHdrSize dflags + 
                           sIZEOF_StgUpdateFrame_NoHdr `quot` wORD_SIZE)
        ; vsp <- getVirtSp
        ; setStackFrame vsp
@@ -311,14 +313,16 @@ emitPushUpdateFrame = emitSpecPushUpdateFrame mkUpdInfoLabel
 
 emitSpecPushUpdateFrame :: CLabel -> CmmExpr -> CmmExpr -> Code
 emitSpecPushUpdateFrame lbl frame_addr updatee = do
+       dflags <- getDynFlags
        stmtsC [  -- Set the info word
                  CmmStore frame_addr (mkLblExpr lbl)
                , -- And the updatee
-                 CmmStore (cmmOffsetB frame_addr off_updatee) updatee ]
+                 CmmStore (cmmOffsetB frame_addr (off_updatee dflags)) updatee ]
        initUpdFrameProf frame_addr
 
-off_updatee :: ByteOff
-off_updatee = fixedHdrSize*wORD_SIZE + oFFSET_StgUpdateFrame_updatee
+off_updatee :: DynFlags -> ByteOff
+off_updatee dflags
+    = fixedHdrSize dflags * wORD_SIZE + oFFSET_StgUpdateFrame_updatee
 \end{code}
 
 
index e933fed..ee41448 100644 (file)
@@ -41,8 +41,8 @@ import Type
 import Id
 import StgSyn
 import PrimOp
+import DynFlags
 import Outputable
-import StaticFlags
 import Util
 
 import Control.Monad
@@ -112,15 +112,15 @@ performTailCall fun_info arg_amodes pending_assts
 
   | otherwise
   = do         { fun_amode <- idInfoToAmode fun_info
+       ; dflags <- getDynFlags
        ; let assignSt  = CmmAssign nodeReg fun_amode
               node_asst = oneStmt assignSt
               node_live = Just [node]
              (opt_node_asst, opt_node_live)
-                      | nodeMustPointToIt lf_info = (node_asst, node_live)
+                      | nodeMustPointToIt dflags lf_info = (node_asst, node_live)
                       | otherwise                 = (noStmts, Just [])
        ; EndOfBlockInfo sp _ <- getEndOfBlockInfo
 
-       ; dflags <- getDynFlags
        ; case (getCallMethod dflags fun_name fun_has_cafs lf_info (length arg_amodes)) of
 
            -- Node must always point to things we enter
@@ -133,7 +133,7 @@ performTailCall fun_info arg_amodes pending_assts
                       -- so we can directly jump to the alternatives switch
                       -- statement.
                       jumpInstr = getEndOfBlockInfo >>=
-                                  maybeSwitchOnCons enterClosure
+                                  maybeSwitchOnCons dflags enterClosure
                ; doFinalJump sp False jumpInstr }
     
            -- A function, but we have zero arguments.  It is already in WHNF,
@@ -194,9 +194,9 @@ performTailCall fun_info arg_amodes pending_assts
     fun_has_cafs = idCafInfo fun_id
     untag_node = CmmAssign nodeReg (cmmUntag (CmmReg nodeReg))
     -- Test if closure is a constructor
-    maybeSwitchOnCons enterClosure eob
+    maybeSwitchOnCons dflags enterClosure eob
               | EndOfBlockInfo _ (CaseAlts lbl _ _) <- eob,
-                not opt_SccProfilingOn
+                not (dopt Opt_SccProfilingOn dflags)
                 -- we can't shortcut when profiling is on, because we have
                 -- to enter a closure to mark it as "used" for LDV profiling
               = do { is_constr <- newLabelC
@@ -251,13 +251,14 @@ directCall :: VirtualSpOffset -> CLabel -> [(CgRep, CmmExpr)]
            -> [(CgRep, CmmExpr)] -> Maybe [GlobalReg] -> CmmStmts
            -> Code
 directCall sp lbl args extra_args live_node assts = do
+  dflags <- getDynFlags
   let
        -- First chunk of args go in registers
        (reg_arg_amodes, stk_args) = assignCallRegs args
      
        -- Any "extra" arguments are placed in frames on the
        -- stack after the other arguments.
-       slow_stk_args = slowArgs extra_args
+       slow_stk_args = slowArgs dflags extra_args
 
        reg_assts = assignToRegs reg_arg_amodes
         live_args = map snd reg_arg_amodes
index 021b0e4..cfef108 100644 (file)
@@ -264,7 +264,7 @@ tickyDynAlloc cl_info
         _               -> return () }
   where
        -- will be needed when we fill in stubs
-    _cl_size   = closureSize cl_info
+    -- _cl_size   = closureSize dflags cl_info
 --    _slop_size = slopSize cl_info
 
     tick_alloc_thk 
index 7a91a5e..b71a722 100644 (file)
@@ -459,14 +459,15 @@ dataConTagZ con = dataConTag con - fIRST_TAG
 %************************************************************************
 
 \begin{code}
-mkClosureInfo :: Bool          -- Is static
+mkClosureInfo :: DynFlags
+              -> Bool          -- Is static
              -> Id
              -> LambdaFormInfo 
              -> Int -> Int     -- Total and pointer words
              -> C_SRT
              -> String         -- String descriptor
              -> ClosureInfo
-mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr
+mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds srt_info descr
   = ClosureInfo { closureName = name, 
                  closureLFInfo = lf_info,
                  closureSMRep = sm_rep, 
@@ -480,18 +481,19 @@ mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr
                    -- anything else gets eta expanded.
   where
     name   = idName id
-    sm_rep = mkHeapRep is_static ptr_wds nonptr_wds (lfClosureType lf_info)
+    sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info)
     nonptr_wds = tot_wds - ptr_wds
 
-mkConInfo :: Bool      -- Is static
+mkConInfo :: DynFlags
+          -> Bool      -- Is static
          -> DataCon    
          -> Int -> Int -- Total and pointer words
          -> ClosureInfo
-mkConInfo is_static data_con tot_wds ptr_wds
+mkConInfo dflags is_static data_con tot_wds ptr_wds
    = ConInfo { closureSMRep = sm_rep,
                closureCon = data_con }
   where
-    sm_rep  = mkHeapRep is_static ptr_wds nonptr_wds (lfClosureType lf_info)
+    sm_rep  = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info)
     lf_info = mkConLFInfo data_con
     nonptr_wds = tot_wds - ptr_wds
 \end{code}
@@ -503,8 +505,8 @@ mkConInfo is_static data_con tot_wds ptr_wds
 %************************************************************************
 
 \begin{code}
-closureSize :: ClosureInfo -> WordOff
-closureSize cl_info = heapClosureSize (closureSMRep cl_info)
+closureSize :: DynFlags -> ClosureInfo -> WordOff
+closureSize dflags cl_info = heapClosureSize dflags (closureSMRep cl_info)
 \end{code}
 
 \begin{code}
@@ -551,8 +553,8 @@ thunkClosureType _                   = Thunk
 Be sure to see the stg-details notes about these...
 
 \begin{code}
-nodeMustPointToIt :: LambdaFormInfo -> Bool
-nodeMustPointToIt (LFReEntrant top _ no_fvs _)
+nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool
+nodeMustPointToIt (LFReEntrant top _ no_fvs _)
   = not no_fvs ||   -- Certainly if it has fvs we need to point to it
     isNotTopLevel top
                    -- If it is not top level we will point to it
@@ -564,7 +566,7 @@ nodeMustPointToIt (LFReEntrant top _ no_fvs _)
                -- non-inherited function i.e. not top level
                -- the  not top  case above ensures this is ok.
 
-nodeMustPointToIt (LFCon _) = True
+nodeMustPointToIt (LFCon _) = True
 
        -- Strictly speaking, the above two don't need Node to point
        -- to it if the arity = 0.  But this is a *really* unlikely
@@ -577,8 +579,8 @@ nodeMustPointToIt (LFCon _) = True
        -- having Node point to the result of an update.  SLPJ
        -- 27/11/92.
 
-nodeMustPointToIt (LFThunk _ no_fvs updatable NonStandardThunk _)
-  = updatable || not no_fvs || opt_SccProfilingOn
+nodeMustPointToIt dflags (LFThunk _ no_fvs updatable NonStandardThunk _)
+  = updatable || not no_fvs || dopt Opt_SccProfilingOn dflags
          -- For the non-updatable (single-entry case):
          --
          -- True if has fvs (in which case we need access to them, and we
@@ -586,12 +588,12 @@ nodeMustPointToIt (LFThunk _ no_fvs updatable NonStandardThunk _)
          -- or profiling (in which case we need to recover the cost centre
          --             from inside it)
 
-nodeMustPointToIt (LFThunk _ _ _ _ _)
+nodeMustPointToIt (LFThunk _ _ _ _ _)
   = True  -- Node must point to any standard-form thunk
 
-nodeMustPointToIt (LFUnknown _)     = True
-nodeMustPointToIt LFBlackHole       = True    -- BH entry may require Node to point
-nodeMustPointToIt (LFLetNoEscape _) = False 
+nodeMustPointToIt (LFUnknown _)     = True
+nodeMustPointToIt LFBlackHole       = True    -- BH entry may require Node to point
+nodeMustPointToIt (LFLetNoEscape _) = False 
 \end{code}
 
 The entry conventions depend on the type of closure being entered,
@@ -650,7 +652,7 @@ getCallMethod :: DynFlags
              -> CallMethod
 
 getCallMethod dflags _ _ lf_info _
-  | nodeMustPointToIt lf_info && dopt Opt_Parallel dflags
+  | nodeMustPointToIt dflags lf_info && dopt Opt_Parallel dflags
   =    -- If we're parallel, then we must always enter via node.  
        -- The reason is that the closure may have been         
        -- fetched since we allocated it.
@@ -662,10 +664,11 @@ getCallMethod _ name caf (LFReEntrant _ arity _ _) n_args
   | n_args < arity = SlowCall  -- Not enough args
   | otherwise      = DirectEntry (enterIdLabel name caf) arity
 
-getCallMethod _ _ _ (LFCon con) n_args
-  | opt_SccProfilingOn     -- when profiling, we must always enter
-  = EnterIt                -- a closure when we use it, so that the closure
-                           -- can be recorded as used for LDV profiling.
+getCallMethod dflags _ _ (LFCon con) n_args
+  -- when profiling, we must always enter a closure when we use it, so
+  -- that the closure can be recorded as used for LDV profiling.
+  | dopt Opt_SccProfilingOn dflags
+  = EnterIt
   | otherwise
   = ASSERT( n_args == 0 )
     ReturnCon con
index c9b2bf8..2919313 100644 (file)
@@ -104,7 +104,7 @@ mkModuleInit dflags cost_centre_info this_mod hpc_info
         ; whenC (opt_Hpc) $
               hpcTable this_mod hpc_info
 
-        ; whenC (opt_SccProfilingOn) $ do
+        ; whenC (dopt Opt_SccProfilingOn dflags) $ do
             initCostCentres cost_centre_info
 
             -- For backwards compatibility: user code may refer to this
@@ -128,11 +128,11 @@ code-generator.)
 initCostCentres :: CollectedCCs -> Code
 -- Emit the declarations, and return code to register them
 initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
-  | not opt_SccProfilingOn = nopC
-  | otherwise
-  = do  { mapM_ emitCostCentreDecl       local_CCs
-        ; mapM_ emitCostCentreStackDecl  singleton_CCSs
-        }
+  = do dflags <- getDynFlags
+       if not (dopt Opt_SccProfilingOn dflags)
+           then nopC
+           else do mapM_ emitCostCentreDecl      local_CCs
+                   mapM_ emitCostCentreStackDecl singleton_CCSs
 \end{code}
 
 %************************************************************************
index dae0ad0..70892ee 100644 (file)
@@ -224,15 +224,16 @@ cgDataCon :: DataCon -> FCode ()
 -- Generate the entry code, info tables, and (for niladic constructor)
 -- the static closure, for a constructor.
 cgDataCon data_con
-  = do { let
+  = do { dflags <- getDynFlags
+        ; let
             (tot_wds, --  #ptr_wds + #nonptr_wds
             ptr_wds, --  #ptr_wds
-            arg_things) = mkVirtConstrOffsets arg_reps
+            arg_things) = mkVirtConstrOffsets dflags arg_reps
 
             nonptr_wds   = tot_wds - ptr_wds
 
-            sta_info_tbl = mkDataConInfoTable data_con True  ptr_wds nonptr_wds
-            dyn_info_tbl = mkDataConInfoTable data_con False ptr_wds nonptr_wds
+            sta_info_tbl = mkDataConInfoTable dflags data_con True  ptr_wds nonptr_wds
+            dyn_info_tbl = mkDataConInfoTable dflags data_con False ptr_wds nonptr_wds
 
             emit_info info_tbl ticky_code
                 = emitClosureAndInfoTable info_tbl NativeDirectCall []
index 942a780..2bec420 100644 (file)
@@ -55,7 +55,6 @@ import Outputable
 import FastString
 import Maybes
 import DynFlags
-import StaticFlags
 
 ------------------------------------------------------------------------
 --             Top-level bindings
@@ -79,17 +78,17 @@ cgTopRhsClosure id ccs _ upd_flag args body = do
   ; mod_name <- getModuleName
   ; dflags   <- getDynFlags
   ; let descr         = closureDescription dflags mod_name name
-        closure_info  = mkClosureInfo True id lf_info 0 0 descr
+        closure_info  = mkClosureInfo dflags True id lf_info 0 0 descr
         closure_label = mkLocalClosureLabel name (idCafInfo id)
        cg_id_info    = litIdInfo id lf_info (CmmLabel closure_label)
         caffy         = idCafInfo id
         info_tbl      = mkCmmInfo closure_info -- XXX short-cut
-        closure_rep   = mkStaticClosureFields info_tbl ccs caffy []
+        closure_rep   = mkStaticClosureFields dflags info_tbl ccs caffy []
 
         -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
   ; emitDataLits closure_label closure_rep
   ; let fv_details :: [(NonVoid Id, VirtualHpOffset)]
-       (_, _, fv_details) = mkVirtHeapOffsets (isLFThunk lf_info)
+       (_, _, fv_details) = mkVirtHeapOffsets dflags (isLFThunk lf_info)
                                               (addIdReps [])
   -- Don't drop the non-void args until the closure info has been made
   ; forkClosureBody (closureCodeBody True id closure_info ccs
@@ -161,13 +160,14 @@ cgRhs name (StgRhsCon cc con args)
   = buildDynCon name cc con args
 
 cgRhs name (StgRhsClosure cc bi fvs upd_flag _srt args body)
-  = mkRhsClosure name cc bi (nonVoidIds fvs) upd_flag args body
+  = do dflags <- getDynFlags
+       mkRhsClosure dflags name cc bi (nonVoidIds fvs) upd_flag args body
 
 ------------------------------------------------------------------------
 --             Non-constructor right hand sides
 ------------------------------------------------------------------------
 
-mkRhsClosure :: Id -> CostCentreStack -> StgBinderInfo
+mkRhsClosure :: DynFlags -> Id -> CostCentreStack -> StgBinderInfo
             -> [NonVoid Id]                    -- Free vars
              -> UpdateFlag
             -> [Id]                            -- Args
@@ -210,7 +210,7 @@ for semi-obvious reasons.
 -}
 
 ---------- Note [Selectors] ------------------
-mkRhsClosure   bndr cc bi
+mkRhsClosure   dflags bndr cc bi
                [NonVoid the_fv]                -- Just one free var
                upd_flag                -- Updatable thunk
                 []                      -- A thunk
@@ -234,14 +234,14 @@ mkRhsClosure      bndr cc bi
   where
     lf_info              = mkSelectorLFInfo bndr offset_into_int
                                 (isUpdatable upd_flag)
-    (_, _, params_w_offsets) = mkVirtConstrOffsets (addIdReps params)
+    (_, _, params_w_offsets) = mkVirtConstrOffsets dflags (addIdReps params)
                               -- Just want the layout
     maybe_offset         = assocMaybe params_w_offsets (NonVoid selectee)
     Just the_offset      = maybe_offset
-    offset_into_int       = the_offset - fixedHdrSize
+    offset_into_int       = the_offset - fixedHdrSize dflags
 
 ---------- Note [Ap thunks] ------------------
-mkRhsClosure    bndr cc bi
+mkRhsClosure    dflags bndr cc bi
                fvs
                upd_flag
                 []                      -- No args; a thunk
@@ -251,7 +251,8 @@ mkRhsClosure    bndr cc bi
        && all (isGcPtrRep . idPrimRep . stripNV) fvs
        && isUpdatable upd_flag
        && arity <= mAX_SPEC_AP_SIZE
-        && not opt_SccProfilingOn -- not when profiling: we don't want to
+        && not (dopt Opt_SccProfilingOn dflags)
+                                  -- not when profiling: we don't want to
                                   -- lose information about this particular
                                   -- thunk (e.g. its type) (#949)
 
@@ -265,7 +266,7 @@ mkRhsClosure    bndr cc bi
        arity   = length fvs
 
 ---------- Default case ------------------
-mkRhsClosure bndr cc _ fvs upd_flag args body
+mkRhsClosure bndr cc _ fvs upd_flag args body
   = do {       -- LAY OUT THE OBJECT
        -- If the binder is itself a free variable, then don't store
        -- it in the closure.  Instead, just bind it to Node on entry.
@@ -289,9 +290,9 @@ mkRhsClosure bndr cc _ fvs upd_flag args body
                 descr = closureDescription dflags mod_name name
                 fv_details :: [(NonVoid Id, VirtualHpOffset)]
                (tot_wds, ptr_wds, fv_details)
-                  = mkVirtHeapOffsets (isLFThunk lf_info)
+                  = mkVirtHeapOffsets dflags (isLFThunk lf_info)
                                       (addIdReps (map stripNV reduced_fvs))
-               closure_info = mkClosureInfo False      -- Not static
+               closure_info = mkClosureInfo dflags False       -- Not static
                                             bndr lf_info tot_wds ptr_wds
                                              descr
 
@@ -335,10 +336,10 @@ cgStdThunk bndr _cc _bndr_info _body lf_info payload
     mod_name <- getModuleName
   ; dflags <- getDynFlags
   ; let (tot_wds, ptr_wds, payload_w_offsets)
-           = mkVirtHeapOffsets (isLFThunk lf_info) (addArgReps payload)
+           = mkVirtHeapOffsets dflags (isLFThunk lf_info) (addArgReps payload)
 
        descr = closureDescription dflags mod_name (idName bndr)
-       closure_info = mkClosureInfo False      -- Not static
+       closure_info = mkClosureInfo dflags False       -- Not static
                                     bndr lf_info tot_wds ptr_wds
                                      descr
 
@@ -419,8 +420,9 @@ closureCodeBody top_lvl bndr cl_info _cc args arity body fv_details
                 -- Emit slow-entry code (for entering a closure through a PAP)
                 { mkSlowEntryCode cl_info arg_regs
 
+                ; dflags <- getDynFlags
                 ; let lf_info = closureLFInfo cl_info
-                      node_points = nodeMustPointToIt lf_info
+                      node_points = nodeMustPointToIt dflags lf_info
                       node' = if node_points then Just node else Nothing
                 ; tickyEnterFun cl_info
                 ; whenC node_points (ldvEnterClosure cl_info)
@@ -475,7 +477,8 @@ mkSlowEntryCode cl_info arg_regs -- function closure is already in `Node'
 thunkCode :: ClosureInfo -> [(NonVoid Id, VirtualHpOffset)] -> CostCentreStack
           -> LocalReg -> Int -> StgExpr -> FCode ()
 thunkCode cl_info fv_details _cc node arity body
-  = do { let node_points = nodeMustPointToIt (closureLFInfo cl_info)
+  = do { dflags <- getDynFlags
+       ; let node_points = nodeMustPointToIt dflags (closureLFInfo cl_info)
              node'       = if node_points then Just node else Nothing
         ; tickyEnterThunk cl_info
         ; ldvEnterClosure cl_info -- NB: Node always points when profiling
@@ -532,7 +535,7 @@ emitBlackHoleCode is_single_entry = do
   -- Note the eager-blackholing check is here rather than in blackHoleOnEntry,
   -- because emitBlackHoleCode is called from CmmParse.
 
-  let  eager_blackholing =  not opt_SccProfilingOn
+  let  eager_blackholing =  not (dopt Opt_SccProfilingOn dflags)
                          && dopt Opt_EagerBlackHoling dflags
              -- Profiling needs slop filling (to support LDV
              -- profiling), so currently eager blackholing doesn't
@@ -540,7 +543,7 @@ emitBlackHoleCode is_single_entry = do
 
   whenC eager_blackholing $ do
     tickyBlackHole (not is_single_entry)
-    emitStore (cmmOffsetW (CmmReg nodeReg) fixedHdrSize)
+    emitStore (cmmOffsetW (CmmReg nodeReg) (fixedHdrSize dflags))
                   (CmmReg (CmmGlobal CurrentTSO))
     emitPrimCall [] MO_WriteBarrier []
     emitStore (CmmReg nodeReg) (CmmReg (CmmGlobal EagerBlackholeInfo))
@@ -561,7 +564,8 @@ setupUpdate closure_info node body
           dflags <- getDynFlags
           let
               bh = blackHoleOnEntry closure_info &&
-                   not opt_SccProfilingOn && dopt Opt_EagerBlackHoling dflags
+                   not (dopt Opt_SccProfilingOn dflags) &&
+                   dopt Opt_EagerBlackHoling dflags
 
               lbl | bh        = mkBHUpdInfoLabel
                   | otherwise = mkUpdInfoLabel
@@ -638,13 +642,14 @@ link_caf :: Bool                -- True <=> updatable, False <=> single-entry
 -- is that we only want to update dynamic heap objects, not static ones,
 -- so that generational GC is easier.
 link_caf _is_upd = do
-  {    -- Alloc black hole specifying CC_HDR(Node) as the cost centre
+  { dflags <- getDynFlags
+    -- Alloc black hole specifying CC_HDR(Node) as the cost centre
   ; let        use_cc   = costCentreFrom (CmmReg nodeReg)
         blame_cc = use_cc
         tso      = CmmReg (CmmGlobal CurrentTSO)
 
   ; (hp_rel, init) <- allocDynClosureCmm cafBlackHoleInfoTable mkLFBlackHole
-                                         use_cc blame_cc [(tso,fixedHdrSize)]
+                                         use_cc blame_cc [(tso,fixedHdrSize dflags)]
   ; emit init
 
        -- Call the RTS function newCAF to add the CAF to the CafList
index 8023abd..73b3d16 100644 (file)
@@ -376,8 +376,8 @@ thunkClosureType _                   = Thunk
 
 -- Be sure to see the stg-details notes about these...
 
-nodeMustPointToIt :: LambdaFormInfo -> Bool
-nodeMustPointToIt (LFReEntrant top _ no_fvs _)
+nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool
+nodeMustPointToIt (LFReEntrant top _ no_fvs _)
   = not no_fvs ||   -- Certainly if it has fvs we need to point to it
     isNotTopLevel top
                    -- If it is not top level we will point to it
@@ -389,7 +389,7 @@ nodeMustPointToIt (LFReEntrant top _ no_fvs _)
                -- non-inherited function i.e. not top level
                -- the  not top  case above ensures this is ok.
 
-nodeMustPointToIt (LFCon _) = True
+nodeMustPointToIt (LFCon _) = True
 
        -- Strictly speaking, the above two don't need Node to point
        -- to it if the arity = 0.  But this is a *really* unlikely
@@ -402,8 +402,8 @@ nodeMustPointToIt (LFCon _) = True
        -- having Node point to the result of an update.  SLPJ
        -- 27/11/92.
 
-nodeMustPointToIt (LFThunk _ no_fvs updatable NonStandardThunk _)
-  = updatable || not no_fvs || opt_SccProfilingOn
+nodeMustPointToIt dflags (LFThunk _ no_fvs updatable NonStandardThunk _)
+  = updatable || not no_fvs || dopt Opt_SccProfilingOn dflags
          -- For the non-updatable (single-entry case):
          --
          -- True if has fvs (in which case we need access to them, and we
@@ -411,13 +411,13 @@ nodeMustPointToIt (LFThunk _ no_fvs updatable NonStandardThunk _)
          -- or profiling (in which case we need to recover the cost centre
          --             from inside it)
 
-nodeMustPointToIt (LFThunk {}) -- Node must point to a standard-form thunk
+nodeMustPointToIt _ (LFThunk {})       -- Node must point to a standard-form thunk
   = True 
 
-nodeMustPointToIt (LFUnknown _)   = True
-nodeMustPointToIt LFUnLifted      = False
-nodeMustPointToIt LFBlackHole     = True    -- BH entry may require Node to point
-nodeMustPointToIt LFLetNoEscape   = False 
+nodeMustPointToIt (LFUnknown _)   = True
+nodeMustPointToIt LFUnLifted      = False
+nodeMustPointToIt LFBlackHole     = True    -- BH entry may require Node to point
+nodeMustPointToIt LFLetNoEscape   = False 
 
 -----------------------------------------------------------------------------
 --             getCallMethod
@@ -475,7 +475,7 @@ getCallMethod :: DynFlags
              -> CallMethod
 
 getCallMethod dflags _name _ lf_info _n_args
-  | nodeMustPointToIt lf_info && dopt Opt_Parallel dflags
+  | nodeMustPointToIt dflags lf_info && dopt Opt_Parallel dflags
   =    -- If we're parallel, then we must always enter via node.  
        -- The reason is that the closure may have been         
        -- fetched since we allocated it.
@@ -673,13 +673,14 @@ mkCmmInfo ClosureInfo {..}
 --     Building ClosureInfos
 --------------------------------------
 
-mkClosureInfo :: Bool          -- Is static
+mkClosureInfo :: DynFlags
+              -> Bool          -- Is static
              -> Id
              -> LambdaFormInfo 
              -> Int -> Int     -- Total and pointer words
               -> String         -- String descriptor
              -> ClosureInfo
-mkClosureInfo is_static id lf_info tot_wds ptr_wds val_descr
+mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr
   = ClosureInfo { closureName      = name,
                   closureLFInfo    = lf_info,
                   closureInfoLabel = info_lbl,  -- These three fields are
@@ -687,8 +688,8 @@ mkClosureInfo is_static id lf_info tot_wds ptr_wds val_descr
                   closureProf      = prof }     -- (we don't have an SRT yet)
   where
     name       = idName id
-    sm_rep     = mkHeapRep is_static ptr_wds nonptr_wds (lfClosureType lf_info)
-    prof       = mkProfilingInfo id val_descr
+    sm_rep     = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info)
+    prof       = mkProfilingInfo dflags id val_descr
     nonptr_wds = tot_wds - ptr_wds
 
     info_lbl = mkClosureInfoTableLabel id lf_info
@@ -851,9 +852,9 @@ enterIdLabel id c
 -- The type is determined from the type information stored with the @Id@
 -- in the closure info using @closureTypeDescr@.
 
-mkProfilingInfo :: Id -> String -> ProfilingInfo
-mkProfilingInfo id val_descr
-  | not opt_SccProfilingOn = NoProfilingInfo
+mkProfilingInfo :: DynFlags -> Id -> String -> ProfilingInfo
+mkProfilingInfo dflags id val_descr
+  | not (dopt Opt_SccProfilingOn dflags) = NoProfilingInfo
   | otherwise = ProfilingInfo ty_descr_w8 val_descr_w8
   where
     ty_descr_w8  = stringToWord8s (getTyDescription (idType id))
@@ -884,8 +885,8 @@ getTyLitDescription l =
 --   CmmInfoTable-related things
 --------------------------------------
 
-mkDataConInfoTable :: DataCon -> Bool -> Int -> Int -> CmmInfoTable
-mkDataConInfoTable data_con is_static ptr_wds nonptr_wds
+mkDataConInfoTable :: DynFlags -> DataCon -> Bool -> Int -> Int -> CmmInfoTable
+mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds
  = CmmInfoTable { cit_lbl  = info_lbl
                 , cit_rep  = sm_rep
                 , cit_prof = prof
@@ -896,13 +897,13 @@ mkDataConInfoTable data_con is_static ptr_wds nonptr_wds
    info_lbl | is_static = mkStaticInfoTableLabel name NoCafRefs
             | otherwise = mkConInfoTableLabel    name NoCafRefs
 
-   sm_rep = mkHeapRep is_static ptr_wds nonptr_wds cl_type
+   sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type
 
    cl_type = Constr (fromIntegral (dataConTagZ data_con))
                    (dataConIdentity data_con)
 
-   prof | not opt_SccProfilingOn = NoProfilingInfo
-        | otherwise              = ProfilingInfo ty_descr val_descr
+   prof | not (dopt Opt_SccProfilingOn dflags) = NoProfilingInfo
+        | otherwise                            = ProfilingInfo ty_descr val_descr
 
    ty_descr  = stringToWord8s $ occNameString $ getOccName $ dataConTyCon data_con
    val_descr = stringToWord8s $ occNameString $ getOccName data_con
index 03a659b..3efa63d 100644 (file)
@@ -71,14 +71,14 @@ cgTopRhsCon id con args
 
             (tot_wds, --  #ptr_wds + #nonptr_wds
              ptr_wds, --  #ptr_wds
-             nv_args_w_offsets) = mkVirtConstrOffsets (addArgReps args)
+             nv_args_w_offsets) = mkVirtConstrOffsets dflags (addArgReps args)
 
             nonptr_wds = tot_wds - ptr_wds
 
              -- we're not really going to emit an info table, so having
              -- to make a CmmInfoTable is a bit overkill, but mkStaticClosureFields
              -- needs to poke around inside it.
-            info_tbl = mkDataConInfoTable con True ptr_wds nonptr_wds
+            info_tbl = mkDataConInfoTable dflags con True ptr_wds nonptr_wds
 
             get_lit (arg, _offset) = do { CmmLit lit <- getArgAmode arg
                                         ; return lit }
@@ -88,6 +88,7 @@ cgTopRhsCon id con args
                 -- NB2: all the amodes should be Lits!
 
         ; let closure_rep = mkStaticClosureFields
+                             dflags
                              info_tbl
                              dontCareCCS                -- Because it's static data
                              caffy                      -- Has CAF refs
@@ -184,7 +185,7 @@ buildDynCon' dflags platform binder _cc con [arg]
   , val >= fromIntegral mIN_INTLIKE     -- ...ditto...
   = do  { let intlike_lbl   = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_INTLIKE_closure")
               val_int = fromIntegral val :: Int
-              offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize + 1)
+              offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize dflags + 1)
                 -- INTLIKE closures consist of a header and one word payload
               intlike_amode = cmmLabelOffW intlike_lbl offsetW
         ; return (litIdInfo binder (mkConLFInfo con) intlike_amode, mkNop) }
@@ -197,18 +198,18 @@ buildDynCon' dflags platform binder _cc con [arg]
   , val_int <= mAX_CHARLIKE
   , val_int >= mIN_CHARLIKE
   = do  { let charlike_lbl   = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_CHARLIKE_closure")
-              offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize + 1)
+              offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize dflags + 1)
                 -- CHARLIKE closures consist of a header and one word payload
               charlike_amode = cmmLabelOffW charlike_lbl offsetW
         ; return (litIdInfo binder (mkConLFInfo con) charlike_amode, mkNop) }
 
 -------- buildDynCon': the general case -----------
-buildDynCon' _ _ binder ccs con args
+buildDynCon' dflags _ binder ccs con args
   = do  { let (tot_wds, ptr_wds, args_w_offsets)
-                = mkVirtConstrOffsets (addArgReps args)
+                = mkVirtConstrOffsets dflags (addArgReps args)
                 -- No void args in args_w_offsets
               nonptr_wds = tot_wds - ptr_wds
-              info_tbl = mkDataConInfoTable con False ptr_wds nonptr_wds
+              info_tbl = mkDataConInfoTable dflags con False ptr_wds nonptr_wds
         ; (tmp, init) <- allocDynClosure info_tbl lf_info
                                          use_cc blame_cc args_w_offsets
         ; regIdInfo binder lf_info tmp init }
@@ -233,10 +234,10 @@ bindConArgs :: AltCon -> LocalReg -> [Id] -> FCode [LocalReg]
 -- found a con
 bindConArgs (DataAlt con) base args
   = ASSERT(not (isUnboxedTupleCon con))
-    mapM bind_arg args_w_offsets
+    do dflags <- getDynFlags
+       let (_, _, args_w_offsets) = mkVirtConstrOffsets dflags (addIdReps args)
+       mapM bind_arg args_w_offsets
   where
-    (_, _, args_w_offsets) = mkVirtConstrOffsets (addIdReps args)
-
     tag = tagForCon con
 
           -- The binding below forces the masking out of the tag bits
index 9e2b78c..65e2416 100644 (file)
@@ -505,12 +505,12 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts
                emitSwitch tag_expr branches' mb_deflt 1 fam_sz
 
           else         -- No, get tag from info table
-                let -- Note that ptr _always_ has tag 1
-                    -- when the family size is big enough
-                    untagged_ptr = cmmRegOffB bndr_reg (-1)
-                    tag_expr = getConstrTag (untagged_ptr)
-                in
-                emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1) }
+                do dflags <- getDynFlags
+                   let -- Note that ptr _always_ has tag 1
+                       -- when the family size is big enough
+                       untagged_ptr = cmmRegOffB bndr_reg (-1)
+                       tag_expr = getConstrTag dflags (untagged_ptr)
+                   emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1) }
 
 cgAlts _ _ _ _ = panic "cgAlts"
        -- UbxTupAlt and PolyAlt have only one alternative
@@ -633,7 +633,7 @@ cgTailCall fun_id fun_info args = do
        -- A direct function call (possibly with some left-over arguments)
        DirectEntry lbl arity -> do
                { tickyDirectCall arity args
-                ; if node_points
+                ; if node_points dflags
                      then directCall NativeNodeCall   lbl arity (fun_arg:args)
                      else directCall NativeDirectCall lbl arity args }
 
@@ -644,7 +644,7 @@ cgTailCall fun_id fun_info args = do
     fun_name    = idName            fun_id
     fun         = idInfoToAmode     fun_info
     lf_info     = cgIdInfoLF        fun_info
-    node_points = nodeMustPointToIt lf_info
+    node_points dflags = nodeMustPointToIt dflags lf_info
 
 
 emitEnter :: CmmExpr -> FCode ()
index c67e0e0..8c061cf 100644 (file)
@@ -35,7 +35,7 @@ import CLabel
 import SMRep
 import ForeignCall
 import Constants
-import StaticFlags
+import DynFlags
 import Maybes
 import Outputable
 import BasicTypes
@@ -259,52 +259,55 @@ maybe_assign_temp e
 -- This stuff can't be done in suspendThread/resumeThread, because it
 -- refers to global registers which aren't available in the C world.
 
-saveThreadState :: CmmAGraph
-saveThreadState =
+saveThreadState :: DynFlags -> CmmAGraph
+saveThreadState dflags =
   -- CurrentTSO->stackobj->sp = Sp;
-  mkStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO tso_stackobj) bWord) stack_SP) stgSp
+  mkStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO (tso_stackobj dflags)) bWord) (stack_SP dflags)) stgSp
   <*> closeNursery
   -- and save the current cost centre stack in the TSO when profiling:
-  <*> if opt_SccProfilingOn then
-        mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS
+  <*> if dopt Opt_SccProfilingOn dflags then
+        mkStore (cmmOffset stgCurrentTSO (tso_CCCS dflags)) curCCS
       else mkNop
 
 emitSaveThreadState :: BlockId -> FCode ()
 emitSaveThreadState bid = do
+  dflags <- getDynFlags
+
   -- CurrentTSO->stackobj->sp = Sp;
-  emitStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO tso_stackobj) bWord) stack_SP)
+  emitStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO (tso_stackobj dflags)) bWord) (stack_SP dflags))
                  (CmmStackSlot (Young bid) (widthInBytes (typeWidth gcWord)))
   emit closeNursery
   -- and save the current cost centre stack in the TSO when profiling:
-  when opt_SccProfilingOn $
-        emitStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS
+  when (dopt Opt_SccProfilingOn dflags) $
+        emitStore (cmmOffset stgCurrentTSO (tso_CCCS dflags)) curCCS
 
    -- CurrentNursery->free = Hp+1;
 closeNursery :: CmmAGraph
 closeNursery = mkStore nursery_bdescr_free (cmmOffsetW stgHp 1)
 
-loadThreadState :: LocalReg -> LocalReg -> CmmAGraph
-loadThreadState tso stack = do
+loadThreadState :: DynFlags -> LocalReg -> LocalReg -> CmmAGraph
+loadThreadState dflags tso stack = do
   -- tso <- newTemp gcWord -- TODO FIXME NOW
   -- stack <- newTemp gcWord -- TODO FIXME NOW
   catAGraphs [
         -- tso = CurrentTSO;
         mkAssign (CmmLocal tso) stgCurrentTSO,
         -- stack = tso->stackobj;
-        mkAssign (CmmLocal stack) (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_stackobj) bWord),
+        mkAssign (CmmLocal stack) (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) bWord),
         -- Sp = stack->sp;
-        mkAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal stack)) stack_SP) bWord),
+        mkAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal stack)) (stack_SP dflags)) bWord),
         -- SpLim = stack->stack + RESERVED_STACK_WORDS;
-        mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal stack)) stack_STACK)
+        mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal stack)) (stack_STACK dflags))
                                     rESERVED_STACK_WORDS),
         openNursery,
         -- and load the current cost centre stack from the TSO when profiling:
-        if opt_SccProfilingOn then
+        if dopt Opt_SccProfilingOn dflags then
           storeCurCCS
-            (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) ccsType)
+            (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) ccsType)
         else mkNop]
 emitLoadThreadState :: LocalReg -> LocalReg -> FCode ()
-emitLoadThreadState tso stack = emit $ loadThreadState tso stack
+emitLoadThreadState tso stack = do dflags <- getDynFlags
+                                   emit $ loadThreadState dflags tso stack
 
 openNursery :: CmmAGraph
 openNursery = catAGraphs [
@@ -334,15 +337,15 @@ nursery_bdescr_free   = cmmOffset stgCurrentNursery oFFSET_bdescr_free
 nursery_bdescr_start  = cmmOffset stgCurrentNursery oFFSET_bdescr_start
 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
 
-tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: ByteOff
-tso_stackobj = closureField oFFSET_StgTSO_stackobj
-tso_CCCS     = closureField oFFSET_StgTSO_cccs
-stack_STACK  = closureField oFFSET_StgStack_stack
-stack_SP     = closureField oFFSET_StgStack_sp
+tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: DynFlags -> ByteOff
+tso_stackobj dflags = closureField dflags oFFSET_StgTSO_stackobj
+tso_CCCS     dflags = closureField dflags oFFSET_StgTSO_cccs
+stack_STACK  dflags = closureField dflags oFFSET_StgStack_stack
+stack_SP     dflags = closureField dflags oFFSET_StgStack_sp
 
 
-closureField :: ByteOff -> ByteOff
-closureField off = off + fixedHdrSize * wORD_SIZE
+closureField :: DynFlags -> ByteOff -> ByteOff
+closureField dflags off = off + fixedHdrSize dflags * wORD_SIZE
 
 stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
 stgSp             = CmmReg sp
@@ -376,19 +379,20 @@ getFCallArgs args
             = return Nothing
             | otherwise
             = do { cmm <- getArgAmode (NonVoid arg)
-                 ; return (Just (add_shim arg_ty cmm, hint)) }
+                 ; dflags <- getDynFlags
+                 ; return (Just (add_shim dflags arg_ty cmm, hint)) }
             where
               arg_ty  = stgArgType arg
               arg_rep = typePrimRep arg_ty
               hint    = typeForeignHint arg_ty
 
-add_shim :: Type -> CmmExpr -> CmmExpr
-add_shim arg_ty expr
+add_shim :: DynFlags -> Type -> CmmExpr -> CmmExpr
+add_shim dflags arg_ty expr
   | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
-  = cmmOffsetB expr arrPtrsHdrSize
+  = cmmOffsetB expr (arrPtrsHdrSize dflags)
 
   | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
-  = cmmOffsetB expr arrWordsHdrSize
+  = cmmOffsetB expr (arrWordsHdrSize dflags)
 
   | otherwise = expr
   where
index 2151f84..e177b72 100644 (file)
@@ -41,6 +41,7 @@ import CostCentre
 import Outputable
 import IdInfo( CafInfo(..), mayHaveCafRefs )
 import Module
+import DynFlags
 import FastString( mkFastString, fsLit )
 import Constants
 import Util
@@ -117,7 +118,8 @@ allocDynClosureCmm info_tbl lf_info use_cc _blame_cc amodes_w_offsets
         ; hpStore base cmm_args offsets
 
         -- BUMP THE VIRTUAL HEAP POINTER
-        ; setVirtHp (virt_hp + heapClosureSize rep)
+        ; dflags <- getDynFlags
+        ; setVirtHp (virt_hp + heapClosureSize dflags rep)
 
         -- Assign to a temporary and return
         -- Note [Return a LocalReg]
@@ -126,10 +128,11 @@ allocDynClosureCmm info_tbl lf_info use_cc _blame_cc amodes_w_offsets
 
 emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
 emitSetDynHdr base info_ptr ccs
-  = hpStore base header [0..]
+  = do dflags <- getDynFlags
+       hpStore base (header dflags) [0..]
   where
-    header :: [CmmExpr]
-    header = [info_ptr] ++ dynProfHdr ccs
+    header :: DynFlags -> [CmmExpr]
+    header dflags = [info_ptr] ++ dynProfHdr dflags ccs
         -- ToDo: Gransim stuff
         -- ToDo: Parallel stuff
         -- No ticky header
@@ -150,13 +153,14 @@ hpStore base vals offs
 -- and adding a static link field if necessary.
 
 mkStaticClosureFields
-        :: CmmInfoTable
+        :: DynFlags
+        -> CmmInfoTable
         -> CostCentreStack
         -> CafInfo
         -> [CmmLit]             -- Payload
         -> [CmmLit]             -- The full closure
-mkStaticClosureFields info_tbl ccs caf_refs payload
-  = mkStaticClosure info_lbl ccs payload padding
+mkStaticClosureFields dflags info_tbl ccs caf_refs payload
+  = mkStaticClosure dflags info_lbl ccs payload padding
         static_link_field saved_info_field
   where
     info_lbl = cit_lbl info_tbl
@@ -197,9 +201,9 @@ mkStaticClosureFields info_tbl ccs caf_refs payload
         | otherwise                = mkIntCLit 1  -- No CAF refs
 
 
-mkStaticClosure :: CLabel -> CostCentreStack -> [CmmLit]
+mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit]
   -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]
-mkStaticClosure info_lbl ccs payload padding static_link_field saved_info_field
+mkStaticClosure dflags info_lbl ccs payload padding static_link_field saved_info_field
   =  [CmmLabel info_lbl]
   ++ variable_header_words
   ++ concatMap padLitToWord payload
@@ -210,7 +214,7 @@ mkStaticClosure info_lbl ccs payload padding static_link_field saved_info_field
     variable_header_words
         =  staticGranHdr
         ++ staticParHdr
-        ++ staticProfHdr ccs
+        ++ staticProfHdr dflags ccs
         ++ staticTickyHdr
 
 -- JD: Simon had ellided this padding, but without it the C back end asserts
index 9c17716..0e9cebf 100644 (file)
@@ -53,6 +53,7 @@ import Id
 import Name
 import TyCon           ( PrimRep(..) )
 import BasicTypes      ( RepArity )
+import DynFlags
 import StaticFlags
 import Module
 
@@ -206,12 +207,15 @@ direct_call caller call_conv lbl arity args
   = emitCall (call_conv, NativeReturn) target (nonVArgs args)
 
   | otherwise       -- Note [over-saturated calls]
-  = emitCallWithExtraStack (call_conv, NativeReturn)
-                           target (nonVArgs fast_args) (mkStkOffsets stack_args)
+  = do dflags <- getDynFlags
+       emitCallWithExtraStack (call_conv, NativeReturn)
+                              target
+                              (nonVArgs fast_args)
+                              (mkStkOffsets (stack_args dflags))
   where
     target = CmmLit (CmmLabel lbl)
     (fast_args, rest_args) = splitAt real_arity args
-    stack_args = slowArgs rest_args
+    stack_args dflags = slowArgs dflags rest_args
     real_arity = case call_conv of
                    NativeNodeCall -> arity+1
                    _              -> arity
@@ -273,11 +277,12 @@ just more arguments that we are passing on the stack (cml_args).
 -- | 'slowArgs' takes a list of function arguments and prepares them for
 -- pushing on the stack for "extra" arguments to a function which requires
 -- fewer arguments than we currently have.
-slowArgs :: [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]
-slowArgs [] = []
-slowArgs args -- careful: reps contains voids (V), but args does not
-  | opt_SccProfilingOn = save_cccs ++ this_pat ++ slowArgs rest_args
-  | otherwise          =              this_pat ++ slowArgs rest_args
+slowArgs :: DynFlags -> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]
+slowArgs _ [] = []
+slowArgs dflags args -- careful: reps contains voids (V), but args does not
+  | dopt Opt_SccProfilingOn dflags
+              = save_cccs ++ this_pat ++ slowArgs dflags rest_args
+  | otherwise =              this_pat ++ slowArgs dflags rest_args
   where
     (arg_pat, n)            = slowCallPattern (map fst args)
     (call_args, rest_args)  = splitAt n args
@@ -396,7 +401,8 @@ getHpRelOffset virtual_offset
        ; return (cmmRegOffW hpReg (hpRel (realHp hp_usg) virtual_offset)) }
 
 mkVirtHeapOffsets
-  :: Bool              -- True <=> is a thunk
+  :: DynFlags
+  -> Bool              -- True <=> is a thunk
   -> [(PrimRep,a)]     -- Things to make offsets for
   -> (WordOff,         -- _Total_ number of words allocated
       WordOff,         -- Number of words allocated for *pointers*
@@ -412,7 +418,7 @@ mkVirtHeapOffsets
 -- mkVirtHeapOffsets always returns boxed things with smaller offsets
 -- than the unboxed things
 
-mkVirtHeapOffsets is_thunk things
+mkVirtHeapOffsets dflags is_thunk things
   = let non_void_things                      = filterOut (isVoidRep . fst)  things
        (ptrs, non_ptrs)              = partition (isGcPtrRep . fst) non_void_things
        (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs
@@ -420,16 +426,16 @@ mkVirtHeapOffsets is_thunk things
     in
     (tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets)
   where
-    hdr_size   | is_thunk   = thunkHdrSize
-               | otherwise  = fixedHdrSize
+    hdr_size | is_thunk   = thunkHdrSize dflags
+             | otherwise  = fixedHdrSize dflags
 
     computeOffset wds_so_far (rep, thing)
       = (wds_so_far + argRepSizeW (toArgRep rep), 
         (NonVoid thing, hdr_size + wds_so_far))
 
-mkVirtConstrOffsets :: [(PrimRep,a)] -> (WordOff, WordOff, [(NonVoid a, VirtualHpOffset)])
+mkVirtConstrOffsets :: DynFlags -> [(PrimRep,a)] -> (WordOff, WordOff, [(NonVoid a, VirtualHpOffset)])
 -- Just like mkVirtHeapOffsets, but for constructors
-mkVirtConstrOffsets = mkVirtHeapOffsets False
+mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags False
 
 
 -------------------------------------------------------------------------
@@ -519,11 +525,12 @@ emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body
         -- top-level binding, which this binding would incorrectly shadow.
         ; node <- if top_lvl then return $ idToReg (NonVoid bndr)
                   else bindToReg (NonVoid bndr) lf_info
-        ; let node_points = nodeMustPointToIt lf_info
+        ; dflags <- getDynFlags
+        ; let node_points = nodeMustPointToIt dflags lf_info
         ; arg_regs <- bindArgsToRegs args
         ; let args' = if node_points then (node : arg_regs) else arg_regs
-              conv  = if nodeMustPointToIt lf_info then NativeNodeCall
-                                                   else NativeDirectCall
+              conv  = if nodeMustPointToIt dflags lf_info then NativeNodeCall
+                                                          else NativeDirectCall
               (offset, _) = mkCallEntry conv args'
         ; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs)
         }
@@ -544,32 +551,32 @@ emitClosureAndInfoTable info_tbl conv args body
 --
 -----------------------------------------------------------------------------
        
-stdInfoTableSizeW :: WordOff
+stdInfoTableSizeW :: DynFlags -> WordOff
 -- The size of a standard info table varies with profiling/ticky etc,
 -- so we can't get it from Constants
 -- It must vary in sync with mkStdInfoTable
-stdInfoTableSizeW
+stdInfoTableSizeW dflags
   = size_fixed + size_prof
   where
     size_fixed = 2     -- layout, type
-    size_prof | opt_SccProfilingOn = 2
+    size_prof | dopt Opt_SccProfilingOn dflags = 2
              | otherwise          = 0
 
-stdInfoTableSizeB  :: ByteOff
-stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE :: ByteOff
+stdInfoTableSizeB  :: DynFlags -> ByteOff
+stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE :: ByteOff
 
-stdSrtBitmapOffset :: ByteOff
+stdSrtBitmapOffset :: DynFlags -> ByteOff
 -- Byte offset of the SRT bitmap half-word which is 
 -- in the *higher-addressed* part of the type_lit
-stdSrtBitmapOffset = stdInfoTableSizeB - hALF_WORD_SIZE
+stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE
 
-stdClosureTypeOffset :: ByteOff
+stdClosureTypeOffset :: DynFlags -> ByteOff
 -- Byte offset of the closure type half-word 
-stdClosureTypeOffset = stdInfoTableSizeB - wORD_SIZE
+stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE
 
-stdPtrsOffset, stdNonPtrsOffset :: ByteOff
-stdPtrsOffset    = stdInfoTableSizeB - 2*wORD_SIZE
-stdNonPtrsOffset = stdInfoTableSizeB - 2*wORD_SIZE + hALF_WORD_SIZE
+stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff
+stdPtrsOffset    dflags = stdInfoTableSizeB dflags - 2*wORD_SIZE
+stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2*wORD_SIZE + hALF_WORD_SIZE
 
 -------------------------------------------------------------------------
 --
@@ -587,65 +594,65 @@ entryCode :: CmmExpr -> CmmExpr
 entryCode e | tablesNextToCode = e
            | otherwise        = CmmLoad e bWord
 
-getConstrTag :: CmmExpr -> CmmExpr
+getConstrTag :: DynFlags -> CmmExpr -> CmmExpr
 -- Takes a closure pointer, and return the *zero-indexed*
 -- constructor tag obtained from the info table
 -- This lives in the SRT field of the info table
 -- (constructors don't need SRTs).
-getConstrTag closure_ptr 
-  = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableConstrTag info_table]
+getConstrTag dflags closure_ptr
+  = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableConstrTag dflags info_table]
   where
-    info_table = infoTable (closureInfoPtr closure_ptr)
+    info_table = infoTable dflags (closureInfoPtr closure_ptr)
 
-cmmGetClosureType :: CmmExpr -> CmmExpr
+cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr
 -- Takes a closure pointer, and return the closure type
 -- obtained from the info table
-cmmGetClosureType closure_ptr 
-  = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableClosureType info_table]
+cmmGetClosureType dflags closure_ptr
+  = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableClosureType dflags info_table]
   where
-    info_table = infoTable (closureInfoPtr closure_ptr)
+    info_table = infoTable dflags (closureInfoPtr closure_ptr)
 
-infoTable :: CmmExpr -> CmmExpr
+infoTable :: DynFlags -> CmmExpr -> CmmExpr
 -- Takes an info pointer (the first word of a closure)
 -- and returns a pointer to the first word of the standard-form
 -- info table, excluding the entry-code word (if present)
-infoTable info_ptr
-  | tablesNextToCode = cmmOffsetB info_ptr (- stdInfoTableSizeB)
+infoTable dflags info_ptr
+  | tablesNextToCode = cmmOffsetB info_ptr (- stdInfoTableSizeB dflags)
   | otherwise       = cmmOffsetW info_ptr 1    -- Past the entry code pointer
 
-infoTableConstrTag :: CmmExpr -> CmmExpr
+infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr
 -- Takes an info table pointer (from infoTable) and returns the constr tag
 -- field of the info table (same as the srt_bitmap field)
 infoTableConstrTag = infoTableSrtBitmap
 
-infoTableSrtBitmap :: CmmExpr -> CmmExpr
+infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr
 -- Takes an info table pointer (from infoTable) and returns the srt_bitmap
 -- field of the info table
-infoTableSrtBitmap info_tbl
-  = CmmLoad (cmmOffsetB info_tbl stdSrtBitmapOffset) bHalfWord
+infoTableSrtBitmap dflags info_tbl
+  = CmmLoad (cmmOffsetB info_tbl (stdSrtBitmapOffset dflags)) bHalfWord
 
-infoTableClosureType :: CmmExpr -> CmmExpr
+infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr
 -- Takes an info table pointer (from infoTable) and returns the closure type
 -- field of the info table.
-infoTableClosureType info_tbl 
-  = CmmLoad (cmmOffsetB info_tbl stdClosureTypeOffset) bHalfWord
+infoTableClosureType dflags info_tbl
+  = CmmLoad (cmmOffsetB info_tbl (stdClosureTypeOffset dflags)) bHalfWord
 
-infoTablePtrs :: CmmExpr -> CmmExpr
-infoTablePtrs info_tbl 
-  = CmmLoad (cmmOffsetB info_tbl stdPtrsOffset) bHalfWord
+infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr
+infoTablePtrs dflags info_tbl
+  = CmmLoad (cmmOffsetB info_tbl (stdPtrsOffset dflags)) bHalfWord
 
-infoTableNonPtrs :: CmmExpr -> CmmExpr
-infoTableNonPtrs info_tbl 
-  = CmmLoad (cmmOffsetB info_tbl stdNonPtrsOffset) bHalfWord
+infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr
+infoTableNonPtrs dflags info_tbl
+  = CmmLoad (cmmOffsetB info_tbl (stdNonPtrsOffset dflags)) bHalfWord
 
-funInfoTable :: CmmExpr -> CmmExpr
+funInfoTable :: DynFlags -> CmmExpr -> CmmExpr
 -- Takes the info pointer of a function,
 -- and returns a pointer to the first word of the StgFunInfoExtra struct
 -- in the info table.
-funInfoTable info_ptr
+funInfoTable dflags info_ptr
   | tablesNextToCode
-  = cmmOffsetB info_ptr (- stdInfoTableSizeB - sIZEOF_StgFunInfoExtraRev)
+  = cmmOffsetB info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev)
   | otherwise
-  = cmmOffsetW info_ptr (1 + stdInfoTableSizeW)
+  = cmmOffsetW info_ptr (1 + stdInfoTableSizeW dflags)
                                -- Past the entry code pointer
 
index 15020cc..e015ac7 100644 (file)
@@ -46,7 +46,6 @@ import Constants
 import Module
 import FastString
 import Outputable
-import StaticFlags
 import Util
 
 import Control.Monad (liftM)
@@ -233,20 +232,23 @@ emitPrimOp [res] SparkOp [arg]
         emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp))
 
 emitPrimOp [res] GetCCSOfOp [arg]
-  = emitAssign (CmmLocal res) val
+  = do dflags <- getDynFlags
+       emitAssign (CmmLocal res) (val dflags)
   where
-    val | opt_SccProfilingOn = costCentreFrom (cmmUntag arg)
-        | otherwise          = CmmLit zeroCLit
+    val dflags
+     | dopt Opt_SccProfilingOn dflags = costCentreFrom (cmmUntag arg)
+     | otherwise                      = CmmLit zeroCLit
 
 emitPrimOp [res] GetCurrentCCSOp [_dummy_arg]
    = emitAssign (CmmLocal res) curCCS
 
 emitPrimOp [res] ReadMutVarOp [mutv]
-   = emitAssign (CmmLocal res) (cmmLoadIndexW mutv fixedHdrSize gcWord)
+   = do dflags <- getDynFlags
+        emitAssign (CmmLocal res) (cmmLoadIndexW mutv (fixedHdrSize dflags) gcWord)
 
 emitPrimOp [] WriteMutVarOp [mutv,var]
-   = do
-        emitStore (cmmOffsetW mutv fixedHdrSize) var
+   = do dflags <- getDynFlags
+        emitStore (cmmOffsetW mutv (fixedHdrSize dflags)) var
        emitCCall
                [{-no results-}]
                (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
@@ -255,8 +257,9 @@ emitPrimOp [] WriteMutVarOp [mutv,var]
 --  #define sizzeofByteArrayzh(r,a) \
 --     r = ((StgArrWords *)(a))->bytes
 emitPrimOp [res] SizeofByteArrayOp [arg]
-   = emit $
-       mkAssign (CmmLocal res) (cmmLoadIndexW arg fixedHdrSize bWord)
+   = do dflags <- getDynFlags
+        emit $
+            mkAssign (CmmLocal res) (cmmLoadIndexW arg (fixedHdrSize dflags) bWord)
 
 --  #define sizzeofMutableByteArrayzh(r,a) \
 --      r = ((StgArrWords *)(a))->bytes
@@ -270,18 +273,21 @@ emitPrimOp res@[] TouchOp args@[_arg]
 
 --  #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
 emitPrimOp [res] ByteArrayContents_Char [arg]
-   = emitAssign (CmmLocal res) (cmmOffsetB arg arrWordsHdrSize)
+   = do dflags <- getDynFlags
+        emitAssign (CmmLocal res) (cmmOffsetB arg (arrWordsHdrSize dflags))
 
 --  #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)
 emitPrimOp [res] StableNameToIntOp [arg]
-   = emitAssign (CmmLocal res) (cmmLoadIndexW arg fixedHdrSize bWord)
+   = do dflags <- getDynFlags
+        emitAssign (CmmLocal res) (cmmLoadIndexW arg (fixedHdrSize dflags) bWord)
 
 --  #define eqStableNamezh(r,sn1,sn2)                                  \
 --    (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
 emitPrimOp [res] EqStableNameOp [arg1,arg2]
-   = emitAssign (CmmLocal res) (CmmMachOp mo_wordEq [
-                               cmmLoadIndexW arg1 fixedHdrSize bWord,
-                               cmmLoadIndexW arg2 fixedHdrSize bWord
+   = do dflags <- getDynFlags
+        emitAssign (CmmLocal res) (CmmMachOp mo_wordEq [
+                                   cmmLoadIndexW arg1 (fixedHdrSize dflags) bWord,
+                                   cmmLoadIndexW arg2 (fixedHdrSize dflags) bWord
                          ])
 
 
@@ -295,7 +301,8 @@ emitPrimOp [res] AddrToAnyOp [arg]
 --  #define dataToTagzh(r,a)  r=(GET_TAG(((StgClosure *)a)->header.info))
 --  Note: argument may be tagged!
 emitPrimOp [res] DataToTagOp [arg]
-   = emitAssign (CmmLocal res) (getConstrTag (cmmUntag arg))
+   = do dflags <- getDynFlags
+        emitAssign (CmmLocal res) (getConstrTag dflags (cmmUntag arg))
 
 {- Freezing arrays-of-ptrs requires changing an info table, for the
    benefit of the generational collector.  It needs to scavenge mutable
@@ -358,7 +365,8 @@ emitPrimOp []  WriteArrayArrayOp_ArrayArray        [obj,ix,v] = doWritePtrArrayO
 emitPrimOp []  WriteArrayArrayOp_MutableArrayArray [obj,ix,v] = doWritePtrArrayOp obj ix v
 
 emitPrimOp [res] SizeofArrayOp [arg]
-   = emit $    mkAssign (CmmLocal res) (cmmLoadIndexW arg (fixedHdrSize + oFFSET_StgMutArrPtrs_ptrs) bWord)
+   = do dflags <- getDynFlags
+        emit $ mkAssign (CmmLocal res) (cmmLoadIndexW arg (fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs) bWord)
 emitPrimOp [res] SizeofMutableArrayOp [arg]
    = emitPrimOp [res] SizeofArrayOp [arg]
 emitPrimOp [res] SizeofArrayArrayOp [arg]
@@ -868,13 +876,15 @@ doIndexOffAddrOp _ _ _ _
 
 doIndexByteArrayOp :: Maybe MachOp -> CmmType -> [LocalReg] -> [CmmExpr] -> FCode ()
 doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]
-   = mkBasicIndexedRead arrWordsHdrSize maybe_post_read_cast rep res addr idx
+   = do dflags <- getDynFlags
+        mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx
 doIndexByteArrayOp _ _ _ _ 
    = panic "CgPrimOp: doIndexByteArrayOp"
 
 doReadPtrArrayOp ::  LocalReg -> CmmExpr -> CmmExpr -> FCode ()
 doReadPtrArrayOp res addr idx
-   = mkBasicIndexedRead arrPtrsHdrSize Nothing gcWord res addr idx
+   = do dflags <- getDynFlags
+        mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing gcWord res addr idx
 
 
 doWriteOffAddrOp :: Maybe MachOp -> [LocalReg] -> [CmmExpr] -> FCode ()
@@ -885,27 +895,29 @@ doWriteOffAddrOp _ _ _
 
 doWriteByteArrayOp :: Maybe MachOp -> [LocalReg] -> [CmmExpr] -> FCode ()
 doWriteByteArrayOp maybe_pre_write_cast [] [addr,idx,val]
-   = mkBasicIndexedWrite arrWordsHdrSize maybe_pre_write_cast addr idx val
+   = do dflags <- getDynFlags
+        mkBasicIndexedWrite (arrWordsHdrSize dflags) maybe_pre_write_cast addr idx val
 doWriteByteArrayOp _ _ _ 
    = panic "CgPrimOp: doWriteByteArrayOp"
 
 doWritePtrArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
 doWritePtrArrayOp addr idx val
-  = do mkBasicIndexedWrite arrPtrsHdrSize Nothing addr idx val
+  = do dflags <- getDynFlags
+       mkBasicIndexedWrite (arrPtrsHdrSize dflags) Nothing addr idx val
        emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
   -- the write barrier.  We must write a byte into the mark table:
   -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]
        emit $ mkStore (
          cmmOffsetExpr
-          (cmmOffsetExprW (cmmOffsetB addr arrPtrsHdrSize)
-                         (loadArrPtrsSize addr))
+          (cmmOffsetExprW (cmmOffsetB addr (arrPtrsHdrSize dflags))
+                         (loadArrPtrsSize dflags addr))
           (CmmMachOp mo_wordUShr [idx,
                                   CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)])
          ) (CmmLit (CmmInt 1 W8))
        
-loadArrPtrsSize :: CmmExpr -> CmmExpr
-loadArrPtrsSize addr = CmmLoad (cmmOffsetB addr off) bWord
- where off = fixedHdrSize*wORD_SIZE + oFFSET_StgMutArrPtrs_ptrs
+loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr
+loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB addr off) bWord
+ where off = fixedHdrSize dflags * wORD_SIZE + oFFSET_StgMutArrPtrs_ptrs
 
 mkBasicIndexedRead :: ByteOff -> Maybe MachOp -> CmmType
                   -> LocalReg -> CmmExpr -> CmmExpr -> FCode ()
@@ -976,8 +988,9 @@ emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
                   -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
                   -> FCode ()
 emitCopyByteArray copy src src_off dst dst_off n = do
-    dst_p <- assignTempE $ cmmOffsetExpr (cmmOffsetB dst arrWordsHdrSize) dst_off
-    src_p <- assignTempE $ cmmOffsetExpr (cmmOffsetB src arrWordsHdrSize) src_off
+    dflags <- getDynFlags
+    dst_p <- assignTempE $ cmmOffsetExpr (cmmOffsetB dst (arrWordsHdrSize dflags)) dst_off
+    src_p <- assignTempE $ cmmOffsetExpr (cmmOffsetB src (arrWordsHdrSize dflags)) src_off
     copy src dst dst_p src_p n
 
 -- ----------------------------------------------------------------------------
@@ -989,7 +1002,8 @@ emitCopyByteArray copy src src_off dst dst_off n = do
 doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
                  -> FCode ()
 doSetByteArrayOp ba off len c
-    = do p <- assignTempE $ cmmOffsetExpr (cmmOffsetB ba arrWordsHdrSize) off
+    = do dflags <- getDynFlags
+         p <- assignTempE $ cmmOffsetExpr (cmmOffsetB ba (arrWordsHdrSize dflags)) off
          emitMemsetCall p c len (CmmLit (mkIntCLit 1))
 
 -- ----------------------------------------------------------------------------
@@ -1046,6 +1060,7 @@ emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
               -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
               -> FCode ()
 emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 = do
+    dflags <- getDynFlags
     -- Passed as arguments (be careful)
     src     <- assignTempE src0
     src_off <- assignTempE src_off0
@@ -1056,15 +1071,15 @@ emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 = do
     -- Set the dirty bit in the header.
     emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
 
-    dst_elems_p <- assignTempE $ cmmOffsetB dst arrPtrsHdrSize
+    dst_elems_p <- assignTempE $ cmmOffsetB dst (arrPtrsHdrSize dflags)
     dst_p <- assignTempE $ cmmOffsetExprW dst_elems_p dst_off
-    src_p <- assignTempE $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize) src_off
+    src_p <- assignTempE $ cmmOffsetExprW (cmmOffsetB src (arrPtrsHdrSize dflags)) src_off
     bytes <- assignTempE $ cmmMulWord n (CmmLit (mkIntCLit wORD_SIZE))
 
     copy src dst dst_p src_p bytes
 
     -- The base address of the destination card table
-    dst_cards_p <- assignTempE $ cmmOffsetExprW dst_elems_p (loadArrPtrsSize dst)
+    dst_cards_p <- assignTempE $ cmmOffsetExprW dst_elems_p (loadArrPtrsSize dflags dst)
 
     emitSetCards dst_off dst_cards_p n
 
@@ -1084,22 +1099,23 @@ emitCloneArray info_p res_r src0 src_off0 n0 = do
                                 (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)))
                   `cmmAddWord` CmmLit (mkIntCLit 1)
     size <- assignTempE $ n `cmmAddWord` card_words
-    words <- assignTempE $ arrPtrsHdrSizeW `cmmAddWord` size
+    dflags <- getDynFlags
+    words <- assignTempE $ arrPtrsHdrSizeW dflags `cmmAddWord` size
 
     arr_r <- newTemp bWord
     emitAllocateCall arr_r myCapability words
-    tickyAllocPrim (CmmLit (mkIntCLit arrPtrsHdrSize)) (n `cmmMulWord` wordSize)
+    tickyAllocPrim (CmmLit (mkIntCLit (arrPtrsHdrSize dflags))) (n `cmmMulWord` wordSize)
         (CmmLit $ mkIntCLit 0)
 
     let arr = CmmReg (CmmLocal arr_r)
     emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCS
-    emit $ mkStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE +
+    emit $ mkStore (cmmOffsetB arr (fixedHdrSize dflags * wORD_SIZE +
                                     oFFSET_StgMutArrPtrs_ptrs)) n
-    emit $ mkStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE +
+    emit $ mkStore (cmmOffsetB arr (fixedHdrSize dflags * wORD_SIZE +
                                     oFFSET_StgMutArrPtrs_size)) size
 
-    dst_p <- assignTempE $ cmmOffsetB arr arrPtrsHdrSize
-    src_p <- assignTempE $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize)
+    dst_p <- assignTempE $ cmmOffsetB arr (arrPtrsHdrSize dflags)
+    src_p <- assignTempE $ cmmOffsetExprW (cmmOffsetB src (arrPtrsHdrSize dflags))
              src_off
 
     emitMemcpyCall dst_p src_p (n `cmmMulWord` wordSize) (CmmLit (mkIntCLit wORD_SIZE))
@@ -1110,8 +1126,8 @@ emitCloneArray info_p res_r src0 src_off0 n0 = do
         (CmmLit (mkIntCLit wORD_SIZE))
     emit $ mkAssign (CmmLocal res_r) arr
   where
-    arrPtrsHdrSizeW = CmmLit $ mkIntCLit $ fixedHdrSize +
-                      (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE)
+    arrPtrsHdrSizeW dflags = CmmLit $ mkIntCLit $ fixedHdrSize dflags +
+                                 (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE)
     wordSize = CmmLit (mkIntCLit wORD_SIZE)
     myCapability = CmmReg baseReg `cmmSubWord`
                    CmmLit (mkIntCLit oFFSET_Capability_r)
index 9ff4d0b..5031693 100644 (file)
@@ -51,7 +51,7 @@ import CLabel
 
 import qualified Module
 import CostCentre
-import StaticFlags
+import DynFlags
 import FastString
 import Module
 import Constants        -- Lots of field offsets
@@ -89,15 +89,15 @@ costCentreFrom :: CmmExpr   -- A closure pointer
               -> CmmExpr       -- The cost centre from that closure
 costCentreFrom cl = CmmLoad (cmmOffsetB cl oFFSET_StgHeader_ccs) ccsType
 
-staticProfHdr :: CostCentreStack -> [CmmLit]
+staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit]
 -- The profiling header words in a static closure
 -- Was SET_STATIC_PROF_HDR
-staticProfHdr ccs = ifProfilingL [mkCCostCentreStack ccs, 
                                staticLdvInit]
+staticProfHdr dflags ccs
= ifProfilingL dflags [mkCCostCentreStack ccs, staticLdvInit]
 
-dynProfHdr :: CmmExpr -> [CmmExpr]
+dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr]
 -- Profiling header words in a dynamic closure
-dynProfHdr ccs = ifProfilingL [ccs, dynLdvInit]
+dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit]
 
 initUpdFrameProf :: CmmExpr -> FCode ()
 -- Initialise the profiling field of an update frame
@@ -139,12 +139,12 @@ We want this kind of code:
 saveCurrentCostCentre :: FCode (Maybe LocalReg)
        -- Returns Nothing if profiling is off
 saveCurrentCostCentre
-  | not opt_SccProfilingOn 
-  = return Nothing
-  | otherwise
-  = do { local_cc <- newTemp ccType
-        ; emitAssign (CmmLocal local_cc) curCCS
-       ; return (Just local_cc) }
+  = do dflags <- getDynFlags
+       if not (dopt Opt_SccProfilingOn dflags)
+           then return Nothing
+           else do local_cc <- newTemp ccType
+                   emitAssign (CmmLocal local_cc) curCCS
+                   return (Just local_cc)
 
 restoreCurrentCostCentre :: Maybe LocalReg -> FCode ()
 restoreCurrentCostCentre Nothing 
@@ -162,7 +162,8 @@ restoreCurrentCostCentre (Just local_cc)
 profDynAlloc :: SMRep -> CmmExpr -> FCode ()
 profDynAlloc rep ccs
   = ifProfiling $
-    profAlloc (CmmLit (mkIntCLit (heapClosureSize rep))) ccs
+    do dflags <- getDynFlags
+       profAlloc (CmmLit (mkIntCLit (heapClosureSize dflags rep))) ccs
 
 -- | Record the allocation of a closure (size is given by a CmmExpr)
 -- The size must be in words, because the allocation counter in a CCS counts
@@ -170,15 +171,16 @@ profDynAlloc rep ccs
 profAlloc :: CmmExpr -> CmmExpr -> FCode ()
 profAlloc words ccs
   = ifProfiling $
-    emit (addToMemE alloc_rep
-               (cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc)
-               (CmmMachOp (MO_UU_Conv wordWidth (typeWidth alloc_rep)) $
-                 [CmmMachOp mo_wordSub [words, 
-                                        CmmLit (mkIntCLit profHdrSize)]]))
-               -- subtract the "profiling overhead", which is the
-               -- profiling header in a closure.
+        do dflags <- getDynFlags
+           emit (addToMemE alloc_rep
+                       (cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc)
+                       (CmmMachOp (MO_UU_Conv wordWidth (typeWidth alloc_rep)) $
+                         [CmmMachOp mo_wordSub [words, 
+                                                CmmLit (mkIntCLit (profHdrSize dflags))]]))
+                       -- subtract the "profiling overhead", which is the
+                       -- profiling header in a closure.
  where 
-       alloc_rep =  REP_CostCentreStack_mem_alloc
+        alloc_rep =  REP_CostCentreStack_mem_alloc
 
 -- -----------------------------------------------------------------------
 -- Setting the current cost centre on entry to a closure
@@ -190,13 +192,15 @@ enterCostCentreThunk closure =
 
 ifProfiling :: FCode () -> FCode ()
 ifProfiling code
-  | opt_SccProfilingOn = code
-  | otherwise         = nopC
+  = do dflags <- getDynFlags
+       if dopt Opt_SccProfilingOn dflags
+           then code
+           else nopC
 
-ifProfilingL :: [a] -> [a]
-ifProfilingL xs
-  | opt_SccProfilingOn = xs
-  | otherwise         = []
+ifProfilingL :: DynFlags -> [a] -> [a]
+ifProfilingL dflags xs
+  | dopt Opt_SccProfilingOn dflags = xs
+  | otherwise                      = []
 
 
 ---------------------------------------------------------------
@@ -206,9 +210,10 @@ ifProfilingL xs
 initCostCentres :: CollectedCCs -> FCode ()
 -- Emit the declarations
 initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
-  = whenC opt_SccProfilingOn $
-    do { mapM_ emitCostCentreDecl local_CCs
-        ; mapM_ emitCostCentreStackDecl  singleton_CCSs  }
+  = do dflags <- getDynFlags
+       whenC (dopt Opt_SccProfilingOn dflags) $
+           do mapM_ emitCostCentreDecl local_CCs
+              mapM_ emitCostCentreStackDecl singleton_CCSs
 
 
 emitCostCentreDecl :: CostCentre -> FCode ()
@@ -272,12 +277,13 @@ sizeof_ccs_words
 
 emitSetCCC :: CostCentre -> Bool -> Bool -> FCode ()
 emitSetCCC cc tick push
-  | not opt_SccProfilingOn = nopC
-  | otherwise = do 
-    tmp <- newTemp ccsType -- TODO FIXME NOW
-    pushCostCentre tmp curCCS cc
-    when tick $ emit (bumpSccCount (CmmReg (CmmLocal tmp)))
-    when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp)))
+ = do dflags <- getDynFlags
+      if not (dopt Opt_SccProfilingOn dflags)
+          then nopC
+          else do tmp <- newTemp ccsType -- TODO FIXME NOW
+                  pushCostCentre tmp curCCS cc
+                  when tick $ emit (bumpSccCount (CmmReg (CmmLocal tmp)))
+                  when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp)))
 
 pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()
 pushCostCentre result ccs cc
index 698bf32..ec8f674 100644 (file)
@@ -285,7 +285,7 @@ tickyDynAlloc rep lf
         | otherwise      -> return ()
   where
         -- will be needed when we fill in stubs
-    _cl_size   = heapClosureSize rep
+--    _cl_size   = heapClosureSize rep
 --    _slop_size = slopSize cl_info
 
     tick_alloc_thk 
index ff3cfc5..4e04a29 100644 (file)
@@ -254,6 +254,8 @@ addTickLHsBind (L pos bind@(AbsBinds { abs_binds   = binds,
 
 
 addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do
+  env <- getEnv
+  let dflags = tte_dflags env
   let name = getOccString id
   decl_path <- getPathEntry
   density <- getDensity
@@ -263,7 +265,7 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do
                  || id `elemVarSet` inline_ids
 
   -- See Note [inline sccs]
-  if inline && opt_SccProfilingOn then return (L pos funBind) else do
+  if inline && dopt Opt_SccProfilingOn dflags then return (L pos funBind) else do
 
   (fvs, (MatchGroup matches' ty)) <-
         getFreeVars $
@@ -1054,12 +1056,14 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path =
 
         cc = mkUserCC (mkFastString cc_name) (this_mod env) pos (mkCostCentreUnique c)
 
-        count = countEntries && dopt Opt_ProfCountEntries (tte_dflags env)
+        dflags = tte_dflags env
+
+        count = countEntries && dopt Opt_ProfCountEntries dflags
 
         tickish
-          | opt_Hpc            = HpcTick (this_mod env) c
-          | opt_SccProfilingOn = ProfNote cc count True{-scopes-}
-          | otherwise          = Breakpoint c ids
+          | opt_Hpc                        = HpcTick (this_mod env) c
+          | dopt Opt_SccProfilingOn dflags = ProfNote cc count True{-scopes-}
+          | otherwise                      = Breakpoint c ids
     in
     ( tickish
     , fvs
index ae9b0ec..8e72e1c 100644 (file)
@@ -112,7 +112,7 @@ deSugar hsc_env
 
                      let want_ticks = opt_Hpc
                                    || target == HscInterpreted
-                                   || (opt_SccProfilingOn
+                                   || (dopt Opt_SccProfilingOn dflags
                                        && case profAuto dflags of
                                             NoProfAuto -> False
                                             _          -> True)
index 5e5a5f0..73724c0 100644 (file)
@@ -121,7 +121,7 @@ instance Outputable UnlinkedBCO where
 -- Top level assembler fn.
 assembleBCOs :: DynFlags -> [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode
 assembleBCOs dflags proto_bcos tycons
-  = do  itblenv <- mkITbls tycons
+  = do  itblenv <- mkITbls dflags tycons
         bcos    <- mapM (assembleBCO dflags) proto_bcos
         return (ByteCode bcos itblenv)
 
index a19d2ec..b277a1e 100644 (file)
@@ -84,8 +84,8 @@ byteCodeGen dflags this_mod binds tycs modBreaks
                         | (bndr, rhs) <- flattenBinds binds]
 
         us <- mkSplitUniqSupply 'y'
-        (BcM_State _us _this_mod _final_ctr mallocd _, proto_bcos)
-           <- runBc us this_mod modBreaks (mapM schemeTopBind flatBinds)
+        (BcM_State _dflags _us _this_mod _final_ctr mallocd _, proto_bcos)
+           <- runBc dflags us this_mod modBreaks (mapM schemeTopBind flatBinds)
 
         when (notNull mallocd)
              (panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
@@ -115,8 +115,8 @@ coreExprToBCOs dflags this_mod expr
       -- the uniques are needed to generate fresh variables when we introduce new
       -- let bindings for ticked expressions
       us <- mkSplitUniqSupply 'y'
-      (BcM_State _us _this_mod _final_ctr mallocd _ , proto_bco)
-         <- runBc us this_mod emptyModBreaks $
+      (BcM_State _dflags _us _this_mod _final_ctr mallocd _ , proto_bco)
+         <- runBc dflags us this_mod emptyModBreaks $
               schemeTopBind (invented_id, freeVars expr)
 
       when (notNull mallocd)
@@ -942,13 +942,15 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
                     -- contains.
                     Just t
                      | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
-                       -> do rest <- pargs (d + fromIntegral addr_sizeW) az
-                             code <- parg_ArrayishRep (fromIntegral arrPtrsHdrSize) d p a
+                       -> do dflags <- getDynFlags
+                             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 rest <- pargs (d + fromIntegral addr_sizeW) az
-                             code <- parg_ArrayishRep (fromIntegral arrWordsHdrSize) d p a
+                       -> do dflags <- getDynFlags
+                             rest <- pargs (d + fromIntegral addr_sizeW) az
+                             code <- parg_ArrayishRep (fromIntegral (arrWordsHdrSize dflags)) d p a
                              return ((code,AddrRep):rest)
 
                     -- Default case: push taggedly, but otherwise intact.
@@ -1526,7 +1528,8 @@ type BcPtr = Either ItblPtr (Ptr ())
 
 data BcM_State
    = BcM_State
-        { uniqSupply :: UniqSupply       -- for generating fresh variable names
+        { bcm_dflags :: DynFlags
+        , uniqSupply :: UniqSupply       -- for generating fresh variable names
         , thisModule :: Module           -- current module (for breakpoints)
         , nextlabel :: Word16            -- for generating local labels
         , malloced  :: [BcPtr]           -- thunks malloced for current BCO
@@ -1541,9 +1544,10 @@ ioToBc io = BcM $ \st -> do
   x <- io
   return (st, x)
 
-runBc :: UniqSupply -> Module -> ModBreaks -> BcM r -> IO (BcM_State, r)
-runBc us this_mod modBreaks (BcM m)
-   = m (BcM_State us this_mod 0 [] breakArray)
+runBc :: DynFlags -> UniqSupply -> Module -> ModBreaks -> BcM r
+      -> IO (BcM_State, r)
+runBc dflags us this_mod modBreaks (BcM m)
+   = m (BcM_State dflags us this_mod 0 [] breakArray)
    where
    breakArray = modBreaks_flags modBreaks
 
@@ -1568,6 +1572,9 @@ instance Monad BcM where
   (>>)  = thenBc_
   return = returnBc
 
+instance HasDynFlags BcM where
+    getDynFlags = BcM $ \st -> return (st, bcm_dflags st)
+
 emitBc :: ([BcPtr] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
 emitBc bco
   = BcM $ \st -> return (st{malloced=[]}, bco (malloced st))
index 7378141..9b22ec8 100644 (file)
@@ -20,6 +20,7 @@ module ByteCodeItbls ( ItblEnv, ItblPtr(..), itblCode, mkITbls
 
 #include "HsVersions.h"
 
+import DynFlags
 import Name             ( Name, getName )
 import NameEnv
 import ClosureInfo
@@ -66,31 +67,31 @@ mkItblEnv pairs = mkNameEnv [(n, (n,p)) | (n,p) <- pairs]
 
 
 -- Make info tables for the data decls in this module
-mkITbls :: [TyCon] -> IO ItblEnv
-mkITbls [] = return emptyNameEnv
-mkITbls (tc:tcs) = do itbls  <- mkITbl tc
-                      itbls2 <- mkITbls tcs
-                      return (itbls `plusNameEnv` itbls2)
-
-mkITbl :: TyCon -> IO ItblEnv
-mkITbl tc
+mkITbls :: DynFlags -> [TyCon] -> IO ItblEnv
+mkITbls [] = return emptyNameEnv
+mkITbls dflags (tc:tcs) = do itbls  <- mkITbl dflags tc
+                             itbls2 <- mkITbls dflags tcs
+                             return (itbls `plusNameEnv` itbls2)
+
+mkITbl :: DynFlags -> TyCon -> IO ItblEnv
+mkITbl dflags tc
    | not (isDataTyCon tc) 
    = return emptyNameEnv
    | dcs `lengthIs` n -- paranoia; this is an assertion.
-   = make_constr_itbls dcs
+   = make_constr_itbls dflags dcs
      where
         dcs = tyConDataCons tc
         n   = tyConFamilySize tc
 
-mkITbl _ = error "Unmatched patter in mkITbl: assertion failed!"
+mkITbl _ = error "Unmatched patter in mkITbl: assertion failed!"
 
 #include "../includes/rts/storage/ClosureTypes.h"
 cONSTR :: Int   -- Defined in ClosureTypes.h
 cONSTR = CONSTR 
 
 -- Assumes constructors are numbered from zero, not one
-make_constr_itbls :: [DataCon] -> IO ItblEnv
-make_constr_itbls cons
+make_constr_itbls :: DynFlags -> [DataCon] -> IO ItblEnv
+make_constr_itbls dflags cons
    = do is <- mapM mk_dirret_itbl (zip cons [0..])
         return (mkItblEnv is)
      where
@@ -100,7 +101,7 @@ make_constr_itbls cons
         mk_itbl :: DataCon -> Int -> Ptr () -> IO (Name,ItblPtr)
         mk_itbl dcon conNo entry_addr = do
            let rep_args = [ (typeCgRep rep_arg,rep_arg) | arg <- dataConRepArgTys dcon, rep_arg <- flattenRepType (repType arg) ]
-               (tot_wds, ptr_wds, _) = mkVirtHeapOffsets False{-not a THUNK-} rep_args
+               (tot_wds, ptr_wds, _) = mkVirtHeapOffsets dflags False{-not a THUNK-} rep_args
 
                ptrs'  = ptr_wds
                nptrs' = tot_wds - ptr_wds
index 331c294..19a3cbb 100644 (file)
@@ -36,9 +36,10 @@ import Data.List
 --
 dataConInfoPtrToName :: Ptr () -> TcM (Either String Name)
 dataConInfoPtrToName x = do 
+   dflags <- getDynFlags
    theString <- liftIO $ do
       let ptr = castPtr x :: Ptr StgInfoTable
-      conDescAddress <- getConDescAddress ptr 
+      conDescAddress <- getConDescAddress dflags ptr
       peekArray0 0 conDescAddress  
    let (pkg, mod, occ) = parse theString 
        pkgFS = mkFastStringByteList pkg
@@ -46,7 +47,6 @@ dataConInfoPtrToName x = do
        occFS = mkFastStringByteList occ
        occName = mkOccNameFS OccName.dataName occFS
        modName = mkModule (fsToPackageId pkgFS) (mkModuleNameFS modFS) 
-   dflags <- getDynFlags
    return (Left $ showSDoc dflags $ ppr modName <> dot <> ppr occName)
     `recoverM` (Right `fmap` lookupOrig modName occName)
 
@@ -92,14 +92,13 @@ dataConInfoPtrToName x = do
          in the memory location: info_table_ptr + info_table_size
    -}
 
-   getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8)
-   getConDescAddress ptr
+   getConDescAddress :: DynFlags -> Ptr StgInfoTable -> IO (Ptr Word8)
+   getConDescAddress dflags ptr
     | ghciTablesNextToCode = do
        offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE)
-       return $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: StgWord))
+       return $ (ptr `plusPtr` stdInfoTableSizeB dflags) `plusPtr` (fromIntegral (offsetToString :: StgWord))
     | otherwise =
-       peek $ intPtrToPtr $ (ptrToIntPtr ptr) + fromIntegral stdInfoTableSizeB
-
+       peek $ intPtrToPtr $ ptrToIntPtr ptr + fromIntegral (stdInfoTableSizeB dflags)
    -- parsing names is a little bit fiddly because we have a string in the form: 
    -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo").
    -- Thus we split at the leftmost colon and the rightmost occurrence of the dot.
index b9e3794..e568d55 100644 (file)
@@ -14,7 +14,6 @@ import Module
 import Name
 import Fingerprint
 -- import Outputable
-import StaticFlags
 
 import qualified Data.IntSet as IntSet
 import System.FilePath (normalise)
@@ -44,7 +43,7 @@ fingerprintDynFlags dflags@DynFlags{..} this_mod nameio =
         paths = [ hcSuf ]
 
         -- -fprof-auto etc.
-        prof = if opt_SccProfilingOn then fromEnum profAuto else 0
+        prof = if dopt Opt_SccProfilingOn dflags then fromEnum profAuto else 0
 
     in -- pprTrace "flags" (ppr (mainis, safeHs, lang, cpp, paths)) $
        computeFingerprint nameio (mainis, safeHs, lang, cpp, paths, prof)
index b75f743..6300cf3 100644 (file)
@@ -321,6 +321,7 @@ data DynFlag
    | Opt_Parallel
    | Opt_GranMacros
    | Opt_PIC
+   | Opt_SccProfilingOn
 
    -- output style opts
    | Opt_PprCaseAsLet
@@ -2047,6 +2048,7 @@ fFlags = [
   ( "helpful-errors",                   Opt_HelpfulErrors, nop ),
   ( "defer-type-errors",                Opt_DeferTypeErrors, nop ),
   ( "parallel",                         Opt_Parallel, nop ),
+  ( "scc-profiling",                    Opt_SccProfilingOn, nop ),
   ( "gransim",                          Opt_GranMacros, nop ),
   ( "building-cabal-package",           Opt_BuildingCabalPackage, nop ),
   ( "implicit-import-qualified",        Opt_ImplicitImportQualified, nop ),
index 215a654..9474ca2 100644 (file)
@@ -1249,7 +1249,6 @@ hscGenHardCode cgguts mod_summary = do
                     cg_dep_pkgs = dependencies,
                     cg_hpc_info = hpc_info } = cgguts
             dflags = hsc_dflags hsc_env
-            platform = targetPlatform dflags
             location = ms_location mod_summary
             data_tycons = filter isDataTyCon tycons
             -- cg_tycons includes newtypes, for the benefit of External Core,
@@ -1283,7 +1282,7 @@ hscGenHardCode cgguts mod_summary = do
 
         ------------------  Code output -----------------------
         rawcmms0 <- {-# SCC "cmmToRawCmm" #-}
-                   cmmToRawCmm platform cmms
+                   cmmToRawCmm dflags cmms
 
         let dump a = do dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm"
                            (ppr a)
@@ -1342,7 +1341,7 @@ hscCompileCmmFile hsc_env filename = runHsc hsc_env $ do
     let dflags = hsc_dflags hsc_env
     cmm <- ioMsgMaybe $ parseCmmFile dflags filename
     liftIO $ do
-        rawCmms <- cmmToRawCmm (targetPlatform dflags) (Stream.yield cmm)
+        rawCmms <- cmmToRawCmm dflags (Stream.yield cmm)
         _ <- codeOutput dflags no_mod no_loc NoStubs [] rawCmms
         return ()
   where
index 2ef2914..ddb4026 100644 (file)
@@ -170,7 +170,6 @@ flagsStatic = [
 isStaticFlag :: String -> Bool
 isStaticFlag f =
   f `elem` [
-    "fscc-profiling",
     "fdicts-strict",
     "fspec-inline-join-points",
     "fno-hi-version-check",
index 3d33565..79faf1e 100644 (file)
@@ -40,9 +40,6 @@ module StaticFlags (
        opt_SuppressTypeSignatures,
         opt_SuppressVarKinds,
 
-       -- profiling opts
-       opt_SccProfilingOn,
-
         -- Hpc opts
        opt_Hpc,
 
@@ -250,10 +247,6 @@ opt_Fuel                        = lookup_def_int "-dopt-fuel" maxBound
 opt_NoDebugOutput   :: Bool
 opt_NoDebugOutput               = lookUp  (fsLit "-dno-debug-output")
 
--- profiling opts
-opt_SccProfilingOn :: Bool
-opt_SccProfilingOn             = lookUp  (fsLit "-fscc-profiling")
-
 -- Hpc opts
 opt_Hpc :: Bool
 opt_Hpc                                = lookUp (fsLit "-fhpc")
index 142f467..7c314ae 100644 (file)
@@ -139,7 +139,7 @@ data NcgImpl statics instr jumpDest = NcgImpl {
     canShortcut               :: instr -> Maybe jumpDest,
     shortcutStatics           :: (BlockId -> Maybe jumpDest) -> statics -> statics,
     shortcutJump              :: (BlockId -> Maybe jumpDest) -> instr -> instr,
-    pprNatCmmDecl              :: Platform -> NatCmmDecl statics instr -> SDoc,
+    pprNatCmmDecl             :: NatCmmDecl statics instr -> SDoc,
     maxSpillSlots             :: Int,
     allocatableRegs           :: [RealReg],
     ncg_x86fp_kludge          :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
@@ -228,7 +228,7 @@ nativeCodeGen' dflags ncgImpl h us cmms
         -- dump native code
         dumpIfSet_dyn dflags
                 Opt_D_dump_asm "Asm code"
-                (vcat $ map (pprNatCmmDecl ncgImpl platform) $ concat native)
+                (vcat $ map (pprNatCmmDecl ncgImpl) $ concat native)
 
         -- dump global NCG stats for graph coloring allocator
         (case concat $ catMaybes colorStats of
@@ -325,14 +325,12 @@ cmmNativeGens _ _ _ us [] impAcc profAcc _
 
 cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count
  = do
-        let platform = targetPlatform dflags
-
         (us', native, imports, colorStats, linearStats)
                 <- {-# SCC "cmmNativeGen" #-} cmmNativeGen dflags ncgImpl us cmm count
 
         {-# SCC "pprNativeCode" #-} Pretty.bufLeftRender h
                 $ withPprStyleDoc dflags (mkCodeStyle AsmStyle)
-                $ vcat $ map (pprNatCmmDecl ncgImpl platform) native
+                $ vcat $ map (pprNatCmmDecl ncgImpl) native
 
            -- carefully evaluate this strictly.  Binding it with 'let'
            -- and then using 'seq' doesn't work, because the let
@@ -399,7 +397,7 @@ cmmNativeGen dflags ncgImpl us cmm count
 
         dumpIfSet_dyn dflags
                 Opt_D_dump_asm_native "Native code"
-                (vcat $ map (pprNatCmmDecl ncgImpl platform) native)
+                (vcat $ map (pprNatCmmDecl ncgImpl) native)
 
         -- tag instructions with register liveness information
         let (withLiveness, usLive) =
@@ -437,7 +435,7 @@ cmmNativeGen dflags ncgImpl us cmm count
                 -- dump out what happened during register allocation
                 dumpIfSet_dyn dflags
                         Opt_D_dump_asm_regalloc "Registers allocated"
-                        (vcat $ map (pprNatCmmDecl ncgImpl platform) alloced)
+                        (vcat $ map (pprNatCmmDecl ncgImpl) alloced)
 
                 dumpIfSet_dyn dflags
                         Opt_D_dump_asm_regalloc_stages "Build/spill stages"
@@ -468,7 +466,7 @@ cmmNativeGen dflags ncgImpl us cmm count
 
                 dumpIfSet_dyn dflags
                         Opt_D_dump_asm_regalloc "Registers allocated"
-                        (vcat $ map (pprNatCmmDecl ncgImpl platform) alloced)
+                        (vcat $ map (pprNatCmmDecl ncgImpl) alloced)
 
                 let mPprStats =
                         if dopt Opt_D_dump_asm_stats dflags
@@ -512,7 +510,7 @@ cmmNativeGen dflags ncgImpl us cmm count
 
         dumpIfSet_dyn dflags
                 Opt_D_dump_asm_expanded "Synthetic instructions expanded"
-                (vcat $ map (pprNatCmmDecl ncgImpl platform) expanded)
+                (vcat $ map (pprNatCmmDecl ncgImpl) expanded)
 
         return  ( usAlloc
                 , expanded
index ea69791..1b49a49 100644 (file)
@@ -46,30 +46,31 @@ import Data.Bits
 -- -----------------------------------------------------------------------------
 -- Printing this stuff out
 
-pprNatCmmDecl :: Platform -> NatCmmDecl CmmStatics Instr -> SDoc
-pprNatCmmDecl platform (CmmData section dats) =
-  pprSectionHeader platform section $$ pprDatas platform dats
+pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc
+pprNatCmmDecl (CmmData section dats) =
+  pprSectionHeader section $$ pprDatas dats
 
  -- special case for split markers:
-pprNatCmmDecl platform (CmmProc Nothing lbl (ListGraph []))
-    = pprLabel platform lbl
+pprNatCmmDecl (CmmProc Nothing lbl (ListGraph []))
+    = pprLabel lbl
 
  -- special case for code without an info table:
-pprNatCmmDecl platform (CmmProc Nothing lbl (ListGraph blocks)) =
-  pprSectionHeader platform Text $$
-  pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed
-  vcat (map (pprBasicBlock platform) blocks)
-
-pprNatCmmDecl platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blocks)) =
-  pprSectionHeader platform Text $$
+pprNatCmmDecl (CmmProc Nothing lbl (ListGraph blocks)) =
+  pprSectionHeader Text $$
+  pprLabel lbl $$ -- blocks guaranteed not null, so label needed
+  vcat (map pprBasicBlock blocks)
+
+pprNatCmmDecl (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blocks)) =
+  sdocWithPlatform $ \platform ->
+  pprSectionHeader Text $$
   (
        (if platformHasSubsectionsViaSymbols platform
         then ppr (mkDeadStripPreventer info_lbl) <> char ':'
         else empty) $$
-       vcat (map (pprData platform) info) $$
-       pprLabel platform info_lbl
+       vcat (map pprData info) $$
+       pprLabel info_lbl
   ) $$
-  vcat (map (pprBasicBlock platform) blocks) $$
+  vcat (map pprBasicBlock blocks) $$
      -- above: Even the first block gets a label, because with branch-chain
      -- elimination, it might be the target of a goto.
         (if platformHasSubsectionsViaSymbols platform
@@ -87,41 +88,42 @@ pprNatCmmDecl platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListG
          else empty)
 
 
-pprBasicBlock :: Platform -> NatBasicBlock Instr -> SDoc
-pprBasicBlock platform (BasicBlock blockid instrs) =
-  pprLabel platform (mkAsmTempLabel (getUnique blockid)) $$
-  vcat (map (pprInstr platform) instrs)
+pprBasicBlock :: NatBasicBlock Instr -> SDoc
+pprBasicBlock (BasicBlock blockid instrs) =
+  pprLabel (mkAsmTempLabel (getUnique blockid)) $$
+  vcat (map pprInstr instrs)
 
 
 
-pprDatas :: Platform -> CmmStatics -> SDoc
-pprDatas platform (Statics lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats)
+pprDatas :: CmmStatics -> SDoc
+pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats)
 
-pprData :: Platform -> CmmStatic -> SDoc
-pprData _ (CmmString str)          = pprASCII str
-pprData platform (CmmUninitialised bytes) = ptext (sLit keyword) <> int bytes
-    where keyword = case platformOS platform of
-                    OSDarwin -> ".space "
-                    _        -> ".skip "
-pprData platform (CmmStaticLit lit)       = pprDataItem platform lit
+pprData :: CmmStatic -> SDoc
+pprData (CmmString str)          = pprASCII str
+pprData (CmmUninitialised bytes) = keyword <> int bytes
+    where keyword = sdocWithPlatform $ \platform ->
+                    case platformOS platform of
+                    OSDarwin -> ptext (sLit ".space ")
+                    _        -> ptext (sLit ".skip ")
+pprData (CmmStaticLit lit)       = pprDataItem lit
 
 pprGloblDecl :: CLabel -> SDoc
 pprGloblDecl lbl
   | not (externallyVisibleCLabel lbl) = empty
   | otherwise = ptext (sLit ".globl ") <> ppr lbl
 
-pprTypeAndSizeDecl :: Platform -> CLabel -> SDoc
-pprTypeAndSizeDecl platform lbl
-  | platformOS platform == OSLinux && externallyVisibleCLabel lbl
-    = ptext (sLit ".type ") <>
-      ppr lbl <> ptext (sLit ", @object")
-pprTypeAndSizeDecl _ _
-  = empty
+pprTypeAndSizeDecl :: CLabel -> SDoc
+pprTypeAndSizeDecl lbl
+  = sdocWithPlatform $ \platform ->
+    if platformOS platform == OSLinux && externallyVisibleCLabel lbl
+    then ptext (sLit ".type ") <>
+         ppr lbl <> ptext (sLit ", @object")
+    else empty
 
-pprLabel :: Platform -> CLabel -> SDoc
-pprLabel platform lbl = pprGloblDecl lbl
-                     $$ pprTypeAndSizeDecl platform lbl
-                     $$ (ppr lbl <> char ':')
+pprLabel :: CLabel -> SDoc
+pprLabel lbl = pprGloblDecl lbl
+            $$ pprTypeAndSizeDecl lbl
+            $$ (ppr lbl <> char ':')
 
 
 pprASCII :: [Word8] -> SDoc
@@ -136,12 +138,12 @@ pprASCII str
 -- pprInstr: print an 'Instr'
 
 instance Outputable Instr where
-    ppr instr = sdocWithPlatform $ \platform -> pprInstr platform instr
+    ppr instr = pprInstr instr
 
 
-pprReg :: Platform -> Reg -> SDoc
+pprReg :: Reg -> SDoc
 
-pprReg platform r
+pprReg r
   = case r of
       RegReal    (RealRegSingle i) -> ppr_reg_no i
       RegReal    (RealRegPair{})   -> panic "PPC.pprReg: no reg pairs on this arch"
@@ -153,6 +155,7 @@ pprReg platform r
   where
     ppr_reg_no :: Int -> SDoc
     ppr_reg_no i =
+        sdocWithPlatform $ \platform ->
         case platformOS platform of
         OSDarwin ->
             ptext
@@ -220,49 +223,54 @@ pprCond c
                 GU      -> sLit "gt";  LEU   -> sLit "le"; })
 
 
-pprImm :: Platform -> Imm -> SDoc
+pprImm :: Imm -> SDoc
 
-pprImm _        (ImmInt i)     = int i
-pprImm _        (ImmInteger i) = integer i
-pprImm _        (ImmCLbl l)    = ppr l
-pprImm _        (ImmIndex l i) = ppr l <> char '+' <> int i
-pprImm _        (ImmLit s)     = s
+pprImm (ImmInt i)     = int i
+pprImm (ImmInteger i) = integer i
+pprImm (ImmCLbl l)    = ppr l
+pprImm (ImmIndex l i) = ppr l <> char '+' <> int i
+pprImm (ImmLit s)     = s
 
-pprImm _        (ImmFloat _)  = ptext (sLit "naughty float immediate")
-pprImm _        (ImmDouble _) = ptext (sLit "naughty double immediate")
+pprImm (ImmFloat _)  = ptext (sLit "naughty float immediate")
+pprImm (ImmDouble _) = ptext (sLit "naughty double immediate")
 
-pprImm platform (ImmConstantSum a b) = pprImm platform a <> char '+' <> pprImm platform b
-pprImm platform (ImmConstantDiff a b) = pprImm platform a <> char '-'
-                            <> lparen <> pprImm platform b <> rparen
+pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b
+pprImm (ImmConstantDiff a b) = pprImm a <> char '-'
+                   <> lparen <> pprImm b <> rparen
 
-pprImm platform (LO i)
-  = if platformOS platform == OSDarwin
-    then hcat [ text "lo16(", pprImm platform i, rparen ]
-    else pprImm platform i <> text "@l"
+pprImm (LO i)
+  = sdocWithPlatform $ \platform ->
+    if platformOS platform == OSDarwin
+    then hcat [ text "lo16(", pprImm i, rparen ]
+    else pprImm i <> text "@l"
 
-pprImm platform (HI i)
-  = if platformOS platform == OSDarwin
-    then hcat [ text "hi16(", pprImm platform i, rparen ]
-    else pprImm platform i <> text "@h"
+pprImm (HI i)
+  = sdocWithPlatform $ \platform ->
+    if platformOS platform == OSDarwin
+    then hcat [ text "hi16(", pprImm i, rparen ]
+    else pprImm i <> text "@h"
 
-pprImm platform (HA i)
-  = if platformOS platform == OSDarwin
-    then hcat [ text "ha16(", pprImm platform i, rparen ]
-    else pprImm platform i <> text "@ha"
+pprImm (HA i)
+  = sdocWithPlatform $ \platform ->
+    if platformOS platform == OSDarwin
+    then hcat [ text "ha16(", pprImm i, rparen ]
+    else pprImm i <> text "@ha"
 
 
-pprAddr :: Platform -> AddrMode -> SDoc
-pprAddr platform (AddrRegReg r1 r2)
-  = pprReg platform r1 <+> ptext (sLit ", ") <+> pprReg platform r2
+pprAddr :: AddrMode -> SDoc
+pprAddr (AddrRegReg r1 r2)
+  = pprReg r1 <+> ptext (sLit ", ") <+> pprReg r2
 
-pprAddr platform (AddrRegImm r1 (ImmInt i)) = hcat [ int i, char '(', pprReg platform r1, char ')' ]
-pprAddr platform (AddrRegImm r1 (ImmInteger i)) = hcat [ integer i, char '(', pprReg platform r1, char ')' ]
-pprAddr platform (AddrRegImm r1 imm) = hcat [ pprImm platform imm, char '(', pprReg platform r1, char ')' ]
+pprAddr (AddrRegImm r1 (ImmInt i)) = hcat [ int i, char '(', pprReg r1, char ')' ]
+pprAddr (AddrRegImm r1 (ImmInteger i)) = hcat [ integer i, char '(', pprReg r1, char ')' ]
+pprAddr (AddrRegImm r1 imm) = hcat [ pprImm imm, char '(', pprReg r1, char ')' ]
 
 
-pprSectionHeader :: Platform -> Section -> SDoc
-pprSectionHeader platform seg
- = case seg of
+pprSectionHeader :: Section -> SDoc
+pprSectionHeader seg
+ = sdocWithPlatform $ \platform ->
+   let osDarwin = platformOS platform == OSDarwin
+   in   case seg of
         Text                    -> ptext (sLit ".text\n.align 2")
         Data                    -> ptext (sLit ".data\n.align 2")
         ReadOnlyData
@@ -279,28 +287,27 @@ pprSectionHeader platform seg
          | otherwise            -> ptext (sLit ".section .rodata\n\t.align 4")
         OtherSection _          ->
             panic "PprMach.pprSectionHeader: unknown section"
-    where osDarwin = platformOS platform == OSDarwin
 
 
-pprDataItem :: Platform -> CmmLit -> SDoc
-pprDataItem platform lit
+pprDataItem :: CmmLit -> SDoc
+pprDataItem lit
   = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit)
     where
         imm = litToImm lit
 
-        ppr_item II8   _ = [ptext (sLit "\t.byte\t") <> pprImm platform imm]
+        ppr_item II8   _ = [ptext (sLit "\t.byte\t") <> pprImm imm]
 
-        ppr_item II32  _ = [ptext (sLit "\t.long\t") <> pprImm platform imm]
+        ppr_item II32  _ = [ptext (sLit "\t.long\t") <> pprImm imm]
 
         ppr_item FF32 (CmmFloat r _)
            = let bs = floatToBytes (fromRational r)
-             in  map (\b -> ptext (sLit "\t.byte\t") <> pprImm platform (ImmInt b)) bs
+             in  map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
 
         ppr_item FF64 (CmmFloat r _)
            = let bs = doubleToBytes (fromRational r)
-             in  map (\b -> ptext (sLit "\t.byte\t") <> pprImm platform (ImmInt b)) bs
+             in  map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs
 
-        ppr_item II16 _        = [ptext (sLit "\t.short\t") <> pprImm platform imm]
+        ppr_item II16 _        = [ptext (sLit "\t.short\t") <> pprImm imm]
 
         ppr_item II64 (CmmInt x _)  =
                 [ptext (sLit "\t.long\t")
@@ -313,43 +320,43 @@ pprDataItem platform lit
                 = panic "PPC.Ppr.pprDataItem: no match"
 
 
-pprInstr :: Platform -> Instr -> SDoc
+pprInstr :: Instr -> SDoc
 
-pprInstr (COMMENT _) = empty -- nuke 'em
+pprInstr (COMMENT _) = empty -- nuke 'em
 {-
-pprInstr platform (COMMENT s) =
+pprInstr (COMMENT s) =
      if platformOS platform == OSLinux
      then ptext (sLit "# ") <> ftext s
      else ptext (sLit "; ") <> ftext s
 -}
-pprInstr platform (DELTA d)
-   = pprInstr platform (COMMENT (mkFastString ("\tdelta = " ++ show d)))
+pprInstr (DELTA d)
+   = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
 
-pprInstr (NEWBLOCK _)
+pprInstr (NEWBLOCK _)
    = panic "PprMach.pprInstr: NEWBLOCK"
 
-pprInstr (LDATA _ _)
+pprInstr (LDATA _ _)
    = panic "PprMach.pprInstr: LDATA"
 
 {-
-pprInstr (SPILL reg slot)
+pprInstr (SPILL reg slot)
    = hcat [
            ptext (sLit "\tSPILL"),
         char '\t',
-        pprReg platform reg,
+        pprReg reg,
         comma,
         ptext (sLit "SLOT") <> parens (int slot)]
 
-pprInstr (RELOAD slot reg)
+pprInstr (RELOAD slot reg)
    = hcat [
            ptext (sLit "\tRELOAD"),
         char '\t',
         ptext (sLit "SLOT") <> parens (int slot),
         comma,
-        pprReg platform reg]
+        pprReg reg]
 -}
 
-pprInstr platform (LD sz reg addr) = hcat [
+pprInstr (LD sz reg addr) = hcat [
         char '\t',
         ptext (sLit "l"),
         ptext (case sz of
@@ -363,11 +370,11 @@ pprInstr platform (LD sz reg addr) = hcat [
         case addr of AddrRegImm _ _ -> empty
                      AddrRegReg _ _ -> char 'x',
         char '\t',
-        pprReg platform reg,
+        pprReg reg,
         ptext (sLit ", "),
-        pprAddr platform addr
+        pprAddr addr
     ]
-pprInstr platform (LA sz reg addr) = hcat [
+pprInstr (LA sz reg addr) = hcat [
         char '\t',
         ptext (sLit "l"),
         ptext (case sz of
@@ -381,67 +388,68 @@ pprInstr platform (LA sz reg addr) = hcat [
         case addr of AddrRegImm _ _ -> empty
                      AddrRegReg _ _ -> char 'x',
         char '\t',
-        pprReg platform reg,
+        pprReg reg,
         ptext (sLit ", "),
-        pprAddr platform addr
+        pprAddr addr
     ]
-pprInstr platform (ST sz reg addr) = hcat [
+pprInstr (ST sz reg addr) = hcat [
         char '\t',
         ptext (sLit "st"),
         pprSize sz,
         case addr of AddrRegImm _ _ -> empty
                      AddrRegReg _ _ -> char 'x',
         char '\t',
-        pprReg platform reg,
+        pprReg reg,
         ptext (sLit ", "),
-        pprAddr platform addr
+        pprAddr addr
     ]
-pprInstr platform (STU sz reg addr) = hcat [
+pprInstr (STU sz reg addr) = hcat [
         char '\t',
         ptext (sLit "st"),
         pprSize sz,
         ptext (sLit "u\t"),
         case addr of AddrRegImm _ _ -> empty
                      AddrRegReg _ _ -> char 'x',
-        pprReg platform reg,
+        pprReg reg,
         ptext (sLit ", "),
-        pprAddr platform addr
+        pprAddr addr
     ]
-pprInstr platform (LIS reg imm) = hcat [
+pprInstr (LIS reg imm) = hcat [
         char '\t',
         ptext (sLit "lis"),
         char '\t',
-        pprReg platform reg,
+        pprReg reg,
         ptext (sLit ", "),
-        pprImm platform imm
+        pprImm imm
     ]
-pprInstr platform (LI reg imm) = hcat [
+pprInstr (LI reg imm) = hcat [
         char '\t',
         ptext (sLit "li"),
         char '\t',
-        pprReg platform reg,
+        pprReg reg,
         ptext (sLit ", "),
-        pprImm platform imm
+        pprImm imm
     ]
-pprInstr platform (MR reg1 reg2) 
+pprInstr (MR reg1 reg2) 
     | reg1 == reg2 = empty
     | otherwise = hcat [
         char '\t',
+        sdocWithPlatform $ \platform ->
         case targetClassOfReg platform reg1 of
             RcInteger -> ptext (sLit "mr")
             _ -> ptext (sLit "fmr"),
         char '\t',
-        pprReg platform reg1,
+        pprReg reg1,
         ptext (sLit ", "),
-        pprReg platform reg2
+        pprReg reg2
     ]
-pprInstr platform (CMP sz reg ri) = hcat [
+pprInstr (CMP sz reg ri) = hcat [
         char '\t',
         op,
         char '\t',
-        pprReg platform reg,
+        pprReg reg,
         ptext (sLit ", "),
-        pprRI platform ri
+        pprRI ri
     ]
     where
         op = hcat [
@@ -451,13 +459,13 @@ pprInstr platform (CMP sz reg ri) = hcat [
                     RIReg _ -> empty
                     RIImm _ -> char 'i'
             ]
-pprInstr platform (CMPL sz reg ri) = hcat [
+pprInstr (CMPL sz reg ri) = hcat [
         char '\t',
         op,
         char '\t',
-        pprReg platform reg,
+        pprReg reg,
         ptext (sLit ", "),
-        pprRI platform ri
+        pprRI ri
     ]
     where
         op = hcat [
@@ -467,7 +475,7 @@ pprInstr platform (CMPL sz reg ri) = hcat [
                     RIReg _ -> empty
                     RIImm _ -> char 'i'
             ]
-pprInstr (BCC cond blockid) = hcat [
+pprInstr (BCC cond blockid) = hcat [
         char '\t',
         ptext (sLit "b"),
         pprCond cond,
@@ -476,7 +484,7 @@ pprInstr _ (BCC cond blockid) = hcat [
     ]
     where lbl = mkAsmTempLabel (getUnique blockid)
 
-pprInstr (BCCFAR cond blockid) = vcat [
+pprInstr (BCCFAR cond blockid) = vcat [
         hcat [
             ptext (sLit "\tb"),
             pprCond (condNegate cond),
@@ -489,118 +497,118 @@ pprInstr _ (BCCFAR cond blockid) = vcat [
     ]
     where lbl = mkAsmTempLabel (getUnique blockid)
 
-pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel
+pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel
         char '\t',
         ptext (sLit "b"),
         char '\t',
         ppr lbl
     ]
 
-pprInstr platform (MTCTR reg) = hcat [
+pprInstr (MTCTR reg) = hcat [
         char '\t',
         ptext (sLit "mtctr"),
         char '\t',
-        pprReg platform reg
+        pprReg reg
     ]
-pprInstr (BCTR _ _) = hcat [
+pprInstr (BCTR _ _) = hcat [
         char '\t',
         ptext (sLit "bctr")
     ]
-pprInstr (BL lbl _) = hcat [
+pprInstr (BL lbl _) = hcat [
         ptext (sLit "\tbl\t"),
         ppr lbl
     ]
-pprInstr (BCTRL _) = hcat [
+pprInstr (BCTRL _) = hcat [
         char '\t',
         ptext (sLit "bctrl")
     ]
-pprInstr platform (ADD reg1 reg2 ri) = pprLogic platform (sLit "add") reg1 reg2 ri
-pprInstr platform (ADDIS reg1 reg2 imm) = hcat [
+pprInstr (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri
+pprInstr (ADDIS reg1 reg2 imm) = hcat [
         char '\t',
         ptext (sLit "addis"),
         char '\t',
-        pprReg platform reg1,
+        pprReg reg1,
         ptext (sLit ", "),
-        pprReg platform reg2,
+        pprReg reg2,
         ptext (sLit ", "),
-        pprImm platform imm
+        pprImm imm
     ]
 
-pprInstr platform (ADDC reg1 reg2 reg3) = pprLogic platform (sLit "addc") reg1 reg2 (RIReg reg3)
-pprInstr platform (ADDE reg1 reg2 reg3) = pprLogic platform (sLit "adde") reg1 reg2 (RIReg reg3)
-pprInstr platform (SUBF reg1 reg2 reg3) = pprLogic platform (sLit "subf") reg1 reg2 (RIReg reg3)
-pprInstr platform (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic platform (sLit "mullw") reg1 reg2 ri
-pprInstr platform (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic platform (sLit "mull") reg1 reg2 ri
-pprInstr platform (DIVW reg1 reg2 reg3) = pprLogic platform (sLit "divw") reg1 reg2 (RIReg reg3)
-pprInstr platform (DIVWU reg1 reg2 reg3) = pprLogic platform (sLit "divwu") reg1 reg2 (RIReg reg3)
-
-pprInstr platform (MULLW_MayOflo reg1 reg2 reg3) = vcat [
-         hcat [ ptext (sLit "\tmullwo\t"), pprReg platform reg1, ptext (sLit ", "),
-                                          pprReg platform reg2, ptext (sLit ", "),
-                                          pprReg platform reg3 ],
-         hcat [ ptext (sLit "\tmfxer\t"),  pprReg platform reg1 ],
-         hcat [ ptext (sLit "\trlwinm\t"), pprReg platform reg1, ptext (sLit ", "),
-                                          pprReg platform reg1, ptext (sLit ", "),
+pprInstr (ADDC reg1 reg2 reg3) = pprLogic (sLit "addc") reg1 reg2 (RIReg reg3)
+pprInstr (ADDE reg1 reg2 reg3) = pprLogic (sLit "adde") reg1 reg2 (RIReg reg3)
+pprInstr (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3)
+pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic (sLit "mullw") reg1 reg2 ri
+pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic (sLit "mull") reg1 reg2 ri
+pprInstr (DIVW reg1 reg2 reg3) = pprLogic (sLit "divw") reg1 reg2 (RIReg reg3)
+pprInstr (DIVWU reg1 reg2 reg3) = pprLogic (sLit "divwu") reg1 reg2 (RIReg reg3)
+
+pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [
+         hcat [ ptext (sLit "\tmullwo\t"), pprReg reg1, ptext (sLit ", "),
+                                          pprReg reg2, ptext (sLit ", "),
+                                          pprReg reg3 ],
+         hcat [ ptext (sLit "\tmfxer\t"),  pprReg reg1 ],
+         hcat [ ptext (sLit "\trlwinm\t"), pprReg reg1, ptext (sLit ", "),
+                                          pprReg reg1, ptext (sLit ", "),
                                           ptext (sLit "2, 31, 31") ]
     ]
 
             -- for some reason, "andi" doesn't exist.
         -- we'll use "andi." instead.
-pprInstr platform (AND reg1 reg2 (RIImm imm)) = hcat [
+pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [
         char '\t',
         ptext (sLit "andi."),
         char '\t',
-        pprReg platform reg1,
+        pprReg reg1,
         ptext (sLit ", "),
-        pprReg platform reg2,
+        pprReg reg2,
         ptext (sLit ", "),
-        pprImm platform imm
+        pprImm imm
     ]
-pprInstr platform (AND reg1 reg2 ri) = pprLogic platform (sLit "and") reg1 reg2 ri
+pprInstr (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri
 
-pprInstr platform (OR reg1 reg2 ri) = pprLogic platform (sLit "or") reg1 reg2 ri
-pprInstr platform (XOR reg1 reg2 ri) = pprLogic platform (sLit "xor") reg1 reg2 ri
+pprInstr (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri
+pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri
 
-pprInstr platform (XORIS reg1 reg2 imm) = hcat [
+pprInstr (XORIS reg1 reg2 imm) = hcat [
         char '\t',
         ptext (sLit "xoris"),
         char '\t',
-        pprReg platform reg1,
+        pprReg reg1,
         ptext (sLit ", "),
-        pprReg platform reg2,
+        pprReg reg2,
         ptext (sLit ", "),
-        pprImm platform imm
+        pprImm imm
     ]
 
-pprInstr platform (EXTS sz reg1 reg2) = hcat [
+pprInstr (EXTS sz reg1 reg2) = hcat [
         char '\t',
         ptext (sLit "exts"),
         pprSize sz,
         char '\t',
-        pprReg platform reg1,
+        pprReg reg1,
         ptext (sLit ", "),
-        pprReg platform reg2
+        pprReg reg2
     ]
 
-pprInstr platform (NEG reg1 reg2) = pprUnary platform (sLit "neg") reg1 reg2
-pprInstr platform (NOT reg1 reg2) = pprUnary platform (sLit "not") reg1 reg2
+pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2
+pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2
 
-pprInstr platform (SLW reg1 reg2 ri) = pprLogic platform (sLit "slw") reg1 reg2 (limitShiftRI ri)
+pprInstr (SLW reg1 reg2 ri) = pprLogic (sLit "slw") reg1 reg2 (limitShiftRI ri)
 
-pprInstr platform (SRW reg1 reg2 (RIImm (ImmInt i))) | i > 31 || i < 0 =
+pprInstr (SRW reg1 reg2 (RIImm (ImmInt i))) | i > 31 || i < 0 =
     -- Handle the case where we are asked to shift a 32 bit register by
     -- less than zero or more than 31 bits. We convert this into a clear
     -- of the destination register.
     -- Fixes ticket http://hackage.haskell.org/trac/ghc/ticket/5900
-    pprInstr platform (XOR reg1 reg2 (RIReg reg2))
-pprInstr platform (SRW reg1 reg2 ri) = pprLogic platform (sLit "srw") reg1 reg2 (limitShiftRI ri)
+    pprInstr (XOR reg1 reg2 (RIReg reg2))
+pprInstr (SRW reg1 reg2 ri) = pprLogic (sLit "srw") reg1 reg2 (limitShiftRI ri)
 
-pprInstr platform (SRAW reg1 reg2 ri) = pprLogic platform (sLit "sraw") reg1 reg2 (limitShiftRI ri)
-pprInstr platform (RLWINM reg1 reg2 sh mb me) = hcat [
+pprInstr (SRAW reg1 reg2 ri) = pprLogic (sLit "sraw") reg1 reg2 (limitShiftRI ri)
+pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [
         ptext (sLit "\trlwinm\t"),
-        pprReg platform reg1,
+        pprReg reg1,
         ptext (sLit ", "),
-        pprReg platform reg2,
+        pprReg reg2,
         ptext (sLit ", "),
         int sh,
         ptext (sLit ", "),
@@ -609,27 +617,27 @@ pprInstr platform (RLWINM reg1 reg2 sh mb me) = hcat [
         int me
     ]
     
-pprInstr platform (FADD sz reg1 reg2 reg3) = pprBinaryF platform (sLit "fadd") sz reg1 reg2 reg3
-pprInstr platform (FSUB sz reg1 reg2 reg3) = pprBinaryF platform (sLit "fsub") sz reg1 reg2 reg3
-pprInstr platform (FMUL sz reg1 reg2 reg3) = pprBinaryF platform (sLit "fmul") sz reg1 reg2 reg3
-pprInstr platform (FDIV sz reg1 reg2 reg3) = pprBinaryF platform (sLit "fdiv") sz reg1 reg2 reg3
-pprInstr platform (FNEG reg1 reg2) = pprUnary platform (sLit "fneg") reg1 reg2
+pprInstr (FADD sz reg1 reg2 reg3) = pprBinaryF (sLit "fadd") sz reg1 reg2 reg3
+pprInstr (FSUB sz reg1 reg2 reg3) = pprBinaryF (sLit "fsub") sz reg1 reg2 reg3
+pprInstr (FMUL sz reg1 reg2 reg3) = pprBinaryF (sLit "fmul") sz reg1 reg2 reg3
+pprInstr (FDIV sz reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") sz reg1 reg2 reg3
+pprInstr (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2
 
-pprInstr platform (FCMP reg1 reg2) = hcat [
+pprInstr (FCMP reg1 reg2) = hcat [
         char '\t',
         ptext (sLit "fcmpu\tcr0, "),
             -- Note: we're using fcmpu, not fcmpo
             -- The difference is with fcmpo, compare with NaN is an invalid operation.
             -- We don't handle invalid fp ops, so we don't care
-        pprReg platform reg1,
+        pprReg reg1,
         ptext (sLit ", "),
-        pprReg platform reg2
+        pprReg reg2
     ]
 
-pprInstr platform (FCTIWZ reg1 reg2) = pprUnary platform (sLit "fctiwz") reg1 reg2
-pprInstr platform (FRSP reg1 reg2) = pprUnary platform (sLit "frsp") reg1 reg2
+pprInstr (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2
+pprInstr (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2
 
-pprInstr (CRNOR dst src1 src2) = hcat [
+pprInstr (CRNOR dst src1 src2) = hcat [
         ptext (sLit "\tcrnor\t"),
         int dst,
         ptext (sLit ", "),
@@ -638,73 +646,73 @@ pprInstr _ (CRNOR dst src1 src2) = hcat [
         int src2
     ]
 
-pprInstr platform (MFCR reg) = hcat [
+pprInstr (MFCR reg) = hcat [
         char '\t',
         ptext (sLit "mfcr"),
         char '\t',
-        pprReg platform reg
+        pprReg reg
     ]
 
-pprInstr platform (MFLR reg) = hcat [
+pprInstr (MFLR reg) = hcat [
         char '\t',
         ptext (sLit "mflr"),
         char '\t',
-        pprReg platform reg
+        pprReg reg
     ]
 
-pprInstr platform (FETCHPC reg) = vcat [
+pprInstr (FETCHPC reg) = vcat [
         ptext (sLit "\tbcl\t20,31,1f"),
-        hcat [ ptext (sLit "1:\tmflr\t"), pprReg platform reg ]
+        hcat [ ptext (sLit "1:\tmflr\t"), pprReg reg ]
     ]
 
-pprInstr LWSYNC = ptext (sLit "\tlwsync")
+pprInstr LWSYNC = ptext (sLit "\tlwsync")
 
--- pprInstr _ = panic "pprInstr (ppc)"
+-- pprInstr _ = panic "pprInstr (ppc)"
 
 
-pprLogic :: Platform -> LitString -> Reg -> Reg -> RI -> SDoc
-pprLogic platform op reg1 reg2 ri = hcat [
+pprLogic :: LitString -> Reg -> Reg -> RI -> SDoc
+pprLogic op reg1 reg2 ri = hcat [
         char '\t',
         ptext op,
         case ri of
             RIReg _ -> empty
             RIImm _ -> char 'i',
         char '\t',
-        pprReg platform reg1,
+        pprReg reg1,
         ptext (sLit ", "),
-        pprReg platform reg2,
+        pprReg reg2,
         ptext (sLit ", "),
-        pprRI platform ri
+        pprRI ri
     ]
 
 
-pprUnary :: Platform -> LitString -> Reg -> Reg -> SDoc
-pprUnary platform op reg1 reg2 = hcat [
+pprUnary :: LitString -> Reg -> Reg -> SDoc
+pprUnary op reg1 reg2 = hcat [
         char '\t',
         ptext op,
         char '\t',
-        pprReg platform reg1,
+        pprReg reg1,
         ptext (sLit ", "),
-        pprReg platform reg2
+        pprReg reg2
     ]
-    
-    
-pprBinaryF :: Platform -> LitString -> Size -> Reg -> Reg -> Reg -> SDoc
-pprBinaryF platform op sz reg1 reg2 reg3 = hcat [
+
+
+pprBinaryF :: LitString -> Size -> Reg -> Reg -> Reg -> SDoc
+pprBinaryF op sz reg1 reg2 reg3 = hcat [
         char '\t',
         ptext op,
         pprFSize sz,
         char '\t',
-        pprReg platform reg1,
+        pprReg reg1,
         ptext (sLit ", "),
-        pprReg platform reg2,
+        pprReg reg2,
         ptext (sLit ", "),
-        pprReg platform reg3
+        pprReg reg3
     ]
     
-pprRI :: Platform -> RI -> SDoc
-pprRI platform (RIReg r) = pprReg platform r
-pprRI platform (RIImm r) = pprImm platform r
+pprRI :: RI -> SDoc
+pprRI (RIReg r) = pprReg r
+pprRI (RIImm r) = pprImm r
 
 
 pprFSize :: Size -> SDoc
index f494571..91a2b89 100644 (file)
@@ -48,20 +48,21 @@ import Data.Word
 -- -----------------------------------------------------------------------------
 -- Printing this stuff out
 
-pprNatCmmDecl :: Platform -> NatCmmDecl CmmStatics Instr -> SDoc
-pprNatCmmDecl (CmmData section dats) =
+pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc
+pprNatCmmDecl (CmmData section dats) =
   pprSectionHeader section $$ pprDatas dats
 
  -- special case for split markers:
-pprNatCmmDecl (CmmProc Nothing lbl (ListGraph [])) = pprLabel lbl
+pprNatCmmDecl (CmmProc Nothing lbl (ListGraph [])) = pprLabel lbl
 
  -- special case for code without info table:
-pprNatCmmDecl (CmmProc Nothing lbl (ListGraph blocks)) =
+pprNatCmmDecl (CmmProc Nothing lbl (ListGraph blocks)) =
   pprSectionHeader Text $$
   pprLabel lbl $$ -- blocks guaranteed not null, so label needed
   vcat (map pprBasicBlock blocks)
 
-pprNatCmmDecl platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blocks)) =
+pprNatCmmDecl (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blocks)) =
+  sdocWithPlatform $ \platform ->
   pprSectionHeader Text $$
   (
        (if platformHasSubsectionsViaSymbols platform
index 1821baf..e844376 100644 (file)
@@ -47,27 +47,28 @@ import Data.Bits
 -- -----------------------------------------------------------------------------
 -- Printing this stuff out
 
-pprNatCmmDecl :: Platform -> NatCmmDecl (Alignment, CmmStatics) Instr -> SDoc
-pprNatCmmDecl platform (CmmData section dats) =
-  pprSectionHeader platform section $$ pprDatas platform dats
+pprNatCmmDecl :: NatCmmDecl (Alignment, CmmStatics) Instr -> SDoc
+pprNatCmmDecl (CmmData section dats) =
+  pprSectionHeader section $$ pprDatas dats
 
  -- special case for split markers:
-pprNatCmmDecl (CmmProc Nothing lbl (ListGraph [])) = pprLabel lbl
+pprNatCmmDecl (CmmProc Nothing lbl (ListGraph [])) = pprLabel lbl
 
  -- special case for code without info table:
-pprNatCmmDecl platform (CmmProc Nothing lbl (ListGraph blocks)) =
-  pprSectionHeader platform Text $$
+pprNatCmmDecl (CmmProc Nothing lbl (ListGraph blocks)) =
+  pprSectionHeader Text $$
   pprLabel lbl $$ -- blocks guaranteed not null, so label needed
   vcat (map pprBasicBlock blocks) $$
-  pprSizeDecl platform lbl
+  pprSizeDecl lbl
 
-pprNatCmmDecl platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blocks)) =
-  pprSectionHeader platform Text $$
+pprNatCmmDecl (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blocks)) =
+  sdocWithPlatform $ \platform ->
+  pprSectionHeader Text $$
   (
        (if platformHasSubsectionsViaSymbols platform
         then ppr (mkDeadStripPreventer info_lbl) <> char ':'
         else empty) $$
-       vcat (map (pprData platform) info) $$
+       vcat (map pprData info) $$
        pprLabel info_lbl
   ) $$
   vcat (map pprBasicBlock blocks) $$
@@ -86,15 +87,16 @@ pprNatCmmDecl platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListG
               <+> char '-'
               <+> ppr (mkDeadStripPreventer info_lbl)
          else empty) $$
-  pprSizeDecl platform info_lbl
+  pprSizeDecl info_lbl
 
 -- | Output the ELF .size directive.
-pprSizeDecl :: Platform -> CLabel -> SDoc
-pprSizeDecl platform lbl
- | osElfTarget (platformOS platform) =
-    ptext (sLit "\t.size") <+> ppr lbl
-    <> ptext (sLit ", .-") <> ppr lbl
- | otherwise = empty
+pprSizeDecl :: CLabel -> SDoc
+pprSizeDecl lbl
+ = sdocWithPlatform $ \platform ->
+   if osElfTarget (platformOS platform)
+   then ptext (sLit "\t.size") <+> ppr lbl
+     <> ptext (sLit ", .-") <> ppr lbl
+   else empty
 
 pprBasicBlock :: NatBasicBlock Instr -> SDoc
 pprBasicBlock (BasicBlock blockid instrs) =
@@ -102,19 +104,20 @@ pprBasicBlock (BasicBlock blockid instrs) =
   vcat (map pprInstr instrs)
 
 
-pprDatas :: Platform -> (Alignment, CmmStatics) -> SDoc
-pprDatas platform (align, (Statics lbl dats))
- = vcat (pprAlign platform align : pprLabel lbl : map (pprData platform) dats)
+pprDatas :: (Alignment, CmmStatics) -> SDoc
+pprDatas (align, (Statics lbl dats))
+ = vcat (pprAlign align : pprLabel lbl : map pprData dats)
  -- TODO: could remove if align == 1
 
-pprData :: Platform -> CmmStatic -> SDoc
-pprData _ (CmmString str)          = pprASCII str
+pprData :: CmmStatic -> SDoc
+pprData (CmmString str) = pprASCII str
 
-pprData platform (CmmUninitialised bytes)
- | platformOS platform == OSDarwin = ptext (sLit ".space ") <> int bytes
- | otherwise                       = ptext (sLit ".skip ")  <> int bytes
+pprData (CmmUninitialised bytes)
+ = sdocWithPlatform $ \platform ->
+   if platformOS platform == OSDarwin then ptext (sLit ".space ") <> int bytes
+                                      else ptext (sLit ".skip ")  <> int bytes
 
-pprData platform (CmmStaticLit lit) = pprDataItem platform lit
+pprData (CmmStaticLit lit) = pprDataItem lit
 
 pprGloblDecl :: CLabel -> SDoc
 pprGloblDecl lbl
@@ -141,13 +144,14 @@ pprASCII str
        do1 :: Word8 -> SDoc
        do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w)
 
-pprAlign :: Platform -> Int -> SDoc
-pprAlign platform bytes
-        = ptext (sLit ".align ") <> int alignment
+pprAlign :: Int -> SDoc
+pprAlign bytes
+        = sdocWithPlatform $ \platform ->
+          ptext (sLit ".align ") <> int (alignment platform)
   where
-        alignment = if platformOS platform == OSDarwin
-                    then log2 bytes
-                    else      bytes
+        alignment platform = if platformOS platform == OSDarwin
+                             then log2 bytes
+                             else      bytes
 
         log2 :: Int -> Int  -- cache the common ones
         log2 1 = 0
@@ -362,9 +366,10 @@ pprAddr (AddrBaseIndex base index displacement)
     ppr_disp imm        = pprImm imm
 
 
-pprSectionHeader :: Platform -> Section -> SDoc
-pprSectionHeader platform seg
- = case platformOS platform of
+pprSectionHeader :: Section -> SDoc
+pprSectionHeader seg
+ = sdocWithPlatform $ \platform ->
+   case platformOS platform of
    OSDarwin
     | target32Bit platform ->
        case seg of
@@ -407,8 +412,11 @@ pprSectionHeader platform seg
 
 
 
-pprDataItem :: Platform -> CmmLit -> SDoc
-pprDataItem platform lit
+pprDataItem :: CmmLit -> SDoc
+pprDataItem lit = sdocWithPlatform $ \platform -> pprDataItem' platform lit
+
+pprDataItem' :: Platform -> CmmLit -> SDoc
+pprDataItem' platform lit
   = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit)
     where
         imm = litToImm lit
index cef5974..b872a7d 100644 (file)
@@ -57,7 +57,7 @@ module Lexer (
    extension, bangPatEnabled, datatypeContextsEnabled,
    traditionalRecordSyntaxEnabled,
    typeLiteralsEnabled,
-   explicitNamespacesEnabled,
+   explicitNamespacesEnabled, sccProfilingOn,
    addWarning,
    lexTokenStream
   ) where
@@ -1849,6 +1849,8 @@ inRulePragBit :: Int
 inRulePragBit = 19
 rawTokenStreamBit :: Int
 rawTokenStreamBit = 20 -- producing a token stream with all comments included
+sccProfilingOnBit :: Int
+sccProfilingOnBit = 21
 alternativeLayoutRuleBit :: Int
 alternativeLayoutRuleBit = 23
 relaxedLayoutBit :: Int
@@ -1909,6 +1911,8 @@ relaxedLayout :: Int -> Bool
 relaxedLayout flags = testBit flags relaxedLayoutBit
 nondecreasingIndentation :: Int -> Bool
 nondecreasingIndentation flags = testBit flags nondecreasingIndentationBit
+sccProfilingOn :: Int -> Bool
+sccProfilingOn flags = testBit flags sccProfilingOnBit
 traditionalRecordSyntaxEnabled :: Int -> Bool
 traditionalRecordSyntaxEnabled flags = testBit flags traditionalRecordSyntaxBit
 typeLiteralsEnabled :: Int -> Bool
@@ -1975,6 +1979,7 @@ mkPState flags buf loc =
                .|. rawTokenStreamBit           `setBitIf` dopt Opt_KeepRawTokenStream       flags
                .|. alternativeLayoutRuleBit    `setBitIf` xopt Opt_AlternativeLayoutRule    flags
                .|. relaxedLayoutBit            `setBitIf` xopt Opt_RelaxedLayout            flags
+               .|. sccProfilingOnBit           `setBitIf` dopt Opt_SccProfilingOn           flags
                .|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags
                .|. safeHaskellBit              `setBitIf` safeImportsOn                     flags
                .|. traditionalRecordSyntaxBit  `setBitIf` xopt Opt_TraditionalRecordSyntax  flags
index 6213227..6c19812 100644 (file)
@@ -43,7 +43,7 @@ import OccName          ( varName, dataName, tcClsName, tvName )
 import DataCon          ( DataCon, dataConName )
 import SrcLoc
 import Module
-import StaticFlags      ( opt_SccProfilingOn, opt_Hpc )
+import StaticFlags      ( opt_Hpc )
 import Kind             ( Kind, liftedTypeKind, unliftedTypeKind, mkArrowKind )
 import Class            ( FunDep )
 import BasicTypes
@@ -1402,9 +1402,10 @@ exp10 :: { LHsExpr RdrName }
         | 'do' stmtlist                 { L (comb2 $1 $2) (mkHsDo DoExpr  (unLoc $2)) }
         | 'mdo' stmtlist                { L (comb2 $1 $2) (mkHsDo MDoExpr (unLoc $2)) }
 
-        | scc_annot exp                         { LL $ if opt_SccProfilingOn
-                                                        then HsSCC (unLoc $1) $2
-                                                        else HsPar $2 }
+        | scc_annot exp             {% do { on <- extension sccProfilingOn
+                                          ; return $ LL $ if on
+                                                          then HsSCC (unLoc $1) $2
+                                                          else HsPar $2 } }
         | hpc_annot exp                         { LL $ if opt_Hpc
                                                         then HsTickPragma (unLoc $1) $2
                                                         else HsPar $2 }
index 7e223f8..0866c03 100644 (file)
@@ -10,8 +10,8 @@ module ProfInit (profilingInitCode) where
 
 import CLabel
 import CostCentre
+import DynFlags
 import Outputable
-import StaticFlags
 import FastString
 import Module
 
@@ -23,9 +23,10 @@ import Module
 
 profilingInitCode :: Module -> CollectedCCs -> SDoc
 profilingInitCode this_mod (local_CCs, ___extern_CCs, singleton_CCSs)
- | not opt_SccProfilingOn = empty
- | otherwise
- = vcat
+ = sdocWithDynFlags $ \dflags ->
+   if not (dopt Opt_SccProfilingOn dflags)
+   then empty
+   else vcat
     [ text "static void prof_init_" <> ppr this_mod
          <> text "(void) __attribute__((constructor));"
     , text "static void prof_init_" <> ppr this_mod <> text "(void)"
index 3e801c6..1b608bd 100644 (file)
@@ -60,7 +60,6 @@ import Packages    ( isDllName )
 import Platform
 import PprCore     ( {- instances -} )
 import PrimOp      ( PrimOp, PrimCall )
-import StaticFlags ( opt_SccProfilingOn )
 import TyCon       ( PrimRep(..) )
 import TyCon       ( TyCon )
 import Type        ( Type )
@@ -810,7 +809,8 @@ pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag srt [{-no args-}] (StgApp fun
 
 -- general case
 pprStgRhs (StgRhsClosure cc bi free_vars upd_flag srt args body)
-  = hang (hsep [if opt_SccProfilingOn then ppr cc else empty,
+  = sdocWithDynFlags $ \dflags ->
+    hang (hsep [if dopt Opt_SccProfilingOn dflags then ppr cc else empty,
                 pp_binder_info bi,
                 ifPprDebug (brackets (interppSP free_vars)),
                 char '\\' <> ppr upd_flag, pprMaybeSRT srt, brackets (interppSP args)])
index 8252621..76bb386 100644 (file)
@@ -21,6 +21,8 @@ data Platform
         = Platform {
               platformArch                     :: Arch,
               platformOS                       :: OS,
+              -- Word size in bytes (i.e. normally 4 or 8,
+              -- for 32bit and 64bit platforms respectively)
               platformWordSize                 :: {-# UNPACK #-} !Int,
               platformHasGnuNonexecStack       :: Bool,
               platformHasIdentDirective        :: Bool,
diff --git a/ghc.mk b/ghc.mk
index 707b3fb..6f57f30 100644 (file)
--- a/ghc.mk
+++ b/ghc.mk
@@ -310,7 +310,7 @@ endif
 # They do not say "this package will be built"; see $(PACKAGES_xx) for that
 
 # Packages that are built but not installed
-PKGS_THAT_ARE_INTREE_ONLY := haskeline transformers terminfo utf8-string xhtml
+PKGS_THAT_ARE_INTREE_ONLY := haskeline transformers terminfo xhtml
 
 PKGS_THAT_ARE_DPH := \
     dph/dph-base \
@@ -389,6 +389,9 @@ endif
 endif
 endef
 
+# Add all the packages. Note that we need to add them in dependency
+# order, as this is the order that they get configured in.
+
 $(eval $(call addPackage,ghc-prim))
 ifeq "$(CLEANING)" "YES"
 $(eval $(call addPackage,integer-gmp))
@@ -404,9 +407,9 @@ $(eval $(call addPackage,bytestring))
 $(eval $(call addPackage,containers))
 $(eval $(call addPackage,old-locale))
 $(eval $(call addPackage,old-time))
-$(eval $(call addPackage,time))
 
 $(eval $(call addPackage,Win32,($$(Windows),YES)))
+$(eval $(call addPackage,time))
 $(eval $(call addPackage,unix,($$(Windows),NO)))
 
 $(eval $(call addPackage,directory))
@@ -421,7 +424,6 @@ $(eval $(call addPackage,binary))
 $(eval $(call addPackage,bin-package-db))
 $(eval $(call addPackage,hoopl))
 $(eval $(call addPackage,transformers))
-$(eval $(call addPackage,utf8-string))
 $(eval $(call addPackage,xhtml))
 $(eval $(call addPackage,terminfo,($$(Windows),NO)))
 $(eval $(call addPackage,haskeline))
index cd7ef1a..ba3b487 100644 (file)
@@ -86,15 +86,6 @@ libraries/haskeline_dist-install_EXTRA_HC_OPTS += -fno-warn-unused-imports
 libraries/binary_dist-boot_EXTRA_HC_OPTS += -fno-warn-unused-imports
 libraries/binary_dist-install_EXTRA_HC_OPTS += -fno-warn-unused-imports -fno-warn-identities
 
-# Temporarily turn off -Werror for some Hoopl modules that have
-# non-exhaustive pattern-match warnings
-libraries/hoopl/src/Compiler/Hoopl/Util_HC_OPTS += -Wwarn
-libraries/hoopl/src/Compiler/Hoopl/GraphUtil_HC_OPTS += -Wwarn
-libraries/hoopl/src/Compiler/Hoopl/MkGraph_HC_OPTS += -Wwarn
-libraries/hoopl/src/Compiler/Hoopl/XUtil_HC_OPTS += -Wwarn
-libraries/hoopl/src/Compiler/Hoopl/Pointed_HC_OPTS += -Wwarn
-libraries/hoopl/src/Compiler/Hoopl/Passes/Dominator_HC_OPTS += -Wwarn
-
 # temporarily turn off -Werror for mtl
 libraries/mtl_dist-install_EXTRA_HC_OPTS += -Wwarn
 
index 162d5ca..fe93177 100644 (file)
--- a/packages
+++ b/packages
@@ -71,7 +71,6 @@ libraries/template-haskell      -           packages/template-haskell.git
 libraries/terminfo              -           packages/terminfo.git               git
 libraries/transformers          -           packages/transformers.git           git
 libraries/unix                  -           packages/unix.git                   git
-libraries/utf8-string           -           packages/utf8-string.git            git
 libraries/Win32                 -           packages/Win32.git                  git
 libraries/xhtml                 -           packages/xhtml.git                  git
 testsuite                       testsuite   testsuite.git                       git
index 34e2d9a..4c33115 100644 (file)
@@ -417,9 +417,9 @@ giveCapabilityToTask (Capability *cap USED_IF_DEBUG, Task *task)
 {
     ASSERT_LOCK_HELD(&cap->lock);
     ASSERT(task->cap == cap);
-    debugTrace(DEBUG_sched, "passing capability %d to %s %p",
+    debugTrace(DEBUG_sched, "passing capability %d to %s %#" FMT_HexWord64,
                cap->no, task->incall->tso ? "bound task" : "worker",
-               (void *)(size_t)task->id);
+               serialisableTaskId(task));
     ACQUIRE_LOCK(&task->lock);
     if (task->wakeup == rtsFalse) {
         task->wakeup = rtsTrue;
index 3380cfd..78725dd 100644 (file)
@@ -395,22 +395,6 @@ workerTaskStop (Task *task)
 
 #endif
 
-#ifdef DEBUG
-// We don't replace this function with serialisableTaskId,
-// because debug prints as pointers are more readable than random
-// 64-bit intergers (especially on 32-bit architectures)
-// and because we want to use this function also for non-threaded RTS.
-static void *taskId(Task *task)
-{
-#ifdef THREADED_RTS
-    return (void *)(size_t)task->id;
-#else
-    return (void *)task;
-#endif
-}
-
-#endif
-
 #if defined(THREADED_RTS)
 
 static void OSThreadProcAttr
@@ -483,7 +467,8 @@ interruptWorkerTask (Task *task)
   ASSERT(osThreadId() != task->id);    // seppuku not allowed
   ASSERT(task->incall->suspended_tso); // use this only for FFI calls
   interruptOSThread(task->id);
-  debugTrace(DEBUG_sched, "interrupted worker task %p", taskId(task));
+  debugTrace(DEBUG_sched, "interrupted worker task %#" FMT_HexWord64,
+             serialisableTaskId(task));
 }
 
 #endif /* THREADED_RTS */
@@ -497,7 +482,8 @@ printAllTasks(void)
 {
     Task *task;
     for (task = all_tasks; task != NULL; task = task->all_next) {
-       debugBelch("task %p is %s, ", taskId(task), task->stopped ? "stopped" : "alive");
+       debugBelch("task %#" FMT_HexWord64 " is %s, ", serialisableTaskId(task),
+                   task->stopped ? "stopped" : "alive");
        if (!task->stopped) {
            if (task->cap) {
                debugBelch("on capability %d, ", task->cap->no);
index 0926950..e5b7295 100644 (file)
@@ -312,7 +312,7 @@ serialisableTaskId (Task *task
 #if defined(THREADED_RTS)
     return serialiseTaskId(task->id);
 #else
-    return 1;
+    return (TaskId) (size_t) task;
 #endif
 }
 
index bbd37d1..ed2a4d0 100644 (file)
@@ -105,7 +105,7 @@ $1_$2_$3_MOST_HC_OPTS = \
  $$($1_$2_MORE_HC_OPTS) \
  $$($1_$2_EXTRA_HC_OPTS) \
  $$($1_$2_$3_HC_OPTS) \
- $$($$(basename $$<)_HC_OPTS) \
+ $$($$(basename $$(subst ./,,$$<))_HC_OPTS) \
  $$(SRC_HC_WARNING_OPTS) \
  $$(EXTRA_HC_OPTS)