4bbe64a · project-m36 · git.iko.soy

git.iko.soy/project-m36

working dynamic atom function loading

commit4bbe64aeb8610c292bc90457c16ba0669ba980a5 authorAgentM <agentm@themactionfaction.com> dateMon 7 May 2018, 19:20 (8 years ago) parent0728c98

13 files changed+120−12

compare with master

unifiedsplit

project-m36.cabal+4−3

@@ -26,6 +26,7 @@ Library

2626 Build-Depends: base>=4.8 && < 6.0

2727 ,ghc >= 7.8 && < 8.3

2828 ,ghc-paths

29+ ,ghci

2930 ,mtl

3031 ,containers

3132 ,unordered-containers

@@ -152,14 +153,14 @@ Library

152153 ProjectM36.TypeConstructorDef,

153154 ProjectM36.FileLock,

154155 ProjectM36.FSType

155− GHC-Options: -Wall

156+ GHC-Options: -Wall -rdynamic

156157 if os(windows)

157158 Build-Depends: Win32 >= 2.3

158159 Other-Modules: ProjectM36.Win32Handle

159160 else

160161 C-sources: cbits/DirectoryFsync.c, cbits/darwin_statfs.c

161162 Build-Depends: unix

162− CC-Options: -fPIC

163+ CC-Options: -fPIC

163164 Hs-Source-Dirs: ./src/lib

164165 Default-Language: Haskell2010

165166 Default-Extensions: OverloadedStrings, CPP

@@ -225,7 +226,7 @@ Executable tutd

225226 TutorialD.Interpreter.SchemaOperator

226227 main-is: TutorialD/tutd.hs

227228 CC-Options: -fPIC

228− GHC-Options: -Wall

229+ GHC-Options: -Wall -rdynamic

229230 Hs-Source-Dirs: ./src/bin

230231 Default-Language: Haskell2010

231232 Default-Extensions: OverloadedStrings

src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs+7−1

@@ -26,6 +26,12 @@ atomTypeSignatureP :: Parser [TypeConstructor]

2626atomTypeSignatureP = sepBy typeConstructorP arrow

2727

2828dbContextIOExprP :: Parser DatabaseContextIOExpr

29−dbContextIOExprP = addAtomFunctionExprP <|> addDatabaseContextFunctionExprP

29+dbContextIOExprP = addAtomFunctionExprP <|> addDatabaseContextFunctionExprP <|> loadAtomFunctionsP

30+

31+loadAtomFunctionsP :: Parser DatabaseContextIOExpr

32+loadAtomFunctionsP = do

33+ reserved "loadatomfunctions"

34+ LoadAtomFunctions <$> quotedString <*> quotedString <*> fmap unpack quotedString

35+

3036

3137

src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs+11

@@ -24,6 +24,7 @@ data RODatabaseContextOperator where

2424 ShowPlan :: DatabaseContextExpr -> RODatabaseContextOperator

2525 ShowTypes :: RODatabaseContextOperator

2626 ShowRelationVariables :: RODatabaseContextOperator

27+ ShowAtomFunctions :: RODatabaseContextOperator

2728 Quit :: RODatabaseContextOperator

2829 deriving (Show)

2930

@@ -48,6 +49,9 @@ showTypesP = reserved ":showtypes" >> pure ShowTypes

4849showRelationVariables :: Parser RODatabaseContextOperator

4950showRelationVariables = reserved ":showrelvars" >> pure ShowRelationVariables

5051

52+showAtomFunctionsP :: Parser RODatabaseContextOperator

53+showAtomFunctionsP = reserved ":showatomfunctions" >> pure ShowAtomFunctions

54+

5155quitP :: Parser RODatabaseContextOperator

5256quitP = do

5357 reservedOp ":quit"

@@ -71,6 +75,7 @@ roDatabaseContextOperatorP = typeP

7175 <|> showConstraintsP

7276 <|> showPlanP

7377 <|> showTypesP

78+ <|> showAtomFunctionsP

7479 <|> quitP

7580

7681--logically, these read-only operations could happen purely, but not if a remote call is required

@@ -125,6 +130,12 @@ evalRODatabaseContextOp sessionId conn ShowRelationVariables = do

125130 case eRel of

126131 Left err -> pure $ DisplayErrorResult (T.pack (show err))

127132 Right rel -> evalRODatabaseContextOp sessionId conn (ShowRelation (ExistingRelation rel))

133+

134+evalRODatabaseContextOp sessionId conn ShowAtomFunctions = do

135+ eRel <- C.atomFunctionsAsRelation sessionId conn

136+ case eRel of

137+ Left err -> pure $ DisplayErrorResult (T.pack (show err))

138+ Right rel -> evalRODatabaseContextOp sessionId conn (ShowRelation (ExistingRelation rel))

128139

129140evalRODatabaseContextOp _ _ Quit = pure QuitResult

130141

src/lib/ProjectM36/AtomFunction.hs+19−2

@@ -1,12 +1,17 @@

11module ProjectM36.AtomFunction where

22import ProjectM36.Base

33import ProjectM36.Error

4+import ProjectM36.Relation

5+import ProjectM36.AtomType

46import ProjectM36.AtomFunctionError

7+import ProjectM36.ScriptSession

58import qualified ProjectM36.Attribute as A

69import qualified Data.HashSet as HS

10+import qualified Data.Text as T

11+

712

813foldAtomFuncType :: AtomType -> AtomType -> [AtomType]

9−foldAtomFuncType foldType returnType = [RelationAtomType (A.attributesFromList [Attribute "_" foldType]), returnType]

14+foldAtomFuncType foldType returnType = [RelationAtomType (A.attributesFromList [Attribute "a" foldType]), returnType]

1015

1116atomFunctionForName :: AtomFunctionName -> AtomFunctions -> Either RelationalError AtomFunction

1217atomFunctionForName funcName funcSet = if HS.null foundFunc then

@@ -64,4 +69,16 @@ createScriptedAtomFunction funcName argsType retType = AddAtomFunction funcName

6469 argsType ++ [ADTypeConstructor "Either" [

6570 ADTypeConstructor "AtomFunctionError" [],

6671 retType]])

67−

72+

73+loadAtomFunctions :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError [AtomFunction])

74+loadAtomFunctions modName funcName objPath = do

75+ loadFunction modName funcName objPath

76+

77+atomFunctionsAsRelation :: AtomFunctions -> Either RelationalError Relation

78+atomFunctionsAsRelation funcs = mkRelationFromList attrs tups

79+ where tups = map atomFuncToTuple (HS.toList funcs)

80+ attrs = A.attributesFromList [Attribute "name" TextAtomType,

81+ Attribute "arguments" TextAtomType]

82+ atomFuncToTuple aFunc = [TextAtom (atomFuncName aFunc),

83+ TextAtom (atomFuncTypeToText aFunc)]

84+ atomFuncTypeToText aFunc = T.intercalate " -> " (map prettyAtomType (atomFuncType aFunc))

src/lib/ProjectM36/AtomType.hs+4−2

@@ -252,14 +252,16 @@ prettyAtomType :: AtomType -> T.Text

252252prettyAtomType (RelationAtomType attrs) = "relation {" `T.append` T.intercalate "," (map prettyAttribute (V.toList attrs)) `T.append` "}"

253253prettyAtomType (ConstructedAtomType tConsName typeVarMap) = tConsName `T.append` T.concat (map showTypeVars (M.toList typeVarMap))

254254 where

255+ showTypeVars (_, TypeVariableType x) = " " <> x

255256 showTypeVars (tyVarName, aType) = " (" `T.append` tyVarName `T.append` "::" `T.append` prettyAtomType aType `T.append` ")"

256257-- it would be nice to have the original ordering, but we don't have access to the type constructor here- maybe the typevarmap should be also positional (ordered map?)

257−prettyAtomType (TypeVariableType x) = "?TypeVariableType " <> x <> "?"

258−prettyAtomType (IntervalAtomType tv) = "Interval (" <> prettyAtomType tv <> ")"

258+prettyAtomType (TypeVariableType x) = x

259+prettyAtomType (IntervalAtomType tv) = "Interval " <> prettyAtomType tv

259260prettyAtomType aType = T.take (T.length fullName - T.length "AtomType") fullName

260261 where fullName = (T.pack . show) aType

261262

262263prettyAttribute :: Attribute -> T.Text

264+prettyAttribute (Attribute _ (TypeVariableType x)) = x

263265prettyAttribute attr = A.attributeName attr `T.append` "::" `T.append` prettyAtomType (A.atomType attr)

264266

265267resolveTypeVariables :: [AtomType] -> [AtomType] -> Either RelationalError TypeVarMap

src/lib/ProjectM36/Base.hs+5−1

@@ -332,9 +332,13 @@ data DatabaseContextExpr =

332332 MultipleExpr [DatabaseContextExpr]

333333 deriving (Show, Eq, Binary, Generic)

334334

335+type ObjModuleName = StringType

336+type ObjFunctionName = StringType

337+

335338-- | Adding an atom function should be nominally a DatabaseExpr except for the fact that it cannot be performed purely. Thus, we create the DatabaseContextIOExpr.

336339data DatabaseContextIOExpr = AddAtomFunction AtomFunctionName [TypeConstructor] AtomFunctionBodyScript |

337− AddDatabaseContextFunction DatabaseContextFunctionName [TypeConstructor] DatabaseContextFunctionBodyScript

340+ LoadAtomFunctions ObjModuleName ObjFunctionName FilePath |

341+ AddDatabaseContextFunction DatabaseContextFunctionName [TypeConstructor] DatabaseContextFunctionBodyScript

338342 deriving (Show, Eq, Generic, Binary)

339343

340344

src/lib/ProjectM36/Client.hs+16−2

@@ -32,6 +32,7 @@ module ProjectM36.Client

3232 setCurrentSchemaName,

3333 transactionGraphAsRelation,

3434 relationVariablesAsRelation,

35+ ProjectM36.Client.atomFunctionsAsRelation,

3536 disconnectedTransactionIsDirty,

3637 headName,

3738 remoteDBLookupName,

@@ -98,7 +99,7 @@ import ProjectM36.Base hiding (inclusionDependencies) --defined in this module a

9899import qualified ProjectM36.Base as B

99100import ProjectM36.Error

100101import ProjectM36.Atomable

101−import ProjectM36.AtomFunction

102+import ProjectM36.AtomFunction as AF

102103import ProjectM36.StaticOptimizer

103104import ProjectM36.Key

104105import qualified ProjectM36.IsomorphicSchema as Schema

@@ -910,7 +911,20 @@ relationVariablesAsRelation sessionId (InProcessConnection conf) = do

910911 Left err -> pure (Left err)

911912 Right relvars -> pure $ R.relationVariablesAsRelation relvars

912913

913−relationVariablesAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveRelationVariableSummary sessionId)

914+relationVariablesAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveRelationVariableSummary sessionId)

915+

916+-- | Returns the names and types of the atom functions in the current 'Session'.

917+atomFunctionsAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation)

918+atomFunctionsAsRelation sessionId (InProcessConnection conf) = do

919+ let sessions = ipSessions conf

920+ atomically $ do

921+ eSession <- sessionAndSchema sessionId sessions

922+ case eSession of

923+ Left err -> pure (Left err)

924+ Right (session, _) -> do

925+ pure (AF.atomFunctionsAsRelation (atomFunctions (concreteDatabaseContext session)))

926+

927+atomFunctionsAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveAtomFunctionSummary sessionId)

914928

915929-- | Returns the transaction id for the connection's disconnected transaction committed parent transaction.

916930headTransactionId :: SessionId -> Connection -> IO (Either RelationalError TransactionId)

src/lib/ProjectM36/Error.hs+1

@@ -85,6 +85,7 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

8585 | UnhandledExceptionError String

8686 | MergeTransactionError MergeError

8787 | ScriptError ScriptCompilationError

88+ | LoadFunctionError

8889 | DatabaseContextFunctionUserError DatabaseContextFunctionError

8990 | DatabaseLoadError PersistenceError

9091

src/lib/ProjectM36/RelationalExpression.hs+7−1

@@ -561,7 +561,13 @@ evalDatabaseContextIOExpr mScriptSession currentContext (AddDatabaseContextFunct

561561 Right eContext -> case eContext of

562562 Left err -> pure (Left err)

563563 Right context' -> pure (Right context')

564−

564+evalDatabaseContextIOExpr _ currentContext (LoadAtomFunctions modName funcName modPath) = do

565+ eLoadFunc <- loadAtomFunctions (T.unpack modName) (T.unpack funcName) modPath

566+ case eLoadFunc of

567+ Left LoadSymbolError -> pure (Left LoadFunctionError)

568+ Right atomFunctionListFunc -> let newContext = currentContext { atomFunctions = mergedFuncs }

569+ mergedFuncs = HS.union (atomFunctions currentContext) (HS.fromList atomFunctionListFunc)

570+ in pure (Right newContext)

565571

566572updateTupleWithAtomExprs :: M.Map AttributeName AtomExpr -> DatabaseContext -> RelationTuple -> Either RelationalError RelationTuple

567573updateTupleWithAtomExprs exprMap context tupIn = do

src/lib/ProjectM36/ScriptSession.hs+38

@@ -1,3 +1,4 @@

1+{-# LANGUAGE MagicHash, UnboxedTuples #-}

12module ProjectM36.ScriptSession where

34import ProjectM36.Error

@@ -9,6 +10,7 @@ import System.Directory

910import Control.Monad.IO.Class

1011import System.FilePath.Glob

1112import System.FilePath

13+import System.Info (os, arch)

1214import Data.Text (Text, unpack)

1315import Data.Maybe

1416

@@ -24,6 +26,11 @@ import PprTyThing

2426import Unsafe.Coerce

2527import Type

2628

29+import GHC.Exts (addrToAny#)

30+import GHC.Ptr (Ptr(..))

31+import GHCi.ObjLink

32+import Encoding

33+

2734data ScriptSession = ScriptSession {

2835 hscEnv :: HscEnv,

2936 atomFunctionBodyType :: Type,

@@ -174,4 +181,35 @@ typeCheckScript expectedType inp = do

174181 pure Nothing

175182 else

176183 pure (Just (TypeCheckCompilationError (showType dflags expectedType) (showType dflags funcType)))

184+

185+mangleSymbol :: Maybe String -> String -> String -> String

186+mangleSymbol pkg module' valsym =

187+ prefixUnderscore ++

188+ maybe "" (\p -> zEncodeString p ++ "_") pkg ++

189+ zEncodeString module' ++ "_" ++ zEncodeString valsym ++ "_closure"

190+

191+type ModName = String

192+type FuncName = String

193+

194+data LoadSymbolError = LoadSymbolError

195+

196+loadFunction :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError a)

197+loadFunction modName funcName objPath = do

198+ initObjLinker

199+ loadObj objPath

200+ _ <- resolveObjs

201+ ptr <- lookupSymbol (mangleSymbol Nothing modName funcName)

202+ case ptr of

203+ Nothing -> pure (Left LoadSymbolError)

204+ Just (Ptr addr) -> case addrToAny# addr of

205+ (# hval #) -> pure (Right hval)

177206

207+prefixUnderscore :: String

208+prefixUnderscore =

209+ case (os,arch) of

210+ ("mingw32","x86_64") -> ""

211+ ("cygwin","x86_64") -> ""

212+ ("mingw32",_) -> "_"

213+ ("darwin",_) -> "_"

214+ ("cygwin",_) -> "_"

215+ _ -> ""

src/lib/ProjectM36/Server.hs+1

@@ -41,6 +41,7 @@ serverDefinition testBool ti = defaultProcess {

4141 handleCall (\conn (CloseSession sessionId) -> handleCloseSession ti sessionId conn),

4242 handleCall (\conn (RetrieveAtomTypesAsRelation sessionId) -> handleRetrieveAtomTypesAsRelation ti sessionId conn),

4343 handleCall (\conn (RetrieveRelationVariableSummary sessionId) -> handleRetrieveRelationVariableSummary ti sessionId conn),

44+ handleCall (\conn (RetrieveAtomFunctionSummary sessionId) -> handleRetrieveAtomFunctionSummary ti sessionId conn),

4445 handleCall (\conn (RetrieveCurrentSchemaName sessionId) -> handleRetrieveCurrentSchemaName ti sessionId conn),

4546 handleCall (\conn (ExecuteSchemaExpr sessionId schemaExpr) -> handleExecuteSchemaExpr ti sessionId conn schemaExpr),

4647 handleCall (\conn (RetrieveSessionIsDirty sessionId) -> handleRetrieveSessionIsDirty ti sessionId conn),

src/lib/ProjectM36/Server/EntryPoints.hs+5

@@ -120,6 +120,11 @@ handleRetrieveRelationVariableSummary ti sessionId conn = do

120120 ret <- timeoutOrDie ti (relationVariablesAsRelation sessionId conn)

121121 reply ret conn

122122

123+handleRetrieveAtomFunctionSummary :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation)

124+handleRetrieveAtomFunctionSummary ti sessionId conn = do

125+ ret <- timeoutOrDie ti (atomFunctionsAsRelation sessionId conn)

126+ reply ret conn

127+

123128handleRetrieveCurrentSchemaName :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError SchemaName)

124129handleRetrieveCurrentSchemaName ti sessionId conn = do

125130 ret <- timeoutOrDie ti (currentSchemaName sessionId conn)

src/lib/ProjectM36/Server/RemoteCallTypes.hs+2

@@ -52,6 +52,8 @@ data RetrieveAtomTypesAsRelation = RetrieveAtomTypesAsRelation SessionId

5252 deriving (Binary, Generic)

5353data RetrieveRelationVariableSummary = RetrieveRelationVariableSummary SessionId

5454 deriving (Binary, Generic)

55+data RetrieveAtomFunctionSummary = RetrieveAtomFunctionSummary SessionId

56+ deriving (Binary, Generic)

5557data RetrieveCurrentSchemaName = RetrieveCurrentSchemaName SessionId

5658 deriving (Binary, Generic)

5759data TestTimeout = TestTimeout SessionId