Version, bumpVersion, initialVersion,
Arity,
+
+ FunctionOrData(..),
WarningTxt(..),
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 BasicTypes
import Binary
import Ratio
| 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.
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
9 -> do
aj <- get bh
mb <- get bh
- return (MachLabel aj mb)
+ fod <- get bh
+ return (MachLabel aj mb fod)
\end{code}
\begin{code}
literalType (MachWord64 _) = word64PrimTy
literalType (MachFloat _) = floatPrimTy
literalType (MachDouble _) = doublePrimTy
-literalType (MachLabel _ _) = addrPrimTy
+literalType (MachLabel _ _ _) = addrPrimTy
\end{code}
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
litTag (MachWord64 _) = _ILIT(7)
litTag (MachFloat _) = _ILIT(8)
litTag (MachDouble _) = _ILIT(9)
-litTag (MachLabel _ _) = _ILIT(10)
+litTag (MachLabel _ _ _) = _ILIT(10)
\end{code}
Printing
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
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)
import IdInfo
import StaticFlags
+import BasicTypes
+import Literal
import Packages
import DataCon
import PackageConfig
| 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
-- 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.
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
-- 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"),
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
labelType (ModuleInitTableLabel _) = DataLabel
labelType (LargeSRTLabel _) = DataLabel
labelType (LargeBitmapLabel _) = DataLabel
+labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel
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
- 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)
#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
pprCLbl ModuleRegdLabel
= ptext (sLit "_module_registered")
-pprCLbl (ForeignLabel str _ _)
+pprCLbl (ForeignLabel str _ _ _)
= ftext str
pprCLbl (IdLabel name cafs flavor) = ppr name <> ppIdFlavor flavor
import Panic
import Constants
import Outputable
+import BasicTypes
import Bag ( emptyBag, unitBag )
import Control.Monad
| '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) [] [] [] }
-- 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
import FastString
import Outputable
import Constants
+import BasicTypes
+import CLabel
-- The rest
import Data.List
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)
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
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.
import Cmm
import CmmUtils
import CLabel
+import BasicTypes
import ForeignCall
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
import MkZipCfg
import Util
+import BasicTypes
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 (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
import StaticFlags
import Outputable
import FastString
+import BasicTypes
import Control.Monad
(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 []"
import HscTypes
import Panic
import Char
+import StaticFlags
+import BasicTypes
+import PackageConfig
import Data.Word
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
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
(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 []"
; 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)
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)
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
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
-> 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)
-}
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.
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)
pushAtom _ _ (AnnLit lit)
= case lit of
- MachLabel _ _ -> code NonPtrArg
+ MachLabel _ _ _ -> code NonPtrArg
MachWord _ -> code NonPtrArg
MachInt _ -> code PtrArg
MachFloat _ -> code FloatArg
import ClosureInfo ( C_SRT(..) )
-- The rest:
+import BasicTypes
import StaticFlags ( opt_PIC )
import ForeignCall ( CCallConv(..) )
import OrdList
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"
dflags <- getDynFlagsNat
mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference
- $ mkForeignLabel functionName Nothing True
+ $ mkForeignLabel functionName Nothing True IsFunction
let mopLabelOrExpr
= case mopExpr of
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
-- 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.
import UniqFM
import FastMutInt
import Fingerprint
+import BasicTypes
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)
+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"
+
projects / ghc-hetmet.git / commitdiff