Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
1b7dfd7f
Commit
1b7dfd7f
authored
Feb 17, 2012
by
Ian Lynagh
Browse files
Small refactoring: Use (Maybe Header) rather than FastString
parent
5d7fd293
Changes
6
Hide whitespace changes
Inline
Side-by-side
compiler/deSugar/DsForeign.lhs
View file @
1b7dfd7f
...
...
@@ -127,8 +127,8 @@ dsFImport :: Id
-> Coercion
-> ForeignImport
-> DsM ([Binding], SDoc, SDoc)
dsFImport id co (CImport cconv safety
h
eader spec) = do
(ids, h, c) <- dsCImport id co spec cconv safety
h
eader
dsFImport id co (CImport cconv safety
mH
eader spec) = do
(ids, h, c) <- dsCImport id co spec cconv safety
mH
eader
return (ids, h, c)
dsCImport :: Id
...
...
@@ -136,7 +136,7 @@ dsCImport :: Id
-> CImportSpec
-> CCallConv
-> Safety
->
FastString -- h
eader
->
Maybe H
eader
-> DsM ([Binding], SDoc, SDoc)
dsCImport id co (CLabel cid) cconv _ _ = do
let ty = pFst $ coercionKind co
...
...
@@ -156,8 +156,8 @@ dsCImport id co (CLabel cid) cconv _ _ = do
dsCImport id co (CFunction target) cconv@PrimCallConv safety _
= dsPrimCall id co (CCall (CCallSpec target cconv safety))
dsCImport id co (CFunction target) cconv safety
h
eader
= dsFCall id co (CCall (CCallSpec target cconv safety))
h
eader
dsCImport id co (CFunction target) cconv safety
mH
eader
= dsFCall id co (CCall (CCallSpec target cconv safety))
mH
eader
dsCImport id co CWrapper cconv _ _
= dsFExportDynamic id co cconv
...
...
@@ -184,9 +184,9 @@ fun_type_arg_stdcall_info _other_conv _
%************************************************************************
\begin{code}
dsFCall :: Id -> Coercion -> ForeignCall ->
FastString
dsFCall :: Id -> Coercion -> ForeignCall ->
Maybe Header
-> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
dsFCall fn_id co fcall
headerFilename
= do
dsFCall fn_id co fcall
mDeclHeader
= do
let
ty = pFst $ coercionKind co
(tvs, fun_ty) = tcSplitForAllTys ty
...
...
@@ -217,7 +217,7 @@ dsFCall fn_id co fcall headerFilename = do
c = includes
$$ fun_proto <+> braces (cRet <> semi)
includes = vcat [ text "#include <" <> ftext h <> text ">"
| h <- nub headers ]
|
Header
h <- nub headers ]
fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes
cRet
| isVoidRes = cCall
...
...
@@ -239,10 +239,8 @@ dsFCall fn_id co fcall headerFilename = do
argTypes = if null argTypeList
then text "void"
else hsep $ punctuate comma argTypeList
mHeaders' = mHeader : mHeaders
headers = if nullFS headerFilename
then catMaybes mHeaders'
else headerFilename : catMaybes mHeaders'
mHeaders' = mDeclHeader : mHeader : mHeaders
headers = catMaybes mHeaders'
argVals = hsep $ punctuate comma
[ char 'a' <> int n
| (_, n) <- zip arg_tys [1..] ]
...
...
@@ -676,7 +674,7 @@ showStgType t = text "Hs" <> text (showFFIType t)
showFFIType :: Type -> String
showFFIType t = getOccString (getName (typeTyCon t))
toCType :: Type -> (Maybe
FastString
, SDoc)
toCType :: Type -> (Maybe
Header
, SDoc)
toCType = f False
where f voidOK t
-- First, if we have (Ptr t) of (FunPtr t), then we need to
...
...
compiler/deSugar/DsMeta.hs
View file @
1b7dfd7f
...
...
@@ -338,15 +338,13 @@ repInstD (L loc (ClsInstDecl ty binds _ ats)) -- Ignore user pragmas for now
Just
(
tvs
,
cxt
,
cls
,
tys
)
=
splitHsInstDeclTy_maybe
(
unLoc
ty
)
repForD
::
Located
(
ForeignDecl
Name
)
->
DsM
(
SrcSpan
,
Core
TH
.
DecQ
)
repForD
(
L
loc
(
ForeignImport
name
typ
_
(
CImport
cc
s
ch
cis
)))
repForD
(
L
loc
(
ForeignImport
name
typ
_
(
CImport
cc
s
m
ch
cis
)))
=
do
MkC
name'
<-
lookupLOcc
name
MkC
typ'
<-
repLTy
typ
MkC
cc'
<-
repCCallConv
cc
MkC
s'
<-
repSafety
s
cis'
<-
conv_cimportspec
cis
MkC
str
<-
coreStringLit
$
static
++
unpackFS
ch
++
" "
++
cis'
MkC
str
<-
coreStringLit
(
static
++
chStr
++
cis'
)
dec
<-
rep2
forImpDName
[
cc'
,
s'
,
str
,
name'
,
typ'
]
return
(
loc
,
dec
)
where
...
...
@@ -357,6 +355,9 @@ repForD (L loc (ForeignImport name typ _ (CImport cc s ch cis)))
static
=
case
cis
of
CFunction
(
StaticTarget
_
_
)
->
"static "
_
->
""
chStr
=
case
mch
of
Nothing
->
""
Just
(
Header
h
)
->
unpackFS
h
++
" "
repForD
decl
=
notHandled
"Foreign declaration"
(
ppr
decl
)
repCCallConv
::
CCallConv
->
DsM
(
Core
TH
.
Callconv
)
...
...
compiler/hsSyn/HsDecls.lhs
View file @
1b7dfd7f
...
...
@@ -985,7 +985,7 @@ data ForeignImport = -- import of a C entity
--
CImport CCallConv -- ccall or stdcall
Safety -- interruptible, safe or unsafe
FastString
-- name of C header
(Maybe Header)
-- name of C header
CImportSpec -- details of the C entity
deriving (Data, Typeable)
...
...
@@ -1015,11 +1015,13 @@ instance OutputableBndr name => Outputable (ForeignDecl name) where
2 (dcolon <+> ppr ty)
instance Outputable ForeignImport where
ppr (CImport cconv safety
h
eader spec) =
ppr (CImport cconv safety
mH
eader spec) =
ppr cconv <+> ppr safety <+>
char '"' <> pprCEntity spec <> char '"'
where
pp_hdr = if nullFS header then empty else ftext header
pp_hdr = case mHeader of
Nothing -> empty
Just (Header header) -> ftext header
pprCEntity (CLabel lbl) =
ptext (sLit "static") <+> pp_hdr <+> char '&' <> ppr lbl
...
...
compiler/parser/Parser.y.pp
View file @
1b7dfd7f
...
...
@@ -741,8 +741,8 @@ tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) }
| type { L1 (Nothing, $1) }
capi_ctype :: { Maybe CType }
capi_ctype : '
{
-
# CTYPE' STRING STRING '#-}' { Just (CType (Just (getSTRING $2)) (getSTRING $3)) }
|
'{-# CTYPE'
STRING
'#-}'
{
Just
(
CType
Nothing
(
getSTRING
$2
))
}
capi_ctype : '
{
-
# CTYPE' STRING STRING '#-}' { Just (CType (Just
(Header
(getSTRING $2))
)
(getSTRING $3)) }
|
'{-# CTYPE'
STRING
'#-}'
{
Just
(
CType
Nothing
(
getSTRING
$2
))
}
|
{
Nothing
}
-----------------------------------------------------------------------------
...
...
compiler/parser/RdrHsSyn.lhs
View file @
1b7dfd7f
...
...
@@ -916,7 +916,7 @@ mkImport :: CCallConv
mkImport cconv safety (L loc entity, v, ty)
| cconv == PrimCallConv = do
let funcTarget = CFunction (StaticTarget entity Nothing)
importSpec = CImport PrimCallConv safety
nilFS
funcTarget
importSpec = CImport PrimCallConv safety
Nothing
funcTarget
return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec))
| otherwise = do
...
...
@@ -936,11 +936,11 @@ parseCImport cconv safety nm str =
parse = do
skipSpaces
r <- choice [
string "dynamic" >> return (mk
nilFS
(CFunction DynamicTarget)),
string "wrapper" >> return (mk
nilFS
CWrapper),
string "dynamic" >> return (mk
Nothing
(CFunction DynamicTarget)),
string "wrapper" >> return (mk
Nothing
CWrapper),
optional (string "static" >> skipSpaces) >>
(mk
nilFS
<$> cimp nm) +++
(do h <- munch1 hdr_char; skipSpaces; mk (mkFastString h) <$> cimp nm)
(mk
Nothing
<$> cimp nm) +++
(do h <- munch1 hdr_char; skipSpaces; mk
(Just (Header
(mkFastString h)
))
<$> cimp nm)
]
skipSpaces
return r
...
...
compiler/prelude/ForeignCall.lhs
View file @
1b7dfd7f
...
...
@@ -15,7 +15,7 @@ module ForeignCall (
CCallTarget(..), isDynamicTarget,
CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,
CType(..),
Header(..),
CType(..),
) where
import FastString
...
...
@@ -230,9 +230,13 @@ instance Outputable CCallSpec where
\end{code}
\begin{code}
-- The filename for a C header file
newtype Header = Header FastString
deriving (Eq, Data, Typeable)
-- | A C type, used in CAPI FFI calls
data CType = CType (Maybe
FastString
) -- header to include for this type
FastString
-- the type itself
data CType = CType (Maybe
Header
) -- header to include for this type
FastString -- the type itself
deriving (Data, Typeable)
\end{code}
...
...
@@ -324,4 +328,9 @@ instance Binary CType where
get bh = do mh <- get bh
fs <- get bh
return (CType mh fs)
instance Binary Header where
put_ bh (Header h) = put_ bh h
get bh = do h <- get bh
return (Header h)
\end{code}
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment