diff --git a/Driver/Salsa.dll b/Driver/Salsa.dll Binary files a/Driver/Salsa.dll and b/Driver/Salsa.dll differ diff --git a/Foreign/Salsa/Binding.hs b/Foreign/Salsa/Binding.hs --- a/Foreign/Salsa/Binding.hs +++ b/Foreign/Salsa/Binding.hs @@ -60,30 +60,30 @@ "System.Int32" -- --- Typeable instances for primitive types +-- SalsaForeignType instances for primitive types -- -instance Typeable Int32 where typeOf _ = typeOfString "System.Int32" -instance Typeable String where typeOf _ = typeOfString "System.String" -instance Typeable Bool where typeOf _ = typeOfString "System.Boolean" -instance Typeable Double where typeOf _ = typeOfString "System.Double" +instance SalsaForeignType Int32 where foreignTypeOf _ = foreignTypeFromString "System.Int32" +instance SalsaForeignType String where foreignTypeOf _ = foreignTypeFromString "System.String" +instance SalsaForeignType Bool where foreignTypeOf _ = foreignTypeFromString "System.Boolean" +instance SalsaForeignType Double where foreignTypeOf _ = foreignTypeFromString "System.Double" -typeOfString :: String -> Obj Type_ -typeOfString s = unsafePerformIO $ do +foreignTypeFromString :: String -> Obj Type_ +foreignTypeFromString s = unsafePerformIO $ do -- putStrLn $ "typeOfString: " ++ s type_GetType s -- marshalMethod1s type_GetType_stub undefined undefined s --- Define the typeOf function for arrays by first calling typeOf on the element type, +-- Define the foreignTypeOf function for arrays by first calling foreignTypeOf on the element type, -- and then using the Type.MakeArrayType method to return the associated one-dimensional -- array type: -instance Typeable t => Typeable (Arr t) where - typeOf _ = unsafePerformIO $ - marshalMethod1i type_MakeArrayType_stub (typeOf (undefined :: t)) undefined (1 :: Int32) +instance SalsaForeignType t => SalsaForeignType (Arr t) where + foreignTypeOf _ = unsafePerformIO $ + marshalMethod1i type_MakeArrayType_stub (foreignTypeOf (undefined :: t)) undefined (1 :: Int32) -- Note: this function requires ScopedTypeVariables --- Define typeOf for reference types in terms of the associated static type. -instance Typeable t => Typeable (Obj t) where - typeOf _ = typeOf (undefined :: t) +-- Define foreignTypeOf for reference types in terms of the associated static type. +instance SalsaForeignType t => SalsaForeignType (Obj t) where + foreignTypeOf _ = foreignTypeOf (undefined :: t) -- vim:set sw=4 ts=4 expandtab: diff --git a/Foreign/Salsa/Core.hs b/Foreign/Salsa/Core.hs --- a/Foreign/Salsa/Core.hs +++ b/Foreign/Salsa/Core.hs @@ -1,7 +1,7 @@ {-# LANGUAGE GADTs, TypeFamilies, MultiParamTypeClasses, EmptyDataDecls #-} {-# LANGUAGE ExistentialQuantification, FlexibleContexts, TypeOperators #-} {-# LANGUAGE ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances, CPP, ForeignFunctionInterface #-} +{-# LANGUAGE UndecidableInstances, CPP, ForeignFunctionInterface, DataKinds, PolyKinds #-} ----------------------------------------------------------------------------- -- | -- Licence : BSD-style (see LICENSE) @@ -53,8 +53,8 @@ -- Calls 'ResolveMember', converting argument tuples to/from type-level lists, -- and passing it the appropriate list of candidate signatures. -type family Resolve t m args -type instance Resolve t m args = ListToTuple (ResolveMember (TupleToList args) (Candidates t m)) +type family Resolve t m args where + Resolve t m args = ListToTuple (ResolveMember (TupleToList args) (Candidates t m)) -- | 'Invoker' provides type-based dispatch to method implementations, and -- a constrainted result type for method invocations. @@ -161,42 +161,37 @@ -- | 'TupleToList t' is the type-level list representation of the tuple @t@ -- containing marshalable types. This allows arguments to .NET members to -- be passed as tuples, which have a much neater syntax than lists. -type family TupleToList t -type instance TupleToList () = TNil -type instance TupleToList (Obj x) = Obj x ::: TNil -type instance TupleToList String = String ::: TNil -type instance TupleToList Int32 = Int32 ::: TNil -type instance TupleToList Bool = Bool ::: TNil -type instance TupleToList Double = Double ::: TNil -type instance TupleToList (a,b) = a ::: b ::: TNil -type instance TupleToList (a,b,c) = a ::: b ::: c ::: TNil -type instance TupleToList (a,b,c,d) = a ::: b ::: c ::: d ::: TNil -type instance TupleToList (a,b,c,d,e) = a ::: b ::: c ::: d ::: e ::: TNil +type family TupleToList t where + TupleToList (a,b,c,d,e) = a ::: b ::: c ::: d ::: e ::: TNil + TupleToList (a,b,c,d) = a ::: b ::: c ::: d ::: TNil + TupleToList (a,b,c) = a ::: b ::: c ::: TNil + TupleToList (a,b) = a ::: b ::: TNil + TupleToList () = TNil + TupleToList (a) = a ::: TNil -- ... -- | 'ListToTuple l' is the tuple type associated with the type-level list @l@. -type family ListToTuple t -type instance ListToTuple (Error x) = Error x -- propagate errors -type instance ListToTuple TNil = () -type instance ListToTuple (a ::: TNil) = a -type instance ListToTuple (a ::: b ::: TNil) = (a,b) -type instance ListToTuple (a ::: b ::: c ::: TNil) = (a,b,c) -type instance ListToTuple (a ::: b ::: c ::: d ::: TNil) = (a,b,c,d) -type instance ListToTuple (a ::: b ::: c ::: d ::: e ::: TNil) = (a,b,c,d,e) +type family ListToTuple t where + ListToTuple (Error x) = Error x -- propagate errors + ListToTuple TNil = () + ListToTuple (a ::: TNil) = a + ListToTuple (a ::: b ::: TNil) = (a,b) + ListToTuple (a ::: b ::: c ::: TNil) = (a,b,c) + ListToTuple (a ::: b ::: c ::: d ::: TNil) = (a,b,c,d) + ListToTuple (a ::: b ::: c ::: d ::: e ::: TNil) = (a,b,c,d,e) -- ... -- -- Type reflection (connects Haskell types to .NET types) -- --- | The class 'Typeable' provides access to the underlying .NET type that is +-- | The class 'SalsaForeignType' provides access to the underlying .NET type that is -- associated with a given Haskell type. -class Typeable t where +class SalsaForeignType t where -- | Returns the .NET System.Type instance for values of type 't'. -- The value of 't' is not evaluated by the function. - typeOf :: t -> Obj Type_ + foreignTypeOf :: t -> Obj Type_ --- TODO: Perhaps rename Typeable to Type or SalsaType or Target? -- diff --git a/Foreign/Salsa/Mono/CLRHost.hs b/Foreign/Salsa/Mono/CLRHost.hs --- a/Foreign/Salsa/Mono/CLRHost.hs +++ b/Foreign/Salsa/Mono/CLRHost.hs @@ -135,8 +135,8 @@ loadDriverAndBoot :: IO (FunPtr (CString -> IO (FunPtr a))) loadDriverAndBoot = do - loadDriver setupDomain + loadDriver salsa <- getSalsa method <- getMethodFromNameImage "Salsa.Driver:Boot()" salsa if method == nullPtr then diff --git a/Foreign/Salsa/Resolver.hs b/Foreign/Salsa/Resolver.hs --- a/Foreign/Salsa/Resolver.hs +++ b/Foreign/Salsa/Resolver.hs @@ -1,5 +1,5 @@ {-# LANGUAGE TypeFamilies, MultiParamTypeClasses, EmptyDataDecls, TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances, DataKinds, PolyKinds, GADTs #-} ----------------------------------------------------------------------------- -- | -- Licence : BSD-style (see LICENSE) @@ -18,63 +18,38 @@ -- Basic predicates -- -type family IsPrim t +type family IsPrim t :: TBool type instance IsPrim Int32 = TTrue type instance IsPrim String = TTrue type instance IsPrim Bool = TTrue type instance IsPrim Double = TTrue type instance IsPrim (Obj t) = TFalse -type family IsRef t +type family IsRef t :: TBool type instance IsRef t = TNot (IsPrim t) -- FIXME: This definition of IsRef is incorrect. String is a reference -- type (in .NET) but it is also a primitive bridge type. --- --- Operations on the encoded (Gödel) representations of .NET types: --- --- | 'TyCode' maps labels representing .NET types to a type-level list of hexadecimal --- values (similar to Gödel numbering) which can (then) be compared for equality. --- This avoids having to define a large type function for comparing every pair --- of labels used to represent .NET types. -type family TyCode t - -type instance TyCode Int32 = D0 ::: TNil -type instance TyCode String = D1 ::: TNil -type instance TyCode Bool = D2 ::: TNil -type instance TyCode Double = D3 ::: TNil -type instance TyCode (Obj Null) = D4 ::: TNil -type instance TyCode (Maybe Bool) = D5 ::: TNil -- Temporary HACK - - -type family FromTyCode t -type instance FromTyCode (D0 ::: TNil) = Int32 -type instance FromTyCode (D1 ::: TNil) = String -type instance FromTyCode (D2 ::: TNil) = Bool -type instance FromTyCode (D3 ::: TNil) = Double -type instance FromTyCode (D4 ::: TNil) = Obj Null -type instance FromTyCode (D5 ::: TNil) = Maybe Bool - - -- | 'TyEq t1 t2' is true iff the types @t1@ and @t2@ are the same .NET type -- (as indicated by their code). -type family TyEq t1 t2 -type instance TyEq t1 t2 = DigitsEq (TyCode t1) (TyCode t2) +type family TyEq t1 t2 where + TyEq x x = TTrue + TyEq x y = TFalse -- | 'MemberEq m n' is true iff the members 'm' and 'n' have the same types. -type family MemberEq m n -type instance MemberEq TNil TNil = TTrue -type instance MemberEq TNil (n ::: ns) = TFalse -type instance MemberEq (m ::: ms) TNil = TFalse -type instance MemberEq (m ::: ms) (n ::: ns) = TAnd (TyEq m n) (MemberEq ms ns) +type family MemberEq m n :: TBool where + MemberEq TNil TNil = TTrue + MemberEq TNil (n ::: ns) = TFalse + MemberEq (m ::: ms) TNil = TFalse + MemberEq (m ::: ms) (n ::: ns) = TAnd (TyEq m n) (MemberEq ms ns) -- | @'TyElem' t ts@ is true iff the type @t@ is present in the list @ts@ -- (containing coded type representations). -type family TyElem t1 ts -type instance TyElem t1 TNil = TFalse -type instance TyElem t1 (t ::: ts) = TOr (TyEq t1 t) (TyElem t1 ts) +type family TyElem t1 ts :: TBool where + TyElem t1 TNil = TFalse + TyElem t1 (t ::: ts) = TOr (TyEq t1 t) (TyElem t1 ts) -- -- Overload resolution algorithm: @@ -110,14 +85,14 @@ -- filterBestMembers :: [Type] -> [Member] -> [Member] -> [Member] -- filterBestMembers as ms ns = filter (isBestMember as ms) ns -- -type family FilterBestMembers as ms ns -type instance FilterBestMembers as ms TNil = TNil -type instance FilterBestMembers as ms (n ::: ns) = FilterBestMembers' as ms n (FilterBestMembers as ms ns) +type family FilterBestMembers as ms ns where + FilterBestMembers as ms TNil = TNil + FilterBestMembers as ms (n ::: ns) = FilterBestMembers' as ms n (FilterBestMembers as ms ns) -- was: If (IsBestMember as ms n) (n ::: (FilterBestMembers as ms ns)) -- (FilterBestMembers as ms ns) -type family FilterBestMembers' as ms n fbms -type instance FilterBestMembers' as ms n fbms = If (IsBestMember as ms n) (n ::: fbms) fbms +type family FilterBestMembers' as ms n fbms where + FilterBestMembers' as ms n fbms = If (IsBestMember as ms n) (n ::: fbms) fbms -- | @'IsBestMember' as ms n@ is true iff the member @n@ is better than all @@ -129,24 +104,24 @@ -- | m /= n = isBetterMember as n m && isBestMember as ms n -- | otherwise = isBestMember as ms n -- skip members equal to 'n' -- -type family IsBestMember as ms n -type instance IsBestMember as TNil n = TTrue -type instance IsBestMember as (m ::: ms) n = - If (MemberEq m n) (IsBestMember as ms n) +type family IsBestMember as ms n :: TBool where + IsBestMember as TNil n = TTrue + IsBestMember as (m ::: ms) n = + If (MemberEq m n) (IsBestMember as ms n) (TAnd (IsBetterMember as n m) (IsBestMember as ms n)) -- | @'FilterApp' as ms@ returns the list of members from @ms@ that are -- applicable with respect to the argument list @as@. -type family FilterApp as ms -type instance FilterApp as TNil = TNil -type instance FilterApp as (m ::: ms) = FilterApp' as m (FilterApp as ms) +type family FilterApp as ms where + FilterApp as TNil = TNil + FilterApp as (m ::: ms) = FilterApp' as m (FilterApp as ms) -- was: If (IsApp as m) (m ::: FilterApp as ms) -- (FilterApp as ms) -- Note: use of FilterApp' increases compilation speed by a factor of 10 (!) -type family FilterApp' as m fas -type instance FilterApp' as m fas = If (IsApp as m) (m ::: fas) fas +type family FilterApp' as m fas where + FilterApp' as m fas = If (IsApp as m) (m ::: fas) fas -- | @'IsApp' as ps@ is true iff the function member defined by the @@ -154,11 +129,11 @@ -- (ref 7.4.2.1). This means they of the same length and an implicit -- conversion exists from the argument type to the corresponding -- parameter on the function member. -type family IsApp as ps -type instance IsApp TNil TNil = TTrue -type instance IsApp TNil (p ::: ps) = TFalse -- different lengths -type instance IsApp (a ::: as) TNil = TFalse -- different lengths -type instance IsApp (a ::: as) (p ::: ps) = TAnd (ConvertsTo a p) (IsApp as ps) +type family IsApp as ps :: TBool where + IsApp TNil TNil = TTrue + IsApp TNil (p ::: ps) = TFalse -- different lengths + IsApp (a ::: as) TNil = TFalse -- different lengths + IsApp (a ::: as) (p ::: ps) = TAnd (ConvertsTo a p) (IsApp as ps) -- | @'IsBetterMember' as ps qs@ returns true iff the function member defined by the @@ -168,22 +143,20 @@ -- isBetterMember :: [Type] -> Member -> Member -> Bool -- isBetterMember as ps qs = someBetter as ps qs && not (someBetter as qs ps) -- -type family IsBetterMember as ps qs -type instance IsBetterMember as ps qs = - TAnd (AnyBetterConv as ps qs) - (TNot (AnyBetterConv as qs ps)) +type family IsBetterMember as ps qs :: TBool where + IsBetterMember as ps qs = + TAnd (AnyBetterConv as ps qs) + (TNot (AnyBetterConv as qs ps)) -type family AnyBetterConv as ss ts -type instance AnyBetterConv TNil TNil TNil = TFalse -type instance AnyBetterConv (a ::: as) (s ::: ss) (t ::: ts) = - TOr (IsBetterConv a s t) (AnyBetterConv as ss ts) +type family AnyBetterConv as ss ts :: TBool where + AnyBetterConv TNil TNil TNil = TFalse + AnyBetterConv (a ::: as) (s ::: ss) (t ::: ts) = TOr (IsBetterConv a s t) (AnyBetterConv as ss ts) -type family IsBetterConv t t1 t2 -type instance IsBetterConv t t1 t2 = - TOr (TAnd (TyEq t t1) (TNot (TyEq t t2))) - (TAnd (ConvertsTo t1 t2) (TNot (ConvertsTo t2 t1))) +type family IsBetterConv t t1 t2 :: TBool where + IsBetterConv t t1 t2 = TOr (TAnd (TyEq t t1) (TNot (TyEq t t2))) + (TAnd (ConvertsTo t1 t2) (TNot (ConvertsTo t2 t1))) -- -- Original: @@ -199,16 +172,16 @@ -- | @'ConvertsTo' s t@ returns true iff there is an implicit conversion from @s@ -- to @t@ (ref 6.1). -type family ConvertsTo t1 t2 -type instance ConvertsTo t1 t2 = - (TOr (TyEq t1 t2) - (TOr (TAnd (IsPrim t1) (TyEq t2 (Obj Object_))) - (TOr (TAnd (TyEq t1 Int32) (TyEq t2 Double)) - (TOr (TAnd (TyEq t1 (Obj Null)) (IsRef t2)) --- (TOr (TAnd (TAnd (IsArr t1) (IsArr t2)) --- (IsSubtypeOf' (ArrElemTy t1) (ArrElemTy t2))) - (TAnd (TAnd (IsRef t1) (IsRef t2)) - (IsSubtypeOf t1 t2)))))) -- ) +type family ConvertsTo t1 t2 :: TBool where + ConvertsTo t1 t2 = + (TOr (TyEq t1 t2) + (TOr (TAnd (IsPrim t1) (TyEq t2 (Obj Object_))) + (TOr (TAnd (TyEq t1 Int32) (TyEq t2 Double)) + (TOr (TAnd (TyEq t1 (Obj Null)) (IsRef t2)) + -- (TOr (TAnd (TAnd (IsArr t1) (IsArr t2)) + -- (IsSubtypeOf' (ArrElemTy t1) (ArrElemTy t2))) + (TAnd (TAnd (IsRef t1) (IsRef t2)) + (IsSubtypeOf t1 t2)))))) -- ) -- (TOr5 (TyEq t1 t2) @@ -219,19 +192,21 @@ -- Note: using TOr5 instead of a nested set of TOr's only gives a small performance improvement. -type family IsSubtypeOf t1 t2 -type instance IsSubtypeOf t1 t2 = - TOr (TyEq t1 t2) +type family IsSubtypeOf t1 t2 :: TBool where + IsSubtypeOf t1 t2 = TOr (TyEq t1 t2) (TyElem t2 (SupertypesOf t1)) -type family IsArr t -type instance IsArr t = TAnd (TNot (TyEq t (Obj Array_))) - (IsSubtypeOf t (Obj Array_)) +type family IsArr t :: TBool where + IsArr t = TAnd (TNot (TyEq t (Obj Array_))) + (IsSubtypeOf t (Obj Array_)) +{- type family ArrElemTy t type instance ArrElemTy t = ArrElemTy' (TyCode t) +-} +{- type family ArrElemTy' tc type instance ArrElemTy' (D0 ::: DF ::: tc) = tc type family IsSubtypeOf' t1 t2 @@ -246,6 +221,7 @@ type family TyElem' t1 ts type instance TyElem' t1 TNil = TFalse type instance TyElem' t1 (t ::: ts) = TOr (TyEq' t1 (TyCode t)) (TyElem' t1 ts) -- UGLY! +-} -- | @'SupertypesOf' t@ is the list of supertypes of @t@. type family SupertypesOf t diff --git a/Foreign/Salsa/TypePrelude.hs b/Foreign/Salsa/TypePrelude.hs --- a/Foreign/Salsa/TypePrelude.hs +++ b/Foreign/Salsa/TypePrelude.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE TypeFamilies, TypeOperators, EmptyDataDecls #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies, TypeOperators, EmptyDataDecls, UndecidableInstances, DataKinds, PolyKinds, GADTs #-} ----------------------------------------------------------------------------- -- | -- Licence : BSD-style (see LICENSE) @@ -14,36 +13,26 @@ -- Type-level booleans and boolean operations: -- -data TTrue = TTrue -data TFalse = TFalse +data TBool where + TTrue :: TBool + TFalse :: TBool -type family TOr x y -type instance TOr TTrue x = TTrue -type instance TOr TFalse x = x -type family TAnd x y -type instance TAnd TFalse x = TFalse -type instance TAnd TTrue x = x - -type family TNot x -type instance TNot TTrue = TFalse -type instance TNot TFalse = TTrue +type family TOr x y where + TOr TTrue x = TTrue + TOr TFalse x = x -type family If c a b -type instance If TTrue a b = a -type instance If TFalse a b = b +type family TAnd x y where + TAnd TFalse x = TFalse + TAnd TTrue x = x ---type family TAnd3 x y z ---type instance TAnd3 TFalse y z = TFalse ---type instance TAnd3 TTrue TFalse z = TFalse ---type instance TAnd3 TTrue TTrue z = z +type family TNot x where + TNot TTrue = TFalse + TNot TFalse = TTrue ---type family TOr5 a b c d e ---type instance TOr5 TTrue b c d e = TTrue ---type instance TOr5 TFalse TTrue c d e = TTrue ---type instance TOr5 TFalse TFalse TTrue d e = TTrue ---type instance TOr5 TFalse TFalse TFalse TTrue e = TTrue ---type instance TOr5 TFalse TFalse TFalse TFalse e = e +type family If c a b where + If TTrue a b = a + If TFalse a b = b -- -- Type-level lists and associated operations: @@ -53,310 +42,24 @@ data x ::: xs -- = x ::: xs infixr 5 ::: -type family BoolEq x y -type instance BoolEq TTrue TTrue = TTrue -type instance BoolEq TFalse TFalse = TTrue -type instance BoolEq TFalse TTrue = TFalse -type instance BoolEq TTrue TFalse = TFalse +type family BoolEq x y where + BoolEq TTrue TTrue = TTrue + BoolEq TFalse TFalse = TTrue + BoolEq TFalse TTrue = TFalse + BoolEq TTrue TFalse = TFalse -- | 'ListEq xs ys' is true if the given type-level boolean lists contain -- the same boolean values, and false otherwise. -type family ListEq xs ys -type instance ListEq TNil TNil = TTrue -type instance ListEq (x ::: xs) TNil = TFalse -type instance ListEq TNil (x ::: xs) = TFalse -type instance ListEq (x ::: xs) (y ::: ys) = TAnd (BoolEq x y) (ListEq xs ys) +type family ListEq xs ys where + ListEq TNil TNil = TTrue + ListEq (x ::: xs) TNil = TFalse + ListEq TNil (x ::: xs) = TFalse + ListEq (x ::: xs) (y ::: ys) = TAnd (BoolEq x y) (ListEq xs ys) -- | @'FromSingleton' xs def@ returns the only element of the list @xs@ (if it is a -- single element list), otherwise it returns the default value @def@. -type family FromSingleton def xs -type instance FromSingleton def TNil = def -type instance FromSingleton def (x ::: TNil) = x -type instance FromSingleton def (x ::: y ::: z) = def - --- --- Type-level base-16 digits and equality: --- - -data D0 = D0 -data D1 = D1 -data D2 = D2 -data D3 = D3 -data D4 = D4 -data D5 = D5 -data D6 = D6 -data D7 = D7 -data D8 = D8 -data D9 = D9 -data DA = DA -data DB = DB -data DC = DC -data DD = DD -data DE = DE -data DF = DF - -type family DigitEq x y -type instance DigitEq D0 D0 = TTrue -type instance DigitEq D1 D0 = TFalse -type instance DigitEq D2 D0 = TFalse -type instance DigitEq D3 D0 = TFalse -type instance DigitEq D4 D0 = TFalse -type instance DigitEq D5 D0 = TFalse -type instance DigitEq D6 D0 = TFalse -type instance DigitEq D7 D0 = TFalse -type instance DigitEq D8 D0 = TFalse -type instance DigitEq D9 D0 = TFalse -type instance DigitEq DA D0 = TFalse -type instance DigitEq DB D0 = TFalse -type instance DigitEq DC D0 = TFalse -type instance DigitEq DD D0 = TFalse -type instance DigitEq DE D0 = TFalse -type instance DigitEq DF D0 = TFalse -type instance DigitEq D0 D1 = TFalse -type instance DigitEq D1 D1 = TTrue -type instance DigitEq D2 D1 = TFalse -type instance DigitEq D3 D1 = TFalse -type instance DigitEq D4 D1 = TFalse -type instance DigitEq D5 D1 = TFalse -type instance DigitEq D6 D1 = TFalse -type instance DigitEq D7 D1 = TFalse -type instance DigitEq D8 D1 = TFalse -type instance DigitEq D9 D1 = TFalse -type instance DigitEq DA D1 = TFalse -type instance DigitEq DB D1 = TFalse -type instance DigitEq DC D1 = TFalse -type instance DigitEq DD D1 = TFalse -type instance DigitEq DE D1 = TFalse -type instance DigitEq DF D1 = TFalse -type instance DigitEq D0 D2 = TFalse -type instance DigitEq D1 D2 = TFalse -type instance DigitEq D2 D2 = TTrue -type instance DigitEq D3 D2 = TFalse -type instance DigitEq D4 D2 = TFalse -type instance DigitEq D5 D2 = TFalse -type instance DigitEq D6 D2 = TFalse -type instance DigitEq D7 D2 = TFalse -type instance DigitEq D8 D2 = TFalse -type instance DigitEq D9 D2 = TFalse -type instance DigitEq DA D2 = TFalse -type instance DigitEq DB D2 = TFalse -type instance DigitEq DC D2 = TFalse -type instance DigitEq DD D2 = TFalse -type instance DigitEq DE D2 = TFalse -type instance DigitEq DF D2 = TFalse -type instance DigitEq D0 D3 = TFalse -type instance DigitEq D1 D3 = TFalse -type instance DigitEq D2 D3 = TFalse -type instance DigitEq D3 D3 = TTrue -type instance DigitEq D4 D3 = TFalse -type instance DigitEq D5 D3 = TFalse -type instance DigitEq D6 D3 = TFalse -type instance DigitEq D7 D3 = TFalse -type instance DigitEq D8 D3 = TFalse -type instance DigitEq D9 D3 = TFalse -type instance DigitEq DA D3 = TFalse -type instance DigitEq DB D3 = TFalse -type instance DigitEq DC D3 = TFalse -type instance DigitEq DD D3 = TFalse -type instance DigitEq DE D3 = TFalse -type instance DigitEq DF D3 = TFalse -type instance DigitEq D0 D4 = TFalse -type instance DigitEq D1 D4 = TFalse -type instance DigitEq D2 D4 = TFalse -type instance DigitEq D3 D4 = TFalse -type instance DigitEq D4 D4 = TTrue -type instance DigitEq D5 D4 = TFalse -type instance DigitEq D6 D4 = TFalse -type instance DigitEq D7 D4 = TFalse -type instance DigitEq D8 D4 = TFalse -type instance DigitEq D9 D4 = TFalse -type instance DigitEq DA D4 = TFalse -type instance DigitEq DB D4 = TFalse -type instance DigitEq DC D4 = TFalse -type instance DigitEq DD D4 = TFalse -type instance DigitEq DE D4 = TFalse -type instance DigitEq DF D4 = TFalse -type instance DigitEq D0 D5 = TFalse -type instance DigitEq D1 D5 = TFalse -type instance DigitEq D2 D5 = TFalse -type instance DigitEq D3 D5 = TFalse -type instance DigitEq D4 D5 = TFalse -type instance DigitEq D5 D5 = TTrue -type instance DigitEq D6 D5 = TFalse -type instance DigitEq D7 D5 = TFalse -type instance DigitEq D8 D5 = TFalse -type instance DigitEq D9 D5 = TFalse -type instance DigitEq DA D5 = TFalse -type instance DigitEq DB D5 = TFalse -type instance DigitEq DC D5 = TFalse -type instance DigitEq DD D5 = TFalse -type instance DigitEq DE D5 = TFalse -type instance DigitEq DF D5 = TFalse -type instance DigitEq D0 D6 = TFalse -type instance DigitEq D1 D6 = TFalse -type instance DigitEq D2 D6 = TFalse -type instance DigitEq D3 D6 = TFalse -type instance DigitEq D4 D6 = TFalse -type instance DigitEq D5 D6 = TFalse -type instance DigitEq D6 D6 = TTrue -type instance DigitEq D7 D6 = TFalse -type instance DigitEq D8 D6 = TFalse -type instance DigitEq D9 D6 = TFalse -type instance DigitEq DA D6 = TFalse -type instance DigitEq DB D6 = TFalse -type instance DigitEq DC D6 = TFalse -type instance DigitEq DD D6 = TFalse -type instance DigitEq DE D6 = TFalse -type instance DigitEq DF D6 = TFalse -type instance DigitEq D0 D7 = TFalse -type instance DigitEq D1 D7 = TFalse -type instance DigitEq D2 D7 = TFalse -type instance DigitEq D3 D7 = TFalse -type instance DigitEq D4 D7 = TFalse -type instance DigitEq D5 D7 = TFalse -type instance DigitEq D6 D7 = TFalse -type instance DigitEq D7 D7 = TTrue -type instance DigitEq D8 D7 = TFalse -type instance DigitEq D9 D7 = TFalse -type instance DigitEq DA D7 = TFalse -type instance DigitEq DB D7 = TFalse -type instance DigitEq DC D7 = TFalse -type instance DigitEq DD D7 = TFalse -type instance DigitEq DE D7 = TFalse -type instance DigitEq DF D7 = TFalse -type instance DigitEq D0 D8 = TFalse -type instance DigitEq D1 D8 = TFalse -type instance DigitEq D2 D8 = TFalse -type instance DigitEq D3 D8 = TFalse -type instance DigitEq D4 D8 = TFalse -type instance DigitEq D5 D8 = TFalse -type instance DigitEq D6 D8 = TFalse -type instance DigitEq D7 D8 = TFalse -type instance DigitEq D8 D8 = TTrue -type instance DigitEq D9 D8 = TFalse -type instance DigitEq DA D8 = TFalse -type instance DigitEq DB D8 = TFalse -type instance DigitEq DC D8 = TFalse -type instance DigitEq DD D8 = TFalse -type instance DigitEq DE D8 = TFalse -type instance DigitEq DF D8 = TFalse -type instance DigitEq D0 D9 = TFalse -type instance DigitEq D1 D9 = TFalse -type instance DigitEq D2 D9 = TFalse -type instance DigitEq D3 D9 = TFalse -type instance DigitEq D4 D9 = TFalse -type instance DigitEq D5 D9 = TFalse -type instance DigitEq D6 D9 = TFalse -type instance DigitEq D7 D9 = TFalse -type instance DigitEq D8 D9 = TFalse -type instance DigitEq D9 D9 = TTrue -type instance DigitEq DA D9 = TFalse -type instance DigitEq DB D9 = TFalse -type instance DigitEq DC D9 = TFalse -type instance DigitEq DD D9 = TFalse -type instance DigitEq DE D9 = TFalse -type instance DigitEq DF D9 = TFalse -type instance DigitEq D0 DA = TFalse -type instance DigitEq D1 DA = TFalse -type instance DigitEq D2 DA = TFalse -type instance DigitEq D3 DA = TFalse -type instance DigitEq D4 DA = TFalse -type instance DigitEq D5 DA = TFalse -type instance DigitEq D6 DA = TFalse -type instance DigitEq D7 DA = TFalse -type instance DigitEq D8 DA = TFalse -type instance DigitEq D9 DA = TFalse -type instance DigitEq DA DA = TTrue -type instance DigitEq DB DA = TFalse -type instance DigitEq DC DA = TFalse -type instance DigitEq DD DA = TFalse -type instance DigitEq DE DA = TFalse -type instance DigitEq DF DA = TFalse -type instance DigitEq D0 DB = TFalse -type instance DigitEq D1 DB = TFalse -type instance DigitEq D2 DB = TFalse -type instance DigitEq D3 DB = TFalse -type instance DigitEq D4 DB = TFalse -type instance DigitEq D5 DB = TFalse -type instance DigitEq D6 DB = TFalse -type instance DigitEq D7 DB = TFalse -type instance DigitEq D8 DB = TFalse -type instance DigitEq D9 DB = TFalse -type instance DigitEq DA DB = TFalse -type instance DigitEq DB DB = TTrue -type instance DigitEq DC DB = TFalse -type instance DigitEq DD DB = TFalse -type instance DigitEq DE DB = TFalse -type instance DigitEq DF DB = TFalse -type instance DigitEq D0 DC = TFalse -type instance DigitEq D1 DC = TFalse -type instance DigitEq D2 DC = TFalse -type instance DigitEq D3 DC = TFalse -type instance DigitEq D4 DC = TFalse -type instance DigitEq D5 DC = TFalse -type instance DigitEq D6 DC = TFalse -type instance DigitEq D7 DC = TFalse -type instance DigitEq D8 DC = TFalse -type instance DigitEq D9 DC = TFalse -type instance DigitEq DA DC = TFalse -type instance DigitEq DB DC = TFalse -type instance DigitEq DC DC = TTrue -type instance DigitEq DD DC = TFalse -type instance DigitEq DE DC = TFalse -type instance DigitEq DF DC = TFalse -type instance DigitEq D0 DD = TFalse -type instance DigitEq D1 DD = TFalse -type instance DigitEq D2 DD = TFalse -type instance DigitEq D3 DD = TFalse -type instance DigitEq D4 DD = TFalse -type instance DigitEq D5 DD = TFalse -type instance DigitEq D6 DD = TFalse -type instance DigitEq D7 DD = TFalse -type instance DigitEq D8 DD = TFalse -type instance DigitEq D9 DD = TFalse -type instance DigitEq DA DD = TFalse -type instance DigitEq DB DD = TFalse -type instance DigitEq DC DD = TFalse -type instance DigitEq DD DD = TTrue -type instance DigitEq DE DD = TFalse -type instance DigitEq DF DD = TFalse -type instance DigitEq D0 DE = TFalse -type instance DigitEq D1 DE = TFalse -type instance DigitEq D2 DE = TFalse -type instance DigitEq D3 DE = TFalse -type instance DigitEq D4 DE = TFalse -type instance DigitEq D5 DE = TFalse -type instance DigitEq D6 DE = TFalse -type instance DigitEq D7 DE = TFalse -type instance DigitEq D8 DE = TFalse -type instance DigitEq D9 DE = TFalse -type instance DigitEq DA DE = TFalse -type instance DigitEq DB DE = TFalse -type instance DigitEq DC DE = TFalse -type instance DigitEq DD DE = TFalse -type instance DigitEq DE DE = TTrue -type instance DigitEq DF DE = TFalse -type instance DigitEq D0 DF = TFalse -type instance DigitEq D1 DF = TFalse -type instance DigitEq D2 DF = TFalse -type instance DigitEq D3 DF = TFalse -type instance DigitEq D4 DF = TFalse -type instance DigitEq D5 DF = TFalse -type instance DigitEq D6 DF = TFalse -type instance DigitEq D7 DF = TFalse -type instance DigitEq D8 DF = TFalse -type instance DigitEq D9 DF = TFalse -type instance DigitEq DA DF = TFalse -type instance DigitEq DB DF = TFalse -type instance DigitEq DC DF = TFalse -type instance DigitEq DD DF = TFalse -type instance DigitEq DE DF = TFalse -type instance DigitEq DF DF = TTrue - -type family DigitsEq xs ys -type instance DigitsEq TNil TNil = TTrue -type instance DigitsEq (x ::: xs) TNil = TFalse -type instance DigitsEq TNil (x ::: xs) = TFalse -type instance DigitsEq (x ::: xs) (y ::: ys) = TAnd (DigitEq x y) (DigitsEq xs ys) +type family FromSingleton def xs where + FromSingleton def (x ::: TNil) = x + FromSingleton def x = def -- vim:set sw=4 ts=4 expandtab: diff --git a/Foreign/Salsa/salsa.c b/Foreign/Salsa/salsa.c --- a/Foreign/Salsa/salsa.c +++ b/Foreign/Salsa/salsa.c @@ -14,6 +14,7 @@ #include #include +#include typedef struct { //layout of structures can be found in mono's domain-internals.h MonoObject object; @@ -22,12 +23,19 @@ MonoString *cache_path; MonoString *configuration_file; MonoString *dynamic_base; + } MonoAppDomainSetupInternal; typedef struct { - void *lock; - void *pad; + uint32_t depth; + pthread_mutex_t mutex; + +} CRITICAL_SECTION; + + +typedef struct { + CRITICAL_SECTION lock; void *mp; void *code_mp; MonoAppDomainSetupInternal *setup; @@ -37,7 +45,7 @@ } MonoDomainInternal; -void setupDomain(MonoDomain *domain, char *baseDir, char *configFile) //workaround for an issue that was introduced since Mono 3.0 but yet unresolved +void setupDomain(MonoDomain *domain, char *baseDir, char *configFile) //workaround for an issue that was introduced since Mono 3.0 but yet unresolved: https://bugzilla.xamarin.com/show_bug.cgi?id=12669 { MonoAppDomainSetupInternal *appDomSetup; appDomSetup = ((MonoDomainInternal*)domain)->setup; diff --git a/Generator/Generator.cs b/Generator/Generator.cs --- a/Generator/Generator.cs +++ b/Generator/Generator.cs @@ -37,9 +37,6 @@ /// private Dictionary _uniqueIds = new Dictionary(); - private int _typeCodeMaxValue = 15; - private int _typeCodeValue = 7; // Leave first 7 codes available for primitive types - /// /// Set of types that are required by the types generated so far. /// @@ -71,41 +68,6 @@ } } - /// - /// Returns a unique type-level list of booleans, which can be used as a type code. - /// - private string GetNextTypeCode() - { - const int encodingBase = 15; - // Note: This is not 16, thus leaving 'DF' available to use as a delimiter in type codes - // for parameterised types (like arrays). - - // Build a string for type code (as a Haskell type) - StringBuilder s = new StringBuilder(); - int x = _typeCodeValue; - int b = _typeCodeMaxValue; - while (b > 1) - { - s.AppendFormat("{0} ::: ", - new string[] { - "D0", "D1", "D2", "D3", "D4", "D5", "D6", "D7", - "D8", "D9", "DA", "DB", "DC", "DD", "DE", "DF" }[x % encodingBase]); - x /= encodingBase; - b /= encodingBase; - } - s.Append("TNil"); - - // Obtain the next type code - _typeCodeValue += 1; - if (_typeCodeValue == _typeCodeMaxValue) - { - _typeCodeValue = 0; - _typeCodeMaxValue *= encodingBase; - } - - return s.ToString(); - } - private void RequestAll(Type t) { _requestedTypes.Add(t); @@ -317,16 +279,16 @@ // - // Write a Salsa.Typeable instance for this class + // Write a Salsa.SalsaForeignType instance for this class // // Note: Type.GetType always returns the same instance for a given type, so it is // safe to use 'unsafePerformIO' below. // - w.WriteLine("instance Typeable {0} where", classLabel); - w.WriteLine(" typeOf _ = unsafePerformIO $ type_GetType \"{0}\"", targetType.AssemblyQualifiedName); + w.WriteLine("instance SalsaForeignType {0} where", classLabel); + w.WriteLine(" foreignTypeOf _ = unsafePerformIO $ type_GetType \"{0}\"", targetType.AssemblyQualifiedName); w.WriteLine(); - // TODO: Cache result of 'typeOf' in an IORef? + // TODO: Cache result of 'foreignTypeOf' in an IORef? { // @@ -591,14 +553,6 @@ foreach (Type supertype in supertypes) RequireType(supertype); - - // - // Type code - // - string typeCode = GetNextTypeCode(); - w.WriteLine("type instance TyCode {0} = {1}", ToHaskellType(targetType), typeCode); - w.WriteLine("type instance FromTyCode ({1}) = {0}", ToHaskellType(targetType), typeCode); // EXPERIMENTAL - w.WriteLine(); // if (targetType == typeof(System.Array)) // { diff --git a/Generator/Generator.csproj b/Generator/Generator.csproj --- a/Generator/Generator.csproj +++ b/Generator/Generator.csproj @@ -1,4 +1,5 @@ - + + Debug AnyCPU @@ -62,24 +63,18 @@ - + False - .NET Framework 2.0 %28x86%29 - true - + False - .NET Framework 3.0 %28x86%29 - false - + False - .NET Framework 3.5 - false - +