Beef up cmmMiniInline a tiny bit

[ghc-hetmet.git] / compiler / codeGen / StgCmmUtils.hs

diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index 4803f5f..4b1446a 100644 (file)
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -44,15 +44,13 @@ module StgCmmUtils (
   ) where
 
 #include "HsVersions.h"
-#include "MachRegs.h"
+#include "../includes/stg/MachRegs.h"
 
 import StgCmmMonad
 import StgCmmClosure
 import BlockId
-import Cmm
-import CmmExpr
+import Cmm hiding (regUsedIn)
 import MkZipCfgCmm
-import ZipCfg hiding (last, unzip, zip)
 import CLabel
 import CmmUtils
 import PprCmm          ( {- instances -} )
@@ -64,6 +62,7 @@ import TyCon
 import Constants
 import SMRep
 import StgSyn  ( SRT(..) )
+import Module
 import Literal
 import Digraph
 import ListSetOps
@@ -99,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) = CmmLabel (mkForeignLabel fs ms is_dyn)
-                             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
@@ -285,28 +286,29 @@ tagToClosure tycon tag
 --
 -------------------------------------------------------------------------
 
-emitRtsCall :: LitString -> [(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 :: LitString -> [(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 -> LitString
+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)]
-   -> LitString
+   -> 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
@@ -315,14 +317,14 @@ emitRtsCall' res fun args _vols safe
   where
     call updfr_off =
       if safe then
-        mkCall fun_expr Native res' args' updfr_off
+        mkCmmCall fun_expr res' args' updfr_off
       else
         mkUnsafeCall (ForeignTarget fun_expr
                          (ForeignConvention CCallConv arg_hints res_hints)) res' args'
     (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)
 
 
 -----------------------------------------------------------------------------
@@ -500,7 +502,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 )
@@ -594,7 +596,6 @@ reg  `regUsedIn` CmmRegOff (CmmLocal reg') _ = reg == reg'
 reg  `regUsedIn` CmmMachOp _ es             = any (reg `regUsedIn`) es
 _reg `regUsedIn` _other                             = False            -- The CmmGlobal cases
 
-
 -------------------------------------------------------------------------
 --     mkSwitch
 -------------------------------------------------------------------------
@@ -636,7 +637,7 @@ mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag
     mk_switch tag_expr' (sortLe le branches) mb_deflt 
              lo_tag hi_tag via_C
          -- Sort the branches before calling mk_switch
-    <*> mkLabel join_lbl emptyStackInfo
+    <*> mkLabel join_lbl
 
   where
     (t1,_) `le` (t2,_) = t1 <= t2
@@ -791,7 +792,7 @@ mkCmmLitSwitch scrut  branches deflt
     label_code join_lbl deflt          $ \ deflt ->
     label_branches join_lbl branches   $ \ branches ->
     mk_lit_switch scrut' deflt (sortLe le branches)
-    <*> mkLabel join_lbl emptyStackInfo
+    <*> mkLabel join_lbl
   where
     le (t1,_) (t2,_) = t1 <= t2
 
@@ -850,7 +851,7 @@ label_code :: BlockId -> CmmAGraph -> (BlockId -> CmmAGraph) -> CmmAGraph
 --  [L: code; goto J] fun L
 label_code join_lbl code thing_inside
   = withFreshLabel "switch"    $ \lbl -> 
-    outOfLine (mkLabel lbl emptyStackInfo <*> code <*> mkBranch join_lbl)
+    outOfLine (mkLabel lbl <*> code <*> mkBranch join_lbl)
     <*> thing_inside lbl