Desugaring for "foreign import prim"

[ghc-hetmet.git] / compiler / codeGen / CgTailCall.lhs

diff --git a/compiler/codeGen/CgTailCall.lhs b/compiler/codeGen/CgTailCall.lhs
index 9527026..60a8561 100644 (file)
--- a/compiler/codeGen/CgTailCall.lhs
+++ b/compiler/codeGen/CgTailCall.lhs
@@ -27,7 +27,6 @@ import CgUtils
 import CgTicky
 import ClosureInfo
 import SMRep
-import MachOp
 import Cmm     
 import CmmUtils
 import CLabel
@@ -36,6 +35,7 @@ import Id
 import StgSyn
 import PrimOp
 import Outputable
+import StaticFlags
 
 import Control.Monad
 
@@ -108,9 +108,9 @@ performTailCall fun_info arg_amodes pending_assts
              opt_node_asst | nodeMustPointToIt lf_info = node_asst
                            | otherwise                 = noStmts
        ; EndOfBlockInfo sp _ <- getEndOfBlockInfo
-       ; this_pkg <- getThisPackage
 
-       ; case (getCallMethod this_pkg fun_name lf_info (length arg_amodes)) of
+       ; dflags <- getDynFlags
+       ; case (getCallMethod dflags fun_name fun_has_cafs lf_info (length arg_amodes)) of
 
            -- Node must always point to things we enter
            EnterIt -> do
@@ -135,7 +135,7 @@ performTailCall fun_info arg_amodes pending_assts
            -- A real constructor.  Don't bother entering it, 
            -- just do the right sort of return instead.
            -- As with any return, Node must point to it.
-           ReturnCon con -> do
+           ReturnCon _ -> do
                { emitSimultaneously (node_asst `plusStmts` pending_assts)
                ; doFinalJump sp False emitReturnInstr }
 
@@ -177,12 +177,17 @@ performTailCall fun_info arg_amodes pending_assts
                }
        }
   where
-    fun_name  = idName (cgIdInfoId fun_info)
+    fun_id    = cgIdInfoId fun_info
+    fun_name  = idName fun_id
     lf_info   = cgIdInfoLF fun_info
+    fun_has_cafs = idCafInfo fun_id
     untag_node = CmmAssign nodeReg (cmmUntag (CmmReg nodeReg))
     -- Test if closure is a constructor
     maybeSwitchOnCons enterClosure eob
-              | EndOfBlockInfo _ (CaseAlts lbl _ _) <- eob
+              | EndOfBlockInfo _ (CaseAlts lbl _ _) <- eob,
+                not opt_SccProfilingOn
+                -- 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
                    -- Is the pointer tagged?
                    -- Yes, jump to switch statement
@@ -191,7 +196,7 @@ performTailCall fun_info arg_amodes pending_assts
                    -- No, enter the closure.
                    ; enterClosure
                    ; labelC is_constr
-                   ; stmtC (CmmJump (CmmLit (CmmLabel lbl)) [])
+                   ; stmtC (CmmJump (entryCode $ CmmLit (CmmLabel lbl)) [])
                    }
 {-
               -- This is a scrutinee for a case expression
@@ -220,6 +225,7 @@ performTailCall fun_info arg_amodes pending_assts
         where
           --cond1 tag  = cmmULtWord tag lowCons
           -- More efficient than the above?
+{-
           tag_expr   = cmmGetClosureType (CmmReg nodeReg)
           cond1 tag  = cmmEqWord tag (CmmLit (mkIntCLit 0))
           cond2 tag  = cmmUGtWord tag highCons
@@ -227,11 +233,11 @@ performTailCall fun_info arg_amodes pending_assts
             -- CONSTR
           highCons   = CmmLit (mkIntCLit 8)
             -- CONSTR_NOCAF_STATIC (from ClosureType.h)
+-}
 
-
-untagCmmAssign (CmmAssign r cmmExpr) = CmmAssign r (cmmUntag cmmExpr)
-untagCmmAssign stmt                  = stmt
-
+directCall :: VirtualSpOffset -> CLabel -> [(CgRep, CmmExpr)]
+           -> [(CgRep, CmmExpr)] -> CmmStmts
+           -> Code
 directCall sp lbl args extra_args assts = do
   let
        -- First chunk of args go in registers
@@ -282,7 +288,7 @@ performReturn :: Code       -- The code to execute to actually do the return
              -> Code
 
 performReturn finish_code
-  = do  { EndOfBlockInfo args_sp sequel <- getEndOfBlockInfo
+  = do  { EndOfBlockInfo args_sp _sequel <- getEndOfBlockInfo
        ; doFinalJump args_sp False{-not a LNE-} finish_code }
 
 -- ----------------------------------------------------------------------------
@@ -314,7 +320,7 @@ performPrimReturn rep amode
 
 returnUnboxedTuple :: [(CgRep, CmmExpr)] -> Code
 returnUnboxedTuple amodes
-  = do         { eob@(EndOfBlockInfo args_sp sequel) <- getEndOfBlockInfo
+  = do         { (EndOfBlockInfo args_sp _sequel) <- getEndOfBlockInfo
        ; tickyUnboxedTupleReturn (length amodes)
        ; (final_sp, assts) <- pushUnboxedTuple args_sp amodes
        ; emitSimultaneously assts
@@ -408,7 +414,7 @@ tailCallPrimOp op args
 
 pushReturnAddress :: EndOfBlockInfo -> Code
 
-pushReturnAddress (EndOfBlockInfo args_sp sequel@(CaseAlts lbl _ _))
+pushReturnAddress (EndOfBlockInfo args_sp (CaseAlts lbl _ _))
   = do { sp_rel <- getSpRelOffset args_sp
        ; stmtC (CmmStore sp_rel (mkLblExpr lbl)) }
 
@@ -468,3 +474,4 @@ adjustSpAndHp newRealSp
        ; setRealHp vHp
        }
 \end{code}
+