Remove old 'foreign import dotnet' code

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

diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 47bf6c4..8952f92 100644 (file)
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -42,6 +42,7 @@ import Maybes
 import Util
 import FastString
 import Outputable
+import UniqSupply
 
 ------------------------------------------------------------------------
 --             cgExpr: the main function
@@ -57,8 +58,13 @@ cgExpr (StgTick m n expr) = do { emit (mkTickBox m n); cgExpr expr }
 cgExpr (StgLit lit)       = do cmm_lit <- cgLit lit
                                emitReturn [CmmLit cmm_lit]
 
-cgExpr (StgLet binds expr)            = do { cgBind binds; cgExpr expr }
-cgExpr (StgLetNoEscape _ _ binds expr) = do { cgLneBinds binds; cgExpr expr }
+cgExpr (StgLet binds expr)             = do { cgBind binds;     cgExpr expr }
+cgExpr (StgLetNoEscape _ _ binds expr) =
+  do { us <- newUniqSupply
+     ; let join_id = mkBlockId (uniqFromSupply us)
+     ; cgLneBinds join_id binds
+     ; cgExpr expr 
+     ; emit $ mkLabel join_id}
 
 cgExpr (StgCase expr _live_vars _save_vars bndr srt alt_type alts) =
   cgCase expr bndr srt alt_type alts
@@ -84,37 +90,42 @@ bound only to stable things like stack locations..  The 'e' part will
 execute *next*, just like the scrutinee of a case. -}
 
 -------------------------
-cgLneBinds :: StgBinding -> FCode ()
-cgLneBinds (StgNonRec bndr rhs)
-  = do { local_cc <- saveCurrentCostCentre
-               -- See Note [Saving the current cost centre]
-       ; info <- cgLetNoEscapeRhs local_cc bndr rhs 
-       ; addBindC (cg_id info) info }
-
-cgLneBinds (StgRec pairs)
-  = do { local_cc <- saveCurrentCostCentre
-       ; new_bindings <- fixC (\ new_bindings -> do
-               { addBindsC new_bindings
-               ; listFCs [ cgLetNoEscapeRhs local_cc b e 
-                         | (b,e) <- pairs ] })
-
-       ; addBindsC new_bindings }
+cgLneBinds :: BlockId -> StgBinding -> FCode ()
+cgLneBinds join_id (StgNonRec bndr rhs)
+  = do  { local_cc <- saveCurrentCostCentre
+                -- See Note [Saving the current cost centre]
+        ; info <- cgLetNoEscapeRhs join_id local_cc bndr rhs 
+        ; addBindC (cg_id info) info }
+
+cgLneBinds join_id (StgRec pairs)
+  = do  { local_cc <- saveCurrentCostCentre
+        ; new_bindings <- fixC (\ new_bindings -> do
+                { addBindsC new_bindings
+                ; listFCs [ cgLetNoEscapeRhs join_id local_cc b e 
+                          | (b,e) <- pairs ] })
+        ; addBindsC new_bindings }
 
 
 -------------------------
-cgLetNoEscapeRhs, cgLetNoEscapeRhsBody
-    :: Maybe LocalReg  -- Saved cost centre
+cgLetNoEscapeRhs
+    :: BlockId          -- join point for successor of let-no-escape
+    -> Maybe LocalReg  -- Saved cost centre
     -> Id
     -> StgRhs
     -> FCode CgIdInfo
 
-cgLetNoEscapeRhs local_cc bndr rhs =
+cgLetNoEscapeRhs join_id local_cc bndr rhs =
   do { (info, rhs_body) <- getCodeR $ cgLetNoEscapeRhsBody local_cc bndr rhs 
      ; let (bid, _) = expectJust "cgLetNoEscapeRhs" $ maybeLetNoEscape info
-     ; emit (outOfLine $ mkLabel bid emptyStackInfo <*> rhs_body)
+     ; emit (outOfLine $ mkLabel bid <*> rhs_body <*> mkBranch join_id)
      ; return info
      }
 
+cgLetNoEscapeRhsBody
+    :: Maybe LocalReg  -- Saved cost centre
+    -> Id
+    -> StgRhs
+    -> FCode CgIdInfo
 cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd _ args body)
   = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body
 cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args)
@@ -285,7 +296,7 @@ cgCase scrut bndr srt alt_type alts
        ; restoreCurrentCostCentre mb_cc
 
   -- JD: We need Note: [Better Alt Heap Checks]
-       ; bindArgsToRegs ret_bndrs
+       ; _ <- bindArgsToRegs ret_bndrs
        ; cgAlts gc_plan (NonVoid bndr) alt_type alts }
 
 -----------------
@@ -309,8 +320,8 @@ isSimpleScrut _                    _           = False
 isSimpleOp :: StgOp -> Bool
 -- True iff the op cannot block or allocate
 isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) = not (playSafe safe)
-isSimpleOp (StgFCallOp (DNCall _) _)                   = False         -- Safe!
 isSimpleOp (StgPrimOp op)                                     = not (primOpOutOfLine op)
+isSimpleOp (StgPrimCallOp _)                           = False
 
 -----------------
 chooseReturnBndrs :: Id -> AltType -> [StgAlt] -> [NonVoid Id]
@@ -396,7 +407,7 @@ cgAltRhss gc_plan bndr alts
     cg_alt (con, bndrs, _uses, rhs)
       = getCodeR                 $
        maybeAltHeapCheck gc_plan $
-       do { bindConArgs con base_reg bndrs
+       do { _ <- bindConArgs con base_reg bndrs
           ; cgExpr rhs
           ; return con }
 
@@ -442,8 +453,9 @@ cgLneJump blk_id lne_regs args      -- Join point; discard sequel
                <*> mkBranch blk_id) }
     
 cgTailCall :: Id -> CgIdInfo -> [StgArg] -> FCode ()
-cgTailCall fun_id fun_info args
-  = case (getCallMethod fun_name (idCafInfo fun_id) lf_info (length args)) of
+cgTailCall fun_id fun_info args = do
+    dflags <- getDynFlags
+    case (getCallMethod dflags fun_name (idCafInfo fun_id) lf_info (length args)) of
 
            -- A value in WHNF, so we can just return it.
        ReturnIt -> emitReturn [fun]    -- ToDo: does ReturnIt guarantee tagged?
@@ -452,8 +464,9 @@ cgTailCall fun_id fun_info args
                do { let fun' = CmmLoad fun (cmmExprType fun)
                    ; [ret,call] <- forkAlts [
                        getCode $ emitReturn [fun],     -- Is tagged; no need to untag
-                       getCode $ do emit (mkAssign nodeReg fun)
-                                     emitCall Native (entryCode fun') []]  -- Not tagged
+                       getCode $ do -- emit (mkAssign nodeReg fun)
+                         emitCall (NativeNodeCall, NativeReturn)
+                                  (entryCode fun') [fun]]  -- Not tagged
                   ; emit (mkCmmIfThenElse (cmmIsTagged fun) ret call) }
 
        SlowCall -> do      -- A slow function call via the RTS apply routines
@@ -468,8 +481,6 @@ cgTailCall fun_id fun_info args
                     do emit $ mkComment $ mkFastString "directEntry"
                        emit (mkAssign nodeReg fun)
                        directCall lbl arity args
-                    -- directCall lbl (arity+1) (StgVarArg fun_id : args))
-                    -- >>= (emit . (mkComment (mkFastString "DirectEntry") <*>))
                  else do emit $ mkComment $ mkFastString "directEntry else"
                           directCall lbl arity args }