More CPP removal: pprDynamicLinkerAsmLabel in CLabel

And some knock-on changes

10 files changed, 102 insertions, 77 deletions

diff --git a/compiler/codeGen/CgBindery.lhs b/compiler/codeGen/CgBindery.lhs
index d8675c53df..3cccbef310 100644
--- a/compiler/codeGen/CgBindery.lhs
+++ b/compiler/codeGen/CgBindery.lhs
@@ -148,9 +148,10 @@ data StableLoc
 \end{code}
 
 \begin{code}
-instance Outputable CgIdInfo where
-  ppr (CgIdInfo id _ vol stb _ _) -- TODO, pretty pring the tag info
-    = ppr id <+> ptext (sLit "-->") <+> vcat [ppr vol, ppr stb]
+instance PlatformOutputable CgIdInfo where
+  pprPlatform platform (CgIdInfo id _ vol stb _ _)
+    -- TODO, pretty pring the tag info
+    = ppr id <+> ptext (sLit "-->") <+> vcat [ppr vol, pprPlatform platform stb]
 
 instance Outputable VolatileLoc where
   ppr NoVolatileLoc = empty
@@ -158,12 +159,12 @@ instance Outputable VolatileLoc where
   ppr (VirHpLoc v)   = ptext (sLit "vh")  <+> ppr v
   ppr (VirNodeLoc v) = ptext (sLit "vn")  <+> ppr v
 
-instance Outputable StableLoc where
-  ppr NoStableLoc   = empty
-  ppr VoidLoc       = ptext (sLit "void")
-  ppr (VirStkLoc v) = ptext (sLit "vs")    <+> ppr v
-  ppr (VirStkLNE v) = ptext (sLit "lne")    <+> ppr v
-  ppr (StableLoc a) = ptext (sLit "amode") <+> ppr a
+instance PlatformOutputable StableLoc where
+  pprPlatform _        NoStableLoc   = empty
+  pprPlatform _        VoidLoc       = ptext (sLit "void")
+  pprPlatform _        (VirStkLoc v) = ptext (sLit "vs")    <+> ppr v
+  pprPlatform _        (VirStkLNE v) = ptext (sLit "lne")   <+> ppr v
+  pprPlatform platform (StableLoc a) = ptext (sLit "amode") <+> pprPlatform platform a
 \end{code}
 
 %************************************************************************
diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs
index 889b1db752..a675c5625c 100644
--- a/compiler/codeGen/CgCon.lhs
+++ b/compiler/codeGen/CgCon.lhs
@@ -47,6 +47,7 @@ import Outputable
 import ListSetOps
 import Util
 import Module
+import DynFlags
 import FastString
 import StaticFlags
 \end{code}
@@ -64,7 +65,7 @@ cgTopRhsCon :: Id		-- Name of thing bound to this RHS
 	    -> [StgArg]		-- Args
 	    -> FCode (Id, CgIdInfo)
 cgTopRhsCon id con args
-  = do { 
+  = do { dflags <- getDynFlags
 #if mingw32_TARGET_OS
         -- Windows DLLs have a problem with static cross-DLL refs.
 	; this_pkg <- getThisPackage
@@ -76,6 +77,7 @@ cgTopRhsCon id con args
 	; amodes <- getArgAmodes args
 
 	; let
+	    platform = targetPlatform dflags
 	    name          = idName id
 	    lf_info	  = mkConLFInfo con
     	    closure_label = mkClosureLabel name $ idCafInfo id
@@ -89,7 +91,7 @@ cgTopRhsCon id con args
 
 	    payload = map get_lit amodes_w_offsets	
 	    get_lit (CmmLit lit, _offset) = lit
-	    get_lit other = pprPanic "CgCon.get_lit" (ppr other)
+	    get_lit other = pprPanic "CgCon.get_lit" (pprPlatform platform other)
 		-- NB1: amodes_w_offsets is sorted into ptrs first, then non-ptrs
 		-- NB2: all the amodes should be Lits!
 
diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs
index 92db95eba8..305081d680 100644
--- a/compiler/codeGen/CgInfoTbls.hs
+++ b/compiler/codeGen/CgInfoTbls.hs
@@ -38,6 +38,7 @@ import Unique
 import StaticFlags
 
 import Constants
+import DynFlags
 import Util
 import Outputable
 
@@ -160,6 +161,8 @@ is not present in the list (it is always assumed).
 -}
 mkStackLayout :: FCode [Maybe LocalReg]
 mkStackLayout = do
+  dflags <- getDynFlags
+  let platform = targetPlatform dflags
   StackUsage { realSp = real_sp,
                frameSp = frame_sp } <- getStkUsage
   binds <- getLiveStackBindings
@@ -169,7 +172,7 @@ mkStackLayout = do
                     | (offset, b) <- binds]
 
   WARN( not (all (\bind -> fst bind >= 0) rel_binds),
-	ppr binds $$ ppr rel_binds $$
+        pprPlatform platform binds $$ pprPlatform platform rel_binds $$
         ppr frame_size $$ ppr real_sp $$ ppr frame_sp )
     return $ stack_layout rel_binds frame_size
 
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index f34fdb80be..1bf9366f50 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -396,7 +396,9 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
     do  { -- Allocate the global ticky counter,
           -- and establish the ticky-counter
           -- label for this block
-        ; let ticky_ctr_lbl = closureRednCountsLabel cl_info
+        ; dflags <- getDynFlags
+        ; let platform = targetPlatform dflags
+              ticky_ctr_lbl = closureRednCountsLabel platform cl_info
         ; emitTickyCounter cl_info (map stripNV args)
         ; setTickyCtrLabel ticky_ctr_lbl $ do
 
@@ -454,14 +456,16 @@ mkSlowEntryCode :: ClosureInfo -> [LocalReg] -> FCode ()
 mkSlowEntryCode _ [] = panic "entering a closure with no arguments?"
 mkSlowEntryCode cl_info arg_regs -- function closure is already in `Node'
   | Just (_, ArgGen _) <- closureFunInfo cl_info
-  = emitProcWithConvention Slow CmmNonInfoTable slow_lbl arg_regs jump
+  = do dflags <- getDynFlags
+       let platform = targetPlatform dflags
+           slow_lbl = closureSlowEntryLabel  platform cl_info
+           fast_lbl = closureLocalEntryLabel platform cl_info
+           -- mkDirectJump does not clobber `Node' containing function closure
+           jump = mkDirectJump (mkLblExpr fast_lbl)
+                               (map (CmmReg . CmmLocal) arg_regs)
+                               initUpdFrameOff
+       emitProcWithConvention Slow CmmNonInfoTable slow_lbl arg_regs jump
   | otherwise = return ()
-  where
-     slow_lbl = closureSlowEntryLabel cl_info
-     fast_lbl = closureLocalEntryLabel cl_info
-     -- mkDirectJump does not clobber `Node' containing function closure
-     jump = mkDirectJump (mkLblExpr fast_lbl) (map (CmmReg . CmmLocal) arg_regs)
-                         initUpdFrameOff
 
 -----------------------------------------
 thunkCode :: ClosureInfo -> [(NonVoid Id, VirtualHpOffset)] -> CostCentreStack
diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
index 712263a156..ede24a5c6f 100644
--- a/compiler/codeGen/StgCmmClosure.hs
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -80,6 +80,7 @@ import TcType
 import TyCon
 import BasicTypes
 import Outputable
+import Platform
 import Constants
 import DynFlags
 
@@ -757,19 +758,19 @@ isToplevClosure (ClosureInfo { closureLFInfo = lf_info })
 --   Label generation
 --------------------------------------
 
-staticClosureLabel :: ClosureInfo -> CLabel
-staticClosureLabel = toClosureLbl .  closureInfoLabel
+staticClosureLabel :: Platform -> ClosureInfo -> CLabel
+staticClosureLabel platform = toClosureLbl platform .  closureInfoLabel
 
-closureRednCountsLabel :: ClosureInfo -> CLabel
-closureRednCountsLabel = toRednCountsLbl . closureInfoLabel
+closureRednCountsLabel :: Platform -> ClosureInfo -> CLabel
+closureRednCountsLabel platform = toRednCountsLbl platform . closureInfoLabel
 
-closureSlowEntryLabel :: ClosureInfo -> CLabel
-closureSlowEntryLabel = toSlowEntryLbl . closureInfoLabel
+closureSlowEntryLabel :: Platform -> ClosureInfo -> CLabel
+closureSlowEntryLabel platform = toSlowEntryLbl platform . closureInfoLabel
 
-closureLocalEntryLabel :: ClosureInfo -> CLabel
-closureLocalEntryLabel
-  | tablesNextToCode = toInfoLbl  . closureInfoLabel
-  | otherwise        = toEntryLbl . closureInfoLabel
+closureLocalEntryLabel :: Platform -> ClosureInfo -> CLabel
+closureLocalEntryLabel platform
+  | tablesNextToCode = toInfoLbl  platform . closureInfoLabel
+  | otherwise        = toEntryLbl platform . closureInfoLabel
 
 mkClosureInfoTableLabel :: Id -> LambdaFormInfo -> CLabel
 mkClosureInfoTableLabel id lf_info
diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs
index 587601f226..4542922675 100644
--- a/compiler/codeGen/StgCmmEnv.hs
+++ b/compiler/codeGen/StgCmmEnv.hs
@@ -44,6 +44,7 @@ import VarEnv
 import Control.Monad
 import Name
 import StgSyn
+import DynFlags
 import Outputable
 
 -------------------------------------
@@ -174,7 +175,8 @@ getCgIdInfo id
     
 cgLookupPanic :: Id -> FCode a
 cgLookupPanic id
-  = do	static_binds <- getStaticBinds
+  = do	dflags <- getDynFlags
+      	static_binds <- getStaticBinds
 	local_binds <- getBinds
 	srt <- getSRTLabel
 	pprPanic "StgCmmEnv: variable not found"
@@ -183,7 +185,7 @@ cgLookupPanic id
 		vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ],
 		ptext (sLit "local binds for:"),
 		vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ],
-	        ptext (sLit "SRT label") <+> pprCLabel srt
+	        ptext (sLit "SRT label") <+> pprCLabel (targetPlatform dflags) srt
 	      ])
 
 
diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index 407a99e571..857fd38e27 100644
--- a/compiler/codeGen/StgCmmHeap.hs
+++ b/compiler/codeGen/StgCmmHeap.hs
@@ -43,6 +43,7 @@ import IdInfo( CafInfo(..), mayHaveCafRefs )
 import Module
 import FastString( mkFastString, fsLit )
 import Constants
+import DynFlags
 
 -----------------------------------------------------------
 --              Initialise dynamic heap objects
@@ -332,35 +333,38 @@ entryHeapCheck :: ClosureInfo
                -> FCode ()
 
 entryHeapCheck cl_info offset nodeSet arity args code
-  = do updfr_sz <- getUpdFrameOff
+  = do dflags <- getDynFlags
+
+       let platform = targetPlatform dflags
+
+           is_thunk = arity == 0
+           is_fastf = case closureFunInfo cl_info of
+                           Just (_, ArgGen _) -> False
+                           _otherwise         -> True
+
+           args' = map (CmmReg . CmmLocal) args
+           setN = case nodeSet of
+                          Just n  -> mkAssign nodeReg (CmmReg $ CmmLocal n)
+                          Nothing -> mkAssign nodeReg $
+                              CmmLit (CmmLabel $ staticClosureLabel platform cl_info)
+
+           {- Thunks:          Set R1 = node, jump GCEnter1
+              Function (fast): Set R1 = node, jump GCFun
+              Function (slow): Set R1 = node, call generic_gc -}
+           gc_call upd = setN <*> gc_lbl upd
+           gc_lbl upd
+               | is_thunk  = mkDirectJump (CmmReg $ CmmGlobal GCEnter1) [] sp
+               | is_fastf  = mkDirectJump (CmmReg $ CmmGlobal GCFun) [] sp
+               | otherwise = mkForeignJump Slow (CmmReg $ CmmGlobal GCFun) args' upd
+               where sp = max offset upd
+           {- DT (12/08/10) This is a little fishy, mainly the sp fix up amount.
+            - This is since the ncg inserts spills before the stack/heap check.
+            - This should be fixed up and then we won't need to fix up the Sp on
+            - GC calls, but until then this fishy code works -}
+
+       updfr_sz <- getUpdFrameOff
        heapCheck True (gc_call updfr_sz) code
 
-  where
-    is_thunk = arity == 0
-    is_fastf = case closureFunInfo cl_info of
-                    Just (_, ArgGen _) -> False
-                    _otherwise         -> True
-
-    args' = map (CmmReg . CmmLocal) args
-    setN = case nodeSet of
-                   Just n  -> mkAssign nodeReg (CmmReg $ CmmLocal n)
-                   Nothing -> mkAssign nodeReg $
-                       CmmLit (CmmLabel $ staticClosureLabel cl_info)
-
-    {- Thunks:          Set R1 = node, jump GCEnter1
-       Function (fast): Set R1 = node, jump GCFun
-       Function (slow): Set R1 = node, call generic_gc -}
-    gc_call upd = setN <*> gc_lbl upd
-    gc_lbl upd
-        | is_thunk  = mkDirectJump (CmmReg $ CmmGlobal GCEnter1) [] sp
-        | is_fastf  = mkDirectJump (CmmReg $ CmmGlobal GCFun) [] sp
-        | otherwise = mkForeignJump Slow (CmmReg $ CmmGlobal GCFun) args' upd
-        where sp = max offset upd
-    {- DT (12/08/10) This is a little fishy, mainly the sp fix up amount.
-     - This is since the ncg inserts spills before the stack/heap check.
-     - This should be fixed up and then we won't need to fix up the Sp on
-     - GC calls, but until then this fishy code works -}
-
 {-
     -- This code is slightly outdated now and we could easily keep the above
     -- GC methods. However, there may be some performance gains to be made by
diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index 58d858f729..f8137dc564 100644
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -44,6 +44,7 @@ import Id
 import Name
 import TyCon		( PrimRep(..) )
 import BasicTypes	( Arity )
+import DynFlags
 import StaticFlags
 
 import Constants
@@ -142,9 +143,12 @@ direct_call :: String -> CLabel -> Arity -> [CmmExpr] -> [ArgRep] -> FCode ()
 -- NB2: 'arity' refers to the *reps* 
 direct_call caller lbl arity args reps
   | debugIsOn && arity > length reps	-- Too few args
-  =  	    -- Caller should ensure that there enough args!  
-    pprPanic "direct_call" (text caller <+> ppr arity <+> ppr lbl <+> ppr (length reps)
-	     	  	    <+> ppr args <+> ppr reps )
+  = do -- Caller should ensure that there enough args!
+       dflags <- getDynFlags
+       let platform = targetPlatform dflags
+       pprPanic "direct_call" (text caller <+> ppr arity
+                           <+> pprPlatform platform lbl <+> ppr (length reps)
+                           <+> pprPlatform platform args <+> ppr reps )
 
   | null rest_reps     -- Precisely the right number of arguments
   = emitCall (NativeDirectCall, NativeReturn) target args
@@ -165,8 +169,10 @@ direct_call caller lbl arity args reps
 --------------
 slow_call :: CmmExpr -> [CmmExpr] -> [ArgRep] -> FCode ()
 slow_call fun args reps
-  = do call <- getCode $ direct_call "slow_call" (mkRtsApFastLabel rts_fun) arity args reps
-       emit $ mkComment $ mkFastString ("slow_call for " ++ showSDoc (ppr fun) ++
+  = do dflags <- getDynFlags
+       let platform = targetPlatform dflags
+       call <- getCode $ direct_call "slow_call" (mkRtsApFastLabel rts_fun) arity args reps
+       emit $ mkComment $ mkFastString ("slow_call for " ++ showSDoc (pprPlatform platform fun) ++
                                         " with pat " ++ showSDoc (ftext rts_fun))
        emit (mkAssign nodeReg fun <*> call)
   where
@@ -395,8 +401,9 @@ emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body
 emitClosureAndInfoTable ::
   CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()
 emitClosureAndInfoTable info_tbl conv args body
-  = do { blks <- getCode body
-       ; let entry_lbl = toEntryLbl (cit_lbl info_tbl)
+  = do { dflags <- getDynFlags
+       ; blks <- getCode body
+       ; let entry_lbl = toEntryLbl (targetPlatform dflags) (cit_lbl info_tbl)
        ; emitProcWithConvention conv info_tbl entry_lbl args blks
        }
 
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index 7ea2183ef2..7263f751c3 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -190,13 +190,13 @@ data CgLoc
 	-- To tail-call it, assign to these locals, 
 	-- and branch to the block id
 
-instance Outputable CgIdInfo where
-  ppr (CgIdInfo { cg_id = id, cg_loc = loc })
-    = ppr id <+> ptext (sLit "-->") <+> ppr loc
+instance PlatformOutputable CgIdInfo where
+  pprPlatform platform (CgIdInfo { cg_id = id, cg_loc = loc })
+    = ppr id <+> ptext (sLit "-->") <+> pprPlatform platform loc
 
-instance Outputable CgLoc where
-  ppr (CmmLoc e)    = ptext (sLit "cmm") <+> ppr e
-  ppr (LneLoc b rs) = ptext (sLit "lne") <+> ppr b <+> ppr rs
+instance PlatformOutputable CgLoc where
+  pprPlatform platform (CmmLoc e)    = ptext (sLit "cmm") <+> pprPlatform platform e
+  pprPlatform _        (LneLoc b rs) = ptext (sLit "lne") <+> ppr b <+> ppr rs
 
 
 -- Sequel tells what to do with the result of this expression
diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs
index 1224ad1d5a..88ff1389dd 100644
--- a/compiler/codeGen/StgCmmTicky.hs
+++ b/compiler/codeGen/StgCmmTicky.hs
@@ -88,7 +88,12 @@ staticTickyHdr = []
 emitTickyCounter :: ClosureInfo -> [Id] -> FCode ()
 emitTickyCounter cl_info args
   = ifTicky $
-    do	{ mod_name <- getModuleName
+    do	{ dflags <- getDynFlags
+        ; mod_name <- getModuleName
+        ; let platform = targetPlatform dflags
+              ticky_ctr_label = closureRednCountsLabel platform cl_info
+              arg_descr = map (showTypeCategory . idType) args
+              fun_descr mod_name = ppr_for_ticky_name mod_name (closureName cl_info)
 	; fun_descr_lit <- newStringCLit (fun_descr mod_name)
 	; arg_descr_lit <- newStringCLit arg_descr
 	; emitDataLits ticky_ctr_label 	-- Must match layout of StgEntCounter
@@ -104,10 +109,6 @@ emitTickyCounter cl_info args
 	      zeroCLit, 		-- Allocs
 	      zeroCLit 			-- Link
 	    ] }
-  where
-    ticky_ctr_label = closureRednCountsLabel cl_info
-    arg_descr = map (showTypeCategory . idType) args
-    fun_descr mod_name = ppr_for_ticky_name mod_name (closureName cl_info)
 
 -- When printing the name of a thing in a ticky file, we want to
 -- give the module name even for *local* things.   We print