Skip to content

Commit 9887597

Browse files
andorpandorp
committed
Sketch of datalog exporter.
1 parent f5000d5 commit 9887597

File tree

4 files changed

+294
-1
lines changed

4 files changed

+294
-1
lines changed

‎grin/grin.cabal

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -115,6 +115,7 @@ library
115115
Grin.ExtendedSyntax.TypeEnv
116116
Grin.ExtendedSyntax.TypeEnvDefs
117117
Grin.ExtendedSyntax.GADT
118+
Grin.ExtendedSyntax.Datalog
118119
Pipeline.Eval
119120
Pipeline.Optimizations
120121
Pipeline.Pipeline
@@ -239,7 +240,8 @@ library
239240
random,
240241
set-extra,
241242
deepseq,
242-
binary
243+
binary,
244+
souffle-haskell
243245

244246
default-language: Haskell2010
245247

‎grin/src/Grin/ExtendedSyntax/Datalog.hs

Lines changed: 281 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,281 @@
1+
{-# LANGUAGE DeriveGeneric #-}
2+
{-# LANGUAGE OverloadedStrings #-}
3+
{-# LANGUAGE LambdaCase #-}
4+
{-# LANGUAGE DataKinds #-}
5+
{-# LANGUAGE TypeFamilies #-}
6+
module Grin.ExtendedSyntax.Datalog where
7+
8+
import Control.Monad (forM_)
9+
import Data.Int
10+
import Language.Souffle.Interpreted as Souffle
11+
import GHC.Generics
12+
import Control.Monad.Trans
13+
import Control.Monad.Trans.Reader
14+
import Data.Text (Text)
15+
import qualified Grin.ExtendedSyntax.Syntax as Grin
16+
import qualified Data.Text as Text
17+
18+
data HPT = HPT
19+
20+
instance Souffle.Program HPT where
21+
type ProgramFacts HPT =
22+
'[ External
23+
, ExternalParam
24+
, Move
25+
, LitAssign
26+
, Node
27+
, NodeArgument
28+
, Fetch
29+
, Store
30+
, Update
31+
, Call
32+
, CallArgument
33+
, NodePattern
34+
, NodeParameter
35+
, Case
36+
, Alt
37+
, AltLiteral
38+
, AltDefault
39+
, ReturnValue
40+
, FirstInst
41+
, NextInst
42+
, FunctionParameter
43+
, AltParameter
44+
]
45+
programName = const "hpt"
46+
47+
type Function = Text
48+
type Boolean = Int32
49+
type SimpleType = Text
50+
type Number = Int32
51+
type Variable = Text
52+
type Literal = Text
53+
type Tag = Text -- TODO: TagType?
54+
type CodeName = Text
55+
56+
--instance Souffle.Marshal Grin.Name where
57+
-- push (Grin.NM n) = push n
58+
-- pop = Grin.NM <$> pop
59+
60+
data External = External !Function !Boolean !SimpleType deriving (Eq, Show, Generic)
61+
data ExternalParam = ExternalParam !Function !Number !SimpleType deriving (Eq, Show, Generic)
62+
data Move = Move !Variable !Variable deriving (Eq, Show, Generic)
63+
data LitAssign = LitAssign !Variable !SimpleType !Literal deriving (Eq, Show, Generic)
64+
data Node = Node !Variable !Tag deriving (Eq, Show, Generic)
65+
data NodeArgument = NodeArgument !Variable !Number !Variable deriving (Eq, Show, Generic)
66+
data Fetch = Fetch !Variable !Variable deriving (Eq, Show, Generic)
67+
data Store = Store !Variable !Variable deriving (Eq, Show, Generic)
68+
data Update = Update !Variable !Variable !Variable deriving (Eq, Show, Generic)
69+
data Call = Call !Variable !Function deriving (Eq, Show, Generic)
70+
data CallArgument = CallArgument !Variable !Number !Variable deriving (Eq, Show, Generic)
71+
data NodePattern = NodePattern !Variable !Tag !Variable deriving (Eq, Show, Generic)
72+
data NodeParameter = NodeParameter !Variable !Number !Variable deriving (Eq, Show, Generic)
73+
data Case = Case !Variable !Variable deriving (Eq, Show, Generic)
74+
data Alt = Alt !Variable !Variable !Tag deriving (Eq, Show, Generic)
75+
data AltLiteral = AltLiteral !Variable !Variable !Literal deriving (Eq, Show, Generic)
76+
data AltDefault = AltDefault !Variable !Variable deriving (Eq, Show, Generic)
77+
data ReturnValue = ReturnValue !CodeName !Variable deriving (Eq, Show, Generic)
78+
data FirstInst = FirstInst !CodeName !Variable deriving (Eq, Show, Generic)
79+
data NextInst = NextInst !Variable !Variable deriving (Eq, Show, Generic)
80+
data FunctionParameter = FunctionParameter !Function !Number !Variable deriving (Eq, Show, Generic)
81+
data AltParameter = AltParameter !Variable !Tag !Number {-!Variable-} deriving (Eq, Show, Generic)
82+
83+
instance Souffle.Marshal External
84+
instance Souffle.Marshal ExternalParam
85+
instance Souffle.Marshal Move
86+
instance Souffle.Marshal LitAssign
87+
instance Souffle.Marshal Node
88+
instance Souffle.Marshal NodeArgument
89+
instance Souffle.Marshal Fetch
90+
instance Souffle.Marshal Store
91+
instance Souffle.Marshal Update
92+
instance Souffle.Marshal Call
93+
instance Souffle.Marshal CallArgument
94+
instance Souffle.Marshal NodePattern
95+
instance Souffle.Marshal NodeParameter
96+
instance Souffle.Marshal Case
97+
instance Souffle.Marshal Alt
98+
instance Souffle.Marshal AltLiteral
99+
instance Souffle.Marshal AltDefault
100+
instance Souffle.Marshal ReturnValue
101+
instance Souffle.Marshal FirstInst
102+
instance Souffle.Marshal NextInst
103+
instance Souffle.Marshal FunctionParameter
104+
instance Souffle.Marshal AltParameter
105+
106+
instance Souffle.Fact External where factName = const "external"
107+
instance Souffle.Fact ExternalParam where factName = const "externalparam"
108+
instance Souffle.Fact Move where factName = const "move"
109+
instance Souffle.Fact LitAssign where factName = const "litassign"
110+
instance Souffle.Fact Node where factName = const "node"
111+
instance Souffle.Fact NodeArgument where factName = const "nodeargument"
112+
instance Souffle.Fact Fetch where factName = const "fetch"
113+
instance Souffle.Fact Store where factName = const "store"
114+
instance Souffle.Fact Update where factName = const "update"
115+
instance Souffle.Fact Call where factName = const "call"
116+
instance Souffle.Fact CallArgument where factName = const "callargument"
117+
instance Souffle.Fact NodePattern where factName = const "nodepattern"
118+
instance Souffle.Fact NodeParameter where factName = const "nodeparameter"
119+
instance Souffle.Fact Case where factName = const "case"
120+
instance Souffle.Fact Alt where factName = const "alt"
121+
instance Souffle.Fact AltLiteral where factName = const "altliteral"
122+
instance Souffle.Fact AltDefault where factName = const "altdefault"
123+
instance Souffle.Fact ReturnValue where factName = const "returnvalue"
124+
instance Souffle.Fact FirstInst where factName = const "firstinst"
125+
instance Souffle.Fact NextInst where factName = const "nextinst"
126+
instance Souffle.Fact FunctionParameter where factName = const "functionparameter"
127+
instance Souffle.Fact AltParameter where factName = const "altparameter"
128+
129+
130+
gtagToDtag :: Grin.Tag -> Tag
131+
gtagToDtag (Grin.Tag tt name) = (renderTagType tt) <> Grin.nameText name
132+
where
133+
renderTagType :: Grin.TagType -> Text
134+
renderTagType Grin.C = "C"
135+
renderTagType Grin.F = "F"
136+
renderTagType (Grin.P m) = "P-" <> Text.pack (show m) <> "-"
137+
138+
-- type Souffle a = ReaderT (Handle HPT) SouffleM a
139+
140+
convertExternals :: [Grin.External] -> SouffleM ()
141+
convertExternals = undefined
142+
143+
emitAlg :: Handle HPT -> Grin.ExpF (Grin.Exp, SouffleM ()) -> SouffleM ()
144+
emitAlg prog = \case
145+
Grin.ProgramF externals defs -> do
146+
convertExternals externals
147+
mapM_ snd defs
148+
149+
-- f param0 param1 = ...
150+
-- .decl FunctionParameter(f:Function, i:number, parameter:Variable)
151+
Grin.DefF name args (_, body) -> do
152+
Souffle.addFacts prog $
153+
zipWith (\n a -> FunctionParameter (Grin.nameText name) n (Grin.nameText a)) [0..] args
154+
body
155+
156+
-- result <- pure value
157+
-- .decl Move(result:Variable, value:Variable)
158+
Grin.EBindF (Grin.SReturn (Grin.Var val), lhs) (Grin.VarPat res) (_, rhs) -> do
159+
lhs
160+
Souffle.addFact prog $ Move (Grin.nameText res) (Grin.nameText val)
161+
rhs
162+
163+
-- result <- pure 1
164+
-- .decl LitAssign(result:Variable, l:Literal)
165+
Grin.EBindF (Grin.SReturn (Grin.Lit l), lhs) (Grin.VarPat res) (_, rhs) -> do
166+
lhs
167+
Souffle.addFact prog $ litAssignFact res l
168+
rhs
169+
170+
-- result_node <- pure (Ctag item0 item1)
171+
-- .decl Node(result_node:Variable, t:Tag)
172+
-- .decl NodeArgument(result_node:Variable, i:number, item:Variable)
173+
Grin.EBindF ((Grin.SReturn (Grin.ConstTagNode tag items)), lhs) (Grin.VarPat res) (_, rhs) -> do
174+
lhs
175+
Souffle.addFact prog $ Node (Grin.nameText res) (gtagToDtag tag)
176+
Souffle.addFacts prog $
177+
zipWith (\n v -> NodeArgument (Grin.nameText res) n (Grin.nameText v)) [0..] items
178+
rhs
179+
180+
-- example: result <- fetch value
181+
-- .decl Fetch(result:Variable, value:Variable)
182+
Grin.EBindF (Grin.SFetch val, lhs) (Grin.VarPat res) (_, rhs) -> do
183+
lhs
184+
Souffle.addFact prog $ Fetch (Grin.nameText res) (Grin.nameText val)
185+
rhs
186+
187+
-- example: result <- store value
188+
-- .decl Store(result:Variable, value:Variable)
189+
Grin.EBindF (Grin.SStore val, lhs) (Grin.VarPat res) (_, rhs) -> do
190+
lhs
191+
Souffle.addFact prog $ Store (Grin.nameText res) (Grin.nameText val)
192+
rhs
193+
194+
-- example: result <- update target value
195+
-- .decl Update(result:Variable, target:Variable, value:Variable)
196+
Grin.EBindF (Grin.SUpdate target val, lhs) (Grin.VarPat res) (_, rhs) -> do
197+
lhs
198+
Souffle.addFact prog $ Update (Grin.nameText res) (Grin.nameText target) (Grin.nameText val)
199+
rhs
200+
201+
-- call_result <- f value0 value1
202+
-- .decl Call(call_result:Variable, f:Function)
203+
-- .decl CallArgument(call_result:Variable, i:number, value:Variable)
204+
Grin.EBindF (Grin.SApp fun args, lhs) (Grin.VarPat res) (_, rhs) -> do
205+
lhs
206+
Souffle.addFact prog $ Call (Grin.nameText res) (Grin.nameText fun)
207+
Souffle.addFacts prog $
208+
zipWith (\n a -> CallArgument (Grin.nameText res) n (Grin.nameText a)) [0..] args
209+
rhs
210+
211+
-- AsPat { _bPatTag :: Tag
212+
-- , _bPatFields :: [Name]
213+
-- , _bPatVar :: Name
214+
-- }
215+
216+
-- bind pattern
217+
-- node@(Ctag param0 param1) <- pure input_value
218+
-- .decl NodePattern(node:Variable, t:Tag, input_value:Variable)
219+
-- .decl NodeParameter(node:Variable, i:number, parameter:Variable)
220+
Grin.EBindF (Grin.SReturn (Grin.Var inp_val), lhs) (Grin.AsPat tag pms nd) (_, rhs) -> do
221+
lhs
222+
Souffle.addFact prog $ NodePattern (Grin.nameText nd) (gtagToDtag tag) (Grin.nameText inp_val)
223+
Souffle.addFacts prog $
224+
zipWith (\n p -> NodeParameter (Grin.nameText nd) n (Grin.nameText p)) [0..] pms
225+
rhs
226+
227+
-- case + alt
228+
-- example:
229+
-- case_result <- case scrut of
230+
-- alt_value@(Ctag param0 param1) -> basic_block_name arg0 arg1
231+
-- .decl Case(case_result:Variable, scrutinee:Variable)
232+
-- .decl Alt(case_result:Variable, alt_value:Variable, t:Tag)
233+
-- .decl AltParameter(case_result:Variable, t:Tag, i:number, parameter:Variable)
234+
-- .decl AltLiteral(case_result:Variable, alt_value:Variable, l:Literal)
235+
-- .decl AltDefault(case_result:Variable, alt_value :: Variable)
236+
Grin.EBindF (Grin.ECase scr alts, lhs) (Grin.VarPat cs_res) (_, rhs) -> do
237+
lhs
238+
Souffle.addFact prog $ Case (Grin.nameText cs_res) (Grin.nameText scr)
239+
-- -- TODO: Improve performance by grouping alternatives
240+
forM_ alts $ \case
241+
Grin.Alt (Grin.NodePat tag args) n _ -> do
242+
Souffle.addFact prog $ Alt (Grin.nameText cs_res) (Grin.nameText n) (gtagToDtag tag)
243+
Souffle.addFacts prog $
244+
zipWith
245+
(\j a -> AltParameter (Grin.nameText cs_res) (gtagToDtag tag) j {-(Grin.nameText a)-})
246+
[0..]
247+
args
248+
249+
-- TODO: Handle literals better
250+
-- Grin.Alt (Grin.LitPat (G.SInt64 i)) n _ ->
251+
-- [ AltLiteral
252+
-- { case_result = Variable cs_res
253+
-- , alt_value = Variable n
254+
-- , l = Literal (show i)
255+
-- }
256+
-- ]
257+
258+
Grin.Alt Grin.DefaultPat n _ -> do
259+
Souffle.addFact prog $ AltDefault (Grin.nameText cs_res) (Grin.nameText n)
260+
261+
rhs
262+
263+
litAssignFact :: Grin.Name -> Grin.Lit -> LitAssign
264+
litAssignFact v sv = (\(ty, value) -> LitAssign (Grin.nameText v) ty value) $ case sv of
265+
Grin.LInt64 i -> (stToDatalogST Grin.T_Int64, Text.pack $ show i)
266+
Grin.LWord64 w -> (stToDatalogST Grin.T_Word64, Text.pack $ show w)
267+
Grin.LFloat f -> (stToDatalogST Grin.T_Float, Text.pack $ show f)
268+
Grin.LBool b -> (stToDatalogST Grin.T_Bool, Text.pack $ show b)
269+
Grin.LChar c -> (stToDatalogST Grin.T_Char, Text.pack $ show c)
270+
Grin.LString s -> (stToDatalogST Grin.T_String, s) -- TODO
271+
272+
stToDatalogST :: Grin.SimpleType -> SimpleType
273+
stToDatalogST = \case
274+
Grin.T_Int64 -> "Int64"
275+
Grin.T_Word64 -> "Word64"
276+
Grin.T_Float -> "Float"
277+
Grin.T_Bool -> "Bool"
278+
Grin.T_Char -> "Char"
279+
Grin.T_Unit -> "Unit"
280+
Grin.T_String -> "String"
281+
other -> error $ "stToDatalogST: None handled case: " ++ show other

‎grin/src/Grin/ExtendedSyntax/SyntaxDefs.hs

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -17,6 +17,9 @@ data Name
1717
| NI !Int
1818
deriving (Generic, Data, NFData, Binary, Eq, Ord, Show)
1919

20+
mkName :: Text -> Name
21+
mkName = NM
22+
2023
nMap :: (Text -> Text) -> Name -> Name
2124
nMap f (NM n) = NM (f n)
2225

@@ -32,6 +35,11 @@ instance IsString Name where
3235
instance PrintfArg Name where
3336
formatArg = formatString . unpack . unNM
3437

38+
nameText :: Name -> Text
39+
nameText = \case
40+
NM n -> n
41+
_ -> error "Name index found." -- This could have left in the AST after a problematic deserialisation.
42+
3543
nameString :: Name -> String
3644
nameString = \case
3745
NM n -> unpack n

‎stack.yaml

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,8 @@ extra-deps:
1818
subdirs:
1919
- llvm-hs
2020
- llvm-hs-pure
21+
- github: luc-tielen/souffle-haskell
22+
commit: c76bd446c210b32e7a1de55b37a4df051586f108
2123

2224
flags:
2325
llvm-hs:

0 commit comments

Comments
 (0)