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

diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index 6cfca5f..bf452c4 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -44,13 +44,12 @@ 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 MkZipCfgCmm
 import CLabel
 import CmmUtils
@@ -98,7 +97,7 @@ 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)
+mkSimpleLit (MachLabel fs ms fod) = CmmLabel (mkForeignLabel fs ms is_dyn fod)
 			      where
 				is_dyn = False	-- ToDo: fix me
 mkSimpleLit other	      = pprPanic "mkSimpleLit" (ppr other)
@@ -284,15 +283,15 @@ tagToClosure tycon tag
 --
 -------------------------------------------------------------------------
 
-emitRtsCall :: LitString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
+emitRtsCall :: FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
 emitRtsCall fun args safe = emitRtsCall' [] fun args Nothing safe
    -- The 'Nothing' says "save all global registers"
 
-emitRtsCallWithVols :: LitString -> [(CmmExpr,ForeignHint)] -> [GlobalReg] -> Bool -> FCode ()
+emitRtsCallWithVols :: FastString -> [(CmmExpr,ForeignHint)] -> [GlobalReg] -> Bool -> FCode ()
 emitRtsCallWithVols fun args vols safe
    = emitRtsCall' [] fun args (Just vols) safe
 
-emitRtsCallWithResult :: LocalReg -> ForeignHint -> LitString
+emitRtsCallWithResult :: LocalReg -> ForeignHint -> FastString
 	-> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
 emitRtsCallWithResult res hint fun args safe
    = emitRtsCall' [(res,hint)] fun args Nothing safe
@@ -300,22 +299,24 @@ emitRtsCallWithResult res hint fun args safe
 -- Make a call to an RTS C procedure
 emitRtsCall'
    :: [(LocalReg,ForeignHint)]
-   -> LitString
+   -> FastString
    -> [(CmmExpr,ForeignHint)]
    -> Maybe [GlobalReg]
    -> Bool -- True <=> CmmSafe call
    -> FCode ()
 emitRtsCall' res fun args _vols safe
   = --error "emitRtsCall'"
-    do { emit caller_save
-       ; emit call
+    do { updfr_off <- getUpdFrameOff
+       ; emit caller_save
+       ; emit $ call updfr_off
        ; emit caller_load }
   where
-    call = if safe then
-             mkCall fun_expr CCallConv res' args' undefined
-           else
-             mkUnsafeCall (ForeignTarget fun_expr
-                            (ForeignConvention CCallConv arg_hints res_hints)) res' args'
+    call updfr_off =
+      if safe then
+        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
@@ -633,7 +634,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 Nothing
+    <*> mkLabel join_lbl
 
   where
     (t1,_) `le` (t2,_) = t1 <= t2
@@ -706,9 +707,9 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
   | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches
   = mkCmmIfThenElse 
 	(cmmUGtWord tag_expr (CmmLit (mkIntCLit highest_branch)))
+	(mkBranch deflt)
 	(mk_switch tag_expr branches mb_deflt 
 			lo_tag highest_branch via_C)
-	(mkBranch deflt)
 
   | otherwise	-- Use an if-tree
   = mkCmmIfThenElse 
@@ -788,6 +789,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
   where
     le (t1,_) (t2,_) = t1 <= t2
 
@@ -795,12 +797,12 @@ mk_lit_switch :: CmmExpr -> BlockId
  	      -> [(Literal,BlockId)]
 	      -> CmmAGraph
 mk_lit_switch scrut deflt [(lit,blk)] 
-  = mkCbranch
-	(CmmMachOp (MO_Ne rep) [scrut, CmmLit cmm_lit])
-	deflt blk
+  = mkCbranch (CmmMachOp ne [scrut, CmmLit cmm_lit]) deflt blk
   where
     cmm_lit = mkSimpleLit lit
-    rep     = typeWidth (cmmLitType cmm_lit)
+    cmm_ty  = cmmLitType cmm_lit
+    rep     = typeWidth cmm_ty
+    ne      = if isFloatType cmm_ty then MO_F_Ne rep else MO_Ne rep
 
 mk_lit_switch scrut deflt_blk_id branches
   = mkCmmIfThenElse cond
@@ -846,7 +848,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 Nothing <*> code <*> mkBranch join_lbl)
+    outOfLine (mkLabel lbl <*> code <*> mkBranch join_lbl)
     <*> thing_inside lbl
  
 
@@ -879,12 +881,14 @@ getSRTInfo (SRTEntries {}) = panic "getSRTInfo"
 getSRTInfo (SRT off len bmp)
   | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
   = do 	{ id <- newUnique
-	; top_srt <- getSRTLabel
+	-- ; top_srt <- getSRTLabel
         ; let srt_desc_lbl = mkLargeSRTLabel id
-	; emitRODataLits srt_desc_lbl
-             ( cmmLabelOffW top_srt off
-	       : mkWordCLit (fromIntegral len)
-	       : map mkWordCLit bmp)
+        -- JD: We're not constructing and emitting SRTs in the back end,
+        -- which renders this code wrong (it now names a now-non-existent label).
+	-- ; emitRODataLits srt_desc_lbl
+        --      ( cmmLabelOffW top_srt off
+	--        : mkWordCLit (fromIntegral len)
+	--        : map mkWordCLit bmp)
 	; return (C_SRT srt_desc_lbl 0 srt_escape) }
 
   | otherwise