module GenBind (expandHooks)
where
import Data.Char (toUpper, toLower, isSpace)
import Data.List (deleteBy, intersperse, isPrefixOf, find, nubBy)
import Data.Maybe (isNothing, isJust, fromJust, fromMaybe)
import Control.Monad (when, unless, liftM, mapAndUnzipM)
import Data.Bits ((.&.), (.|.), xor, complement)
import Position (Position, Pos(posOf), nopos, builtinPos)
import Errors (interr, todo)
import Idents (Ident, identToLexeme, onlyPosIdent)
import Attributes (newAttrsOnlyPos)
import C2HSConfig (dlsuffix)
import C2HSState (CST, nop, errorsPresent, showErrors, fatal,
SwitchBoard(..), Traces(..), putTraceStr, getSwitch,
printCIO)
import C (AttrC, CObj(..), CTag(..), lookupDefObjC, lookupDefTagC,
CHeader(..), CExtDecl, CDecl(..), CDeclSpec(..),
CStorageSpec(..), CTypeSpec(..), CTypeQual(..),
CStructUnion(..), CStructTag(..), CEnum(..), CDeclr(..),
CInit(..), CExpr(..), CAssignOp(..), CBinaryOp(..),
CUnaryOp(..), CConst (..),
CT, readCT, transCT, getCHeaderCT, runCT, ifCTExc,
raiseErrorCTExc, findValueObj, findFunObj, findTag,
findTypeObj, applyPrefixToNameSpaces, isTypedef,
simplifyDecl, declrFromDecl, declrNamed, structMembers,
structName, tagName, declaredName , structFromDecl,
funResultAndArgs, chaseDecl, findAndChaseDecl,
findObjShadow,
checkForAlias, checkForOneAliasName, lookupEnum,
lookupStructUnion, lookupDeclOrTag, isPtrDeclr,
isArrDeclr, dropPtrDeclr, isPtrDecl, getDeclOf, isFunDeclr,
refersToNewDef, CDef(..))
import CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSTrans(..),
CHSParm(..), CHSArg(..), CHSAccess(..), CHSAPath(..),
CHSPtrType(..), showCHSParm)
import CInfo (CPrimType(..), size, alignment, bitfieldIntSigned,
bitfieldAlignment)
import GBMonad (TransFun, transTabToTransFun, HsObject(..), GB, HsPtrRep,
initialGBState, setContext, getPrefix, getLock,
delayCode, getDelayedCode, ptrMapsTo, queryPtr, objIs,
queryObj, queryClass, queryPointer, mergeMaps, dumpMaps)
lookupDftMarshIn :: String -> [ExtType] -> GB (Maybe (Ident, CHSArg))
lookupDftMarshIn "Bool" [PrimET pt] | isIntegralCPrimType pt =
return $ Just (cFromBoolIde, CHSValArg)
lookupDftMarshIn hsTy [PrimET pt] | isIntegralHsType hsTy
&&isIntegralCPrimType pt =
return $ Just (cIntConvIde, CHSValArg)
lookupDftMarshIn hsTy [PrimET pt] | isFloatHsType hsTy
&&isFloatCPrimType pt =
return $ Just (cFloatConvIde, CHSValArg)
lookupDftMarshIn "String" [PtrET (PrimET CCharPT)] =
return $ Just (withCStringIde, CHSIOArg)
lookupDftMarshIn "String" [PtrET (PrimET CCharPT), PrimET pt]
| isIntegralCPrimType pt =
return $ Just (withCStringLenIde, CHSIOArg)
lookupDftMarshIn hsTy [PtrET ty] | showExtType ty == hsTy =
return $ Just (withIde, CHSIOArg)
lookupDftMarshIn hsTy [PtrET (PrimET pt)]
| isIntegralHsType hsTy && isIntegralCPrimType pt =
return $ Just (withIntConvIde, CHSIOArg)
lookupDftMarshIn hsTy [PtrET (PrimET pt)]
| isFloatHsType hsTy && isFloatCPrimType pt =
return $ Just (withFloatConvIde, CHSIOArg)
lookupDftMarshIn "Bool" [PtrET (PrimET pt)]
| isIntegralCPrimType pt =
return $ Just (withFromBoolIde, CHSIOArg)
lookupDftMarshIn _ _ =
return Nothing
lookupDftMarshOut :: String -> [ExtType] -> GB (Maybe (Ident, CHSArg))
lookupDftMarshOut "()" _ =
return $ Just (voidIde, CHSVoidArg)
lookupDftMarshOut "Bool" [PrimET pt] | isIntegralCPrimType pt =
return $ Just (cToBoolIde, CHSValArg)
lookupDftMarshOut hsTy [PrimET pt] | isIntegralHsType hsTy
&&isIntegralCPrimType pt =
return $ Just (cIntConvIde, CHSValArg)
lookupDftMarshOut hsTy [PrimET pt] | isFloatHsType hsTy
&&isFloatCPrimType pt =
return $ Just (cFloatConvIde, CHSValArg)
lookupDftMarshOut "String" [PtrET (PrimET CCharPT)] =
return $ Just (peekCStringIde, CHSIOArg)
lookupDftMarshOut "String" [PtrET (PrimET CCharPT), PrimET pt]
| isIntegralCPrimType pt =
return $ Just (peekCStringLenIde, CHSIOArg)
lookupDftMarshOut hsTy [PtrET ty] | showExtType ty == hsTy =
return $ Just (peekIde, CHSIOArg)
lookupDftMarshOut _ _ =
return Nothing
isIntegralHsType :: String -> Bool
isIntegralHsType "Int" = True
isIntegralHsType "Int8" = True
isIntegralHsType "Int16" = True
isIntegralHsType "Int32" = True
isIntegralHsType "Int64" = True
isIntegralHsType "Word8" = True
isIntegralHsType "Word16" = True
isIntegralHsType "Word32" = True
isIntegralHsType "Word64" = True
isIntegralHsType _ = False
isFloatHsType :: String -> Bool
isFloatHsType "Float" = True
isFloatHsType "Double" = True
isFloatHsType _ = False
isIntegralCPrimType :: CPrimType -> Bool
isIntegralCPrimType = (`elem` [CCharPT, CSCharPT, CIntPT, CShortPT, CLongPT,
CLLongPT, CUIntPT, CUCharPT, CUShortPT,
CULongPT, CULLongPT])
isFloatCPrimType :: CPrimType -> Bool
isFloatCPrimType = (`elem` [CFloatPT, CDoublePT, CLDoublePT])
voidIde = noPosIdent "void"
cFromBoolIde = noPosIdent "cFromBool"
cToBoolIde = noPosIdent "cToBool"
cIntConvIde = noPosIdent "cIntConv"
cFloatConvIde = noPosIdent "cFloatConv"
withIde = noPosIdent "with"
withCStringIde = noPosIdent "withCString"
withCStringLenIde = noPosIdent "withCStringLenIntConv"
withIntConvIde = noPosIdent "withIntConv"
withFloatConvIde = noPosIdent "withFloatConv"
withFromBoolIde = noPosIdent "withFromBoolConv"
peekIde = noPosIdent "peek"
peekCStringIde = noPosIdent "peekCString"
peekCStringLenIde = noPosIdent "peekCStringLenIntConv"
expandHooks :: AttrC -> CHSModule -> CST s (CHSModule, String, String)
expandHooks ac mod = do
mLock <- getSwitch lockFunSB
(_, res) <- runCT (expandModule mod) ac (initialGBState mLock)
return res
expandModule :: CHSModule -> GB (CHSModule, String, String)
expandModule (CHSModule frags) =
do
traceInfoExpand
frags' <- expandFrags frags
delayedFrags <- getDelayedCode
chi <- dumpMaps
errs <- errorsPresent
if errs
then do
traceInfoErr
errmsgs <- showErrors
fatal ("Errors during expansion of binding hooks:\n\n"
++ errmsgs)
else do
traceInfoOK
warnmsgs <- showErrors
return (CHSModule (frags' ++ delayedFrags), chi, warnmsgs)
where
traceInfoExpand = putTraceStr tracePhasesSW
("...expanding binding hooks...\n")
traceInfoErr = putTraceStr tracePhasesSW
("...error(s) detected.\n")
traceInfoOK = putTraceStr tracePhasesSW
("...successfully completed.\n")
expandFrags :: [CHSFrag] -> GB [CHSFrag]
expandFrags = liftM concat . mapM expandFrag
expandFrag :: CHSFrag -> GB [CHSFrag]
expandFrag verb@(CHSVerb _ _ ) = return [verb]
expandFrag line@(CHSLine _ ) = return [line]
expandFrag prag@(CHSLang _ _ ) = return [prag]
expandFrag (CHSHook h ) =
do
code <- expandHook h
return [CHSVerb code builtinPos]
`ifCTExc` return [CHSVerb "** ERROR **" builtinPos]
expandFrag (CHSCPP s _ ) =
interr $ "GenBind.expandFrag: Left over CHSCPP!\n---\n" ++ s ++ "\n---"
expandFrag (CHSC s _ ) =
interr $ "GenBind.expandFrag: Left over CHSC!\n---\n" ++ s ++ "\n---"
expandFrag (CHSCond alts dft) =
do
traceInfoCond
select alts
where
select [] = do
traceInfoDft dft
expandFrags (maybe [] id dft)
select ((ide, frags):alts) = do
oobj <- findTag ide
traceInfoVal ide oobj
if isNothing oobj
then
select alts
else
expandFrags frags
traceInfoCond = traceGenBind "** CPP conditional:\n"
traceInfoVal ide oobj = traceGenBind $ identToLexeme ide ++ " is " ++
(if isNothing oobj then "not " else "") ++
"defined.\n"
traceInfoDft dft = if isNothing dft
then
return ()
else
traceGenBind "Choosing else branch.\n"
expandHook :: CHSHook -> GB String
expandHook (CHSImport qual ide chi _) =
do
mergeMaps chi
return $
"import " ++ (if qual then "qualified " else "") ++ identToLexeme ide
expandHook (CHSContext olib oprefix olock _) =
do
setContext olib oprefix olock
mapMaybeM_ applyPrefixToNameSpaces oprefix
return ""
expandHook (CHSType ide pos) =
do
traceInfoType
decl <- findAndChaseDecl ide False True
ty <- extractSimpleType pos decl
traceInfoDump decl ty
return $ "(" ++ showExtType ty ++ ")"
where
traceInfoType = traceGenBind "** Type hook:\n"
traceInfoDump decl ty = traceGenBind $
"Declaration\n" ++ show decl ++ "\ntranslates to\n"
++ showExtType ty ++ "\n"
expandHook (CHSSizeof ide pos) =
do
traceInfoSizeof
decl <- findAndChaseDecl ide False True
(size, _) <- sizeAlignOf decl
traceInfoDump decl size
return $ show (fromIntegral . padBits $ size)
where
traceInfoSizeof = traceGenBind "** Sizeof hook:\n"
traceInfoDump decl size = traceGenBind $
"Size of declaration\n" ++ show decl ++ "\nis "
++ show (fromIntegral . padBits $ size) ++ "\n"
expandHook (CHSEnum cide oalias chsTrans oprefix derive _) =
do
enum <- lookupEnum cide True
gprefix <- getPrefix
let prefix = fromMaybe gprefix oprefix
trans = transTabToTransFun prefix chsTrans
hide = identToLexeme . fromMaybe cide $ oalias
enumDef enum hide trans (map identToLexeme derive)
expandHook hook@(CHSCall isPure isUns isNol ide oalias pos) =
do
traceEnter
(ObjCO cdecl, ide) <- findFunObj ide True
mLock <- if isNol then return Nothing else getLock
let ideLexeme = identToLexeme ide
hsLexeme = ideLexeme `maybe` identToLexeme $ oalias
cdecl' = ide `simplifyDecl` cdecl
callImport hook isPure isUns mLock ideLexeme hsLexeme cdecl' pos
where
traceEnter = traceGenBind $
"** Call hook for `" ++ identToLexeme ide ++ "':\n"
expandHook hook@(CHSFun isPure isUns isNol ide oalias ctxt parms parm pos) =
do
traceEnter
(ObjCO cdecl, cide) <- findFunObj ide True
mLock <- if isNol then return Nothing else getLock
let ideLexeme = identToLexeme ide
hsLexeme = ideLexeme `maybe` identToLexeme $ oalias
fiLexeme = hsLexeme ++ "'_"
fiIde = onlyPosIdent nopos fiLexeme
cdecl' = cide `simplifyDecl` cdecl
callHook = CHSCall isPure isUns isNol cide (Just fiIde) pos
callImport callHook isPure isUns mLock (identToLexeme cide) fiLexeme cdecl' pos
funDef isPure hsLexeme fiLexeme cdecl' ctxt mLock parms parm pos
where
traceEnter = traceGenBind $
"** Fun hook for `" ++ identToLexeme ide ++ "':\n"
expandHook (CHSField access path pos) =
do
traceInfoField
(decl, offsets) <- accessPath path
traceDepth offsets
ty <- extractSimpleType pos decl
traceValueType ty
setGet pos access offsets ty
where
accessString = case access of
CHSGet -> "Get"
CHSSet -> "Set"
traceInfoField = traceGenBind $ "** " ++ accessString ++ " hook:\n"
traceDepth offsets = traceGenBind $ "Depth of access path: "
++ show (length offsets) ++ "\n"
traceValueType et = traceGenBind $
"Type of accessed value: " ++ showExtType et ++ "\n"
expandHook (CHSPointer isStar cName oalias ptrKind isNewtype oRefType pos) =
do
traceInfoPointer
let hsIde = fromMaybe cName oalias
hsName = identToLexeme hsIde
hsIde `objIs` Pointer ptrKind isNewtype
declOrTag <- lookupDeclOrTag cName True
case declOrTag of
Left cdecl -> do
cNameFull <- case declaredName cdecl of
Just ide -> return ide
Nothing -> interr
"GenBind.expandHook: Where is the name?"
cNameFull `refersToNewDef` ObjCD (TypeCO cdecl)
traceInfoCName "declaration" cNameFull
unless (isStar || isPtrDecl cdecl) $
ptrExpectedErr (posOf cName)
(hsType, isFun) <-
case oRefType of
Nothing -> do
cDecl <- chaseDecl cNameFull (not isStar)
et <- extractPtrType cDecl
let et' = adjustPtr isStar et
return (showExtType et', isFunExtType et')
Just hsType -> return (identToLexeme hsType, False)
traceInfoHsType hsName hsType
realCName <- liftM (maybe cName snd) $ findObjShadow cName
pointerDef isStar realCName hsName ptrKind isNewtype hsType isFun
Right tag -> do
let cNameFull = tagName tag
traceInfoCName "tag definition" cNameFull
unless isStar $
ptrExpectedErr (posOf cName)
let hsType = case oRefType of
Nothing -> "()"
Just hsType -> identToLexeme hsType
traceInfoHsType hsName hsType
pointerDef isStar cNameFull hsName ptrKind isNewtype hsType False
where
adjustPtr True et = et
adjustPtr False (PtrET et) = et
adjustPtr _ _ = interr "GenBind.adjustPtr: Where is the Ptr?"
traceInfoPointer = traceGenBind "** Pointer hook:\n"
traceInfoCName kind ide = traceGenBind $
"found C " ++ kind ++ " for `" ++ identToLexeme ide ++ "'\n"
traceInfoHsType name ty = traceGenBind $
"associated with Haskell entity `" ++ name ++ "'\nhaving type " ++ ty
++ "\n"
expandHook (CHSClass oclassIde classIde typeIde pos) =
do
traceInfoClass
classIde `objIs` Class oclassIde typeIde
superClasses <- collectClasses oclassIde
Pointer ptrType isNewtype <- queryPointer typeIde
when (ptrType == CHSStablePtr) $
illegalStablePtrErr pos
classDef pos (identToLexeme classIde) (identToLexeme typeIde)
ptrType isNewtype superClasses
where
collectClasses :: Maybe Ident -> GB [(String, String, HsObject)]
collectClasses Nothing = return []
collectClasses (Just ide) =
do
Class oclassIde typeIde <- queryClass ide
ptr <- queryPointer typeIde
classes <- collectClasses oclassIde
return $ (identToLexeme ide, identToLexeme typeIde, ptr) : classes
traceInfoClass = traceGenBind $ "** Class hook:\n"
enumDef :: CEnum -> String -> TransFun -> [String] -> GB String
enumDef cenum@(CEnum _ list _) hident trans userDerive =
do
(list', enumAuto) <- evalTagVals list
let enumVals = [(trans ide, cexpr) | (ide, cexpr) <- list']
defHead = enumHead hident
defBody = enumBody (length defHead - 2) enumVals
inst = makeDerives
(if enumAuto then "Enum" : userDerive else userDerive) ++
if enumAuto then "\n" else "\n" ++ enumInst hident enumVals
return $ defHead ++ defBody ++ inst
where
cpos = posOf cenum
evalTagVals [] = return ([], True)
evalTagVals ((ide, Nothing ):list) =
do
(list', derived) <- evalTagVals list
return ((ide, Nothing):list', derived)
evalTagVals ((ide, Just exp):list) =
do
(list', derived) <- evalTagVals list
val <- evalConstCExpr exp
case val of
IntResult val' ->
return ((ide, Just $ CConst (CIntConst val' at1) at2):list',
False)
FloatResult _ ->
illegalConstExprErr (posOf exp) "a float result"
where
at1 = newAttrsOnlyPos nopos
at2 = newAttrsOnlyPos nopos
makeDerives [] = ""
makeDerives dList = "deriving (" ++ concat (intersperse "," dList) ++")"
enumHead :: String -> String
enumHead ident = "data " ++ ident ++ " = "
enumBody :: Int -> [(String, Maybe CExpr)] -> String
enumBody indent [] = ""
enumBody indent ((ide, _):list) =
ide ++ "\n" ++ replicate indent ' '
++ (if null list then "" else "| " ++ enumBody indent list)
enumInst :: String -> [(String, Maybe CExpr)] -> String
enumInst ident list =
"instance Enum " ++ ident ++ " where\n"
++ fromDef flatList ++ "\n" ++ toDef flatList ++ "\n"
++ succDef names ++ "\n" ++ predDef names ++ "\n"
++ enumFromToDef names
where
names = map fst list
flatList = flatten list 0
flatten [] n = []
flatten ((ide, exp):list) n = (ide, val) : flatten list (val + 1)
where
val = case exp of
Nothing -> n
Just (CConst (CIntConst m _) _) -> m
Just _ -> interr "GenBind.enumInst: Integer constant expected!"
show' x = if x < 0 then "(" ++ show x ++ ")" else show x
fromDef list = concat
[ " fromEnum " ++ ide ++ " = " ++ show' val ++ "\n"
| (ide, val) <- list
]
toDef list = concat
[ " toEnum " ++ show' val ++ " = " ++ ide ++ "\n"
| (ide, val) <- nubBy (\x y -> snd x == snd y) list
]
++ " toEnum unmatched = error (\"" ++ ident
++ ".toEnum: Cannot match \" ++ show unmatched)\n"
succDef [] = " succ _ = undefined\n"
succDef [x] = " succ _ = undefined\n"
succDef (x:x':xs) =
" succ " ++ x ++ " = " ++ x' ++ "\n"
++ succDef (x':xs)
predDef [] = " pred _ = undefined\n"
predDef [x] = " pred _ = undefined\n"
predDef (x:x':xs) =
" pred " ++ x' ++ " = " ++ x ++ "\n"
++ predDef (x':xs)
enumFromToDef [] = ""
enumFromToDef names =
" enumFromTo x y | fromEnum x == fromEnum y = [ y ]\n"
++ " | otherwise = x : enumFromTo (succ x) y\n"
++ " enumFrom x = enumFromTo x " ++ last names ++ "\n"
++ " enumFromThen _ _ = "
++ " error \"Enum "++ident++": enumFromThen not implemented\"\n"
++ " enumFromThenTo _ _ _ = "
++ " error \"Enum "++ident++": enumFromThenTo not implemented\"\n"
callImport :: CHSHook -> Bool -> Bool -> Maybe String -> String -> String
-> CDecl -> Position -> GB String
callImport hook isPure isUns mLock ideLexeme hsLexeme cdecl pos =
do
(mHsPtrRep, extType) <- extractFunType pos cdecl isPure
header <- getSwitch headerSB
delayCode hook (foreignImport header ideLexeme hsLexeme isUns extType)
traceFunType extType
if any isJust mHsPtrRep
then createLambdaExpr mHsPtrRep
else return funStr
where
createLambdaExpr :: [Maybe HsPtrRep] -> GB String
createLambdaExpr foreignVec = return $
"(\\" ++
unwords (zipWith wrPattern foreignVec [1..])++ " -> "++
concat (zipWith wrForPtr foreignVec [1..])++funStr++" "++
unwords (zipWith wrArg foreignVec [1..])++")"
wrPattern (Just (_,_,Just con,_)) n = "("++con++" arg"++show n++")"
wrPattern _ n = "arg"++show n
wrForPtr (Just (_,CHSForeignPtr,_,_)) n
= "withForeignPtr arg"++show n++" $ \\argPtr"++show n++" ->"
wrForPtr _ n = ""
wrArg (Just (_,CHSForeignPtr,_,_)) n = "argPtr"++show n
wrArg (Just (_,CHSStablePtr,_,_)) n =
"(castStablePtrToPtr arg"++show n++")"
wrArg _ n = "arg"++show n
funStr = case mLock of Nothing -> hsLexeme
Just lockFun -> lockFun ++ " $ " ++ hsLexeme
traceFunType et = traceGenBind $
"Imported function type: " ++ showExtType et ++ "\n"
foreignImport :: String -> String -> String -> Bool -> ExtType -> String
foreignImport header ident hsIdent isUnsafe ty =
"foreign import ccall " ++ safety ++ " " ++ show entity ++
"\n " ++ hsIdent ++ " :: " ++ showExtType ty ++ "\n"
where
safety = if isUnsafe then "unsafe" else "safe"
entity | null header = ident
| otherwise = header ++ " " ++ ident
funDef :: Bool
-> String
-> String
-> CDecl
-> Maybe String
-> Maybe String
-> [CHSParm]
-> CHSParm
-> Position
-> GB String
funDef isPure hsLexeme fiLexeme cdecl octxt mLock parms parm pos =
do
(parms', parm', isImpure) <- addDftMarshaller pos parms parm cdecl
traceMarsh parms' parm' isImpure
let
sig = hsLexeme ++ " :: " ++ funTy parms' parm' ++ "\n"
marshs = [marshArg i parm | (i, parm) <- zip [1..] parms']
funArgs = [funArg | (funArg, _, _, _, _) <- marshs, funArg /= ""]
marshIns = [marshIn | (_, marshIn, _, _, _) <- marshs]
callArgs = [callArg | (_, _, callArg, _, _) <- marshs]
marshOuts = [marshOut | (_, _, _, marshOut, _) <- marshs, marshOut /= ""]
retArgs = [retArg | (_, _, _, _, retArg) <- marshs, retArg /= ""]
funHead = hsLexeme ++ join funArgs ++ " =\n" ++
if isPure && isImpure then " unsafePerformIO $\n" else ""
lock = case mLock of Nothing -> ""
Just lock -> lock ++ " $"
call = if isPure
then " let {res = " ++ fiLexeme ++ join callArgs ++ "} in\n"
else " " ++ lock ++ fiLexeme ++ join callArgs ++ " >>= \\res ->\n"
marshRes = case parm' of
CHSParm _ _ twoCVal (Just (_ , CHSVoidArg)) _ -> ""
CHSParm _ _ twoCVal (Just (omIde, CHSIOArg )) _ ->
" " ++ identToLexeme omIde ++ " res >>= \\res' ->\n"
CHSParm _ _ twoCVal (Just (omIde, CHSValArg )) _ ->
" let {res' = " ++ identToLexeme omIde ++ " res} in\n"
CHSParm _ _ _ Nothing _ ->
interr "GenBind.funDef: marshRes: no default?"
retArgs' = case parm' of
CHSParm _ _ _ (Just (_, CHSVoidArg)) _ -> retArgs
_ -> "res'":retArgs
ret = "(" ++ concat (intersperse ", " retArgs') ++ ")"
funBody = joinLines marshIns ++
call ++
joinLines marshOuts ++
marshRes ++
" " ++
(if isImpure || not isPure then "return " else "") ++ ret
return $ sig ++ funHead ++ funBody
where
join = concatMap (' ':)
joinLines = concatMap (\s -> " " ++ s ++ "\n")
funTy parms parm =
let
ctxt = case octxt of
Nothing -> ""
Just ctxtStr -> ctxtStr ++ " => "
argTys = [ty | CHSParm im ty _ _ _ <- parms , notVoid im]
resTys = [ty | CHSParm _ ty _ om _ <- parm:parms, notVoid om]
resTup = let
(lp, rp) = if isPure && length resTys == 1
then ("", "")
else ("(", ")")
io = if isPure then "" else "IO "
in
io ++ lp ++ concat (intersperse ", " resTys) ++ rp
in
ctxt ++ concat (intersperse " -> " (argTys ++ [resTup]))
where
notVoid Nothing = interr "GenBind.funDef: \
\No default marshaller?"
notVoid (Just (_, kind)) = kind /= CHSVoidArg
marshArg i (CHSParm (Just (imIde, imArgKind)) _ twoCVal
(Just (omIde, omArgKind)) _ ) =
let
a = "a" ++ show i
imStr = identToLexeme imIde
imApp = imStr ++ " " ++ a
funArg = if imArgKind == CHSVoidArg then "" else a
inBndr = if twoCVal
then "(" ++ a ++ "'1, " ++ a ++ "'2)"
else a ++ "'"
marshIn = case imArgKind of
CHSVoidArg -> imStr ++ " $ \\" ++ inBndr ++ " -> "
CHSIOArg -> imApp ++ " $ \\" ++ inBndr ++ " -> "
CHSValArg -> "let {" ++ inBndr ++ " = " ++
imApp ++ "} in "
callArg = if twoCVal
then "" ++ a ++ "'1 " ++ a ++ "'2"
else a ++ "'"
omApp = identToLexeme omIde ++ " " ++ callArg
outBndr = a ++ "''"
marshOut = case omArgKind of
CHSVoidArg -> ""
CHSIOArg -> omApp ++ ">>= \\" ++ outBndr ++ " -> "
CHSValArg -> "let {" ++ outBndr ++ " = " ++
omApp ++ "} in "
retArg = if omArgKind == CHSVoidArg then "" else outBndr
in
(funArg, marshIn, callArg, marshOut, retArg)
marshArg _ _ = interr "GenBind.funDef: Missing default?"
traceMarsh parms parm isImpure = traceGenBind $
"Marshalling specification including defaults: \n" ++
showParms (parms ++ [parm]) "" ++
" The marshalling is " ++ if isImpure then "impure.\n" else "pure.\n"
where
showParms [] = id
showParms (parm:parms) = showString " "
. showCHSParm parm
. showChar '\n'
. showParms parms
addDftMarshaller :: Position -> [CHSParm] -> CHSParm -> CDecl
-> GB ([CHSParm], CHSParm, Bool)
addDftMarshaller pos parms parm cdecl = do
(_, fType) <- extractFunType pos cdecl True
let (resTy, argTys) = splitFunTy fType
(parm' , isImpure1) <- checkResMarsh parm resTy
(parms', isImpure2) <- addDft parms argTys
return (parms', parm', isImpure1 || isImpure2)
where
checkResMarsh (CHSParm (Just _) _ _ _ pos) _ =
resMarshIllegalInErr pos
checkResMarsh (CHSParm _ _ True _ pos) _ =
resMarshIllegalTwoCValErr pos
checkResMarsh (CHSParm _ ty _ omMarsh pos) cTy = do
(imMarsh', _ ) <- addDftVoid Nothing
(omMarsh', isImpure) <- addDftOut pos omMarsh ty [cTy]
return (CHSParm imMarsh' ty False omMarsh' pos, isImpure)
splitFunTy (FunET UnitET ty ) = splitFunTy ty
splitFunTy (FunET ty1 ty2) = let
(resTy, argTys) = splitFunTy ty2
in
(resTy, ty1:argTys)
splitFunTy resTy = (resTy, [])
addDft ((CHSParm imMarsh hsTy False omMarsh p):parms) (cTy :cTys) = do
(imMarsh', isImpureIn ) <- addDftIn p imMarsh hsTy [cTy]
(omMarsh', isImpureOut) <- addDftVoid omMarsh
(parms' , isImpure ) <- addDft parms cTys
return (CHSParm imMarsh' hsTy False omMarsh' p : parms',
isImpure || isImpureIn || isImpureOut)
addDft ((CHSParm imMarsh hsTy True omMarsh p):parms) (cTy1:cTy2:cTys) = do
(imMarsh', isImpureIn ) <- addDftIn p imMarsh hsTy [cTy1, cTy2]
(omMarsh', isImpureOut) <- addDftVoid omMarsh
(parms' , isImpure ) <- addDft parms cTys
return (CHSParm imMarsh' hsTy True omMarsh' p : parms',
isImpure || isImpureIn || isImpureOut)
addDft [] [] =
return ([], False)
addDft ((CHSParm _ _ _ _ pos):parms) [] =
marshArgMismatchErr pos "This parameter is in excess of the C arguments."
addDft [] (_:_) =
marshArgMismatchErr pos "Parameter marshallers are missing."
addDftIn _ imMarsh@(Just (_, kind)) _ _ = return (imMarsh,
kind == CHSIOArg)
addDftIn pos imMarsh@Nothing hsTy cTys = do
marsh <- lookupDftMarshIn hsTy cTys
when (isNothing marsh) $
noDftMarshErr pos "\"in\"" hsTy cTys
return (marsh, case marsh of {Just (_, kind) -> kind == CHSIOArg})
addDftOut _ omMarsh@(Just (_, kind)) _ _ = return (omMarsh,
kind == CHSIOArg)
addDftOut pos omMarsh@Nothing hsTy cTys = do
marsh <- lookupDftMarshOut hsTy cTys
when (isNothing marsh) $
noDftMarshErr pos "\"out\"" hsTy cTys
return (marsh, case marsh of {Just (_, kind) -> kind == CHSIOArg})
addDftVoid marsh@(Just (_, kind)) = return (marsh, kind == CHSIOArg)
addDftVoid Nothing = do
return (Just (noPosIdent "void", CHSVoidArg), False)
accessPath :: CHSAPath -> GB (CDecl, [BitSize])
accessPath (CHSRoot ide) =
do
decl <- findAndChaseDecl ide False True
return (ide `simplifyDecl` decl, [BitSize 0 0])
accessPath (CHSDeref (CHSRoot ide) _) =
do
decl <- findAndChaseDecl ide True True
return (ide `simplifyDecl` decl, [BitSize 0 0])
accessPath (CHSRef root@(CHSRoot ide1) ide2) =
do
su <- lookupStructUnion ide1 False True
(offset, decl') <- refStruct su ide2
adecl <- replaceByAlias decl'
return (adecl, [offset])
accessPath (CHSRef (CHSDeref (CHSRoot ide1) _) ide2) =
do
su <- lookupStructUnion ide1 True True
(offset, decl') <- refStruct su ide2
adecl <- replaceByAlias decl'
return (adecl, [offset])
accessPath (CHSRef path ide) =
do
(decl, offset:offsets) <- accessPath path
assertPrimDeclr ide decl
su <- structFromDecl (posOf ide) decl
(addOffset, decl') <- refStruct su ide
adecl <- replaceByAlias decl'
return (adecl, offset `addBitSize` addOffset : offsets)
where
assertPrimDeclr ide (CDecl _ [declr] _) =
case declr of
(Just (CVarDeclr _ _), _, _) -> nop
_ -> structExpectedErr ide
accessPath (CHSDeref path pos) =
do
(decl, offsets) <- accessPath path
decl' <- derefOrErr decl
adecl <- replaceByAlias decl'
return (adecl, BitSize 0 0 : offsets)
where
derefOrErr (CDecl specs [declr] at) =
case declr of
(Just (CPtrDeclr [_] declr at), oinit, oexpr) ->
return $ CDecl specs [(Just declr, oinit, oexpr)] at
(Just (CPtrDeclr (_:quals) declr at), oinit, oexpr) ->
return $
CDecl specs [(Just (CPtrDeclr quals declr at), oinit, oexpr)] at
_ ->
ptrExpectedErr pos
replaceByAlias :: CDecl -> GB CDecl
replaceByAlias cdecl@(CDecl _ [(_, _, size)] at) =
do
ocdecl <- checkForAlias cdecl
case ocdecl of
Nothing -> return cdecl
Just (CDecl specs [(declr, init, _)] at) ->
return $ CDecl specs [(declr, init, size)] at
refStruct :: CStructUnion -> Ident -> GB (BitSize, CDecl)
refStruct su ide =
do
let (fields, tag) = structMembers su
(pre, post) = span (not . flip declNamed ide) fields
when (null post) $
unknownFieldErr (posOf su) ide
let decl = head post
offset <- case tag of
CStructTag -> offsetInStruct pre decl tag
CUnionTag -> return $ BitSize 0 0
return (offset, decl)
declNamed :: CDecl -> Ident -> Bool
(CDecl _ [(Nothing , _, _)] _) `declNamed` ide = False
(CDecl _ [(Just declr, _, _)] _) `declNamed` ide = declr `declrNamed` ide
(CDecl _ [] _) `declNamed` _ =
interr "GenBind.declNamed: Abstract declarator in structure!"
_ `declNamed` _ =
interr "GenBind.declNamed: More than one declarator!"
setGet :: Position -> CHSAccess -> [BitSize] -> ExtType -> GB String
setGet pos access offsets ty =
do
let pre = case access of
CHSSet -> "(\\ptr val -> do {"
CHSGet -> "(\\ptr -> do {"
body <- setGetBody (reverse offsets)
return $ pre ++ body ++ "})"
where
setGetBody [BitSize offset bitOffset] =
do
let ty' = case ty of
t@(DefinedET _ _) -> PtrET t
t -> t
let tyTag = showExtType ty'
bf <- checkType ty'
case bf of
Nothing -> return $ case access of
CHSGet -> peekOp offset tyTag
CHSSet -> pokeOp offset tyTag "val"
Just (_, bs) -> return $ case access of
CHSGet -> "val <- " ++ peekOp offset tyTag
++ extractBitfield
CHSSet -> "org <- " ++ peekOp offset tyTag
++ insertBitfield
++ pokeOp offset tyTag "val'"
where
extractBitfield = "; return $ (val `shiftL` ("
++ bitsPerField ++ " - "
++ show (bs + bitOffset) ++ ")) `shiftR` ("
++ bitsPerField ++ " - " ++ show bs
++ ")"
bitsPerField = show $ size CIntPT * 8
insertBitfield = "; let {val' = (org .&. " ++ middleMask
++ ") .|. (val `shiftL` "
++ show bitOffset ++ ")}; "
middleMask = "fromIntegral (((maxBound::CUInt) `shiftL` "
++ show bs ++ ") `rotateL` "
++ show bitOffset ++ ")"
setGetBody (BitSize offset 0 : offsets) =
do
code <- setGetBody offsets
return $ "ptr <- peekByteOff ptr " ++ show offset ++ "; " ++ code
setGetBody (BitSize _ _ : _ ) =
derefBitfieldErr pos
checkType (IOET _ ) = interr "GenBind.setGet: Illegal \
\type!"
checkType (UnitET ) = voidFieldErr pos
checkType (PrimET (CUFieldPT bs)) = return $ Just (False, bs)
checkType (PrimET (CSFieldPT bs)) = return $ Just (True , bs)
checkType _ = return Nothing
peekOp off tyTag = "peekByteOff ptr " ++ show off ++ " ::IO " ++ tyTag
pokeOp off tyTag var = "pokeByteOff ptr " ++ show off ++ " (" ++ var
++ "::" ++ tyTag ++ ")"
pointerDef :: Bool
-> Ident
-> String
-> CHSPtrType
-> Bool
-> String
-> Bool
-> GB String
pointerDef isStar cNameFull hsName ptrKind isNewtype hsType isFun =
do
keepOld <- getSwitch oldFFI
let ptrArg = if keepOld
then "()"
else if isNewtype
then hsName
else hsType
ptrCon = case ptrKind of
CHSPtr | isFun -> "FunPtr"
_ -> show ptrKind
ptrType = ptrCon ++ " (" ++ ptrArg ++ ")"
thePtr = (isStar, cNameFull)
thePtr `ptrMapsTo` (isFun,
ptrKind,
if isNewtype then Just hsName else Nothing,
ptrArg)
return $
if isNewtype
then "newtype " ++ hsName ++ " = " ++ hsName ++ " (" ++ ptrType ++ ")"
else "type " ++ hsName ++ " = " ++ ptrType
classDef :: Position
-> String
-> String
-> CHSPtrType
-> Bool
-> [(String, String, HsObject)]
-> GB String
classDef pos className typeName ptrType isNewtype superClasses =
do
let
toMethodName = case typeName of
"" -> interr "GenBind.classDef: \
\Illegal identifier!"
c:cs -> toLower c : cs
fromMethodName = "from" ++ typeName
classDefContext = case superClasses of
[] -> ""
(superName, _, _):_ -> superName ++ " p => "
classDef =
"class " ++ classDefContext ++ className ++ " p where\n"
++ " " ++ toMethodName ++ " :: p -> " ++ typeName ++ "\n"
++ " " ++ fromMethodName ++ " :: " ++ typeName ++ " -> p\n"
instDef =
"instance " ++ className ++ " " ++ typeName ++ " where\n"
++ " " ++ toMethodName ++ " = id\n"
++ " " ++ fromMethodName ++ " = id\n"
instDefs <- castInstDefs superClasses
return $ classDef ++ instDefs ++ instDef
where
castInstDefs [] = return ""
castInstDefs ((superName, ptrName, Pointer ptrType' isNewtype'):classes) =
do
unless (ptrType == ptrType') $
pointerTypeMismatchErr pos className superName
let toMethodName = case ptrName of
"" -> interr "GenBind.classDef: \
\Illegal identifier - 2!"
c:cs -> toLower c : cs
fromMethodName = "from" ++ ptrName
castFun = "cast" ++ show ptrType
typeConstr = if isNewtype then typeName ++ " " else ""
superConstr = if isNewtype' then ptrName ++ " " else ""
instDef =
"instance " ++ superName ++ " " ++ typeName ++ " where\n"
++ " " ++ toMethodName ++ " (" ++ typeConstr ++ "p) = "
++ superConstr ++ "(" ++ castFun ++ " p)\n"
++ " " ++ fromMethodName ++ " (" ++ superConstr ++ "p) = "
++ typeConstr ++ "(" ++ castFun ++ " p)\n"
instDefs <- castInstDefs classes
return $ instDef ++ instDefs
data ConstResult = IntResult Integer
| FloatResult Float
data ExtType = FunET ExtType ExtType
| IOET ExtType
| PtrET ExtType
| DefinedET CDecl HsPtrRep
| PrimET CPrimType
| UnitET
instance Eq ExtType where
(FunET t1 t2 ) == (FunET t1' t2' ) = t1 == t1' && t2 == t2'
(IOET t ) == (IOET t' ) = t == t'
(PtrET t ) == (PtrET t' ) = t == t'
(DefinedET _ rep ) == (DefinedET _ rep' ) = rep == rep'
(PrimET t ) == (PrimET t' ) = t == t'
UnitET == UnitET = True
data CompType = ExtType ExtType
| SUType CStructUnion
isFunExtType :: ExtType -> Bool
isFunExtType (FunET _ _) = True
isFunExtType (IOET _ ) = True
isFunExtType (DefinedET _ (isFun,_,_,_)) = isFun
isFunExtType _ = False
showExtType :: ExtType -> String
showExtType (FunET UnitET res) = showExtType res
showExtType (FunET arg res) = "(" ++ showExtType arg ++ " -> "
++ showExtType res ++ ")"
showExtType (IOET t) = "(IO " ++ showExtType t ++ ")"
showExtType (PtrET t) = let ptrCon = if isFunExtType t
then "FunPtr" else "Ptr"
in
"(" ++ ptrCon ++ " " ++ showExtType t
++ ")"
showExtType (DefinedET _ (_,_,_,str)) = str
showExtType (PrimET CPtrPT) = "(Ptr ())"
showExtType (PrimET CFunPtrPT) = "(FunPtr ())"
showExtType (PrimET CCharPT) = "CChar"
showExtType (PrimET CUCharPT) = "CUChar"
showExtType (PrimET CSCharPT) = "CSChar"
showExtType (PrimET CIntPT) = "CInt"
showExtType (PrimET CShortPT) = "CShort"
showExtType (PrimET CLongPT) = "CLong"
showExtType (PrimET CLLongPT) = "CLLong"
showExtType (PrimET CUIntPT) = "CUInt"
showExtType (PrimET CUShortPT) = "CUShort"
showExtType (PrimET CULongPT) = "CULong"
showExtType (PrimET CULLongPT) = "CULLong"
showExtType (PrimET CFloatPT) = "CFloat"
showExtType (PrimET CDoublePT) = "CDouble"
showExtType (PrimET CLDoublePT) = "CLDouble"
showExtType (PrimET (CSFieldPT bs)) = "CInt{-:" ++ show bs ++ "-}"
showExtType (PrimET (CUFieldPT bs)) = "CUInt{-:" ++ show bs ++ "-}"
showExtType UnitET = "()"
extractFunType :: Position -> CDecl -> Bool ->
GB ([Maybe HsPtrRep], ExtType)
extractFunType pos cdecl isPure =
do
let (args, resultDecl, variadic) = funResultAndArgs cdecl
when variadic $
variadicErr pos cpos
preResultType <- liftM (snd . expandSpecialPtrs) $
extractSimpleType pos resultDecl
let resultType = if isPure
then preResultType
else IOET preResultType
(foreignSyn, argTypes) <- liftM (unzip . map expandSpecialPtrs) $
mapM (extractSimpleType pos) args
return (foreignSyn, foldr FunET resultType argTypes)
where
cpos = posOf cdecl
expandSpecialPtrs :: ExtType -> (Maybe HsPtrRep, ExtType)
expandSpecialPtrs all@(DefinedET cdecl (_, CHSPtr, Nothing, _)) =
(Nothing, PtrET all)
expandSpecialPtrs all@(DefinedET cdecl hsPtrRep) =
(Just hsPtrRep, PtrET all)
expandSpecialPtrs all = (Nothing, all)
extractSimpleType :: Position -> CDecl -> GB ExtType
extractSimpleType pos cdecl =
do
traceEnter
ct <- extractCompType cdecl
case ct of
ExtType et -> return et
SUType _ -> illegalStructUnionErr (posOf cdecl) pos
where
traceEnter = traceGenBind $
"Entering `extractSimpleType'...\n"
extractPtrType :: CDecl -> GB ExtType
extractPtrType cdecl = do
ct <- extractCompType cdecl
case ct of
ExtType et -> return et
SUType _ -> return UnitET
extractCompType :: CDecl -> GB CompType
extractCompType cdecl@(CDecl specs declrs ats) =
if length declrs > 1
then interr "GenBind.extractCompType: Too many declarators!"
else case declrs of
[(Just declr, _, size)] | isPtrDeclr declr -> ptrType declr
| isFunDeclr declr -> funType
| otherwise -> aliasOrSpecType size
[] -> aliasOrSpecType Nothing
where
ptrType declr = do
tracePtrType
let declrs' = dropPtrDeclr declr
cdecl' = CDecl specs [(Just declrs', Nothing, Nothing)] ats
oalias = checkForOneAliasName cdecl'
oHsRepr <- case oalias of
Nothing -> return $ Nothing
Just ide -> queryPtr (True, ide)
case oHsRepr of
Just repr -> ptrAlias repr
Nothing -> do
ct <- extractCompType cdecl'
returnX $ case ct of
ExtType et -> PtrET et
SUType _ -> PtrET UnitET
funType = do
traceFunType
(_, et) <- extractFunType (posOf cdecl) cdecl False
returnX et
aliasOrSpecType :: Maybe CExpr -> GB CompType
aliasOrSpecType size = do
traceAliasOrSpecType size
case checkForOneAliasName cdecl of
Nothing -> specType (posOf cdecl) specs size
Just ide -> do
traceAlias ide
oHsRepr <- queryPtr (False, ide)
case oHsRepr of
Nothing -> do
cdecl' <- getDeclOf ide
let CDecl specs [(declr, init, _)] at =
ide `simplifyDecl` cdecl'
sdecl = CDecl specs [(declr, init, size)] at
extractCompType sdecl
Just repr -> ptrAlias repr
ptrAlias (isFun, ptrTy, wrapped, tyArg) =
returnX $ DefinedET cdecl (isFun, ptrTy, wrapped, tyArg)
returnX retval@(PtrET et) = do
keepOld <- getSwitch oldFFI
if keepOld
then return $ ExtType (PrimET CPtrPT)
else return $ ExtType retval
returnX retval = return $ ExtType retval
tracePtrType = traceGenBind $ "extractCompType: explicit pointer type\n"
traceFunType = traceGenBind $ "extractCompType: explicit function type\n"
traceAliasOrSpecType Nothing = traceGenBind $
"extractCompType: checking for alias\n"
traceAliasOrSpecType (Just _) = traceGenBind $
"extractCompType: checking for alias of bitfield\n"
traceAlias ide = traceGenBind $
"extractCompType: found an alias called `" ++ identToLexeme ide ++ "'\n"
typeMap :: [([CTypeSpec], ExtType)]
typeMap = [([void] , UnitET ),
([char] , PrimET CCharPT ),
([unsigned, char] , PrimET CUCharPT ),
([signed, char] , PrimET CSCharPT ),
([signed] , PrimET CIntPT ),
([int] , PrimET CIntPT ),
([signed, int] , PrimET CIntPT ),
([short] , PrimET CShortPT ),
([short, int] , PrimET CShortPT ),
([signed, short] , PrimET CShortPT ),
([signed, short, int] , PrimET CShortPT ),
([long] , PrimET CLongPT ),
([long, int] , PrimET CLongPT ),
([signed, long] , PrimET CLongPT ),
([signed, long, int] , PrimET CLongPT ),
([long, long] , PrimET CLLongPT ),
([long, long, int] , PrimET CLLongPT ),
([signed, long, long] , PrimET CLLongPT ),
([signed, long, long, int] , PrimET CLLongPT ),
([unsigned] , PrimET CUIntPT ),
([unsigned, int] , PrimET CUIntPT ),
([unsigned, short] , PrimET CUShortPT ),
([unsigned, short, int] , PrimET CUShortPT ),
([unsigned, long] , PrimET CULongPT ),
([unsigned, long, int] , PrimET CULongPT ),
([unsigned, long, long] , PrimET CULLongPT ),
([unsigned, long, long, int] , PrimET CULLongPT ),
([float] , PrimET CFloatPT ),
([double] , PrimET CDoublePT ),
([long, double] , PrimET CLDoublePT),
([enum] , PrimET CIntPT )]
where
void = CVoidType undefined
char = CCharType undefined
short = CShortType undefined
int = CIntType undefined
long = CLongType undefined
float = CFloatType undefined
double = CDoubleType undefined
signed = CSignedType undefined
unsigned = CUnsigType undefined
enum = CEnumType undefined undefined
specType :: Position -> [CDeclSpec] -> Maybe CExpr -> GB CompType
specType cpos specs osize =
let tspecs = [ts | CTypeSpec ts <- specs]
in case lookupTSpec tspecs typeMap of
Just et | isUnsupportedType et -> unsupportedTypeSpecErr cpos
| isNothing osize -> return $ ExtType et
| otherwise -> bitfieldSpec tspecs et osize
Nothing ->
case tspecs of
[CSUType cu _] -> return $ SUType cu
[CEnumType _ _] -> return $ ExtType (PrimET CIntPT)
[CTypeDef _ _] -> interr "GenBind.specType: Illegal typedef alias!"
_ -> illegalTypeSpecErr cpos
where
lookupTSpec = lookupBy matches
isUnsupportedType (PrimET et) = size et == 0
isUnsupportedType _ = False
matches :: [CTypeSpec] -> [CTypeSpec] -> Bool
[] `matches` [] = True
[] `matches` (_:_) = False
(spec:specs) `matches` specs'
| any (eqSpec spec) specs' = specs `matches` deleteBy eqSpec spec specs'
| otherwise = False
eqSpec (CVoidType _) (CVoidType _) = True
eqSpec (CCharType _) (CCharType _) = True
eqSpec (CShortType _) (CShortType _) = True
eqSpec (CIntType _) (CIntType _) = True
eqSpec (CLongType _) (CLongType _) = True
eqSpec (CFloatType _) (CFloatType _) = True
eqSpec (CDoubleType _) (CDoubleType _) = True
eqSpec (CSignedType _) (CSignedType _) = True
eqSpec (CUnsigType _) (CUnsigType _) = True
eqSpec (CSUType _ _) (CSUType _ _) = True
eqSpec (CEnumType _ _) (CEnumType _ _) = True
eqSpec (CTypeDef _ _) (CTypeDef _ _) = True
eqSpec _ _ = False
bitfieldSpec :: [CTypeSpec] -> ExtType -> Maybe CExpr -> GB CompType
bitfieldSpec tspecs et (Just sizeExpr) =
do
let pos = posOf sizeExpr
sizeResult <- evalConstCExpr sizeExpr
case sizeResult of
FloatResult _ -> illegalConstExprErr pos "a float result"
IntResult size' -> do
let size = fromInteger size'
case et of
PrimET CUIntPT -> returnCT $ CUFieldPT size
PrimET CIntPT
| [signed] `matches` tspecs
|| [signed, int] `matches` tspecs -> returnCT $ CSFieldPT size
| [int] `matches` tspecs ->
returnCT $ if bitfieldIntSigned then CSFieldPT size
else CUFieldPT size
_ -> illegalFieldSizeErr pos
where
returnCT = return . ExtType . PrimET
int = CIntType undefined
signed = CSignedType undefined
data BitSize = BitSize Int Int
deriving (Eq, Show)
instance Ord BitSize where
bs1@(BitSize o1 b1) < bs2@(BitSize o2 b2) =
padBits bs1 < padBits bs2 || (o1 == o2 && b1 < b2)
bs1 <= bs2 = bs1 < bs2 || bs1 == bs2
addBitSize :: BitSize -> BitSize -> BitSize
addBitSize (BitSize o1 b1) (BitSize o2 b2) = BitSize (o1 + o2 + overflow) rest
where
bitsPerBitfield = size CIntPT * 8
(overflow, rest) = (b1 + b2) `divMod` bitsPerBitfield
padBits :: BitSize -> Int
padBits (BitSize o 0) = o
padBits (BitSize o _) = o + size CIntPT
offsetInStruct :: [CDecl] -> CDecl -> CStructTag -> GB BitSize
offsetInStruct [] _ _ = return $ BitSize 0 0
offsetInStruct decls decl tag =
do
(offset, _) <- sizeAlignOfStruct decls tag
(_, align) <- sizeAlignOf decl
return $ alignOffset offset align
sizeAlignOfStruct :: [CDecl] -> CStructTag -> GB (BitSize, Int)
sizeAlignOfStruct [] _ = return (BitSize 0 0, 1)
sizeAlignOfStruct decls CStructTag =
do
(offset, preAlign) <- sizeAlignOfStruct (init decls) CStructTag
(size, align) <- sizeAlignOf (last decls)
let sizeOfStruct = alignOffset offset align `addBitSize` size
align' = if align > 0 then align else bitfieldAlignment
alignOfStruct = preAlign `max` align'
return (sizeOfStruct, alignOfStruct)
sizeAlignOfStruct decls CUnionTag =
do
(sizes, aligns) <- mapAndUnzipM sizeAlignOf decls
let aligns' = [if align > 0 then align else bitfieldAlignment
| align <- aligns]
return (maximum sizes, maximum aligns')
sizeAlignOfStructPad :: [CDecl] -> CStructTag -> GB (BitSize, Int)
sizeAlignOfStructPad decls tag =
do
(size, align) <- sizeAlignOfStruct decls tag
return (alignOffset size align, align)
sizeAlignOf :: CDecl -> GB (BitSize, Int)
sizeAlignOf (CDecl specs [(Just declr, _, size)] ats) | isArrDeclr declr =
interr $ "sizeAlignOf: calculating size of constant array not supported."
sizeAlignOf cdecl =
do
ct <- extractCompType cdecl
case ct of
ExtType (FunET _ _ ) -> return (bitSize CFunPtrPT,
alignment CFunPtrPT)
ExtType (IOET _ ) -> interr "GenBind.sizeof: Illegal IO type!"
ExtType (PtrET t )
| isFunExtType t -> return (bitSize CFunPtrPT,
alignment CFunPtrPT)
| otherwise -> return (bitSize CPtrPT, alignment CPtrPT)
ExtType (DefinedET _ _ ) -> return (bitSize CPtrPT, alignment CPtrPT)
ExtType (PrimET pt ) -> return (bitSize pt, alignment pt)
ExtType UnitET -> voidFieldErr (posOf cdecl)
SUType su ->
do
let (fields, tag) = structMembers su
fields' <- let ide = structName su
in
if (not . null $ fields) || isNothing ide
then return fields
else do
tag <- findTag (fromJust ide)
case tag of
Just (StructUnionCT su) -> return
(fst . structMembers $ su)
_ -> return fields
sizeAlignOfStructPad fields' tag
where
bitSize et | sz < 0 = BitSize 0 (-sz)
| otherwise = BitSize sz 0
where
sz = size et
alignOffset :: BitSize -> Int -> BitSize
alignOffset offset@(BitSize octetOffset bitOffset) align
| align > 0 && bitOffset /= 0 =
alignOffset (BitSize (octetOffset + (bitOffset + 7) `div` 8) 0) align
| align > 0 && bitOffset == 0 =
BitSize (((octetOffset - 1) `div` align + 1) * align) 0
| bitOffset == 0
|| overflowingBitfield =
alignOffset offset bitfieldAlignment
| otherwise =
offset
where
bitsPerBitfield = size CIntPT * 8
overflowingBitfield = bitOffset - align >= bitsPerBitfield
evalConstCExpr :: CExpr -> GB ConstResult
evalConstCExpr (CComma _ at) =
illegalConstExprErr (posOf at) "a comma expression"
evalConstCExpr (CAssign _ _ _ at) =
illegalConstExprErr (posOf at) "an assignment"
evalConstCExpr (CCond b (Just t) e _) =
do
bv <- evalConstCExpr b
case bv of
IntResult bvi -> if bvi /= 0 then evalConstCExpr t else evalConstCExpr e
FloatResult _ -> illegalConstExprErr (posOf b) "a float result"
evalConstCExpr (CBinary op lhs rhs at) =
do
lhsVal <- evalConstCExpr lhs
rhsVal <- evalConstCExpr rhs
let (lhsVal', rhsVal') = usualArithConv lhsVal rhsVal
applyBin (posOf at) op lhsVal' rhsVal'
evalConstCExpr (CCast _ _ _) =
todo "GenBind.evalConstCExpr: Casts are not implemented yet."
evalConstCExpr (CUnary op arg at) =
do
argVal <- evalConstCExpr arg
applyUnary (posOf at) op argVal
evalConstCExpr (CSizeofExpr _ _) =
todo "GenBind.evalConstCExpr: sizeof not implemented yet."
evalConstCExpr (CSizeofType decl _) =
do
(size, _) <- sizeAlignOf decl
return $ IntResult (fromIntegral . padBits $ size)
evalConstCExpr (CAlignofExpr _ _) =
todo "GenBind.evalConstCExpr: alignof (GNU C extension) not implemented yet."
evalConstCExpr (CAlignofType decl _) =
do
(_, align) <- sizeAlignOf decl
return $ IntResult (fromIntegral align)
evalConstCExpr (CIndex _ _ at) =
illegalConstExprErr (posOf at) "array indexing"
evalConstCExpr (CCall _ _ at) =
illegalConstExprErr (posOf at) "function call"
evalConstCExpr (CMember _ _ _ at) =
illegalConstExprErr (posOf at) "a . or -> operator"
evalConstCExpr (CVar ide at) =
do
(cobj, _) <- findValueObj ide False
case cobj of
EnumCO ide (CEnum _ enumrs _) -> liftM IntResult $
enumTagValue ide enumrs 0
_ ->
todo $ "GenBind.evalConstCExpr: variable names not implemented yet " ++
show (posOf at)
where
enumTagValue _ [] _ =
interr "GenBind.enumTagValue: enumerator not in declaration"
enumTagValue ide ((ide', oexpr):enumrs) val =
do
val' <- case oexpr of
Nothing -> return val
Just exp ->
do
val' <- evalConstCExpr exp
case val' of
IntResult val' -> return val'
FloatResult _ ->
illegalConstExprErr (posOf exp) "a float result"
if ide == ide'
then
return val'
else
enumTagValue ide enumrs (val' + 1)
evalConstCExpr (CConst c _) =
evalCConst c
evalCConst :: CConst -> GB ConstResult
evalCConst (CIntConst i _ ) = return $ IntResult i
evalCConst (CCharConst c _ ) = return $ IntResult (toInteger (fromEnum c))
evalCConst (CFloatConst s _ ) =
todo "GenBind.evalCConst: Float conversion from literal misses."
evalCConst (CStrConst s at) =
illegalConstExprErr (posOf at) "a string constant"
usualArithConv :: ConstResult -> ConstResult -> (ConstResult, ConstResult)
usualArithConv lhs@(FloatResult _) rhs = (lhs, toFloat rhs)
usualArithConv lhs rhs@(FloatResult _) = (toFloat lhs, rhs)
usualArithConv lhs rhs = (lhs, rhs)
toFloat :: ConstResult -> ConstResult
toFloat x@(FloatResult _) = x
toFloat (IntResult i) = FloatResult . fromIntegral $ i
applyBin :: Position
-> CBinaryOp
-> ConstResult
-> ConstResult
-> GB ConstResult
applyBin cpos CMulOp (IntResult x)
(IntResult y) = return $ IntResult (x * y)
applyBin cpos CMulOp (FloatResult x)
(FloatResult y) = return $ FloatResult (x * y)
applyBin cpos CDivOp (IntResult x)
(IntResult y) = return $ IntResult (x `div` y)
applyBin cpos CDivOp (FloatResult x)
(FloatResult y) = return $ FloatResult (x / y)
applyBin cpos CRmdOp (IntResult x)
(IntResult y) = return$ IntResult (x `mod` y)
applyBin cpos CRmdOp (FloatResult x)
(FloatResult y) =
illegalConstExprErr cpos "a % operator applied to a float"
applyBin cpos CAddOp (IntResult x)
(IntResult y) = return $ IntResult (x + y)
applyBin cpos CAddOp (FloatResult x)
(FloatResult y) = return $ FloatResult (x + y)
applyBin cpos CSubOp (IntResult x)
(IntResult y) = return $ IntResult (x - y)
applyBin cpos CSubOp (FloatResult x)
(FloatResult y) = return $ FloatResult (x - y)
applyBin cpos CShlOp (IntResult x)
(IntResult y) = return $ IntResult (x * 2^y)
applyBin cpos CShlOp (FloatResult x)
(FloatResult y) =
illegalConstExprErr cpos "a << operator applied to a float"
applyBin cpos CShrOp (IntResult x)
(IntResult y) = return $ IntResult (x `div` 2^y)
applyBin cpos CShrOp (FloatResult x)
(FloatResult y) =
illegalConstExprErr cpos "a >> operator applied to a float"
applyBin cpos CAndOp (IntResult x)
(IntResult y) = return $ IntResult (x .&. y)
applyBin cpos COrOp (IntResult x)
(IntResult y) = return $ IntResult (x .|. y)
applyBin cpos CXorOp (IntResult x)
(IntResult y) = return $ IntResult (x `xor` y)
applyBin cpos _ (IntResult x)
(IntResult y) =
todo "GenBind.applyBin: Not yet implemented operator in constant expression."
applyBin cpos _ (FloatResult x)
(FloatResult y) =
todo "GenBind.applyBin: Not yet implemented operator in constant expression."
applyBin _ _ _ _ =
interr "GenBind.applyBinOp: Illegal combination!"
applyUnary :: Position -> CUnaryOp -> ConstResult -> GB ConstResult
applyUnary cpos CPreIncOp _ =
illegalConstExprErr cpos "a ++ operator"
applyUnary cpos CPreDecOp _ =
illegalConstExprErr cpos "a -- operator"
applyUnary cpos CPostIncOp _ =
illegalConstExprErr cpos "a ++ operator"
applyUnary cpos CPostDecOp _ =
illegalConstExprErr cpos "a -- operator"
applyUnary cpos CAdrOp _ =
illegalConstExprErr cpos "a & operator"
applyUnary cpos CIndOp _ =
illegalConstExprErr cpos "a * operator"
applyUnary cpos CPlusOp arg = return arg
applyUnary cpos CMinOp (IntResult x) = return (IntResult (-x))
applyUnary cpos CMinOp (FloatResult x) = return (FloatResult (-x))
applyUnary cpos CCompOp (IntResult x) = return (IntResult (complement x))
applyUnary cpos CNegOp (IntResult x) =
let r = toInteger . fromEnum $ (x == 0)
in return (IntResult r)
applyUnary cpos CNegOp (FloatResult _) =
illegalConstExprErr cpos "! applied to a float"
noPosIdent :: String -> Ident
noPosIdent = onlyPosIdent nopos
traceGenBind :: String -> GB ()
traceGenBind = putTraceStr traceGenBindSW
lookupBy :: (a -> a -> Bool) -> a -> [(a, b)] -> Maybe b
lookupBy eq x = fmap snd . find (eq x . fst)
mapMaybeM_ :: Monad m => (a -> m b) -> Maybe a -> m ()
mapMaybeM_ m Nothing = return ()
mapMaybeM_ m (Just a) = m a >> return ()
unknownFieldErr :: Position -> Ident -> GB a
unknownFieldErr cpos ide =
raiseErrorCTExc (posOf ide)
["Unknown member name!",
"The structure has no member called `" ++ identToLexeme ide
++ "'. The structure is defined at",
show cpos ++ "."]
illegalStructUnionErr :: Position -> Position -> GB a
illegalStructUnionErr cpos pos =
raiseErrorCTExc pos
["Illegal structure or union type!",
"There is not automatic support for marshaling of structures and",
"unions; the offending type is declared at "
++ show cpos ++ "."]
illegalTypeSpecErr :: Position -> GB a
illegalTypeSpecErr cpos =
raiseErrorCTExc cpos
["Illegal type!",
"The type specifiers of this declaration do not form a legal ANSI C(89) \
\type."
]
unsupportedTypeSpecErr :: Position -> GB a
unsupportedTypeSpecErr cpos =
raiseErrorCTExc cpos
["Unsupported type!",
"The type specifier of this declaration is not supported by your C \
\compiler."
]
variadicErr :: Position -> Position -> GB a
variadicErr pos cpos =
raiseErrorCTExc pos
["Variadic function!",
"Calling variadic functions is not supported by the FFI; the function",
"is defined at " ++ show cpos ++ "."]
illegalConstExprErr :: Position -> String -> GB a
illegalConstExprErr cpos hint =
raiseErrorCTExc cpos ["Illegal constant expression!",
"Encountered " ++ hint ++ " in a constant expression,",
"which ANSI C89 does not permit."]
voidFieldErr :: Position -> GB a
voidFieldErr cpos =
raiseErrorCTExc cpos ["Void field in struct!",
"Attempt to access a structure field of type void."]
structExpectedErr :: Ident -> GB a
structExpectedErr ide =
raiseErrorCTExc (posOf ide)
["Expected a structure or union!",
"Attempt to access member `" ++ identToLexeme ide ++ "' in something not",
"a structure or union."]
ptrExpectedErr :: Position -> GB a
ptrExpectedErr pos =
raiseErrorCTExc pos
["Expected a pointer object!",
"Attempt to dereference a non-pointer object or to use it in a `pointer' \
\hook."]
illegalStablePtrErr :: Position -> GB a
illegalStablePtrErr pos =
raiseErrorCTExc pos
["Illegal use of a stable pointer!",
"Class hooks cannot be used for stable pointers."]
pointerTypeMismatchErr :: Position -> String -> String -> GB a
pointerTypeMismatchErr pos className superName =
raiseErrorCTExc pos
["Pointer type mismatch!",
"The pointer of the class hook for `" ++ className
++ "' is of a different kind",
"than that of the class hook for `" ++ superName ++ "'; this is illegal",
"as the latter is defined to be an (indirect) superclass of the former."]
illegalFieldSizeErr :: Position -> GB a
illegalFieldSizeErr cpos =
raiseErrorCTExc cpos
["Illegal field size!",
"Only signed and unsigned `int' types may have a size annotation."]
derefBitfieldErr :: Position -> GB a
derefBitfieldErr pos =
raiseErrorCTExc pos
["Illegal dereferencing of a bit field!",
"Bit fields cannot be dereferenced."]
resMarshIllegalInErr :: Position -> GB a
resMarshIllegalInErr pos =
raiseErrorCTExc pos
["Malformed result marshalling!",
"There may not be an \"in\" marshaller for the result."]
resMarshIllegalTwoCValErr :: Position -> GB a
resMarshIllegalTwoCValErr pos =
raiseErrorCTExc pos
["Malformed result marshalling!",
"Two C values (i.e., the `&' symbol) are not allowed for the result."]
marshArgMismatchErr :: Position -> String -> GB a
marshArgMismatchErr pos reason =
raiseErrorCTExc pos
["Function arity mismatch!",
reason]
noDftMarshErr :: Position -> String -> String -> [ExtType] -> GB a
noDftMarshErr pos inOut hsTy cTys =
raiseErrorCTExc pos
["Missing " ++ inOut ++ " marshaller!",
"There is no default marshaller for this combination of Haskell and \
\C type:",
"Haskell type: " ++ hsTy,
"C type : " ++ concat (intersperse " " (map showExtType cTys))]