Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
10
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
1b7dfd7f
Commit
1b7dfd7f
authored
Feb 17, 2012
by
Ian Lynagh
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Small refactoring: Use (Maybe Header) rather than FastString
parent
5d7fd293
Changes
6
Hide whitespace changes
Inline
Side-by-side
Showing
6 changed files
with
40 additions
and
30 deletions
+40
-30
compiler/deSugar/DsForeign.lhs
compiler/deSugar/DsForeign.lhs
+11
-13
compiler/deSugar/DsMeta.hs
compiler/deSugar/DsMeta.hs
+5
-4
compiler/hsSyn/HsDecls.lhs
compiler/hsSyn/HsDecls.lhs
+5
-3
compiler/parser/Parser.y.pp
compiler/parser/Parser.y.pp
+2
-2
compiler/parser/RdrHsSyn.lhs
compiler/parser/RdrHsSyn.lhs
+5
-5
compiler/prelude/ForeignCall.lhs
compiler/prelude/ForeignCall.lhs
+12
-3
No files found.
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
Markdown
is supported
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