% % (c) The Foo Project, University of Glasgow, 1998 % % @(#) $Docid: Feb. 9th 2003 15:15 Sigbjorn Finne $ % @(#) $Contactid: sof@galois.com $ % A hodgepodge of helper functions over the CoreIDL data types. \begin{code} module CoreUtils ( mkId , setIdModule , mkParam , flattenDecls , reallyFlattenDecls , inSeparateHaskellModule , findFieldTy , findFieldOrigTy , findParam , findParamTy , localiseTypes , getTypeAttributes -- :: Type -> [Attribute] , getHsImports -- :: Id -> [QualName] , keepValueAsPointer , isStructTy , isEnumTy , isPointerTy , isVoidPointerTy , isArrayTy , isSafeArrayTy , isOpenArrayTy , isFunTy , isBoolTy , isVoidTy , isPointerOrArrayTy , isPtrPointerTy , isRefPointerTy , isUniquePointerTy , isStringTy , isSeqTy , isAnyTy , isObjectTy , isConstructedTy , isCompleteTy , isReferenceTy , isSimpleTy , isIntegerTy , isSynTy , isAbstractTy , isAbstractFinalTy , isNonEncUnionTy , getNonEncUnionTy , isUnionTy , isIfaceTy , isIUnknownTy , isIfacePtr , isVariantTy , getIfaceTy , tyFun , stringTy , wStringTy , bstrTy , intTy , addrTy , boolTy , variantBoolTy , variantTy , charTy , wCharTy , int32Ty , int64Ty , word64Ty , shortTy , floatTy , doubleTy , byteTy , word32Ty , int16Ty , word16Ty , voidTy , currencyTy , dateTy , fileTimeTy , safeArrayTy , iUnknownTy , iDispatchTy , hresultTy , guidTy , isHRESULTTy -- :: Type -> Bool , isHRESULT -- :: Result -> Bool , mkPtrPointer , removePtr , removePtrAndArray , removePtrAll , removePtrs , removeNames , nukeNames , pushPointerType , hasIgnoreAttribute , findPtrType , mkRefPointer , rawPointerToIP , notAggregatableAttribute , childAttributes , getTyTag , findFreeVars , solve , complementOp , isCommutative , contains , evalExpr , simplifyExpr , simpRedExpr , plusOne , minusOne , add , sizeofType , sizeAndAlignModulus , computeStructSizeOffsets , align , Dependent(..) , DepVal(..) , DependInfo , findDependents , attrToDependent , computeArrayConstraints , isLengthIs , isSizeIs , isMaxIs , isMinIs , isFirstIs , isLastIs , sizeOrLength , minOrFirst , maxOrLast , isSwitchIs , lookupDepender , isDepender , isDependee , isSwitchDependee , isSwitchDepender , isNotSwitchDependee , hasNonConstantExprs , mkHaskellVarName , mkHaskellTyConName , toCType , mkIfaceTypeName , getInterfaceIds -- :: Decl -> [Id] , idHaskellModule , isMethod , isConst , isMethodOrProp , isProperty , isCoClass , dummyMethod , unionToStruct , binParams , objParam , resultParam , iPointerParam , derivesFromIDispatch , toDispInterfaceMethod , sortDecls , isFinalisedType ) where import CoreIDL import BasicTypes ( Name, Size(..), BinaryOp(..), ShiftDir(..) , PointerType(..), UnaryOp(..), ParamDir(..) , CallConv, qName, qDefModule, qModule, QualName , toQualName, qOrigName ) import Attribute import Literal import LibUtils import Opts ( optOneModulePerInterface, optNoDependentArgs, optDeepMarshall, optHaskellToC, optClassicNameMangling, optLongLongIsInteger, optPointerDefault ) import PpCore ( ppType, showCore, ppExpr ) import Digraph import Utils import Maybe ( mapMaybe, fromMaybe, mapMaybe, isJust ) import List ( partition ) import Char ( toLower, toUpper, isLower, isUpper, isAlpha, isDigit ) import TypeInfo import NativeInfo import Env import Int import List import Bits {- BEGIN_GHC_ONLY import GlaExts END_GHC_ONLY -} \end{code} \begin{code} mkId :: Name -> Name -> Maybe Name -> [Attribute] -> Id mkId nm orig_nm md attrs = Id nm orig_nm md attrs setIdModule :: Maybe Name -> Id -> Id setIdModule md i = i{idModule=md} \end{code} \begin{code} mkParam :: Name -> ParamDir -> Type -> Param mkParam nm mode ty = Param (mkId nm nm Nothing noAttrs) mode ty ty False \end{code} \begin{code} isHRESULT :: Result -> Bool isHRESULT res = isHRESULTTy (resultOrigType res) \end{code} Lifting contents of modules and libraries to the top. \begin{code} flattenDecls :: [Decl] -> [Decl] flattenDecls ls = flatDecls True inSeparateHaskellModule ls flatDecls :: Bool -> (Decl -> Bool) -> [Decl] -> [Decl] flatDecls _ _ [] = [] flatDecls isTopLev predic (Module i ds : rs) = ( lift ++ (Module i don't_lift : flatDecls isTopLev predic rs) ) where (lift, don't_lift) = partition predic ds flatDecls isTopLev predic (Library i ds : rs) | not isTopLev = Library i ds : flatDecls isTopLev predic rs | otherwise = (Library i don't_lift) : lift ++ flatDecls False predic rs where (lift, don't_lift) = partition (\ x -> predic x && not (isLibrary x)) ds isLibrary (Library _ _) = True isLibrary _ = False flatDecls isTopLev predic (d:ds) = d : flatDecls isTopLev predic ds reallyFlattenDecls :: [Decl] -> [Decl] reallyFlattenDecls ls = flatDecls True (\ _ -> True) ls -- True => put the generated contents of IDL declaration in -- separate Haskell module. inSeparateHaskellModule :: Decl -> Bool inSeparateHaskellModule Module{} = True inSeparateHaskellModule Library{} = True inSeparateHaskellModule DispInterface{} = optOneModulePerInterface inSeparateHaskellModule Interface{} = optOneModulePerInterface inSeparateHaskellModule CoClass{} = optOneModulePerInterface inSeparateHaskellModule _ = False {- If we're splitting up the input into multiple Haskell modules, minimise the scope of types/constants. i.e., iff a type is only used within one interface (==module), float it into that interface. -} localiseTypes :: [Decl] -> [Decl] localiseTypes ds | not optOneModulePerInterface = ds | otherwise = --trace (show (map fst $ envToList moveEnv, envToList uniqueEnv, allTD_Names)) $ mapMaybe moveTypes ds where moveTypes d@Typedef{declId=i} | isJust (lookupEnv uniqueEnv (idName i)) = Nothing | otherwise = Just d moveTypes (Module i ds1) = let ds' = mapMaybe moveTypes ds1 in case lookupEnv moveEnv (idName i) of Just ts -> Just (Module i (map (adjustMod (idName i) ts) (ts ++ ds'))) _ -> Just (Module i ds') moveTypes (Library i ds1) = let ds' = mapMaybe moveTypes ds1 in case lookupEnv moveEnv (idName i) of Just ts -> Just (Library i (map (adjustMod (idName i) ts) (ts ++ ds'))) _ -> Just (Library i ds') moveTypes d@(Interface{declId=i}) = case lookupEnv moveEnv (idName i) of Just ts -> Just d{declDecls=map (adjustMod (idName i) ts) (ts ++ declDecls d)} _ -> Just d moveTypes d@(DispInterface{declId=i}) = case lookupEnv moveEnv (idName i) of Just ts -> Just d{declDecls=map (adjustMod (idName i) ts) (ts ++ declDecls d)} Nothing -> Just d moveTypes d = Just d adjustMod nm ls d = foldl adj d ls where adj acc Typedef{declId=i} = adjustModName (idName i) nm acc moveEnv :: Env String{-type name-} [Decl] {- _declarations_ to be added-} moveEnv = addListToEnv_C (++) newEnv (mapMaybe findDecl (envToList uniqueEnv)) where findDecl (nm,use) = case find (withName nm) typesMoving of Just d -> Just (use,[d]) Nothing -> Nothing withName nm (Typedef{declId=i}) = idName i == nm || idOrigName i == nm withName _ _ = False typesMoving = filter isMoving allTDs where isMoving Typedef{declId=i} = isJust (lookupEnv uniqueEnv (idName i)) isMoving _ = False allTD_Names = map (idName.declId) allTDs allTDs = concatMap allTypedefs ds where allTypedefs d = case d of Typedef{} -> [d] Module _ ds1 -> concatMap allTypedefs ds1 Library _ ds1 -> concatMap allTypedefs ds1 Interface{declDecls=ds1} -> concatMap allTypedefs ds1 DispInterface{declDecls=ds1} -> concatMap allTypedefs ds1 _ -> [] -- environment mapping type names to the name of the _only_ -- declaration that uses it. uniqueEnv :: Env String{-used type name-} String{-where it is used-} uniqueEnv = mapMaybeEnv isOfInterest useEnv where isOfInterest _ ls = case nub ls of [x] | x `notElem` allTD_Names -> Just x -- only interested if it was used at a -- a non typedef-site (=> in an interface). _ -> Nothing isOfInterest _ _ = Nothing useEnv :: Env String {- used type name -} [String] {- names of decls that uses type -} useEnv = foldl addIt newEnv use_info where addIt env (_decl,d,us) = foldl (addUse d) env us addUse nm env use = addToEnv_C (++) env use [nm] use_info = concatMap mkDeps ds where mkDeps d = case d of Module _ ds1 -> concatMap mkDeps ds1 Library _ ds1 -> concatMap mkDeps ds1 _ -> [mkDeclDep d] adjustModName :: String -> String -> Decl -> Decl adjustModName nm newMod d = case d of Typedef i ty oty -> Typedef i (adjustType ty) (adjustType oty) Constant i ty oty e -> Constant i (adjustType ty) (adjustType oty) e Interface i flg inh ds -> Interface i flg (map adjustInherit inh) (map (adjustModName nm newMod) ds) DispInterface i expF ps ds -> DispInterface i (fmap (adjustModName nm newMod) expF) (map (adjustModName nm newMod) ps) (map (adjustModName nm newMod) ds) Module i ds -> Module i (map (adjustModName nm newMod) ds) Library i ds -> Module i (map (adjustModName nm newMod) ds) Method i cc res ps off -> Method i cc (adjustResult res) (map adjustParam ps) off Property i ty off si gi -> Property i (adjustType ty) off si gi _ -> d where adjustResult (Result ty oty) = Result (adjustType ty) (adjustType oty) adjustParam p@Param{paramType=ty,paramOrigType=oty} = p{paramType=adjustType ty,paramOrigType=adjustType oty} adjustInherit (qnm,i) = (adjustQName qnm, i) adjustQName qnm | qName qnm == nm || qOrigName qnm == nm = qnm{qModule=Just newMod,qDefModule=Just newMod} | otherwise = qnm adjustType ty = case ty of Integer{} -> ty StablePtr{} -> ty FunTy cc res ps -> FunTy cc (adjustResult res) (map adjustParam ps) Float{} -> ty Char{} -> ty WChar{} -> ty Bool{} -> ty Octet{} -> ty Any{} -> ty Object{} -> ty String t flg mb -> String (adjustType t) flg mb WString{} -> ty Fixed{} -> ty Name n onm mbMod attrs mbTy mbTi | n == nm -> Name n onm (Just newMod) attrs (fmap adjustType mbTy) mbTi | otherwise -> Name n onm mbMod attrs (fmap adjustType mbTy) mbTi Struct i fs p -> Struct i (map adjustField fs) p Enum{} -> ty Union i ty1 a b sws -> Union i (adjustType ty1) a b (map adjustSwitch sws) UnionNon i sws -> UnionNon i (map adjustSwitch sws) CUnion i fs p -> CUnion i (map adjustField fs) p Pointer p flg t -> Pointer p flg (adjustType t) Array t e -> Array (adjustType t) e Void{} -> ty Iface n md onm attrs flg ih | n == nm || onm == nm -> Iface n (Just newMod) onm attrs flg (map adjustInherit ih) | otherwise -> Iface n md onm attrs flg (map adjustInherit ih) SafeArray t -> SafeArray (adjustType t) adjustField f@Field{fieldType=ty,fieldOrigType=oty} = f{fieldType=adjustType ty, fieldOrigType=adjustType oty } adjustSwitch s@SwitchEmpty{} = s adjustSwitch s@Switch{switchType=ty,switchOrigType=oty} = s{switchType=adjustType ty, switchOrigType=adjustType oty} isMethod :: Decl -> Bool isMethod Method{} = True isMethod _ = False isConst :: Decl -> Bool isConst Constant{} = True isConst _ = False isMethodOrProp :: Decl -> Bool isMethodOrProp Method{} = True isMethodOrProp Property{} = True isMethodOrProp _ = False isProperty :: Decl -> Bool isProperty Property{} = True isProperty Method{declId=i} = attrs `hasAttributeWithNames` ["propget", "propput", "propputref"] where attrs = idAttributes i isProperty _ = False isCoClass :: Decl -> Bool isCoClass CoClass{} = True isCoClass _ = False \end{code} \begin{code} dummyMethod :: Decl dummyMethod = Method (mkId "dummy" "dummy" Nothing []) defaultCConv (Result hresultTy hresultTy) [{-no params-}] Nothing \end{code} \begin{code} getInterfaceIds :: Decl -> [Id] getInterfaceIds decl = reverse (go [] decl) where go acc d = case d of Interface{} -> foldl go ((declId d):acc) (declDecls d) Module _ ds -> foldl go acc ds DispInterface{} -> foldl go ((declId d):acc) (declDecls d) Library _ ds -> foldl go acc ds _ -> acc \end{code} \begin{code} findFieldTy :: [Field] -> Name -> Type findFieldTy [] nm = error ("findFieldTy: " ++ nm) -- not supposed to happen. findFieldTy (f : xs) nm | nm == idName (fieldId f) = fieldType f | otherwise = findFieldTy xs nm findFieldOrigTy :: [Field] -> Name -> Type findFieldOrigTy [] nm = error ("findFieldOrigTy: " ++ nm) -- not supposed to happen. findFieldOrigTy (f : xs) nm | nm == idName (fieldId f) = fieldOrigType f | otherwise = findFieldOrigTy xs nm findParam :: [Param] -> Name -> Param findParam [] nm = error ("findParam: " ++ nm) -- not supposed to happen. findParam (p : xs) nm | nm == idName (paramId p) = p | otherwise = findParam xs nm findParamTy :: [Param] -> Name -> Type findParamTy ps nm = paramType (findParam ps nm) \end{code} Fish out attributes attached to type: \begin{code} getTypeAttributes :: Type -> [Attribute] getTypeAttributes ty = case ty of Name _ _ _ mb_as mb_ty _ -> fromMaybe [] mb_as ++ fromMaybe [] (fmap getTypeAttributes mb_ty) Struct i _ _ -> idAttributes i Enum i _ _ -> idAttributes i Union i _ _ _ _ -> idAttributes i UnionNon i _ -> idAttributes i CUnion i _ _ -> idAttributes i Pointer _ _ t -> getTypeAttributes t Iface _ _ _ as _ _ -> as _ -> [] \end{code} The [hs_import(qualName)] is used on IDL module declarations to have 'qualName' be imported in the corresponding Haskell module. Normally only used in conjunction with hs_quote(..) declarations & you don't want to write all the import declarations yourself. \begin{code} getHsImports :: Id -> [QualName] getHsImports i = imp_attrs where imp_attrs = mapMaybe toHsImport attrs attrs = filterAttributes (idAttributes i) ["hs_import"] toHsImport :: Attribute -> Maybe QualName toHsImport a = case a of Attribute _ [ParamLit (StringLit s)] -> let qNm = toQualName s in case qModule qNm of Nothing -> Nothing Just _ -> Just (qNm{qDefModule=qModule qNm}) _ -> Nothing \end{code} \begin{code} isStructTy :: Type -> Bool isStructTy Struct{} = True isStructTy (Name _ _ _ _ (Just t) _) = isStructTy t isStructTy _ = False isEnumTy :: Type -> Bool isEnumTy Enum{} = True isEnumTy (Name _ _ _ _ (Just t) _) = isEnumTy t isEnumTy _ = False isPointerTy :: Type -> Bool isPointerTy Pointer{} = True isPointerTy _ = False isVoidPointerTy :: Type -> Bool isVoidPointerTy (Pointer _ _ Void) = True isVoidPointerTy (Name _ _ _ _ (Just t) _) = isVoidPointerTy t isVoidPointerTy _ = False {- keepValueAsPointer is used to determine whether we should unmarshall a parameter/result coming back from a method. The policy is as follows: - pointer to a struct or union is held back as an external value. - pointers to basic types, strings, arrays are unmarshalled into the Haskell heap. -} keepValueAsPointer :: Type -> Bool keepValueAsPointer ty | optDeepMarshall = False | otherwise = case ty of Pointer _ _ (Name _ _ _ _ Nothing _) -> True Pointer _ _ (Name _ _ _ _ (Just t) _) -> keepValueAsPointer t Pointer _ _ Struct{} -> True Pointer _ _ Union{} -> True Pointer _ _ UnionNon{} -> True Pointer _ _ CUnion{} -> True _ -> False isArrayTy :: Type -> Bool isArrayTy Array{} = True isArrayTy (Name _ _ _ _ (Just t) _) = isArrayTy t isArrayTy _ = False isSafeArrayTy :: Type -> Bool isSafeArrayTy SafeArray{} = True isSafeArrayTy (Name _ _ _ _ (Just t) _) = isSafeArrayTy t isSafeArrayTy _ = False isOpenArrayTy :: Type -> Bool isOpenArrayTy (Array _ []) = True isOpenArrayTy _ = False isBoolTy :: Type -> Bool isBoolTy Bool = True isBoolTy (Name _ _ _ _ (Just t) _) = isBoolTy t isBoolTy _ = False isFunTy :: Type -> Bool isFunTy FunTy{} = True isFunTy (Name _ _ _ _ (Just t) _) = isFunTy t isFunTy _ = False isVoidTy :: Type -> Bool isVoidTy Void = True isVoidTy (Name _ _ _ _ (Just t) _) = isVoidTy t isVoidTy _ = False isPointerOrArrayTy :: Type -> Bool isPointerOrArrayTy ty = isPointerTy ty || isArrayTy ty isPtrPointerTy :: Type -> Bool isPtrPointerTy (Pointer Ptr _ _) = True isPtrPointerTy _ = False isRefPointerTy :: Type -> Bool isRefPointerTy (Pointer Ref _ _) = True isRefPointerTy _ = False mkRefPointer :: Type -> Type mkRefPointer (Pointer _ expl t) = Pointer Ref expl t mkRefPointer (Name nm onm md a (Just ty) mb_ti) = Name nm onm md a (Just (mkRefPointer ty)) mb_ti mkRefPointer t = t -- convert the (innermost) void* into an interface pointer. -- (used when a [iid_is()] is in effect. rawPointerToIP :: Type -> Type rawPointerToIP (Pointer _ _ Void) = Pointer Ref True iUnknownTy rawPointerToIP (Pointer pt expl t) = Pointer pt expl (rawPointerToIP t) rawPointerToIP (Name nm onm md a (Just ty) mb_ti) = Name nm onm md a (Just (rawPointerToIP ty)) mb_ti rawPointerToIP t = t isUniquePointerTy :: Type -> Bool isUniquePointerTy (Pointer Unique _ _) = True isUniquePointerTy _ = False isStringTy :: Type -> Bool isStringTy String{} = True isStringTy WString{} = True isStringTy (Name _ _ _ _ _ (Just ti)) = qName (haskell_type ti) == stringName isStringTy _ = False isSeqTy :: Type -> Bool isSeqTy Sequence{} = True isSeqTy (Name _ _ _ _ (Just t) _) = isSeqTy t isSeqTy _ = False isAnyTy :: Type -> Bool isAnyTy Any = True isAnyTy _ = False isObjectTy :: Type -> Bool isObjectTy Object = True isObjectTy (Name _ _ _ _ (Just t) _) = isObjectTy t isObjectTy _ = False intTy :: Type intTy = Integer Natural True{-Signed-} addrTy :: Type addrTy = Pointer Ptr True Void charTy :: Type charTy = Char False{-Unsigned-} wCharTy :: Type wCharTy = WChar boolTy :: Type boolTy = Bool -- built-in Automation type variantBoolTy :: Type variantBoolTy = Name "VARIANT_BOOL" "VARIANT_BOOL" Nothing Nothing Nothing Nothing variantTy :: Type variantTy = Name "VARIANT" "VARIANT" autoLib Nothing Nothing (Just variant_ti) int32Ty :: Type int32Ty = Integer Long True{-Signed-} int64Ty :: Type int64Ty = Integer LongLong True{-Signed-} word64Ty :: Type word64Ty = Integer LongLong False{-unsigned-} word32Ty :: Type word32Ty = Integer Long False{-Unsigned-} word16Ty :: Type word16Ty = Integer Short False{-Unsigned-} int16Ty :: Type int16Ty = Integer Short True{-Signed-} voidTy :: Type voidTy = Void currencyTy :: Type currencyTy = Name "CURRENCY" "CURRENCY" autoLib Nothing Nothing mb_currency_ti dateTy :: Type dateTy = Name "DATE" "DATE" autoLib Nothing (Just int64Ty) mb_date_ti fileTimeTy :: Type fileTimeTy = Name "FILETIME" "FILETIME" Nothing Nothing Nothing Nothing safeArrayTy :: Type -> Type safeArrayTy t = SafeArray t shortTy :: Type shortTy = Integer Short True{-signed-} byteTy :: Type byteTy = Char False floatTy :: Type floatTy = Float Short doubleTy :: Type doubleTy = Float Long stringTy :: Type stringTy = String (Char False) False Nothing wStringTy :: Type wStringTy = WString False Nothing bstrTy :: Type bstrTy = Name "BSTR" "BSTR" comLib Nothing Nothing (Just bstr_ti) iUnknownTy :: Type iUnknownTy = Iface "IUnknown" comLib "IUnknown" [] False [] iDispatchTy :: Type iDispatchTy = Iface "IDispatch" autoLib "IDispatch" [] True [(iUnknown,3)] hresultTy :: Type hresultTy = Name "HRESULT" "HRESULT" comLib Nothing (Just int32Ty) Nothing isHRESULTTy :: Type -> Bool isHRESULTTy (Name "HRESULT" _ _ _ _ _) = True isHRESULTTy _ = False guidTy :: Type guidTy = Name "GUID" "GUID" comLib Nothing Nothing Nothing -- weird name, funTy is already taken, I'm afraid. tyFun :: CallConv -> Result -> [Param] -> Type tyFun = FunTy \end{code} \begin{code} mkPtrPointer :: Type -> Type mkPtrPointer (Pointer _ _ t) = Pointer Ptr True t mkPtrPointer (Array t []) = Pointer Ptr True t mkPtrPointer t = t removePtr :: Type -> Type removePtr t@(Pointer _ _ Void) = t removePtr (Pointer _ _ t) = t removePtr t = t removePtrAndArray :: Type -> Type removePtrAndArray t@(Pointer _ _ Void) = t removePtrAndArray (Pointer _ _ t) = t removePtrAndArray (Array t _) = t removePtrAndArray t = t removePtrAll :: Type -> Type removePtrAll t@(Pointer _ _ Void) = t removePtrAll (Pointer _ _ t) = t removePtrAll (Array t _) = t removePtrAll (String t _ _) = t removePtrAll WString{} = WChar removePtrAll t = t removePtrs :: Type -> Type removePtrs (Pointer _ _ t) = removePtrs t removePtrs t = t removeNames :: Type -> Type removeNames t@(Name _ _ _ _ _ (Just _)) = t removeNames (Name _ _ _ _ (Just t) _) | not (isConstructedTy t) = removeNames t removeNames t = t nukeNames :: Type -> Type nukeNames t@(Name _ _ _ _ _ (Just _)) = t nukeNames (Name _ _ _ _ (Just t) _) = nukeNames t nukeNames t = t pushPointerType :: PointerType -> Type -> Type pushPointerType pt (Pointer _ expl ty) = Pointer pt expl ty pushPointerType _ ty = ty \end{code} \begin{code} hasIgnoreAttribute :: Id -> Bool hasIgnoreAttribute i = idAttributes i `hasAttributeWithName` "ignore" childAttributes :: [Attribute] -> [Attribute] childAttributes as = filter (not.notAggregatableAttribute) as notAggregatableAttribute :: Attribute -> Bool notAggregatableAttribute (AttrMode _) = False notAggregatableAttribute (AttrDependent _ _) = False notAggregatableAttribute (Attribute nm _) = nm `elem` junk_list where junk_list = [ "helpstring" , "helpcontext" -- , "pointer_default" , "dllname" , "lcid" , "odl" , "restricted" , "ole" , "uuid" , "object" , "oleautomation" , "hidden" , "version" , "local" , "custom" , "public" , "dual" , "switch_type" , "switch_is" , "depender" , "ty_params" , "jni_interface" , "jni_iface_ty" , "jni_class" , "hs_name" , "hs_import" , "hs_newtype" ] \end{code} \begin{code} isConstructedTy :: Type -> Bool isConstructedTy Struct{} = True isConstructedTy Enum{} = True isConstructedTy Union{} = True isConstructedTy UnionNon{} = True isConstructedTy CUnion{} = True isConstructedTy FunTy{} = True isConstructedTy _ = False {- only used on constructed types. -} isCompleteTy :: Type -> Bool isCompleteTy (Struct _ ls _) = notNull ls isCompleteTy (Enum _ _ ls) = notNull ls isCompleteTy (Union _ _ _ _ ls) = notNull ls isCompleteTy (UnionNon _ ls ) = notNull ls isCompleteTy (CUnion _ ls _) = notNull ls isCompleteTy (Name _ _ _ _ (Just t) _) = isCompleteTy t isCompleteTy FunTy{} = True isCompleteTy _ = False isReferenceTy :: Type -> Bool isReferenceTy = not.isCompleteTy \end{code} What is a simple IDL type? This predicate is currently only used by the code that implements the translation of type(def) declarations, determining whether to use a type synonym or data declaration to represent the Haskell repr of the IDL type. \begin{code} isSimpleTy :: Type -> Bool isSimpleTy ty = case ty of Sequence{} -> False -- for now. Fixed{} -> False Struct{} -> False Enum{} -> False Union{} -> False UnionNon{} -> False CUnion{} -> False Array{} -> False SafeArray{} -> False Pointer{} -> False String {} -> False WString{} -> False Bool -> False FunTy{} -> False Name _ _ _ _ _ (Just _) -> False -- bit of a sweeping statement. Name _ _ _ _ Nothing _ -> False Name _ _ _ _ (Just t) _ -> isSimpleTy t Iface{} -> not optHaskellToC Integer LongLong _ -> not optLongLongIsInteger _ -> True isIntegerTy :: Type -> Bool isIntegerTy (Integer LongLong _) = optLongLongIsInteger isIntegerTy _ = False isSynTy :: Type -> Bool isSynTy Name{} = True isSynTy _ = False isAbstractTy :: Type -> Bool isAbstractTy Iface{} = optHaskellToC isAbstractTy (Pointer _ _ Iface{}) = optHaskellToC isAbstractTy _ = False isAbstractFinalTy :: Type -> Bool isAbstractFinalTy (Iface _ _ _ attrs _ _) = optHaskellToC && attrs `hasAttributeWithName` "finaliser" isAbstractFinalTy (Pointer _ _ (Iface _ _ _ attrs _ _)) = optHaskellToC && attrs `hasAttributeWithName` "finaliser" isAbstractFinalTy _ = False isNonEncUnionTy :: Type -> Bool isNonEncUnionTy t = have_a_look t where have_a_look ty = case ty of UnionNon{} -> True CUnion{} -> True Name _ _ _ _ (Just tt) _ -> have_a_look tt _ -> False {- Invariant: always called on a ty for which 'isNonEncUnionTy' returned True. -} getNonEncUnionTy :: Type -> Type getNonEncUnionTy t = look_around t where look_around ty = case ty of UnionNon{} -> ty CUnion{} -> ty Name _ _ _ _ (Just tt) _ -> look_around tt _ -> error "getNonEncUnionTy: you've reached unreachable code (..oops!)" isUnionTy :: Type -> Bool isUnionTy t = have_a_look t where have_a_look ty = case ty of Union{} -> True UnionNon{} -> True CUnion{} -> True Name _ _ _ _ (Just tt) _ -> have_a_look tt _ -> False -- peer through names and pointers to see if there's an interface hiding here somewhere. isIfaceTy :: Type -> Bool isIfaceTy (Name _ _ _ _ (Just t) _) = isIfaceTy t isIfaceTy (Pointer _ _ t) = isIfaceTy t isIfaceTy Iface{} = True isIfaceTy _ = False isIUnknownTy :: Type -> Bool isIUnknownTy (Name _ _ _ _ (Just t) _) = isIUnknownTy t isIUnknownTy (Pointer _ _ t) = isIUnknownTy t isIUnknownTy (Iface "IUnknown" _ _ _ _ _) = True isIUnknownTy (Iface _ _ _ _ flg _) = not flg isIUnknownTy _ = False isIfacePtr :: Type -> Bool isIfacePtr (Name _ _ _ _ (Just t) _) = isIfacePtr t isIfacePtr (Pointer _ _ (Iface{})) = True isIfacePtr (Pointer _ _ t) = case (removeNames t) of Iface{} -> True _ -> False isIfacePtr _ = False getIfaceTy :: Type -> Type getIfaceTy (Name _ _ _ _ (Just t) _) = getIfaceTy t getIfaceTy (Pointer _ _ t) = getIfaceTy t getIfaceTy t@Iface{} = t getIfaceTy _ = error "getIfaceTy: should never happen" isVariantTy :: Type -> Bool isVariantTy (Name "VARIANT" _ _ _ _ _) = True isVariantTy (Name _ _ _ _ (Just t) _) = isVariantTy t isVariantTy _ = False \end{code} \begin{code} getTyTag :: Type -> Id getTyTag (Enum i _ _) = i getTyTag (Struct i _ _) = i getTyTag (Union i _ _ _ _) = i getTyTag (UnionNon i _) = i getTyTag (CUnion i _ _) = i getTyTag (Name n onm md attrs _ _) = mkId n onm md (fromMaybe [] attrs) getTyTag (Pointer _ _ t) = getTyTag t getTyTag t = error ("getTyTag: not supposed to be given this type as arg!" ++ showCore (ppType t)) \end{code} \begin{code} findFreeVars :: Expr -> [Name] findFreeVars (Var v) = [v] findFreeVars (Lit _) = [] findFreeVars (Sizeof _) = [] findFreeVars (Cast _ e) = findFreeVars e findFreeVars (Unary _ e) = findFreeVars e findFreeVars (Binary _ e1 e2) = findFreeVars e1 ++ findFreeVars e2 findFreeVars (Cond e1 e2 e3) = findFreeVars e1 ++ findFreeVars e2 ++ findFreeVars e3 \end{code} A very simplistic expression solver, the variable we're solving for is given as first argument. \begin{code} solve :: Name -> Expr -> Expr -> Expr solve nm lhs (Cast _ e) = solve nm lhs e solve nm lhs (Unary op rhs) = solve nm (Unary op lhs) rhs solve nm lhs (Binary op e1 e2) | contains nm e1 = solve nm (Binary op' lhs e2) e1 | isCommutative op && contains nm e2 = solve nm (Binary op' lhs e1) e2 | contains nm e2 = solve nm (Binary op e1 lhs) e2 where op' = complementOp op solve _ lhs _ = lhs complementOp :: BinaryOp -> BinaryOp complementOp Add = Sub complementOp Sub = Add complementOp Mul = Div complementOp Mod = Div complementOp Div = Mul complementOp Eq = Ne complementOp Ne = Eq complementOp And = Or complementOp Or = And complementOp (Shift L) = Shift R complementOp (Shift R) = Shift L complementOp Gt = Lt complementOp Ge = Le complementOp Le = Ge complementOp Lt = Gt complementOp LogOr = LogAnd complementOp LogAnd = LogOr complementOp Xor = Xor isCommutative :: BinaryOp -> Bool isCommutative Add = True isCommutative Mul = True isCommutative _ = False contains :: Name -> Expr -> Bool contains nm (Var v) = v == nm contains nm (Cast _ e) = contains nm e contains nm (Unary _ e) = contains nm e contains nm (Binary _ e1 e2) = contains nm e1 || contains nm e2 contains _ _ = False plusOne :: Expr -> Expr plusOne e = Binary Add e (Lit (iLit (1::Int))) minusOne :: Expr -> Expr minusOne e = Binary Sub e (Lit (iLit (1::Int))) add :: Expr -> Expr -> Expr add e1 e2 = Binary Add e1 e2 \end{code} \begin{code} evalExpr :: Expr -> Integer evalExpr e = case e of {- In order to be correct, evaluation needs to be type driven -} Binary bop e1 e2 -> let i1 = evalExpr e1 i2 = evalExpr e2 in case bop of Add -> i1 + i2 Sub -> i1 - i2 Div -> i1 `div` i2 Mod -> i1 `mod` i2 Mul -> i1 * i2 Xor -> toInteger (fromInteger i1 `xor` ((fromInteger i2)::Int32)) -- an Bits instance for Integers, anyone? Or -> toInteger (fromInteger i1 .|. ((fromInteger i2)::Int32)) And -> toInteger (fromInteger i1 .&. ((fromInteger i2)::Int32)) Shift L -> toInteger (shiftL ((fromInteger i1)::Int32) (fromIntegral i2)) Shift R -> toInteger (shiftR ((fromInteger i1)::Int32) (fromIntegral i2)) LogAnd -> if i1 /= 0 && i2 /=0 then 1 else 0 LogOr -> if i1 /= 0 || i2 /=0 then 1 else 0 Gt -> if i1 > i2 then 1 else 0 Ge -> if i1 >= i2 then 1 else 0 Eq -> if i1 == i2 then 1 else 0 Le -> if i1 <= i2 then 1 else 0 Lt -> if i1 < i2 then 1 else 0 Ne -> if i1 /= i2 then 1 else 0 Cond e1 e2 e3 -> let i1 = evalExpr e1 i2 = evalExpr e2 i3 = evalExpr e3 in if i1 == 0 then i2 else i3 Unary uop e1 -> let i1 = evalExpr e1 in case uop of Minus -> -i1 Plus -> i1 Not -> if i1==0 then 1 else 0 Negate -> toInteger ((complement (fromInteger i1)) :: Int32) Deref -> i1 Var nm -> error ("evalExpr: cannot handle free variable " ++ show nm) Lit (IntegerLit (ILit _ i)) -> i Cast _ e1 -> evalExpr e1 Sizeof t -> fromIntegral (sizeofType t) _ -> error ("CoreUtils.evalExpr: Unmatched case for: " ++ showCore (ppExpr e)) \end{code} Expand out occurrences of @(Var x)@ and @(Sizeof t)@: \begin{code} simpRedExpr :: Env String (Either Int32 Expr) -> Type -> Expr -> Expr simpRedExpr env ty ex = case (simplifyExpr env ex) of e@(Lit _) -> e e -> case ty of Integer _ _ -> Lit (iLit (evalExpr e)) -- reduce 'int'y things. _ -> e simplifyExpr :: Env String (Either Int32 Expr) -> Expr -> Expr simplifyExpr val_env ex = case ex of Binary bop e1 e2 -> Binary bop (simplifyExpr val_env e1) (simplifyExpr val_env e2) Cond e1 e2 e3 -> Cond (simplifyExpr val_env e1) (simplifyExpr val_env e2) (simplifyExpr val_env e3) Unary op e -> Unary op (simplifyExpr val_env e) Var nm -> case lookupEnv val_env nm of Nothing -> Var nm -- good luck! Just (Left x) -> Lit (iLit (toInteger x)) Just (Right e) -> e Lit l -> Lit l -- notice that casting would have been trickier -- to deal with if the expression language permitted -- sizeof(x), where x is an expression, since -- sizeof((t)x) == sizeof(t) Cast t e -> Cast t (simplifyExpr val_env e) Sizeof t -> Lit (iLit (toInteger (sizeofType t))) \end{code} @findDependents@ computes the attribute dependencies an identifier has on others, i.e., in DCE IDL, it is possible to express dependencies between field members and parameters. The dependencies encode what/how much of an array/pointer value should be marshalled between client and server. The attributes are: first_is(params) -- non-neg (array) index(es) of first element last_is(params) -- (array) index(es) of last element to be transmitted/received. length_is(params) -- number of elements of array that are to be transmitted/received. max_is(params) -- specifies upper bound for valid array indexes. min_is(params) -- lower bound (normally zero.) size_is(params) -- the allocation size of the array. where params is a list of expressions (arrays can be multi-dimensional.), some of which might be empty. @findDependents@ returns a list of identifiers, with each id paired with a list containing its dependencies. \begin{code} type DependInfo = [(Id,[Dependent])] data DepVal = DepNone -- empty/unspecified (for this dimension.) | DepVal (Maybe Name) -- a dependent value might contain at most one -- free variable which refers to another field/param. Expr -- -- for debugging purps. only deriving (Show) data Dependent = Dep DepReason [DepVal] -- a list, since the id might be multi-dimensional. deriving ( Show ) {- BEGIN_GHC_ONLY -- For Hugs users, this instance will conflict with the one in CoreIDL. instance Show Expr where show x = showCore (ppExpr x) END_GHC_ONLY -} \end{code} \begin{code} findDependents :: [Id] -> DependInfo findDependents ls | optNoDependentArgs = [] | otherwise = map (\ i -> (i, findDep i)) ls where findDep i = mapMaybe ((mapMb attrToDependent).isDependentAttribute) (idAttributes i) attrToDependent :: Attribute -> Dependent attrToDependent (AttrDependent reason args) = Dep reason (map toDepVal args) where toDepVal (ParamLit l@(IntegerLit _)) = DepVal Nothing (Lit l) -- the only legal lit toDepVal (ParamVar v) = DepVal (Just v) (Var v) toDepVal (ParamExpr (Var v)) = DepVal (Just v) (Var v) toDepVal ParamVoid = DepNone toDepVal (ParamExpr e) = -- Assume the expression has been checked -- as having at most one free variable. case (findFreeVars e) of [] -> DepVal Nothing e (f:_) -> DepVal (Just f) e toDepVal (ParamPtr p) = case (toDepVal p) of DepVal fv e -> DepVal fv (Unary Deref e) d -> d toDepVal _ = DepNone attrToDependent _ = error "attrToDependent" \end{code} \begin{code} computeArrayConstraints :: Bool -> [Dependent] -> ([DepVal], [DepVal], [DepVal]) computeArrayConstraints unmarshalling deps | unmarshalling = (trans_start_posns, trans_end_posns, trans_lengths) | otherwise = (trans_start_posns, trans_end_posns, alloc_sizes) where -- multiple traversals of the dependencies list here, but lists -- are likely to be very short, so merging the passes into -- one is likely to cost more than it saves. --not supported, and of little use --when we're representing lists as arrays: -- mins = filter isMinIs deps maxs = mapHead (\ (Dep _ ls) -> ls) $ filter isMaxIs deps firsts = mapHead (\ (Dep _ ls) -> ls) $ filter isFirstIs deps lasts = mapHead (\ (Dep _ ls) -> ls) $ filter isLastIs deps lengths = mapHead (\ (Dep _ ls) -> ls) $ filter isLengthIs deps sizes = mapHead (\ (Dep _ ls) -> ls) $ filter isSizeIs deps dimensions = maximum (map length [maxs,firsts,lasts,lengths,sizes]) alloc_sizes = zipWith genUpperBound (fillInDims maxs) (fillInDims sizes) trans_start_posns = map genLowerBound (fillInDims firsts) trans_end_posns = zipWith3 genEnd (fillInDims lasts) trans_lengths trans_start_posns trans_lengths = zipWith genLength (fillInDims lengths) alloc_sizes -- generate the array indexes from which to start transmitting elements. -- If none given for a dimension, start from zero. genLowerBound DepNone = DepVal Nothing (Lit (iLit (0::Int))) genLowerBound d = d -- generate expressions holding the lengths of transmittable ranges. The second -- argument will not have any DepNone's in it. genLength DepNone d = d genLength d _ = d {- The upper bound of what is to be transmitted is determined by preferably looking at the last_is() attribute. If not present, we derive its value as follows: last_is = length + first - 1 -} genEnd DepNone (DepVal fv l) (DepVal _ f) = DepVal fv (minusOne (add l f)) -- BUG: we're dropping a free variable here! genEnd d _ _ = d {- The upper allocation boundary is determined by looking at either the max_is() or size_is(). max_is -} genUpperBound DepNone DepNone = DepNone --error "genUpperBound: max_is nor size_is value not specified (need one of them.)" genUpperBound (DepVal _ _) (DepVal _ _) = error "genUpperBound: size_is and max_is both given for a dimension (not legal.)" genUpperBound DepNone d = d genUpperBound (DepVal fv e) DepNone = DepVal fv (plusOne e) --mapHead :: (a -> [b]) -> [a] -> [b] mapHead _ [] = [] mapHead f (x:_) = f x --fillInDims :: [a] -> [a] fillInDims ls = go dimensions ls where go 0 _ = [] go n (x:xs) = x:go (n-1) xs go n [] = DepNone:go (n-1) [] \end{code} Predicates over dependency items and lists. \begin{code} isLengthIs, isSizeIs :: Dependent -> Bool isSizeIs (Dep SizeIs _) = True isSizeIs _ = False isLengthIs (Dep LengthIs _) = True isLengthIs _ = False isMaxIs, isMinIs :: Dependent -> Bool isMinIs (Dep MinIs _) = True isMinIs _ = False isMaxIs (Dep MaxIs _) = True isMaxIs _ = False isFirstIs, isLastIs :: Dependent -> Bool isFirstIs (Dep FirstIs _) = True isFirstIs _ = False isLastIs (Dep LastIs _) = True isLastIs _ = False sizeOrLength :: Dependent -> Bool sizeOrLength d = isSizeIs d || isLengthIs d minOrFirst :: Dependent -> Bool minOrFirst d = isMinIs d || isFirstIs d maxOrLast :: Dependent -> Bool maxOrLast d = isMaxIs d || isLastIs d isSwitchIs :: Dependent -> Bool isSwitchIs (Dep SwitchIs _) = True isSwitchIs _ = False lookupDepender :: DependInfo -> Id -> Maybe [Dependent] lookupDepender ls i = case (filter (\ (i1, _) -> idName i1 == nm) ls) of ((_,ls2):_) -> Just ls2 _ -> Nothing where nm = idName i isDepender :: DependInfo -> Id -> Bool isDepender ls i = any isDependerElem ls where nm = idName i isDependerElem (x,deps) = idName x == nm && notNull deps isSwitchDepender :: DependInfo -> Id -> Bool isSwitchDepender ls i = any isElem ls where nm = idName i isElem (x,deps) = idName x == nm && any (isSwitchIs) deps isDependee :: DependInfo -> Id -> Bool isDependee ls i = any (isDependeeElem nm) dvals where -- join up all the DepVals dvals = concatMap ((concatMap (\ (Dep _ ls1) -> ls1)).snd) ls nm = idName i isDependeeElem :: String -> DepVal -> Bool isDependeeElem _ DepNone = False isDependeeElem _ (DepVal Nothing _) = False isDependeeElem nm (DepVal (Just x) _) = x == nm isSwitchDependee :: DependInfo -> Id -> Bool isSwitchDependee lss i = any isSwitchDependeeElem ls where ls = concatMap (snd) lss nm = idName i isSwitchDependeeElem (Dep SwitchIs ls1) = any (isDependeeElem nm) ls1 isSwitchDependeeElem _ = False isNotSwitchDependee :: DependInfo -> Id -> Bool isNotSwitchDependee lss i = any isNotSwitchDependeeElem ls where ls = concatMap (snd) lss nm = idName i isNotSwitchDependeeElem (Dep r ls1) | r /= SwitchIs = any (isDependeeElem nm) ls1 isNotSwitchDependeeElem _ = False hasNonConstantExprs :: Dependent -> Bool hasNonConstantExprs (Dep _ ls) = any isNon ls where isNon (DepVal (Just _) _) = True isNon _ = False \end{code} Translating an IDL type name into a valid Haskell variable name. \begin{code} mkHaskellVarName :: Name -> Name mkHaskellVarName nm | optClassicNameMangling = toHask (casifyName nm) | otherwise = toHask nm where toHask [] = "anon" -- shouldn't happen! -- toHask ('_':xs) = toHask xs -- drop leading underscores. toHask (x:xs) | not (isAlpha x) = toHask xs -- anything non-alphabetic, really. toHask ls@(x:xs) | isUpper x = toLower x : map (subst '$' '_') xs | otherwise = map (subst '$' '_') ls subst x y ch | x == ch = y | otherwise = ch \end{code} Translating an IDL type name into a valid Haskell type constructor name. \begin{code} mkHaskellTyConName :: Name -> Name mkHaskellTyConName nm | optClassicNameMangling = casifyName nm | otherwise = toHask nm where toHask [] = "Anon" -- shouldn't happen! toHask (x:xs) | not (isAlpha x) = toHask xs -- it's a non-starter with anything -- non-alphabetic at the front (i.e., -- don't want '_' there). toHask ls@(x:xs) | isLower x = toUpper x : map (subst '$' '_') xs | otherwise = map (subst '$' '_') ls subst x y ch | x == ch = y | otherwise = ch -- From: THIS_IS_A_SILLY_ID, ThisIs_ANOTHER_Silly_ID -- to: ThisIsASillyId, ThisIsAnotherSillyId casifyName :: String -> String casifyName nm = concatMap caseWord (split '_' nm) caseWord :: String -> String caseWord [] = [] caseWord (c:cs) = toUpper c : cs' where cs' | all (\ ch -> isUpper ch || isDigit ch) cs = map toLower cs | otherwise = cs \end{code} Until GHC supports the new FFI declarations, the IDL compiler will emit _casm_s that performs the actual invocation of COM methods. (but, more importantly, this is also used by the Hugs backend.) \begin{code} toCType :: Type -> Either String -- (primitive / FFI supported) C type String -- other; need C impedance matching code. toCType ty = case ty of Char signed | signed -> Left "signed char" | otherwise -> Left "unsigned char" WChar -> Left "wchar_t" Bool -> Left "int" -- contentious Octet -> Left "unsigned char" Integer LongLong signed | signed -> Left "int64" | otherwise -> Left "uint64" Integer Natural True -> Left "int" Integer sz signed | signed -> Left (sizeToString sz) | otherwise -> Left ("unsigned " ++ sizeToString sz) StablePtr -> Left "unsigned long" Float sz -> case sz of Short -> Left "float" Long -> Left "double" LongLong -> Left "long double" Natural -> Left "float" String{} -> Left "char*" WString{} -> Left "void*" Sequence{} -> Left "void*" Enum{} -> Left "int" Struct _ [f] _ | isSimpleTy (fieldType f) -> toCType (fieldType f) Struct i _ _ -> Right ("struct " ++ idName i) Union i _ _ _ _ -> Right ("struct " ++ idName i) -- an encapsulated union is a struct in C. UnionNon i _ -> Right ("union " ++ idName i) CUnion i _ _ -> Right ("union " ++ idName i) Name _ onm _ _ _ (Just ti) | not (is_pointed ti) -> Left (c_type ti) | otherwise -> Right onm Name _ onm _ _ Nothing _ -> Right onm Name _ onm _ _ (Just t) _ | isConstructedTy t -> if isEnumTy ty || isFunTy ty then toCType t else Right onm | otherwise -> toCType t Pointer _ _ (Name _ _ _ (Just as) _ _) -> case findAttribute "ctype" as of Just (Attribute _ [ParamLit (StringLit t)]) -> Left t _ -> Left "void*" Pointer _ _ (t@Iface{}) -> case toCType t of Left l -- confusingly, IA and IA* are the same thing when in 'C mode', -- so qualify the addition of an indirection accordingly. -- Ditto on the 'COM' side - if we end up with just 'IA' (which -- we shouldn't), treat this as IA*. -- -> Left l Right x -> Right x Pointer{} -> Left "void*" Array{} -> Left "void*" Void -> Left "void" SafeArray{} -> Left "void*" Iface _ _ _ as _ _ -> case findAttribute "ctype" as of Just (Attribute _ [ParamLit (StringLit t)]) -> Left t _ -> Left "void*" FunTy{} -> Left "void*" Object -> Left "void*" Any -> Left "void*" _ -> error ("toCType: unhandled " ++ showCore (ppType ty)) where sizeToString Short = "short" sizeToString Long = "long" sizeToString Natural = "long" sizeToString LongLong = "int64" \end{code} \begin{code} mkIfaceTypeName :: Name -> Name mkIfaceTypeName ('_':nm) = mkIfaceTypeName nm mkIfaceTypeName nm = map (subst '$' '_') nm where subst x y ch | x == ch = y | otherwise = ch \end{code} From a set of parameter/result attributes, figure out the pointer type. Boolean flag determine whether the pointer is embedded or not. \begin{code} findPtrType :: Bool -> [Attribute] -> (Type -> Type) --PointerType findPtrType isTop ls = -- a specific pointer type takes priority over -- any setting of a pointer default. case (filter isPtrAttr ptr_ls) of ((Attribute kind []):_) -> Pointer (stringToPointerType kind) True [] | isTop -> Pointer Ref False | otherwise -> case (filter isPtrDefault ptr_ls) of ((Attribute _ [ParamVar v]):_) -> Pointer (stringToPointerType v) False [] -> case optPointerDefault of Nothing -> Pointer Unique False Just x -> Pointer (stringToPointerType x) False where ptr_ls = filter isPtrAttrib ls isPtrAttrib a = isPtrDefault a || isPtrAttr a isPtrDefault (Attribute "pointer_default" [ParamVar _]) = True isPtrDefault _ = False isPtrAttr (Attribute "ptr" []) = True isPtrAttr (Attribute "ref" []) = True isPtrAttr (Attribute "unique" []) = True isPtrAttr (Attribute "any" []) = True isPtrAttr _ = False stringToPointerType :: String -> PointerType stringToPointerType "ref" = Ref stringToPointerType "unique" = Unique stringToPointerType "ptr" = Ptr \end{code} \begin{code} idHaskellModule :: Id -> Maybe Name idHaskellModule i = mapMb (mkHaskellTyConName.dropSuffix) (idModule i) \end{code} Group the parameters according to their attributes (preserving the ordering of the given parameter list.) @binParams ls@ returns @(ps, is, os, ios, rs)@ where @ps@ is the list of parameters the Haskell function takes as arguments (this is not the final list, as the processing of dependent arguments will remove the dependees.) @is@ is the [in] parameters (preserved left-to-right ordering of original parameter list.) @os@ is the [out] params. @ios@ is the [in,out] params. @rs@ is the parameters that should be returned as results from the Haskell programmer. \begin{code} binParams :: [Param] -> ([Param], [Param], [Param], [Param], [Param]) binParams ps = foldr binParam ([],[],[],[],[]) ps where binParam p (params, ins, outs, inouts, results) = case (paramMode p) of InOut -> case (paramType p) of Pointer Ptr _ _ -> (p:params, p:ins,outs, inouts, results) _ -> (p:params, ins, outs, p:inouts, p:results) In -> (p:params, p:ins,outs, inouts, results) Out -> (params, ins, p:outs, inouts, p:results) \end{code} \begin{code} iPointerParam :: Name -> Param iPointerParam nm = mkParam "iptr" In (Pointer Ptr True (Name (mkHaskellTyConName nm) nm Nothing Nothing Nothing Nothing)) objParam :: Name -> Param objParam nm = mkParam "obj" In (Name (mkHaskellTyConName nm) nm Nothing Nothing Nothing Nothing) resultParam :: Type -> Param resultParam ty = mkParam "result" Out ty \end{code} Reduce fancy unions down to C-style unions and structs. \begin{code} unionToStruct :: Type -> (Maybe (Id, Type), Type) unionToStruct t = case t of UnionNon un_tag sws -> (Nothing, CUnion un_tag fields Nothing) where fields = map switchToField sws Union enc_struct_tag tag_ty tg un_tag sws -> ( Just (un_tag{idName=un_ty_nm, idOrigName=un_ty_nm}, c_union) , Struct enc_struct_tag [ Field un_tag nm_ty nm_ty Nothing Nothing , Field tg tag_ty tag_ty Nothing Nothing ] Nothing ) where un_ty_nm = "__IHC__" ++ idOrigName un_tag nm_ty = Name un_ty_nm un_ty_nm Nothing Nothing (Just c_union) Nothing c_union = CUnion un_tag fields Nothing fields = map switchToField sws _ -> (Nothing, t) where switchToField (Switch i _ ty o_ty) = Field i ty o_ty Nothing Nothing switchToField _ = error "switchToField" \end{code} Check whether an interface derives from IDispatch or not. \begin{code} derivesFromIDispatch :: CoClassDecl -> Bool derivesFromIDispatch (CoClassInterface _ mb_decl) = case mb_decl of Nothing -> False -- worth a warning? Just d -> case d of Interface{declId=i,declInherit=inherits} -> idOrigName i == "IDispatch" || any (\ (x,_) -> qName x == "IDispatch") inherits DispInterface{} -> True derivesFromIDispatch _ = True \end{code} \begin{code} toDispInterfaceMethod :: Decl -> Decl toDispInterfaceMethod (Method i cc _ ps off) = case break ((\ x -> hasAttributeWithName x "retval").idAttributes.paramId) ps of (bef,p:aft) -> let ty = removePtr (paramType p) o_ty = removePtr (paramOrigType p) in Method i cc (Result ty o_ty) (bef++aft) off _ -> Method i cc (Result voidTy voidTy) ps off toDispInterfaceMethod d = d \end{code} Order-sort declarations - by now, there should be no cyclic dependencies.. \begin{code} sortDecls :: [Decl] -> [Decl] sortDecls ds = ds_sorted where -- compute def & use of the individual decls. ds_depped = map mkDeclDep ds -- compute scc's ds_groups = stronglyConnComp ds_depped -- expand the cyclic groups ds_sorted = concatMap expandGroup ds_groups mkDeclDep :: Decl -> (Decl, String, [String]) mkDeclDep d = let (def,uses) = getDeclUses d in (d,def,uses) getDeclUses :: Decl -> (String,[String]) getDeclUses d = (def, uses) where uses = getUses d def = getDef d getDef defn = case defn of Typedef i _ _ -> idName i Constant i _ _ _ -> idName i Interface i _ _ _ -> idName i DispInterface i _ _ _ -> idName i CoClass i _ -> idName i Library i _ -> idName i Method i _ _ _ _ -> idName i Property i _ _ _ _ -> idName i _ -> "" getUses :: Decl -> [String] getUses d = case d of Typedef _ ty _ -> getTyUses ty Constant _ ty _ _ -> getTyUses ty Interface _ _ is ds -> map (qName.fst) is ++ concatMap getUses ds Module _ ds -> concatMap getUses ds DispInterface _ _ ps ds -> concatMap getUses ps ++ concatMap getUses ds CoClass _ cs -> map (idName.coClassId) cs Library _ ds -> concatMap getUses ds Method _ _ r ps _ -> getTyUses (resultType r) ++ concatMap (getTyUses.paramType) ps Property _ t _ _ _ -> getTyUses t _ -> [] -- Since the types were constructed from type libraries, we can make -- a number of simplifying assumptions. getTyUses :: Type -> [String] getTyUses ty = case ty of FunTy _ r ps -> getTyUses (resultType r) ++ concatMap (getTyUses.paramType) ps String t _ _ -> getTyUses t Sequence t _ _ -> getTyUses t Name n _ _ _ _ _ -> [n] Struct _ fs _ -> concatMap (getTyUses.fieldType) fs Union _ _ _ _ ss -> concatMap (getTyUses.switchType) ss UnionNon _ ss -> concatMap (getTyUses.switchType) ss CUnion _ fs _ -> concatMap (getTyUses.fieldType) fs Pointer _ _ t -> getTyUses t Array t _ -> getTyUses t Iface n _ _ _ _ _ -> [n] SafeArray t -> getTyUses t _ -> [] expandGroup :: SCC a -> [a] expandGroup (AcyclicSCC d) = [d] expandGroup (CyclicSCC ds) = ds -- for now.. \end{code} \begin{code} sizeofType :: Type -> Int sizeofType t = fst (sizeAndAlignModulus Nothing t) --tedious function that maps a type to its size and alignment modulus. --The constants it returns are platform dependent. sizeAndAlignModulus :: Maybe Int -> Type -> (Int, Int) sizeAndAlignModulus mb_pack ty = case ty of Float sz -> case sz of Short -> (fLOAT_SIZE, fLOAT_ALIGN_MODULUS) Long -> (dOUBLE_SIZE, dOUBLE_ALIGN_MODULUS) LongLong -> (dOUBLE_SIZE, dOUBLE_ALIGN_MODULUS) -- no support for (long double)/quads yet (TODO) Natural -> (dOUBLE_SIZE, dOUBLE_ALIGN_MODULUS) Integer sz signed | signed -> case sz of Short -> (sHORT_SIZE, sHORT_ALIGN_MODULUS) Long -> (lONG_SIZE, lONG_ALIGN_MODULUS) Natural -> (lONG_SIZE, lONG_ALIGN_MODULUS) LongLong -> (lONGLONG_SIZE, lONGLONG_ALIGN_MODULUS) | otherwise -> case sz of Short -> (uSHORT_SIZE, uSHORT_ALIGN_MODULUS) Long -> (uLONG_SIZE, uLONG_ALIGN_MODULUS) Natural -> (uLONG_SIZE, uLONG_ALIGN_MODULUS) LongLong -> (uLONGLONG_SIZE, uLONGLONG_ALIGN_MODULUS) Char signed | signed -> (sCHAR_SIZE, sCHAR_ALIGN_MODULUS) | otherwise -> (uCHAR_SIZE, uCHAR_ALIGN_MODULUS) WChar -> (uCHAR_SIZE, uCHAR_ALIGN_MODULUS) Bool -> (uLONG_SIZE, uLONG_ALIGN_MODULUS) Octet -> (uCHAR_SIZE, uCHAR_ALIGN_MODULUS) String{} -> (dATA_PTR_SIZE, dATA_PTR_ALIGN_MODULUS) WString{} -> (dATA_PTR_SIZE, dATA_PTR_ALIGN_MODULUS) Struct _ fields mb_pack2 -> (real_sz, real_ale) where mb_pack_to_use = combinePackLevels mb_pack mb_pack2 (sz, al) = fst (computeStructSizeOffsets mb_pack_to_use fields) real_ale = realModulus mb_pack_to_use al real_sz = align sz real_ale Enum{} -> (lONG_SIZE, lONG_ALIGN_MODULUS) -- TODO: this is [v1_enum] Union _ tty _ _ sw -> (align (uni_off + uni_sz) uni_align, uni_align) where sw_no_empties = filter (not.isEmptySwitch) sw isEmptySwitch (SwitchEmpty _) = True isEmptySwitch _ = False (sw_sizes, sw_aligns) = unzip (map ((sizeAndAlignModulus mb_pack).switchType) sw_no_empties) (tag_sz, {-tag_align-} _) = sizeAndAlignModulus mb_pack tty uni_sz = maximum sw_sizes uni_align = realModulus mb_pack (maximum sw_aligns) -- compute the offset of union (=> size of tag + pad.) uni_off = align tag_sz uni_align UnionNon _ sw -> (uni_sz, uni_align) where sw_no_empties = filter (not.isEmptySwitch) sw isEmptySwitch (SwitchEmpty _) = True isEmptySwitch _ = False (sw_sizes, sw_aligns) = unzip (map ((sizeAndAlignModulus mb_pack).switchType) sw_no_empties) uni_sz = maximum sw_sizes uni_align = realModulus mb_pack (maximum sw_aligns) CUnion _ fields mb_pack2 -> (uni_sz, uni_align) where mb_pack_to_use = combinePackLevels mb_pack mb_pack2 (sw_sizes, sw_aligns) = unzip (map ((sizeAndAlignModulus mb_pack_to_use).fieldType) fields) uni_sz = maximum sw_sizes uni_align = realModulus mb_pack_to_use (maximum sw_aligns) Pointer{} -> (dATA_PTR_SIZE, dATA_PTR_ALIGN_MODULUS) Object -> (dATA_PTR_SIZE, dATA_PTR_ALIGN_MODULUS) Any -> (dATA_PTR_SIZE, dATA_PTR_ALIGN_MODULUS) FunTy{} -> (dATA_PTR_SIZE, dATA_PTR_ALIGN_MODULUS) Array aty [e] -> let (el_sz, al) = sizeAndAlignModulus mb_pack aty in (el_sz * fromIntegral (evalExpr e), al) -- catch the case of conformant/open arrays. Array aty [] -> let (el_sz, al) = sizeAndAlignModulus mb_pack aty in (el_sz, al) Array _ _ -> (dATA_PTR_SIZE, dATA_PTR_ALIGN_MODULUS) Void -> (0, dATA_PTR_ALIGN_MODULUS) SafeArray{} -> (sAFEARRAY_SIZE, sAFEARRAY_ALIGN_MODULUS) Name _ _ _ _ _ (Just ti) -> (prim_sizeof ti, prim_align ti) -- need next one for when we're not doing magic overloading of variants. Name "VARIANT" _ _ _ _ _ -> (16, 8) -- Vanilla fudge. -- Name "GUID" _ _ _ _ _ -> (16, 4) -- Vanilla fudge. Name _ _ _ _ (Just t) _ -> sizeAndAlignModulus mb_pack t Name nm _ _ _ Nothing _ -> let msg = error ("sizeAndAlignModulus: "++nm) in (msg, msg) Fixed{} -> (undefined, undefined) Sequence{} -> (dATA_PTR_SIZE, dATA_PTR_ALIGN_MODULUS) Any -> (undefined, undefined) Object -> (dATA_PTR_SIZE, dATA_PTR_ALIGN_MODULUS) Iface{} -> (dATA_PTR_SIZE, dATA_PTR_ALIGN_MODULUS) StablePtr{} -> (dATA_PTR_SIZE, dATA_PTR_ALIGN_MODULUS) \end{code} \begin{code} computeStructSizeOffsets :: Maybe Int -> [Field] -> ((Int, Int), [Int]) computeStructSizeOffsets mb_pack fields = case (mapAccumL (place mb_pack) (0::Int,1::Int) fields) of ((size, al), offsets) -> let real_al = max structAlign al in ( (align size real_al, real_al) , offsets ) where structAlign = sTRUCT_ALIGN_MODULUS place :: Maybe Int -> ( Int -- tentative offset for field , Int -- current alignment modulus for struct ) -> Field -> ( (Int,Int) -- updated state , Int -- offset at which to store/access field. ) place mb_pack (off,struct_align) f = case sizeAndAlignModulus mb_pack (fieldType f) of (sz, al) -> let real_ale = realModulus mb_pack al field_off = align off real_ale in ((field_off+sz, max real_ale struct_align), field_off) realModulus :: Maybe Int -> Int -> Int realModulus Nothing n = n realModulus (Just v) n = min v n -- align off al = off' such that (off' `mod` align = 0) align :: Int -> Int -> Int align off al | off `mod` al == 0 = off -- perfect, no padding. | otherwise = off + (al - off `mod` al) combinePackLevels :: Maybe Int -> Maybe Int -> Maybe Int combinePackLevels Nothing x = x combinePackLevels x Nothing = x combinePackLevels (Just _) (Just y) = Just y -- the inner one 'wins'. \end{code} When deciding whether to generate (or use) a marshaller for a type, we need to know whether it is (or has components) that are finalised. The reason we need to know this detail of the type is that finalisation is handled differently depending on whether the unmarshaller is called from a stub or a proxy. \begin{code} isFinalisedType :: Bool -> Type -> Bool isFinalisedType ifaceOnly t = case t of Integer{} -> False StablePtr{} -> False Float{} -> False Char{} -> False WChar{} -> False FunTy _ r ps -> any (isFinalisedType ifaceOnly) (resultType r : map paramType ps) Bool{} -> False Octet{} -> False Any{} -> False Object{} -> False String{} -> False WString{} -> False Sequence ty _ _ -> isFinalisedType ifaceOnly ty Fixed{} -> False Void{} -> False SafeArray _ -> True Iface _ _ _ as _ _ -> not optHaskellToC || as `hasAttributeWithName` "finaliser" Array ty _ -> isFinalisedType ifaceOnly ty Pointer Ptr _ _ -> False Pointer _ _ ty -> isFinalisedType ifaceOnly ty Struct _ fs _ -> any (isFinalisedType ifaceOnly) (map fieldType fs) CUnion _ fs _ -> any (isFinalisedType ifaceOnly) (map fieldType fs) UnionNon _ ss -> any (isFinalisedType ifaceOnly) (map switchType (filter isNonDef ss)) Enum{} -> False Union _ _ _ _ ss -> any (isFinalisedType ifaceOnly) (map switchType (filter isNonDef ss)) Name _ _ _ _ _ (Just ti) -> not ifaceOnly && finalised ti Name _ _ _ _ (Just ty) _ -> isFinalisedType ifaceOnly ty Name{} -> False where isNonDef Switch{} = True isNonDef _ = False \end{code}