When generating C, don't pretend functions are data

We used to generated things like:
    extern StgWordArray (newCAF) __attribute__((aligned (8)));
    ((void (*)(void *))(W_)&newCAF)((void *)R1.w);
(which is to say, pretend that newCAF is some data, then cast it to a
function and call it).
This goes wrong on at least IA64, where:
    A function pointer on the ia64 does not point to the first byte of
    code. Intsead, it points to a structure that describes the function.
    The first quadword in the structure is the address of the first byte
    of code
so we end up dereferencing function pointers one time too many, and
segfaulting.

5 files changed, 47 insertions, 34 deletions

diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index aa72b65243..2501b6ebed 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -119,6 +119,8 @@ module CLabel (
 
 import IdInfo
 import StaticFlags
+import BasicTypes
+import Literal
 import Packages
 import DataCon
 import PackageConfig
@@ -193,11 +195,12 @@ data CLabel
 
   | RtsLabel RtsLabelInfo
 
-  | ForeignLabel FastString	-- a 'C' (or otherwise foreign) label
-	(Maybe Int) 		-- possible '@n' suffix for stdcall functions
-		-- When generating C, the '@n' suffix is omitted, but when
-		-- generating assembler we must add it to the label.
-	Bool			-- True <=> is dynamic
+  | ForeignLabel FastString     -- a 'C' (or otherwise foreign) label
+        (Maybe Int)             -- possible '@n' suffix for stdcall functions
+                -- When generating C, the '@n' suffix is omitted, but when
+                -- generating assembler we must add it to the label.
+        Bool                    -- True <=> is dynamic
+        FunctionOrData
 
   | CC_Label  CostCentre
   | CCS_Label CostCentreStack
@@ -373,17 +376,18 @@ mkApEntryLabel upd off		= RtsLabel (RtsApEntry   upd off)
 
 	-- Foreign labels
 
-mkForeignLabel :: FastString -> Maybe Int -> Bool -> CLabel
-mkForeignLabel str mb_sz  is_dynamic = ForeignLabel str mb_sz is_dynamic
+mkForeignLabel :: FastString -> Maybe Int -> Bool -> FunctionOrData -> CLabel
+mkForeignLabel str mb_sz is_dynamic fod
+    = ForeignLabel str mb_sz is_dynamic fod
 
 addLabelSize :: CLabel -> Int -> CLabel
-addLabelSize (ForeignLabel str _ is_dynamic) sz
-  = ForeignLabel str (Just sz) is_dynamic
+addLabelSize (ForeignLabel str _ is_dynamic fod) sz
+  = ForeignLabel str (Just sz) is_dynamic fod
 addLabelSize label _
   = label
 
 foreignLabelStdcallInfo :: CLabel -> Maybe Int
-foreignLabelStdcallInfo (ForeignLabel _ info _) = info
+foreignLabelStdcallInfo (ForeignLabel _ info _ _) = info
 foreignLabelStdcallInfo _lbl = Nothing
 
 	-- Cost centres etc.
@@ -498,7 +502,7 @@ needsCDecl ModuleRegdLabel		= False
 needsCDecl (StringLitLabel _)		= False
 needsCDecl (AsmTempLabel _)		= False
 needsCDecl (RtsLabel _)			= False
-needsCDecl l@(ForeignLabel _ _ _)	= not (isMathFun l)
+needsCDecl l@(ForeignLabel _ _ _ _)	= not (isMathFun l)
 needsCDecl (CC_Label _)			= True
 needsCDecl (CCS_Label _)		= True
 needsCDecl (HpcTicksLabel _)            = True
@@ -518,7 +522,7 @@ maybeAsmTemp _ 	    	       = Nothing
 -- they are builtin to the C compiler.  For these labels we avoid
 -- generating our own C prototypes.
 isMathFun :: CLabel -> Bool
-isMathFun (ForeignLabel fs _ _) = fs `elem` math_funs
+isMathFun (ForeignLabel fs _ _ _) = fs `elem` math_funs
   where
   math_funs = [
         (fsLit "pow"),    (fsLit "sin"),   (fsLit "cos"),
@@ -557,7 +561,7 @@ externallyVisibleCLabel (PlainModuleInitLabel _)= True
 externallyVisibleCLabel (ModuleInitTableLabel _)= False
 externallyVisibleCLabel ModuleRegdLabel    = False
 externallyVisibleCLabel (RtsLabel _)	   = True
-externallyVisibleCLabel (ForeignLabel _ _ _) = True
+externallyVisibleCLabel (ForeignLabel _ _ _ _) = True
 externallyVisibleCLabel (IdLabel name _ _)     = isExternalName name
 externallyVisibleCLabel (CC_Label _)	   = True
 externallyVisibleCLabel (CCS_Label _)	   = True
@@ -611,6 +615,7 @@ labelType (PlainModuleInitLabel _)            = CodeLabel
 labelType (ModuleInitTableLabel _)            = DataLabel
 labelType (LargeSRTLabel _)                   = DataLabel
 labelType (LargeBitmapLabel _)                = DataLabel
+labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel
 labelType (IdLabel _ _ info) = idInfoLabelType info
 labelType _                = DataLabel
 
@@ -639,11 +644,11 @@ labelDynamic this_pkg lbl =
    RtsLabel _  	     -> not opt_Static && (this_pkg /= rtsPackageId) -- i.e., is the RTS in a DLL or not?
    IdLabel n _ k       -> isDllName this_pkg n
 #if mingw32_TARGET_OS
-   ForeignLabel _ _ d  -> d
+   ForeignLabel _ _ d _ -> d
 #else
    -- On Mac OS X and on ELF platforms, false positives are OK,
    -- so we claim that all foreign imports come from dynamic libraries
-   ForeignLabel _ _ _ -> True
+   ForeignLabel _ _ _ _ -> True
 #endif
    ModuleInitLabel m _    -> not opt_Static && this_pkg /= (modulePackageId m)
    PlainModuleInitLabel m -> not opt_Static && this_pkg /= (modulePackageId m)
@@ -738,7 +743,7 @@ maybe_underscore doc
 #ifdef mingw32_TARGET_OS
 -- In asm mode, we need to put the suffix on a stdcall ForeignLabel.
 -- (The C compiler does this itself).
-pprAsmCLbl (ForeignLabel fs (Just sz) _)
+pprAsmCLbl (ForeignLabel fs (Just sz) _ _)
    = ftext fs <> char '@' <> int sz
 #endif
 pprAsmCLbl lbl
@@ -832,7 +837,7 @@ pprCLbl (RtsLabel (RtsSlowTickyCtr pat))
 pprCLbl ModuleRegdLabel
   = ptext (sLit "_module_registered")
 
-pprCLbl (ForeignLabel str _ _)
+pprCLbl (ForeignLabel str _ _ _)
   = ftext str
 
 pprCLbl (IdLabel name cafs flavor) = ppr name <> ppIdFlavor flavor
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 180aad62ea..e488a669b0 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -52,6 +52,7 @@ import FastString
 import Panic
 import Constants
 import Outputable
+import BasicTypes
 import Bag              ( emptyBag, unitBag )
 
 import Control.Monad
@@ -202,7 +203,7 @@ static 	:: { ExtFCode [CmmStatic] }
 	| 'CLOSURE' '(' NAME lits ')'
 		{ do lits <- sequence $4;
 		     return $ map CmmStaticLit $
-                       mkStaticClosure (mkForeignLabel $3 Nothing True)
+                       mkStaticClosure (mkForeignLabel $3 Nothing True IsFunction)
                          -- mkForeignLabel because these are only used
                          -- for CHARLIKE and INTLIKE closures in the RTS.
 			 dontCareCCS (map getLit lits) [] [] [] }
@@ -824,7 +825,7 @@ newLocal ty name = do
 -- PIC code for them.
 newImport :: FastString -> ExtFCode ()
 newImport name
-   = addVarDecl name (CmmLit (CmmLabel (mkForeignLabel name Nothing True)))
+   = addVarDecl name (CmmLit (CmmLabel (mkForeignLabel name Nothing True IsFunction)))
 
 newLabel :: FastString -> ExtFCode BlockId
 newLabel name = do
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 665122e224..04aa9e90ca 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -49,6 +49,8 @@ import UniqFM
 import FastString
 import Outputable
 import Constants
+import BasicTypes
+import CLabel
 
 -- The rest
 import Data.List
@@ -213,7 +215,7 @@ pprStmt stmt = case stmt of
 
     CmmCall (CmmCallee fn cconv) results args safety ret ->
         maybe_proto $$
-	pprCall ppr_fn cconv results args safety
+	fnCall
 	where
         cast_fn = parens (cCast (pprCFunType (char '*') cconv results args) fn)
 
@@ -221,7 +223,7 @@ pprStmt stmt = case stmt of
                         pprCFunType (pprCLabel lbl) cconv results args <> 
                         noreturn_attr <> semi
 
-        data_proto lbl = ptext (sLit ";EI_(") <> 
+        fun_proto lbl = ptext (sLit ";EF_(") <>
                          pprCLabel lbl <> char ')' <> semi
 
         noreturn_attr = case ret of
@@ -229,24 +231,27 @@ pprStmt stmt = case stmt of
                           CmmMayReturn    -> empty
 
         -- See wiki:Commentary/Compiler/Backends/PprC#Prototypes
-    	(maybe_proto, ppr_fn) = 
+    	(maybe_proto, fnCall) = 
             case fn of
 	      CmmLit (CmmLabel lbl) 
-                | StdCallConv <- cconv -> (real_fun_proto lbl, pprCLabel lbl)
+                | StdCallConv <- cconv ->
+                    let myCall = pprCall (pprCLabel lbl) cconv results args safety
+                    in (real_fun_proto lbl, myCall)
                         -- 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 -> (real_fun_proto lbl, pprCLabel lbl)
-                | not (isMathFun lbl) -> (data_proto lbl, cast_fn)
-                        -- we declare all other called functions as
-                        -- data labels, and then cast them to the
-                        -- right type when calling.  This is because
-                        -- the label might already have a declaration
-                        -- as a data label in the same file,
-                        -- e.g. Foreign.Marshal.Alloc declares 'free'
-                        -- as both a data label and a function label.
+                | CmmNeverReturns <- ret ->
+                    let myCall = pprCall (pprCLabel lbl) cconv results args safety
+                    in (real_fun_proto lbl, myCall)
+                | not (isMathFun lbl) ->
+                    let myCall = braces (
+                                     pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi
+                                  $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi
+                                  $$ pprCall (text "ghcFunPtr") cconv results args safety <> semi
+                                 )
+                    in (fun_proto lbl, myCall)
 	      _ -> 
                    (empty {- no proto -}, cast_fn)
 			-- for a dynamic call, no declaration is necessary.
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index a9e00fc0ae..504098891a 100644
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -42,6 +42,7 @@ import BlockId
 import Cmm
 import CmmUtils
 import CLabel
+import BasicTypes
 
 
 import ForeignCall
@@ -275,7 +276,7 @@ pprStmt stmt = case stmt of
         pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv)
                         results args safety ret)
         where
-          lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
+          lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False IsFunction)
 
     CmmBranch ident          -> genBranch ident
     CmmCondBranch expr ident -> genCondBranch expr ident
diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs
index 43e310c80c..453b8f0e9f 100644
--- a/compiler/cmm/ZipCfgCmmRep.hs
+++ b/compiler/cmm/ZipCfgCmmRep.hs
@@ -35,6 +35,7 @@ import ZipCfg
 import MkZipCfg
 import Util
 
+import BasicTypes
 import Maybes
 import Monad
 import Outputable
@@ -460,7 +461,7 @@ ppr_safety Unsafe         = text "unsafe"
 
 ppr_call_target :: MidCallTarget -> SDoc
 ppr_call_target (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
-ppr_call_target (PrimTarget op)      = ppr (CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False))
+ppr_call_target (PrimTarget op)      = ppr (CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False IsFunction))
 
 ppr_target :: CmmExpr -> SDoc
 ppr_target t@(CmmLit _) = ppr t