In CMM, only allow foreign calls to labels, not arbitrary expressions

I'm not sure if we want to make this change permanently, but for now it
fixes the unreg build.

I've also removed some redundant special-case code that generated
prototypes for foreign functions. The standard pprTempAndExternDecls
now generates them.

compiler/cmm/CLabel.hs

@@ -398,13 +398,13 @@ mkConEntryLabel name        c     = IdLabel name c ConEntry
 mkStaticConEntryLabel name  c     = IdLabel name c StaticConEntry
 
 -- Constructing Cmm Labels
-mkSplitMarkerLabel, mkDirty_MUT_VAR_Label, mkUpdInfoLabel,
+mkDirty_MUT_VAR_Label, mkSplitMarkerLabel, mkUpdInfoLabel,
     mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel,
     mkMAP_FROZEN_infoLabel, mkMAP_DIRTY_infoLabel,
     mkEMPTY_MVAR_infoLabel, mkTopTickyCtrLabel,
     mkCAFBlackHoleInfoTableLabel, mkCAFBlackHoleEntryLabel :: CLabel
+mkDirty_MUT_VAR_Label           = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction
 mkSplitMarkerLabel              = CmmLabel rtsPackageId (fsLit "__stg_split_marker")    CmmCode
-mkDirty_MUT_VAR_Label           = CmmLabel rtsPackageId (fsLit "dirty_MUT_VAR")         CmmCode
 mkUpdInfoLabel                  = CmmLabel rtsPackageId (fsLit "stg_upd_frame")         CmmInfo
 mkBHUpdInfoLabel                = CmmLabel rtsPackageId (fsLit "stg_bh_upd_frame" )     CmmInfo
 mkIndStaticInfoLabel            = CmmLabel rtsPackageId (fsLit "stg_IND_STATIC")        CmmInfo

compiler/cmm/CmmLayoutStack.hs

@@ -6,13 +6,13 @@ module CmmLayoutStack (
 import StgCmmUtils      ( callerSaveVolatileRegs ) -- XXX layering violation
 import StgCmmForeign    ( saveThreadState, loadThreadState ) -- XXX layering violation
 
+import BasicTypes
 import Cmm
 import CmmInfo
 import BlockId
 import CLabel
 import CmmUtils
 import MkGraph
-import Module
 import ForeignCall
 import CmmLive
 import CmmProcPoint
@@ -965,7 +965,7 @@ lowerSafeForeignCall dflags block
 
 
 foreignLbl :: FastString -> CmmExpr
-foreignLbl name = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId name))
+foreignLbl name = CmmLit (CmmLabel (mkForeignLabel name Nothing ForeignLabelInExternalPackage IsFunction))
 
 newTemp :: CmmType -> UniqSM LocalReg
 newTemp rep = getUniqueM >>= \u -> return (LocalReg u rep)

compiler/cmm/CmmParse.y

@@ -557,7 +557,7 @@ stmt    :: { CmmParse () }
         -- we tweak the syntax to avoid the conflict.  The later
         -- option is taken here because the other way would require
         -- multiple levels of expanding and get unwieldy.
-        | foreign_results 'foreign' STRING expr '(' cmm_hint_exprs0 ')' safety opt_never_returns ';'
+        | foreign_results 'foreign' STRING foreignLabel '(' cmm_hint_exprs0 ')' safety opt_never_returns ';'
                 {% foreignCall $3 $1 $4 $6 $8 $9 }
         | foreign_results 'prim' '%' NAME '(' exprs0 ')' ';'
                 {% primCall $1 $4 $6 }
@@ -588,6 +588,9 @@ stmt    :: { CmmParse () }
         | 'push' '(' exprs0 ')' maybe_body
                 { pushStackFrame $3 $5 }
 
+foreignLabel     :: { CmmParse CmmExpr }
+        : NAME                          { return (CmmLit (CmmLabel (mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction))) }
+
 opt_never_returns :: { CmmReturnInfo }
         :                               { CmmMayReturn }
         | 'never' 'returns'             { CmmNeverReturns }

compiler/cmm/PprC.hs

@@ -189,7 +189,6 @@ pprStmt stmt =
           rep = cmmExprType dflags src
 
     CmmUnsafeForeignCall target@(ForeignTarget fn conv) results args ->
-        maybe_proto $$
         fnCall
         where
         (res_hints, arg_hints) = foreignTargetHints target
@@ -200,40 +199,29 @@ pprStmt stmt =
 
         cast_fn = parens (cCast (pprCFunType (char '*') cconv hresults hargs) fn)
 
-        real_fun_proto lbl = char ';' <>
-                        pprCFunType (ppr lbl) cconv hresults hargs <>
-                        noreturn_attr <> semi
-
-        noreturn_attr = case ret of
-                          CmmNeverReturns -> text "__attribute__ ((noreturn))"
-                          CmmMayReturn    -> empty
-
         -- See wiki:Commentary/Compiler/Backends/PprC#Prototypes
-        (maybe_proto, fnCall) =
+        fnCall =
             case fn of
               CmmLit (CmmLabel lbl)
                 | StdCallConv <- cconv ->
-                    let myCall = pprCall (ppr lbl) cconv hresults hargs
-                    in (real_fun_proto lbl, myCall)
+                    pprCall (ppr lbl) cconv hresults hargs
                         -- stdcall functions must be declared with
                         -- a function type, otherwise the C compiler
                         -- doesn't add the @n suffix to the label.  We
                         -- can't add the @n suffix ourselves, because
                         -- it isn't valid C.
                 | CmmNeverReturns <- ret ->
-                    let myCall = pprCall (ppr lbl) cconv hresults hargs
-                    in (real_fun_proto lbl, myCall)
+                    pprCall cast_fn cconv hresults hargs <> semi
                 | not (isMathFun lbl) ->
                     pprForeignCall (ppr lbl) cconv hresults hargs
               _ ->
-                   (empty {- no proto -},
-                    pprCall cast_fn cconv hresults hargs <> semi)
+                    pprCall cast_fn cconv hresults hargs <> semi
                         -- for a dynamic call, no declaration is necessary.
 
     CmmUnsafeForeignCall (PrimTarget MO_Touch) _results _args -> empty
 
     CmmUnsafeForeignCall target@(PrimTarget op) results args ->
-        proto $$ fn_call
+        fn_call
       where
         cconv = CCallConv
         fn = pprCallishMachOp_for_C op
@@ -242,15 +230,16 @@ pprStmt stmt =
         hresults = zip results res_hints
         hargs    = zip args arg_hints
 
-        (proto, fn_call)
+        fn_call
           -- The mem primops carry an extra alignment arg, must drop it.
           -- We could maybe emit an alignment directive using this info.
           -- We also need to cast mem primops to prevent conflicts with GCC
           -- builtins (see bug #5967).
           | op `elem` [MO_Memcpy, MO_Memset, MO_Memmove]
-          = pprForeignCall fn cconv hresults (init hargs)
+          = (ptext (sLit ";EF_(") <> fn <> char ')' <> semi) $$
+            pprForeignCall fn cconv hresults (init hargs)
           | otherwise
-          = (empty, pprCall fn cconv hresults hargs)
+          = pprCall fn cconv hresults hargs
 
     CmmBranch ident          -> pprBranch ident
     CmmCondBranch expr yes no -> pprCondBranch expr yes no
@@ -263,8 +252,8 @@ pprStmt stmt =
 type Hinted a = (a, ForeignHint)
 
 pprForeignCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual]
-               -> (SDoc, SDoc)
-pprForeignCall fn cconv results args = (proto, fn_call)
+               -> SDoc
+pprForeignCall fn cconv results args = fn_call
   where
     fn_call = braces (
                  pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi
@@ -272,7 +261,6 @@ pprForeignCall fn cconv results args = (proto, fn_call)
               $$ pprCall (text "ghcFunPtr") cconv results args <> semi
              )
     cast_fn = parens (parens (pprCFunType (char '*') cconv results args) <> fn)
-    proto = ptext (sLit ";EF_(") <> fn <> char ')' <> semi
 
 pprCFunType :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc
 pprCFunType ppr_fn cconv ress args

compiler/codeGen/StgCmmBind.hs

@@ -731,7 +731,7 @@ link_caf node _is_upd = do
         -- This must be done *before* the info table pointer is overwritten,
         -- because the old info table ptr is needed for reversion
   ; ret <- newTemp (bWord dflags)
-  ; emitRtsCallGen [(ret,NoHint)] rtsPackageId (fsLit "newCAF")
+  ; emitRtsCallGen [(ret,NoHint)] (mkForeignLabel (fsLit "newCAF") Nothing ForeignLabelInExternalPackage IsFunction)
       [ (CmmReg (CmmGlobal BaseReg),  AddrHint),
         (CmmReg (CmmLocal node), AddrHint),
         (hp_rel, AddrHint) ]

compiler/codeGen/StgCmmPrim.hs

@@ -36,7 +36,6 @@ import CLabel
 import CmmUtils
 import PrimOp
 import SMRep
-import Module
 import FastString
 import Outputable
 import Util
@@ -214,7 +213,7 @@ emitPrimOp _ [res] ParOp [arg]
         -- later, we might want to inline it.
     emitCCall
         [(res,NoHint)]
-        (CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark"))))
+        (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))
         [(CmmReg (CmmGlobal BaseReg), AddrHint), (arg,AddrHint)]
 
 emitPrimOp dflags [res] SparkOp [arg]
@@ -226,7 +225,7 @@ emitPrimOp dflags [res] SparkOp [arg]
         tmp2 <- newTemp (bWord dflags)
         emitCCall
             [(tmp2,NoHint)]
-            (CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark"))))
+            (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))
             [(CmmReg (CmmGlobal BaseReg), AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)]
         emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp))
 

compiler/codeGen/StgCmmUtils.hs

@@ -173,22 +173,21 @@ tagToClosure dflags tycon tag
 -------------------------------------------------------------------------
 
 emitRtsCall :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
-emitRtsCall pkg fun args safe = emitRtsCallGen [] pkg fun args safe
+emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe
 
 emitRtsCallWithResult :: LocalReg -> ForeignHint -> PackageId -> FastString
         -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
 emitRtsCallWithResult res hint pkg fun args safe
-   = emitRtsCallGen [(res,hint)] pkg fun args safe
+   = emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe
 
 -- Make a call to an RTS C procedure
 emitRtsCallGen
    :: [(LocalReg,ForeignHint)]
-   -> PackageId
-   -> FastString
+   -> CLabel
    -> [(CmmExpr,ForeignHint)]
    -> Bool -- True <=> CmmSafe call
    -> FCode ()
-emitRtsCallGen res pkg fun args safe
+emitRtsCallGen res lbl args safe
   = do { dflags <- getDynFlags
        ; updfr_off <- getUpdFrameOff
        ; let (caller_save, caller_load) = callerSaveVolatileRegs dflags
@@ -204,7 +203,7 @@ emitRtsCallGen res pkg fun args safe
         emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args'
     (args', arg_hints) = unzip args
     (res',  res_hints) = unzip res
-    fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun)
+    fun_expr = mkLblExpr lbl
 
 
 -----------------------------------------------------------------------------