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.
21 files changed:
Version, bumpVersion, initialVersion,
Arity,
Version, bumpVersion, initialVersion,
Arity,
type Arity = Int
\end{code}
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}
+
%************************************************************************
%* *
%************************************************************************
%* *
import Outputable
import FastTypes
import FastString
import Outputable
import FastTypes
import FastString
import Binary
import Ratio
import Binary
import Ratio
| MachDouble Rational -- ^ @Double#@. Create with 'mkMachDouble'
| MachLabel FastString
| 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.
-- the label expects. Only applicable with
-- @stdcall@ labels. @Just x@ => @\<x\>@ will
-- be appended to label name when emitting assembly.
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 (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
get bh = do
h <- getByte bh
case h of
9 -> do
aj <- get bh
mb <- get bh
9 -> do
aj <- get bh
mb <- get bh
- return (MachLabel aj mb)
+ fod <- get bh
+ return (MachLabel aj mb fod)
literalType (MachWord64 _) = word64PrimTy
literalType (MachFloat _) = floatPrimTy
literalType (MachDouble _) = doublePrimTy
literalType (MachWord64 _) = word64PrimTy
literalType (MachFloat _) = floatPrimTy
literalType (MachDouble _) = doublePrimTy
-literalType (MachLabel _ _) = addrPrimTy
+literalType (MachLabel _ _ _) = addrPrimTy
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 (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
cmpLit lit1 lit2 | litTag lit1 <# litTag lit2 = LT
| otherwise = GT
litTag (MachWord64 _) = _ILIT(7)
litTag (MachFloat _) = _ILIT(8)
litTag (MachDouble _) = _ILIT(9)
litTag (MachWord64 _) = _ILIT(7)
litTag (MachFloat _) = _ILIT(8)
litTag (MachDouble _) = _ILIT(9)
-litTag (MachLabel _ _) = _ILIT(10)
+litTag (MachLabel _ _ _) = _ILIT(10)
pprLit (MachFloat f) = ptext (sLit "__float") <+> rational f
pprLit (MachDouble d) = rational d
pprLit (MachNullAddr) = ptext (sLit "__NULL")
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
pprIntVal :: Integer -> SDoc
-- ^ Print negative integers with parens to be sure it's unambiguous
hashLiteral (MachWord64 i) = hashInteger i
hashLiteral (MachFloat r) = hashRational r
hashLiteral (MachDouble r) = hashRational r
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)
hashRational :: Rational -> Int
hashRational r = hashInteger (numerator r)
import IdInfo
import StaticFlags
import IdInfo
import StaticFlags
+import BasicTypes
+import Literal
import Packages
import DataCon
import PackageConfig
import Packages
import DataCon
import PackageConfig
- | 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
| CC_Label CostCentre
| CCS_Label CostCentreStack
-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 :: 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
addLabelSize label _
= label
foreignLabelStdcallInfo :: CLabel -> Maybe Int
-foreignLabelStdcallInfo (ForeignLabel _ info _) = info
+foreignLabelStdcallInfo (ForeignLabel _ info _ _) = info
foreignLabelStdcallInfo _lbl = Nothing
-- Cost centres etc.
foreignLabelStdcallInfo _lbl = Nothing
-- Cost centres etc.
needsCDecl (StringLitLabel _) = False
needsCDecl (AsmTempLabel _) = False
needsCDecl (RtsLabel _) = 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
needsCDecl (CC_Label _) = True
needsCDecl (CCS_Label _) = True
needsCDecl (HpcTicksLabel _) = True
-- they are builtin to the C compiler. For these labels we avoid
-- generating our own C prototypes.
isMathFun :: CLabel -> Bool
-- 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"),
where
math_funs = [
(fsLit "pow"), (fsLit "sin"), (fsLit "cos"),
externallyVisibleCLabel (ModuleInitTableLabel _)= False
externallyVisibleCLabel ModuleRegdLabel = False
externallyVisibleCLabel (RtsLabel _) = 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
externallyVisibleCLabel (IdLabel name _ _) = isExternalName name
externallyVisibleCLabel (CC_Label _) = True
externallyVisibleCLabel (CCS_Label _) = True
labelType (ModuleInitTableLabel _) = DataLabel
labelType (LargeSRTLabel _) = DataLabel
labelType (LargeBitmapLabel _) = DataLabel
labelType (ModuleInitTableLabel _) = DataLabel
labelType (LargeSRTLabel _) = DataLabel
labelType (LargeBitmapLabel _) = DataLabel
+labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel
labelType (IdLabel _ _ info) = idInfoLabelType info
labelType _ = DataLabel
labelType (IdLabel _ _ info) = idInfoLabelType info
labelType _ = DataLabel
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
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
#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)
#endif
ModuleInitLabel m _ -> not opt_Static && this_pkg /= (modulePackageId m)
PlainModuleInitLabel m -> not opt_Static && this_pkg /= (modulePackageId m)
#ifdef mingw32_TARGET_OS
-- In asm mode, we need to put the suffix on a stdcall ForeignLabel.
-- (The C compiler does this itself).
#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
= ftext fs <> char '@' <> int sz
#endif
pprAsmCLbl lbl
pprCLbl ModuleRegdLabel
= ptext (sLit "_module_registered")
pprCLbl ModuleRegdLabel
= ptext (sLit "_module_registered")
-pprCLbl (ForeignLabel str _ _)
+pprCLbl (ForeignLabel str _ _ _)
= ftext str
pprCLbl (IdLabel name cafs flavor) = ppr name <> ppIdFlavor flavor
= ftext str
pprCLbl (IdLabel name cafs flavor) = ppr name <> ppIdFlavor flavor
import Panic
import Constants
import Outputable
import Panic
import Constants
import Outputable
import Bag ( emptyBag, unitBag )
import Control.Monad
import Bag ( emptyBag, unitBag )
import Control.Monad
| 'CLOSURE' '(' NAME lits ')'
{ do lits <- sequence $4;
return $ map CmmStaticLit $
| '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) [] [] [] }
-- mkForeignLabel because these are only used
-- for CHARLIKE and INTLIKE closures in the RTS.
dontCareCCS (map getLit lits) [] [] [] }
-- PIC code for them.
newImport :: FastString -> ExtFCode ()
newImport name
-- 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
newLabel :: FastString -> ExtFCode BlockId
newLabel name = do
import FastString
import Outputable
import Constants
import FastString
import Outputable
import Constants
+import BasicTypes
+import CLabel
-- The rest
import Data.List
-- The rest
import Data.List
CmmCall (CmmCallee fn cconv) results args safety ret ->
maybe_proto $$
CmmCall (CmmCallee fn cconv) results args safety ret ->
maybe_proto $$
- pprCall ppr_fn cconv results args safety
where
cast_fn = parens (cCast (pprCFunType (char '*') cconv results args) fn)
where
cast_fn = parens (cCast (pprCFunType (char '*') cconv results args) fn)
pprCFunType (pprCLabel lbl) cconv results args <>
noreturn_attr <> semi
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
pprCLabel lbl <> char ')' <> semi
noreturn_attr = case ret of
CmmMayReturn -> empty
-- See wiki:Commentary/Compiler/Backends/PprC#Prototypes
CmmMayReturn -> empty
-- See wiki:Commentary/Compiler/Backends/PprC#Prototypes
- (maybe_proto, ppr_fn) =
+ (maybe_proto, fnCall) =
case fn of
CmmLit (CmmLabel lbl)
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.
-- 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.
_ ->
(empty {- no proto -}, cast_fn)
-- for a dynamic call, no declaration is necessary.
import Cmm
import CmmUtils
import CLabel
import Cmm
import CmmUtils
import CLabel
pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv)
results args safety ret)
where
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
CmmBranch ident -> genBranch ident
CmmCondBranch expr ident -> genCondBranch expr ident
import MkZipCfg
import Util
import MkZipCfg
import Util
import Maybes
import Monad
import Outputable
import Maybes
import Monad
import Outputable
ppr_call_target :: MidCallTarget -> SDoc
ppr_call_target (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
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
ppr_target :: CmmExpr -> SDoc
ppr_target t@(CmmLit _) = ppr t
import StaticFlags
import Outputable
import FastString
import StaticFlags
import Outputable
import FastString
(call_args, cmm_target)
= case target of
StaticTarget lbl -> (args, CmmLit (CmmLabel
(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 []"
DynamicTarget -> case args of
(CmmHinted fn _):rest -> (rest, fn)
[] -> panic "emitForeignCall: DynamicTarget []"
import HscTypes
import Panic
import Char
import HscTypes
import Panic
import Char
+import StaticFlags
+import BasicTypes
+import PackageConfig
PlayRisky
[CmmHinted id NoHint]
(CmmCallee
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
CCallConv
)
[ CmmHinted (mkLblExpr mkHpcModuleNameLabel) AddrHint
mkSimpleLit (MachWord64 i) = CmmInt i W64
mkSimpleLit (MachFloat r) = CmmFloat r W32
mkSimpleLit (MachDouble r) = CmmFloat r W64
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
where
is_dyn = False -- ToDo: fix me
(call_args, cmm_target)
= case target of
StaticTarget lbl -> (args, CmmLit (CmmLabel
(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 []"
DynamicTarget -> case args of
fn:rest -> (rest, fn)
[] -> panic "cgForeignCall []"
; id <- newTemp bWord -- TODO FIXME NOW
; emitCCall
[(id,NoHint)]
; 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)
[ (mkLblExpr mkHpcModuleNameLabel,AddrHint)
, (CmmLit $ mkIntCLit tickCount,NoHint)
, (CmmLit $ mkIntCLit hashNo,NoHint)
mkSimpleLit (MachWord64 i) = CmmInt i W64
mkSimpleLit (MachFloat r) = CmmFloat r W32
mkSimpleLit (MachDouble r) = CmmFloat r W64
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)
where
is_dyn = False -- ToDo: fix me
mkSimpleLit other = pprPanic "mkSimpleLit" (ppr other)
is_static _ (Lit lit)
= case lit of
is_static _ (Lit lit)
= case lit of
+ MachLabel _ _ _ -> False
_ -> True
-- A MachLabel (foreign import "&foo") in an argument
-- prevents a constructor application from being static. The
_ -> True
-- A MachLabel (foreign import "&foo") in an argument
-- prevents a constructor application from being static. The
DataConWorkId _ -> C.Var (make_var_qid False vName)
DataConWrapId _ -> C.Var (make_var_qid False vName)
_ -> C.Var (make_var_qid isLocal vName)
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
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
-> DsM ([Binding], SDoc, SDoc)
dsCImport id (CLabel cid) cconv _ = do
let ty = idType 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
(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)
stdcall_info = fun_type_arg_stdcall_info cconv ty
in
return ([(id, rhs)], empty, empty)
-}
adj_args = [ mkIntLitInt (ccallConvToInt cconv)
, Var stbl_value
-}
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.
, Lit (mkMachString typestring)
]
-- name of external entry point providing these services.
return (sizeSS st_l0, (st_i0,st_l1,st_p0))
#ifdef mingw32_TARGET_OS
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
= 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)
literal st (MachWord w) = int st (fromIntegral w)
literal st (MachInt j) = int st (fromIntegral j)
literal st MachNullAddr = int st (fromIntegral 0)
pushAtom _ _ (AnnLit lit)
= case lit of
pushAtom _ _ (AnnLit lit)
= case lit of
- MachLabel _ _ -> code NonPtrArg
+ MachLabel _ _ _ -> code NonPtrArg
MachWord _ -> code NonPtrArg
MachInt _ -> code PtrArg
MachFloat _ -> code FloatArg
MachWord _ -> code NonPtrArg
MachInt _ -> code PtrArg
MachFloat _ -> code FloatArg
import ClosureInfo ( C_SRT(..) )
-- The rest:
import ClosureInfo ( C_SRT(..) )
-- The rest:
import StaticFlags ( opt_PIC )
import ForeignCall ( CCallConv(..) )
import OrdList
import StaticFlags ( opt_PIC )
import ForeignCall ( CCallConv(..) )
import OrdList
code2 <- stmtToInstrs (CmmAssign (CmmLocal res) (CmmReg (CmmLocal tmp)))
return (code1 `appOL` code2)
where
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"
fn = case mop of
MO_F32_Sqrt -> fsLit "sqrtf"
dflags <- getDynFlagsNat
mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference
dflags <- getDynFlagsNat
mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference
- $ mkForeignLabel functionName Nothing True
+ $ mkForeignLabel functionName Nothing True IsFunction
let mopLabelOrExpr
= case mopExpr of
let mopLabelOrExpr
= case mopExpr of
do
dflags <- getDynFlagsNat
mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference $
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
let mopLabelOrExpr = case mopExpr of
CmmLit (CmmLabel lbl) -> Left lbl
_ -> Right mopExpr
-- The label used to refer to our "fake GOT" from
-- position-independent code.
gotLabel = mkForeignLabel -- HACK: it's not really foreign
-- 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.
-- pprGotDeclaration
-- Output whatever needs to be output once per .s file.
import UniqFM
import FastMutInt
import Fingerprint
import UniqFM
import FastMutInt
import Fingerprint
import Foreign
import Data.Array
import Foreign
import Data.Array
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)
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"
+