summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/basicTypes/BasicTypes.lhs17
-rw-r--r--compiler/basicTypes/Literal.lhs38
-rw-r--r--compiler/cmm/CLabel.hs39
-rw-r--r--compiler/cmm/CmmParse.y5
-rw-r--r--compiler/cmm/PprC.hs31
-rw-r--r--compiler/cmm/PprCmm.hs3
-rw-r--r--compiler/cmm/ZipCfgCmmRep.hs3
-rw-r--r--compiler/codeGen/CgForeignCall.hs3
-rw-r--r--compiler/codeGen/CgHpc.hs5
-rw-r--r--compiler/codeGen/CgUtils.hs2
-rw-r--r--compiler/codeGen/StgCmmForeign.hs2
-rw-r--r--compiler/codeGen/StgCmmHpc.hs2
-rw-r--r--compiler/codeGen/StgCmmUtils.hs2
-rw-r--r--compiler/coreSyn/CoreUtils.lhs2
-rw-r--r--compiler/coreSyn/MkExternalCore.lhs2
-rw-r--r--compiler/deSugar/DsForeign.lhs9
-rw-r--r--compiler/ghci/ByteCodeAsm.lhs4
-rw-r--r--compiler/ghci/ByteCodeGen.lhs2
-rw-r--r--compiler/nativeGen/MachCodeGen.hs7
-rw-r--r--compiler/nativeGen/PositionIndependentCode.hs2
-rw-r--r--compiler/utils/Binary.hs11
21 files changed, 125 insertions, 66 deletions
diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs
index 70a9312a36..04ed8fa141 100644
--- a/compiler/basicTypes/BasicTypes.lhs
+++ b/compiler/basicTypes/BasicTypes.lhs
@@ -18,6 +18,8 @@ module BasicTypes(
Version, bumpVersion, initialVersion,
Arity,
+
+ FunctionOrData(..),
WarningTxt(..),
@@ -72,6 +74,21 @@ import Outputable
type Arity = Int
\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}
+
%************************************************************************
%* *
diff --git a/compiler/basicTypes/Literal.lhs b/compiler/basicTypes/Literal.lhs
index 626f0cb880..f2ea137567 100644
--- a/compiler/basicTypes/Literal.lhs
+++ b/compiler/basicTypes/Literal.lhs
@@ -48,6 +48,7 @@ import Type
import Outputable
import FastTypes
import FastString
+import BasicTypes
import Binary
import Ratio
@@ -121,11 +122,13 @@ data Literal
| MachDouble Rational -- ^ @Double#@. Create with 'mkMachDouble'
| MachLabel FastString
- (Maybe Int) -- ^ A label literal. Parameters:
- --
- -- 1) The name of the symbol mentioned in the declaration
- --
- -- 2) The size (in bytes) of the arguments
+ (Maybe Int)
+ FunctionOrData
+ -- ^ A label literal. Parameters:
+ --
+ -- 1) The name of the symbol mentioned in the declaration
+ --
+ -- 2) The size (in bytes) of the arguments
-- the label expects. Only applicable with
-- @stdcall@ labels. @Just x@ => @\<x\>@ will
-- be appended to label name when emitting assembly.
@@ -144,7 +147,11 @@ instance Binary Literal where
put_ bh (MachWord64 ag) = do putByte bh 6; put_ bh ag
put_ bh (MachFloat ah) = do putByte bh 7; put_ bh ah
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
h <- getByte bh
case h of
@@ -177,7 +184,8 @@ instance Binary Literal where
9 -> do
aj <- get bh
mb <- get bh
- return (MachLabel aj mb)
+ fod <- get bh
+ return (MachLabel aj mb fod)
\end{code}
\begin{code}
@@ -349,7 +357,7 @@ literalType (MachInt64 _) = int64PrimTy
literalType (MachWord64 _) = word64PrimTy
literalType (MachFloat _) = floatPrimTy
literalType (MachDouble _) = doublePrimTy
-literalType (MachLabel _ _) = addrPrimTy
+literalType (MachLabel _ _ _) = addrPrimTy
\end{code}
@@ -366,7 +374,7 @@ cmpLit (MachInt64 a) (MachInt64 b) = a `compare` b
cmpLit (MachWord64 a) (MachWord64 b) = a `compare` b
cmpLit (MachFloat a) (MachFloat 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
| otherwise = GT
@@ -380,7 +388,7 @@ litTag (MachInt64 _) = _ILIT(6)
litTag (MachWord64 _) = _ILIT(7)
litTag (MachFloat _) = _ILIT(8)
litTag (MachDouble _) = _ILIT(9)
-litTag (MachLabel _ _) = _ILIT(10)
+litTag (MachLabel _ _ _) = _ILIT(10)
\end{code}
Printing
@@ -399,10 +407,10 @@ pprLit (MachWord64 w) = ptext (sLit "__word64") <+> integer w
pprLit (MachFloat f) = ptext (sLit "__float") <+> rational f
pprLit (MachDouble d) = rational d
pprLit (MachNullAddr) = ptext (sLit "__NULL")
-pprLit (MachLabel l mb) = ptext (sLit "__label") <+>
- case mb of
- Nothing -> pprHsString l
- Just x -> doubleQuotes (text (unpackFS l ++ '@':show x))
+pprLit (MachLabel l mb fod) = ptext (sLit "__label") <+> b <+> ppr fod
+ where b = case mb of
+ Nothing -> pprHsString l
+ Just x -> doubleQuotes (text (unpackFS l ++ '@':show x))
pprIntVal :: Integer -> SDoc
-- ^ Print negative integers with parens to be sure it's unambiguous
@@ -431,7 +439,7 @@ hashLiteral (MachWord i) = hashInteger i
hashLiteral (MachWord64 i) = hashInteger i
hashLiteral (MachFloat r) = hashRational r
hashLiteral (MachDouble r) = hashRational r
-hashLiteral (MachLabel s _) = hashFS s
+hashLiteral (MachLabel s _ _) = hashFS s
hashRational :: Rational -> Int
hashRational r = hashInteger (numerator r)
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
diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs
index ceff757d3d..cf99f316c3 100644
--- a/compiler/codeGen/CgForeignCall.hs
+++ b/compiler/codeGen/CgForeignCall.hs
@@ -34,6 +34,7 @@ import Constants
import StaticFlags
import Outputable
import FastString
+import BasicTypes
import Control.Monad
@@ -77,7 +78,7 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
(call_args, cmm_target)
= case target of
StaticTarget lbl -> (args, CmmLit (CmmLabel
- (mkForeignLabel lbl call_size False)))
+ (mkForeignLabel lbl call_size False IsFunction)))
DynamicTarget -> case args of
(CmmHinted fn _):rest -> (rest, fn)
[] -> panic "emitForeignCall: DynamicTarget []"
diff --git a/compiler/codeGen/CgHpc.hs b/compiler/codeGen/CgHpc.hs
index 9ae576944b..faee9c2d3f 100644
--- a/compiler/codeGen/CgHpc.hs
+++ b/compiler/codeGen/CgHpc.hs
@@ -21,6 +21,9 @@ import FastString
import HscTypes
import Panic
import Char
+import StaticFlags
+import BasicTypes
+import PackageConfig
import Data.Word
@@ -66,7 +69,7 @@ initHpc this_mod (HpcInfo tickCount hashNo)
PlayRisky
[CmmHinted id NoHint]
(CmmCallee
- (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing False)
+ (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing False IsFunction)
CCallConv
)
[ CmmHinted (mkLblExpr mkHpcModuleNameLabel) AddrHint
diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
index b14d318c66..fad85f7e16 100644
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -110,7 +110,7 @@ mkSimpleLit (MachWord i) = CmmInt i wordWidth
mkSimpleLit (MachWord64 i) = CmmInt i W64
mkSimpleLit (MachFloat r) = CmmFloat r W32
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
is_dyn = False -- ToDo: fix me
diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
index a4b5cf9f15..711b79e13f 100644
--- a/compiler/codeGen/StgCmmForeign.hs
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -58,7 +58,7 @@ cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_a
(call_args, cmm_target)
= case target of
StaticTarget lbl -> (args, CmmLit (CmmLabel
- (mkForeignLabel lbl (call_size args) False)))
+ (mkForeignLabel lbl (call_size args) False IsFunction)))
DynamicTarget -> case args of
fn:rest -> (rest, fn)
[] -> panic "cgForeignCall []"
diff --git a/compiler/codeGen/StgCmmHpc.hs b/compiler/codeGen/StgCmmHpc.hs
index f53c5c6839..afc238a252 100644
--- a/compiler/codeGen/StgCmmHpc.hs
+++ b/compiler/codeGen/StgCmmHpc.hs
@@ -54,7 +54,7 @@ initHpc this_mod (HpcInfo tickCount hashNo)
; id <- newTemp bWord -- TODO FIXME NOW
; emitCCall
[(id,NoHint)]
- (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing False)
+ (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing False IsFunction)
[ (mkLblExpr mkHpcModuleNameLabel,AddrHint)
, (CmmLit $ mkIntCLit tickCount,NoHint)
, (CmmLit $ mkIntCLit hashNo,NoHint)
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index 4803f5fba7..dc7fb8b9d1 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -99,7 +99,7 @@ mkSimpleLit (MachWord i) = CmmInt i wordWidth
mkSimpleLit (MachWord64 i) = CmmInt i W64
mkSimpleLit (MachFloat r) = CmmFloat r W32
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
is_dyn = False -- ToDo: fix me
mkSimpleLit other = pprPanic "mkSimpleLit" (ppr other)
diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 374c344d20..5d33b0f338 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -1191,7 +1191,7 @@ rhsIsStatic _this_pkg rhs = is_static False rhs
is_static _ (Lit lit)
= case lit of
- MachLabel _ _ -> False
+ MachLabel _ _ _ -> False
_ -> True
-- A MachLabel (foreign import "&foo") in an argument
-- prevents a constructor application from being static. The
diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs
index 82731597cd..0cfb787fc4 100644
--- a/compiler/coreSyn/MkExternalCore.lhs
+++ b/compiler/coreSyn/MkExternalCore.lhs
@@ -142,7 +142,7 @@ make_exp (Var v) = do
DataConWorkId _ -> C.Var (make_var_qid False vName)
DataConWrapId _ -> C.Var (make_var_qid False 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)
make_exp (Lit l) = return $ C.Lit (make_lit l)
make_exp (App e (Type t)) = make_exp e >>= (\ b -> return $ C.Appt b (make_ty t))
make_exp (App e1 e2) = do
diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index 080289e8f9..0c40318a1f 100644
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -142,10 +142,15 @@ dsCImport :: Id
-> DsM ([Binding], SDoc, SDoc)
dsCImport id (CLabel cid) cconv _ = do
let ty = idType id
+ fod = case splitTyConApp_maybe (repType ty) of
+ Just (tycon, _)
+ | tyConUnique tycon == funPtrTyConKey ->
+ IsFunction
+ _ -> IsData
(resTy, foRhs) <- resultWrapper ty
ASSERT(fromJust resTy `coreEqType` addrPrimTy) -- typechecker ensures this
let
- rhs = foRhs (Lit (MachLabel cid stdcall_info))
+ rhs = foRhs (Lit (MachLabel cid stdcall_info fod))
stdcall_info = fun_type_arg_stdcall_info cconv ty
in
return ([(id, rhs)], empty, empty)
@@ -355,7 +360,7 @@ dsFExportDynamic id cconv = do
-}
adj_args = [ mkIntLitInt (ccallConvToInt cconv)
, Var stbl_value
- , Lit (MachLabel fe_nm mb_sz_args)
+ , Lit (MachLabel fe_nm mb_sz_args IsFunction)
, Lit (mkMachString typestring)
]
-- name of external entry point providing these services.
diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs
index c6c7a0d0f9..24fda15ce9 100644
--- a/compiler/ghci/ByteCodeAsm.lhs
+++ b/compiler/ghci/ByteCodeAsm.lhs
@@ -377,12 +377,12 @@ mkBits findLabel st proto_insns
return (sizeSS st_l0, (st_i0,st_l1,st_p0))
#ifdef mingw32_TARGET_OS
- literal st (MachLabel fs (Just sz))
+ literal st (MachLabel fs (Just sz) _)
= litlabel st (appendFS fs (mkFastString ('@':show sz)))
-- On Windows, stdcall labels have a suffix indicating the no. of
-- arg words, e.g. foo@8. testcase: ffi012(ghci)
#endif
- literal st (MachLabel fs _) = litlabel st fs
+ literal st (MachLabel fs _ _) = litlabel st fs
literal st (MachWord w) = int st (fromIntegral w)
literal st (MachInt j) = int st (fromIntegral j)
literal st MachNullAddr = int st (fromIntegral 0)
diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index a9e3c07524..95aae77671 100644
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -1205,7 +1205,7 @@ pushAtom d p (AnnVar v)
pushAtom _ _ (AnnLit lit)
= case lit of
- MachLabel _ _ -> code NonPtrArg
+ MachLabel _ _ _ -> code NonPtrArg
MachWord _ -> code NonPtrArg
MachInt _ -> code PtrArg
MachFloat _ -> code FloatArg
diff --git a/compiler/nativeGen/MachCodeGen.hs b/compiler/nativeGen/MachCodeGen.hs
index d16962cfbe..d94a906bbd 100644
--- a/compiler/nativeGen/MachCodeGen.hs
+++ b/compiler/nativeGen/MachCodeGen.hs
@@ -40,6 +40,7 @@ import CLabel
import ClosureInfo ( C_SRT(..) )
-- The rest:
+import BasicTypes
import StaticFlags ( opt_PIC )
import ForeignCall ( CCallConv(..) )
import OrdList
@@ -3408,7 +3409,7 @@ outOfLineFloatOp mop res args
code2 <- stmtToInstrs (CmmAssign (CmmLocal res) (CmmReg (CmmLocal tmp)))
return (code1 `appOL` code2)
where
- lbl = mkForeignLabel fn Nothing False
+ lbl = mkForeignLabel fn Nothing False IsFunction
fn = case mop of
MO_F32_Sqrt -> fsLit "sqrtf"
@@ -3841,7 +3842,7 @@ outOfLineFloatOp mop
dflags <- getDynFlagsNat
mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference
- $ mkForeignLabel functionName Nothing True
+ $ mkForeignLabel functionName Nothing True IsFunction
let mopLabelOrExpr
= case mopExpr of
@@ -4112,7 +4113,7 @@ genCCall target dest_regs argsAndHints
do
dflags <- getDynFlagsNat
mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference $
- mkForeignLabel functionName Nothing True
+ mkForeignLabel functionName Nothing True IsFunction
let mopLabelOrExpr = case mopExpr of
CmmLit (CmmLabel lbl) -> Left lbl
_ -> Right mopExpr
diff --git a/compiler/nativeGen/PositionIndependentCode.hs b/compiler/nativeGen/PositionIndependentCode.hs
index 16359094a8..d74a627d0a 100644
--- a/compiler/nativeGen/PositionIndependentCode.hs
+++ b/compiler/nativeGen/PositionIndependentCode.hs
@@ -525,7 +525,7 @@ needImportedSymbols = not opt_Static && not opt_PIC
-- The label used to refer to our "fake GOT" from
-- position-independent code.
gotLabel = mkForeignLabel -- HACK: it's not really foreign
- (fsLit ".LCTOC1") Nothing False
+ (fsLit ".LCTOC1") Nothing False IsData
-- pprGotDeclaration
-- Output whatever needs to be output once per .s file.
diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs
index 4f48a424b3..c61f8a6baa 100644
--- a/compiler/utils/Binary.hs
+++ b/compiler/utils/Binary.hs
@@ -67,6 +67,7 @@ import Panic
import UniqFM
import FastMutInt
import Fingerprint
+import BasicTypes
import Foreign
import Data.Array
@@ -726,3 +727,13 @@ instance Binary Fingerprint where
put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2
get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2)
+instance Binary FunctionOrData where
+ put_ bh IsFunction = putByte bh 0
+ put_ bh IsData = putByte bh 1
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return IsFunction
+ 1 -> return IsData
+ _ -> panic "Binary FunctionOrData"
+
View Lorry Controller Status