Commit 497302c4 authored by Ian Lynagh's avatar Ian Lynagh

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.
parent 1353826e
...@@ -19,6 +19,8 @@ module BasicTypes( ...@@ -19,6 +19,8 @@ module BasicTypes(
Arity, Arity,
FunctionOrData(..),
WarningTxt(..), WarningTxt(..),
Fixity(..), FixityDirection(..), Fixity(..), FixityDirection(..),
...@@ -72,6 +74,21 @@ import Outputable ...@@ -72,6 +74,21 @@ import Outputable
type Arity = Int type Arity = Int
\end{code} \end{code}
%************************************************************************
%* *
\subsection[FunctionOrData]{FunctionOrData}
%* *
%************************************************************************
\begin{code}
data FunctionOrData = IsFunction | IsData
deriving (Eq, Ord)
instance Outputable FunctionOrData where
ppr IsFunction = text "(function)"
ppr IsData = text "(data)"
\end{code}
%************************************************************************ %************************************************************************
%* * %* *
......
...@@ -48,6 +48,7 @@ import Type ...@@ -48,6 +48,7 @@ import Type
import Outputable import Outputable
import FastTypes import FastTypes
import FastString import FastString
import BasicTypes
import Binary import Binary
import Ratio import Ratio
...@@ -121,7 +122,9 @@ data Literal ...@@ -121,7 +122,9 @@ data Literal
| MachDouble Rational -- ^ @Double#@. Create with 'mkMachDouble' | MachDouble Rational -- ^ @Double#@. Create with 'mkMachDouble'
| MachLabel FastString | MachLabel FastString
(Maybe Int) -- ^ A label literal. Parameters: (Maybe Int)
FunctionOrData
-- ^ A label literal. Parameters:
-- --
-- 1) The name of the symbol mentioned in the declaration -- 1) The name of the symbol mentioned in the declaration
-- --
...@@ -144,7 +147,11 @@ instance Binary Literal where ...@@ -144,7 +147,11 @@ instance Binary Literal where
put_ bh (MachWord64 ag) = do putByte bh 6; put_ bh ag put_ bh (MachWord64 ag) = do putByte bh 6; put_ bh ag
put_ bh (MachFloat ah) = do putByte bh 7; put_ bh ah put_ bh (MachFloat ah) = do putByte bh 7; put_ bh ah
put_ bh (MachDouble ai) = do putByte bh 8; put_ bh ai put_ bh (MachDouble ai) = do putByte bh 8; put_ bh ai
put_ bh (MachLabel aj mb) = do putByte bh 9; put_ bh aj ; put_ bh mb put_ bh (MachLabel aj mb fod)
= do putByte bh 9
put_ bh aj
put_ bh mb
put_ bh fod
get bh = do get bh = do
h <- getByte bh h <- getByte bh
case h of case h of
...@@ -177,7 +184,8 @@ instance Binary Literal where ...@@ -177,7 +184,8 @@ instance Binary Literal where
9 -> do 9 -> do
aj <- get bh aj <- get bh
mb <- get bh mb <- get bh
return (MachLabel aj mb) fod <- get bh
return (MachLabel aj mb fod)
\end{code} \end{code}
\begin{code} \begin{code}
...@@ -349,7 +357,7 @@ literalType (MachInt64 _) = int64PrimTy ...@@ -349,7 +357,7 @@ literalType (MachInt64 _) = int64PrimTy
literalType (MachWord64 _) = word64PrimTy literalType (MachWord64 _) = word64PrimTy
literalType (MachFloat _) = floatPrimTy literalType (MachFloat _) = floatPrimTy
literalType (MachDouble _) = doublePrimTy literalType (MachDouble _) = doublePrimTy
literalType (MachLabel _ _) = addrPrimTy literalType (MachLabel _ _ _) = addrPrimTy
\end{code} \end{code}
...@@ -366,7 +374,7 @@ cmpLit (MachInt64 a) (MachInt64 b) = a `compare` b ...@@ -366,7 +374,7 @@ cmpLit (MachInt64 a) (MachInt64 b) = a `compare` b
cmpLit (MachWord64 a) (MachWord64 b) = a `compare` b cmpLit (MachWord64 a) (MachWord64 b) = a `compare` b
cmpLit (MachFloat a) (MachFloat b) = a `compare` b cmpLit (MachFloat a) (MachFloat b) = a `compare` b
cmpLit (MachDouble a) (MachDouble b) = a `compare` b cmpLit (MachDouble a) (MachDouble b) = a `compare` b
cmpLit (MachLabel a _) (MachLabel b _) = a `compare` b cmpLit (MachLabel a _ _) (MachLabel b _ _) = a `compare` b
cmpLit lit1 lit2 | litTag lit1 <# litTag lit2 = LT cmpLit lit1 lit2 | litTag lit1 <# litTag lit2 = LT
| otherwise = GT | otherwise = GT
...@@ -380,7 +388,7 @@ litTag (MachInt64 _) = _ILIT(6) ...@@ -380,7 +388,7 @@ litTag (MachInt64 _) = _ILIT(6)
litTag (MachWord64 _) = _ILIT(7) litTag (MachWord64 _) = _ILIT(7)
litTag (MachFloat _) = _ILIT(8) litTag (MachFloat _) = _ILIT(8)
litTag (MachDouble _) = _ILIT(9) litTag (MachDouble _) = _ILIT(9)
litTag (MachLabel _ _) = _ILIT(10) litTag (MachLabel _ _ _) = _ILIT(10)
\end{code} \end{code}
Printing Printing
...@@ -399,8 +407,8 @@ pprLit (MachWord64 w) = ptext (sLit "__word64") <+> integer w ...@@ -399,8 +407,8 @@ pprLit (MachWord64 w) = ptext (sLit "__word64") <+> integer w
pprLit (MachFloat f) = ptext (sLit "__float") <+> rational f pprLit (MachFloat f) = ptext (sLit "__float") <+> rational f
pprLit (MachDouble d) = rational d pprLit (MachDouble d) = rational d
pprLit (MachNullAddr) = ptext (sLit "__NULL") pprLit (MachNullAddr) = ptext (sLit "__NULL")
pprLit (MachLabel l mb) = ptext (sLit "__label") <+> pprLit (MachLabel l mb fod) = ptext (sLit "__label") <+> b <+> ppr fod
case mb of where b = case mb of
Nothing -> pprHsString l Nothing -> pprHsString l
Just x -> doubleQuotes (text (unpackFS l ++ '@':show x)) Just x -> doubleQuotes (text (unpackFS l ++ '@':show x))
...@@ -431,7 +439,7 @@ hashLiteral (MachWord i) = hashInteger i ...@@ -431,7 +439,7 @@ hashLiteral (MachWord i) = hashInteger i
hashLiteral (MachWord64 i) = hashInteger i hashLiteral (MachWord64 i) = hashInteger i
hashLiteral (MachFloat r) = hashRational r hashLiteral (MachFloat r) = hashRational r
hashLiteral (MachDouble r) = hashRational r hashLiteral (MachDouble r) = hashRational r
hashLiteral (MachLabel s _) = hashFS s hashLiteral (MachLabel s _ _) = hashFS s
hashRational :: Rational -> Int hashRational :: Rational -> Int
hashRational r = hashInteger (numerator r) hashRational r = hashInteger (numerator r)
......
...@@ -119,6 +119,8 @@ module CLabel ( ...@@ -119,6 +119,8 @@ module CLabel (
import IdInfo import IdInfo
import StaticFlags import StaticFlags
import BasicTypes
import Literal
import Packages import Packages
import DataCon import DataCon
import PackageConfig import PackageConfig
...@@ -198,6 +200,7 @@ data CLabel ...@@ -198,6 +200,7 @@ data CLabel
-- When generating C, the '@n' suffix is omitted, but when -- When generating C, the '@n' suffix is omitted, but when
-- generating assembler we must add it to the label. -- generating assembler we must add it to the label.
Bool -- True <=> is dynamic Bool -- True <=> is dynamic
FunctionOrData
| CC_Label CostCentre | CC_Label CostCentre
| CCS_Label CostCentreStack | CCS_Label CostCentreStack
...@@ -373,17 +376,18 @@ mkApEntryLabel upd off = RtsLabel (RtsApEntry upd off) ...@@ -373,17 +376,18 @@ mkApEntryLabel upd off = RtsLabel (RtsApEntry upd off)
-- Foreign labels -- Foreign labels
mkForeignLabel :: FastString -> Maybe Int -> Bool -> CLabel mkForeignLabel :: FastString -> Maybe Int -> Bool -> FunctionOrData -> CLabel
mkForeignLabel str mb_sz is_dynamic = ForeignLabel str mb_sz is_dynamic mkForeignLabel str mb_sz is_dynamic fod
= ForeignLabel str mb_sz is_dynamic fod
addLabelSize :: CLabel -> Int -> CLabel addLabelSize :: CLabel -> Int -> CLabel
addLabelSize (ForeignLabel str _ is_dynamic) sz addLabelSize (ForeignLabel str _ is_dynamic fod) sz
= ForeignLabel str (Just sz) is_dynamic = ForeignLabel str (Just sz) is_dynamic fod
addLabelSize label _ addLabelSize label _
= label = label
foreignLabelStdcallInfo :: CLabel -> Maybe Int foreignLabelStdcallInfo :: CLabel -> Maybe Int
foreignLabelStdcallInfo (ForeignLabel _ info _) = info foreignLabelStdcallInfo (ForeignLabel _ info _ _) = info
foreignLabelStdcallInfo _lbl = Nothing foreignLabelStdcallInfo _lbl = Nothing
-- Cost centres etc. -- Cost centres etc.
...@@ -498,7 +502,7 @@ needsCDecl ModuleRegdLabel = False ...@@ -498,7 +502,7 @@ needsCDecl ModuleRegdLabel = False
needsCDecl (StringLitLabel _) = False needsCDecl (StringLitLabel _) = False
needsCDecl (AsmTempLabel _) = False needsCDecl (AsmTempLabel _) = False
needsCDecl (RtsLabel _) = False needsCDecl (RtsLabel _) = False
needsCDecl l@(ForeignLabel _ _ _) = not (isMathFun l) needsCDecl l@(ForeignLabel _ _ _ _) = not (isMathFun l)
needsCDecl (CC_Label _) = True needsCDecl (CC_Label _) = True
needsCDecl (CCS_Label _) = True needsCDecl (CCS_Label _) = True
needsCDecl (HpcTicksLabel _) = True needsCDecl (HpcTicksLabel _) = True
...@@ -518,7 +522,7 @@ maybeAsmTemp _ = Nothing ...@@ -518,7 +522,7 @@ maybeAsmTemp _ = Nothing
-- they are builtin to the C compiler. For these labels we avoid -- they are builtin to the C compiler. For these labels we avoid
-- generating our own C prototypes. -- generating our own C prototypes.
isMathFun :: CLabel -> Bool isMathFun :: CLabel -> Bool
isMathFun (ForeignLabel fs _ _) = fs `elem` math_funs isMathFun (ForeignLabel fs _ _ _) = fs `elem` math_funs
where where
math_funs = [ math_funs = [
(fsLit "pow"), (fsLit "sin"), (fsLit "cos"), (fsLit "pow"), (fsLit "sin"), (fsLit "cos"),
...@@ -557,7 +561,7 @@ externallyVisibleCLabel (PlainModuleInitLabel _)= True ...@@ -557,7 +561,7 @@ externallyVisibleCLabel (PlainModuleInitLabel _)= True
externallyVisibleCLabel (ModuleInitTableLabel _)= False externallyVisibleCLabel (ModuleInitTableLabel _)= False
externallyVisibleCLabel ModuleRegdLabel = False externallyVisibleCLabel ModuleRegdLabel = False
externallyVisibleCLabel (RtsLabel _) = True externallyVisibleCLabel (RtsLabel _) = True
externallyVisibleCLabel (ForeignLabel _ _ _) = True externallyVisibleCLabel (ForeignLabel _ _ _ _) = True
externallyVisibleCLabel (IdLabel name _ _) = isExternalName name externallyVisibleCLabel (IdLabel name _ _) = isExternalName name
externallyVisibleCLabel (CC_Label _) = True externallyVisibleCLabel (CC_Label _) = True
externallyVisibleCLabel (CCS_Label _) = True externallyVisibleCLabel (CCS_Label _) = True
...@@ -611,6 +615,7 @@ labelType (PlainModuleInitLabel _) = CodeLabel ...@@ -611,6 +615,7 @@ labelType (PlainModuleInitLabel _) = CodeLabel
labelType (ModuleInitTableLabel _) = DataLabel labelType (ModuleInitTableLabel _) = DataLabel
labelType (LargeSRTLabel _) = DataLabel labelType (LargeSRTLabel _) = DataLabel
labelType (LargeBitmapLabel _) = DataLabel labelType (LargeBitmapLabel _) = DataLabel
labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel
labelType (IdLabel _ _ info) = idInfoLabelType info labelType (IdLabel _ _ info) = idInfoLabelType info
labelType _ = DataLabel labelType _ = DataLabel
...@@ -639,11 +644,11 @@ labelDynamic this_pkg lbl = ...@@ -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? RtsLabel _ -> not opt_Static && (this_pkg /= rtsPackageId) -- i.e., is the RTS in a DLL or not?
IdLabel n _ k -> isDllName this_pkg n IdLabel n _ k -> isDllName this_pkg n
#if mingw32_TARGET_OS #if mingw32_TARGET_OS
ForeignLabel _ _ d -> d ForeignLabel _ _ d _ -> d
#else #else
-- On Mac OS X and on ELF platforms, false positives are OK, -- On Mac OS X and on ELF platforms, false positives are OK,
-- so we claim that all foreign imports come from dynamic libraries -- so we claim that all foreign imports come from dynamic libraries
ForeignLabel _ _ _ -> True ForeignLabel _ _ _ _ -> True
#endif #endif
ModuleInitLabel m _ -> not opt_Static && this_pkg /= (modulePackageId m) ModuleInitLabel m _ -> not opt_Static && this_pkg /= (modulePackageId m)
PlainModuleInitLabel m -> not opt_Static && this_pkg /= (modulePackageId m) PlainModuleInitLabel m -> not opt_Static && this_pkg /= (modulePackageId m)
...@@ -738,7 +743,7 @@ maybe_underscore doc ...@@ -738,7 +743,7 @@ maybe_underscore doc
#ifdef mingw32_TARGET_OS #ifdef mingw32_TARGET_OS
-- In asm mode, we need to put the suffix on a stdcall ForeignLabel. -- In asm mode, we need to put the suffix on a stdcall ForeignLabel.
-- (The C compiler does this itself). -- (The C compiler does this itself).
pprAsmCLbl (ForeignLabel fs (Just sz) _) pprAsmCLbl (ForeignLabel fs (Just sz) _ _)
= ftext fs <> char '@' <> int sz = ftext fs <> char '@' <> int sz
#endif #endif
pprAsmCLbl lbl pprAsmCLbl lbl
...@@ -832,7 +837,7 @@ pprCLbl (RtsLabel (RtsSlowTickyCtr pat)) ...@@ -832,7 +837,7 @@ pprCLbl (RtsLabel (RtsSlowTickyCtr pat))
pprCLbl ModuleRegdLabel pprCLbl ModuleRegdLabel
= ptext (sLit "_module_registered") = ptext (sLit "_module_registered")
pprCLbl (ForeignLabel str _ _) pprCLbl (ForeignLabel str _ _ _)
= ftext str = ftext str
pprCLbl (IdLabel name cafs flavor) = ppr name <> ppIdFlavor flavor pprCLbl (IdLabel name cafs flavor) = ppr name <> ppIdFlavor flavor
......
...@@ -52,6 +52,7 @@ import FastString ...@@ -52,6 +52,7 @@ import FastString
import Panic import Panic
import Constants import Constants
import Outputable import Outputable
import BasicTypes
import Bag ( emptyBag, unitBag ) import Bag ( emptyBag, unitBag )
import Control.Monad import Control.Monad
...@@ -202,7 +203,7 @@ static :: { ExtFCode [CmmStatic] } ...@@ -202,7 +203,7 @@ static :: { ExtFCode [CmmStatic] }
| 'CLOSURE' '(' NAME lits ')' | 'CLOSURE' '(' NAME lits ')'
{ do lits <- sequence $4; { do lits <- sequence $4;
return $ map CmmStaticLit $ return $ map CmmStaticLit $
mkStaticClosure (mkForeignLabel $3 Nothing True) mkStaticClosure (mkForeignLabel $3 Nothing True IsFunction)
-- mkForeignLabel because these are only used -- mkForeignLabel because these are only used
-- for CHARLIKE and INTLIKE closures in the RTS. -- for CHARLIKE and INTLIKE closures in the RTS.
dontCareCCS (map getLit lits) [] [] [] } dontCareCCS (map getLit lits) [] [] [] }
...@@ -824,7 +825,7 @@ newLocal ty name = do ...@@ -824,7 +825,7 @@ newLocal ty name = do
-- PIC code for them. -- PIC code for them.
newImport :: FastString -> ExtFCode () newImport :: FastString -> ExtFCode ()
newImport name newImport name
= addVarDecl name (CmmLit (CmmLabel (mkForeignLabel name Nothing True))) = addVarDecl name (CmmLit (CmmLabel (mkForeignLabel name Nothing True IsFunction)))
newLabel :: FastString -> ExtFCode BlockId newLabel :: FastString -> ExtFCode BlockId
newLabel name = do newLabel name = do
......
...@@ -49,6 +49,8 @@ import UniqFM ...@@ -49,6 +49,8 @@ import UniqFM
import FastString import FastString
import Outputable import Outputable
import Constants import Constants
import BasicTypes
import CLabel
-- The rest -- The rest
import Data.List import Data.List
...@@ -213,7 +215,7 @@ pprStmt stmt = case stmt of ...@@ -213,7 +215,7 @@ pprStmt stmt = case stmt of
CmmCall (CmmCallee fn cconv) results args safety ret -> CmmCall (CmmCallee fn cconv) results args safety ret ->
maybe_proto $$ maybe_proto $$
pprCall ppr_fn cconv results args safety fnCall
where where
cast_fn = parens (cCast (pprCFunType (char '*') cconv results args) fn) cast_fn = parens (cCast (pprCFunType (char '*') cconv results args) fn)
...@@ -221,7 +223,7 @@ pprStmt stmt = case stmt of ...@@ -221,7 +223,7 @@ pprStmt stmt = case stmt of
pprCFunType (pprCLabel lbl) cconv results args <> pprCFunType (pprCLabel lbl) cconv results args <>
noreturn_attr <> semi noreturn_attr <> semi
data_proto lbl = ptext (sLit ";EI_(") <> fun_proto lbl = ptext (sLit ";EF_(") <>
pprCLabel lbl <> char ')' <> semi pprCLabel lbl <> char ')' <> semi
noreturn_attr = case ret of noreturn_attr = case ret of
...@@ -229,24 +231,27 @@ pprStmt stmt = case stmt of ...@@ -229,24 +231,27 @@ pprStmt stmt = case stmt of
CmmMayReturn -> empty CmmMayReturn -> empty
-- See wiki:Commentary/Compiler/Backends/PprC#Prototypes -- See wiki:Commentary/Compiler/Backends/PprC#Prototypes
(maybe_proto, ppr_fn) = (maybe_proto, fnCall) =
case fn of case fn of
CmmLit (CmmLabel lbl) 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 -- stdcall functions must be declared with
-- a function type, otherwise the C compiler -- a function type, otherwise the C compiler
-- doesn't add the @n suffix to the label. We -- doesn't add the @n suffix to the label. We
-- can't add the @n suffix ourselves, because -- can't add the @n suffix ourselves, because
-- it isn't valid C. -- it isn't valid C.
| CmmNeverReturns <- ret -> (real_fun_proto lbl, pprCLabel lbl) | CmmNeverReturns <- ret ->
| not (isMathFun lbl) -> (data_proto lbl, cast_fn) let myCall = pprCall (pprCLabel lbl) cconv results args safety
-- we declare all other called functions as in (real_fun_proto lbl, myCall)
-- data labels, and then cast them to the | not (isMathFun lbl) ->
-- right type when calling. This is because let myCall = braces (
-- the label might already have a declaration pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi
-- as a data label in the same file, $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi
-- e.g. Foreign.Marshal.Alloc declares 'free' $$ pprCall (text "ghcFunPtr") cconv results args safety <> semi
-- as both a data label and a function label. )
in (fun_proto lbl, myCall)
_ -> _ ->
(empty {- no proto -}, cast_fn) (empty {- no proto -}, cast_fn)
-- for a dynamic call, no declaration is necessary. -- for a dynamic call, no declaration is necessary.
......
...@@ -42,6 +42,7 @@ import BlockId ...@@ -42,6 +42,7 @@ import BlockId
import Cmm import Cmm
import CmmUtils import CmmUtils
import CLabel import CLabel
import BasicTypes
import ForeignCall import ForeignCall
...@@ -275,7 +276,7 @@ pprStmt stmt = case stmt of ...@@ -275,7 +276,7 @@ pprStmt stmt = case stmt of
pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv) pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv)
results args safety ret) results args safety ret)
where where
lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False) lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False IsFunction)
CmmBranch ident -> genBranch ident CmmBranch ident -> genBranch ident
CmmCondBranch expr ident -> genCondBranch expr ident CmmCondBranch expr ident -> genCondBranch expr ident
......
...@@ -35,6 +35,7 @@ import ZipCfg ...@@ -35,6 +35,7 @@ import ZipCfg
import MkZipCfg import MkZipCfg
import Util import Util
import BasicTypes
import Maybes import Maybes
import Monad import Monad
import Outputable import Outputable
...@@ -460,7 +461,7 @@ ppr_safety Unsafe = text "unsafe" ...@@ -460,7 +461,7 @@ ppr_safety Unsafe = text "unsafe"
ppr_call_target :: MidCallTarget -> SDoc ppr_call_target :: MidCallTarget -> SDoc
ppr_call_target (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn 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 :: CmmExpr -> SDoc
ppr_target t@(CmmLit _) = ppr t ppr_target t@(CmmLit _) = ppr t
......
...@@ -34,6 +34,7 @@ import Constants ...@@ -34,6 +34,7 @@ import Constants
import StaticFlags import StaticFlags
import Outputable import Outputable
import FastString import FastString
import BasicTypes
import Control.Monad import Control.Monad
...@@ -77,7 +78,7 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live ...@@ -77,7 +78,7 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
(call_args, cmm_target) (call_args, cmm_target)
= case target of = case target of
StaticTarget lbl -> (args, CmmLit (CmmLabel StaticTarget lbl -> (args, CmmLit (CmmLabel
(mkForeignLabel lbl call_size False))) (mkForeignLabel lbl call_size False IsFunction)))
DynamicTarget -> case args of DynamicTarget -> case args of
(CmmHinted fn _):rest -> (rest, fn) (CmmHinted fn _):rest -> (rest, fn)
[] -> panic "emitForeignCall: DynamicTarget []" [] -> panic "emitForeignCall: DynamicTarget []"
......
...@@ -21,6 +21,9 @@ import FastString ...@@ -21,6 +21,9 @@ import FastString
import HscTypes import HscTypes
import Panic import Panic
import Char import Char
import StaticFlags
import BasicTypes
import PackageConfig
import Data.Word import Data.Word
...@@ -66,7 +69,7 @@ initHpc this_mod (HpcInfo tickCount hashNo) ...@@ -66,7 +69,7 @@ initHpc this_mod (HpcInfo tickCount hashNo)
PlayRisky PlayRisky
[CmmHinted id NoHint] [CmmHinted id NoHint]
(CmmCallee (CmmCallee
(CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing False) (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing False IsFunction)
CCallConv CCallConv
) )
[ CmmHinted (mkLblExpr mkHpcModuleNameLabel) AddrHint [ CmmHinted (mkLblExpr mkHpcModuleNameLabel) AddrHint
......
...@@ -110,7 +110,7 @@ mkSimpleLit (MachWord i) = CmmInt i wordWidth ...@@ -110,7 +110,7 @@ mkSimpleLit (MachWord i) = CmmInt i wordWidth
mkSimpleLit (MachWord64 i) = CmmInt i W64 mkSimpleLit (MachWord64 i) = CmmInt i W64
mkSimpleLit (MachFloat r) = CmmFloat r W32 mkSimpleLit (MachFloat r) = CmmFloat r W32
mkSimpleLit (MachDouble r) = CmmFloat r W64 mkSimpleLit (MachDouble r) = CmmFloat r W64
mkSimpleLit (MachLabel fs ms) = CmmLabel (mkForeignLabel fs ms is_dyn) mkSimpleLit (MachLabel fs ms fod) = CmmLabel (mkForeignLabel fs ms is_dyn fod)
where where
is_dyn = False -- ToDo: fix me is_dyn = False -- ToDo: fix me
......
...@@ -58,7 +58,7 @@ cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_a ...@@ -58,7 +58,7 @@ cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_a
(call_args, cmm_target) (call_args, cmm_target)
= case target of = case target of
StaticTarget lbl -> (args, CmmLit (CmmLabel StaticTarget lbl -> (args, CmmLit (CmmLabel
(mkForeignLabel lbl (call_size args) False))) (mkForeignLabel lbl (call_size args) False IsFunction)))
DynamicTarget -> case args of DynamicTarget -> case args of
fn:rest -> (rest, fn) fn:rest -> (rest, fn)
[] -> panic "cgForeignCall []" [] -> panic "cgForeignCall []"
......
...@@ -54,7 +54,7 @@ initHpc this_mod (HpcInfo tickCount hashNo) ...@@ -54,7 +54,7 @@ initHpc this_mod (HpcInfo tickCount hashNo)
; id <- newTemp bWord -- TODO FIXME NOW ; id <- newTemp bWord -- TODO FIXME NOW
; emitCCall ; emitCCall
[(id,NoHint)] [(id,NoHint)]
(CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing False) (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing False IsFunction)
[ (mkLblExpr mkHpcModuleNameLabel,AddrHint) [ (mkLblExpr mkHpcModuleNameLabel,AddrHint)
, (CmmLit $ mkIntCLit tickCount,NoHint) , (CmmLit $ mkIntCLit tickCount,NoHint)
, (CmmLit $ mkIntCLit hashNo,NoHint) , (CmmLit $ mkIntCLit hashNo,NoHint)
......
...@@ -99,7 +99,7 @@ mkSimpleLit (MachWord i) = CmmInt i wordWidth ...@@ -99,7 +99,7 @@ mkSimpleLit (MachWord i) = CmmInt i wordWidth
mkSimpleLit (MachWord64 i) = CmmInt i W64 mkSimpleLit (MachWord64 i) = CmmInt i W64
mkSimpleLit (MachFloat r) = CmmFloat r W32 mkSimpleLit (MachFloat r) = CmmFloat r W32
mkSimpleLit (MachDouble r) = CmmFloat r W64 mkSimpleLit (MachDouble r) = CmmFloat r W64
mkSimpleLit (MachLabel fs ms) = CmmLabel (mkForeignLabel fs ms is_dyn) mkSimpleLit (MachLabel fs ms fod) = CmmLabel (mkForeignLabel fs ms is_dyn fod)
where where
is_dyn = False -- ToDo: fix me is_dyn = False -- ToDo: fix me
mkSimpleLit other = pprPanic "mkSimpleLit" (ppr other) mkSimpleLit other = pprPanic "mkSimpleLit" (ppr other)
......
...@@ -1191,7 +1191,7 @@ rhsIsStatic _this_pkg rhs = is_static False rhs ...@@ -1191,7 +1191,7 @@ rhsIsStatic _this_pkg rhs = is_static False rhs
is_static _ (Lit lit) is_static _ (Lit lit)
= case lit of = case lit of
MachLabel _ _ -> False MachLabel _ _ _ -> False
_ -> True _ -> True
-- A MachLabel (foreign import "&foo") in an argument -- A MachLabel (foreign import "&foo") in an argument
-- prevents a constructor application from being static. The -- prevents a constructor application from being static. The
......
...@@ -142,7 +142,7 @@ make_exp (Var v) = do ...@@ -142,7 +142,7 @@ make_exp (Var v) = do
DataConWorkId _ -> C.Var (make_var_qid False vName) DataConWorkId _ -> C.Var (make_var_qid False vName)
DataConWrapId _ -> C.Var (make_var_qid False vName) DataConWrapId _ -> C.Var (make_var_qid False vName)
_ -> C.Var (make_var_qid isLocal vName) _ -> C.Var (make_var_qid isLocal vName)
make_exp (Lit (MachLabel s _)) = return $ C.Label (unpackFS s) make_exp (Lit (MachLabel s _ _)) = return $ C.Label (unpackFS s)