In CMM, only allow foreign calls to labels, not arbitrary expressions
authorIan Lynagh <ian@well-typed.com>
Tue, 23 Apr 2013 19:53:06 +0000 (20:53 +0100)
committerIan Lynagh <ian@well-typed.com>
Wed, 24 Apr 2013 00:06:33 +0000 (01:06 +0100)
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
compiler/cmm/CmmLayoutStack.hs
compiler/cmm/CmmParse.y
compiler/cmm/PprC.hs
compiler/codeGen/StgCmmBind.hs
compiler/codeGen/StgCmmPrim.hs
compiler/codeGen/StgCmmUtils.hs

index 8fe8c3c..a2830b9 100644 (file)
@@ -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
index a48d487..acec31b 100644 (file)
@@ -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)
index cb3bf0c..43fe88d 100644 (file)
@@ -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 }
index 45c415f..00ba7ac 100644 (file)
@@ -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
index 1e5d6b9..c070e80 100644 (file)
@@ -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) ]
index fb5acde..54002e8 100644 (file)
@@ -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))
 
index 3df75ce..45b0f0c 100644 (file)
@@ -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
 
 
 -----------------------------------------------------------------------------