X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmmUtils.hs;h=d9178116840129bc1fa9d7673d5e802ed51b4974;hp=bf452c46514f8462038a6647395f3ff562f12a86;hb=52cba3c47b25a78402e542ff63dc905fc5b26b62;hpb=984a288119983912d40a80845c674ee4b83a19ce

diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index bf452c4..d917811 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -20,7 +20,7 @@ module StgCmmUtils (
 
 	tagToClosure, mkTaggedObjectLoad,
 
-        callerSaveVolatileRegs, get_GlobalReg_addr,
+        callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,
 
 	cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
         cmmUGtWord,
@@ -49,11 +49,11 @@ module StgCmmUtils (
 import StgCmmMonad
 import StgCmmClosure
 import BlockId
-import Cmm
-import MkZipCfgCmm
+import CmmDecl
+import CmmExpr hiding (regUsedIn)
+import MkGraph
 import CLabel
 import CmmUtils
-import PprCmm		( {- instances -} )
 
 import ForeignCall
 import IdInfo
@@ -62,6 +62,7 @@ import TyCon
 import Constants
 import SMRep
 import StgSyn	( SRT(..) )
+import Module
 import Literal
 import Digraph
 import ListSetOps
@@ -97,9 +98,11 @@ mkSimpleLit (MachWord i)      = CmmInt i wordWidth
 mkSimpleLit (MachWord64 i)    = CmmInt i W64
 mkSimpleLit (MachFloat r)     = CmmFloat r W32
 mkSimpleLit (MachDouble r)    = CmmFloat r W64
-mkSimpleLit (MachLabel fs ms fod) = CmmLabel (mkForeignLabel fs ms is_dyn fod)
-			      where
-				is_dyn = False	-- ToDo: fix me
+mkSimpleLit (MachLabel fs ms fod) 
+	= CmmLabel (mkForeignLabel fs ms labelSrc fod)
+	where
+		-- TODO: Literal labels might not actually be in the current package...
+		labelSrc = ForeignLabelInThisPackage	
 mkSimpleLit other	      = pprPanic "mkSimpleLit" (ppr other)
 
 mkLtOp :: Literal -> MachOp
@@ -283,28 +286,29 @@ tagToClosure tycon tag
 --
 -------------------------------------------------------------------------
 
-emitRtsCall :: FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
-emitRtsCall fun args safe = emitRtsCall' [] fun args Nothing safe
+emitRtsCall :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
+emitRtsCall pkg fun args safe = emitRtsCall' [] pkg fun args Nothing safe
    -- The 'Nothing' says "save all global registers"
 
-emitRtsCallWithVols :: FastString -> [(CmmExpr,ForeignHint)] -> [GlobalReg] -> Bool -> FCode ()
-emitRtsCallWithVols fun args vols safe
-   = emitRtsCall' [] fun args (Just vols) safe
+emitRtsCallWithVols :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> [GlobalReg] -> Bool -> FCode ()
+emitRtsCallWithVols pkg fun args vols safe
+   = emitRtsCall' [] pkg fun args (Just vols) safe
 
-emitRtsCallWithResult :: LocalReg -> ForeignHint -> FastString
+emitRtsCallWithResult :: LocalReg -> ForeignHint -> PackageId -> FastString
 	-> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
-emitRtsCallWithResult res hint fun args safe
-   = emitRtsCall' [(res,hint)] fun args Nothing safe
+emitRtsCallWithResult res hint pkg fun args safe
+   = emitRtsCall' [(res,hint)] pkg fun args Nothing safe
 
 -- Make a call to an RTS C procedure
 emitRtsCall'
    :: [(LocalReg,ForeignHint)]
+   -> PackageId
    -> FastString
    -> [(CmmExpr,ForeignHint)]
    -> Maybe [GlobalReg]
    -> Bool -- True <=> CmmSafe call
    -> FCode ()
-emitRtsCall' res fun args _vols safe
+emitRtsCall' res pkg fun args _vols safe
   = --error "emitRtsCall'"
     do { updfr_off <- getUpdFrameOff
        ; emit caller_save
@@ -320,7 +324,7 @@ emitRtsCall' res fun args _vols safe
     (args', arg_hints) = unzip args
     (res',  res_hints) = unzip res
     (caller_save, caller_load) = callerSaveVolatileRegs
-    fun_expr = mkLblExpr (mkRtsCodeLabel fun)
+    fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun)
 
 
 -----------------------------------------------------------------------------
@@ -336,6 +340,23 @@ emitRtsCall' res fun args _vols safe
 --  * Regs.h claims that BaseReg should be saved last and loaded first
 --    * This might not have been tickled before since BaseReg is callee save
 --  * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
+--
+-- This code isn't actually used right now, because callerSaves
+-- only ever returns true in the current universe for registers NOT in
+-- system_regs (just do a grep for CALLER_SAVES in
+-- includes/stg/MachRegs.h).  It's all one giant no-op, and for
+-- good reason: having to save system registers on every foreign call
+-- would be very expensive, so we avoid assigning them to those
+-- registers when we add support for an architecture.
+--
+-- Note that the old code generator actually does more work here: it
+-- also saves other global registers.  We can't (nor want) to do that
+-- here, as we don't have liveness information.  And really, we
+-- shouldn't be doing the workaround at this point in the pipeline, see
+-- Note [Register parameter passing] and the ToDo on CmmCall in
+-- cmm/CmmNode.hs.  Right now the workaround is to avoid inlining across
+-- unsafe foreign calls in rewriteAssignments, but this is strictly
+-- temporary.
 callerSaveVolatileRegs :: (CmmAGraph, CmmAGraph)
 callerSaveVolatileRegs = (caller_save, caller_load)
   where
@@ -392,6 +413,51 @@ callerSaves :: GlobalReg -> Bool
 #ifdef CALLER_SAVES_Base
 callerSaves BaseReg		= True
 #endif
+#ifdef CALLER_SAVES_R1
+callerSaves (VanillaReg 1 _)	= True
+#endif
+#ifdef CALLER_SAVES_R2
+callerSaves (VanillaReg 2 _)	= True
+#endif
+#ifdef CALLER_SAVES_R3
+callerSaves (VanillaReg 3 _)	= True
+#endif
+#ifdef CALLER_SAVES_R4
+callerSaves (VanillaReg 4 _)	= True
+#endif
+#ifdef CALLER_SAVES_R5
+callerSaves (VanillaReg 5 _)	= True
+#endif
+#ifdef CALLER_SAVES_R6
+callerSaves (VanillaReg 6 _)	= True
+#endif
+#ifdef CALLER_SAVES_R7
+callerSaves (VanillaReg 7 _)	= True
+#endif
+#ifdef CALLER_SAVES_R8
+callerSaves (VanillaReg 8 _)	= True
+#endif
+#ifdef CALLER_SAVES_F1
+callerSaves (FloatReg 1)	= True
+#endif
+#ifdef CALLER_SAVES_F2
+callerSaves (FloatReg 2)	= True
+#endif
+#ifdef CALLER_SAVES_F3
+callerSaves (FloatReg 3)	= True
+#endif
+#ifdef CALLER_SAVES_F4
+callerSaves (FloatReg 4)	= True
+#endif
+#ifdef CALLER_SAVES_D1
+callerSaves (DoubleReg 1)	= True
+#endif
+#ifdef CALLER_SAVES_D2
+callerSaves (DoubleReg 2)	= True
+#endif
+#ifdef CALLER_SAVES_L1
+callerSaves (LongReg 1)		= True
+#endif
 #ifdef CALLER_SAVES_Sp
 callerSaves Sp			= True
 #endif
@@ -498,7 +564,7 @@ newTemp rep = do { uniq <- newUnique
 newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])
 -- Choose suitable local regs to use for the components
 -- of an unboxed tuple that we are about to return to 
--- the Sequel.  If the Sequel is a joint point, using the
+-- the Sequel.  If the Sequel is a join point, using the
 -- regs it wants will save later assignments.
 newUnboxedTupleRegs res_ty 
   = ASSERT( isUnboxedTupleType res_ty )
@@ -592,7 +658,6 @@ reg  `regUsedIn` CmmRegOff (CmmLocal reg') _ = reg == reg'
 reg  `regUsedIn` CmmMachOp _ es   	     = any (reg `regUsedIn`) es
 _reg `regUsedIn` _other		 	     = False    	-- The CmmGlobal cases
 
-
 -------------------------------------------------------------------------
 --	mkSwitch
 -------------------------------------------------------------------------