Skip to content

Commit a3b6d19

Browse files
AnabraAnabra
authored
Merge pull request #68 from grin-compiler/32-alt-analyses
Extended syntax: analyses now handle named alternatives
2 parents a5e680b + 7183706 commit a3b6d19

File tree

11 files changed

+213
-102
lines changed

11 files changed

+213
-102
lines changed

‎grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs‎

Lines changed: 15 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -254,7 +254,7 @@ codeGen e = flip evalState emptyCGState $ para folder e >> mkCByProgramM where
254254
caseResultReg <- newReg
255255
altResults <- sequence . fmap snd $ alts_
256256

257-
forM_ altResults $ \(A cpat altM) -> do
257+
forM_ altResults $ \(A cpat altNameReg altM) -> do
258258
let codeGenAlt bindM = codeGenBlock_ $ do
259259
bindM
260260
altM >>= \case
@@ -276,6 +276,10 @@ codeGen e = flip evalState emptyCGState $ para folder e >> mkCByProgramM where
276276
, srcReg = scrutReg
277277
, dstReg = altScrutReg
278278
}
279+
emit IR.Move
280+
{ srcReg = altScrutReg
281+
, dstReg = altNameReg
282+
}
279283

280284
-- bind pattern variables
281285
forM_ (zip [1..] vars) $ \(idx, var) -> do
@@ -302,14 +306,18 @@ codeGen e = flip evalState emptyCGState $ para folder e >> mkCByProgramM where
302306
, srcReg = scrutReg
303307
, dstReg = altScrutReg
304308
}
309+
emit IR.Move
310+
{ srcReg = altScrutReg
311+
, dstReg = altNameReg
312+
}
305313
emit IR.If
306314
{ condition = IR.SimpleTypeExists (litToSimpleType lit)
307315
, srcReg = scrutReg
308316
, instructions = altInstructions
309317
}
310318

311319
DefaultPat -> do
312-
tags <- Set.fromList <$> sequence [getTag tag | A (NodePat tag _) _ <- altResults]
320+
tags <- Set.fromList <$> sequence [getTag tag | A (NodePat tag _) _ _ <- altResults]
313321
altInstructions <- codeGenAlt $ do
314322
-- restrict scrutinee to alternative's domain
315323
altScrutReg <- newReg
@@ -319,6 +327,10 @@ codeGen e = flip evalState emptyCGState $ para folder e >> mkCByProgramM where
319327
, srcReg = scrutReg
320328
, dstReg = altScrutReg
321329
}
330+
emit IR.Move
331+
{ srcReg = altScrutReg
332+
, dstReg = altNameReg
333+
}
322334
emit IR.If
323335
{ condition = IR.AnyNotIn tags
324336
, srcReg = scrutReg
@@ -333,11 +345,10 @@ codeGen e = flip evalState emptyCGState $ para folder e >> mkCByProgramM where
333345
{- NOTE: The alternatives are already evaluated,
334346
we only have return them.
335347
-}
336-
-- NOTE: Currently, the names of the alternatives are ignored by the analysis.
337348
AltF cpat n (_, cgAlt) -> do
338349
altNameReg <- newReg
339350
addReg n altNameReg
340-
pure $ A cpat cgAlt
351+
pure $ A cpat altNameReg cgAlt
341352

342353
SAppF name args -> getExternal name >>= \case
343354
Just ext -> do

‎grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGenBase.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -63,7 +63,7 @@ type CG = State CGState
6363
data Result
6464
= R IR.Reg
6565
| Z
66-
| A CPat (CG Result)
66+
| A CPat IR.Reg (CG Result)
6767

6868
emit :: IR.Instruction -> CG ()
6969
emit inst = modify' $ \s@CGState{..} -> s {_sInstructions = inst : _sInstructions}

‎grin/src/AbstractInterpretation/ExtendedSyntax/EffectTracking/CodeGen.hs‎

Lines changed: 10 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -75,15 +75,21 @@ codeGenM = cata folder where
7575
ECaseF val alts_ -> do
7676
caseResultReg <- newReg
7777
altRegs <- sequence alts_
78-
forM altRegs $ \(R altReg) ->
79-
emit IR.Move { srcReg = altReg, dstReg = caseResultReg }
78+
forM altRegs $ \(A _ altNameReg altM) -> do
79+
altResult <- altM
80+
case altResult of
81+
R altResultReg -> do
82+
-- NOTE: Propagate the effect info back to both the case result register and the alternative's register as well
83+
emit IR.Move { srcReg = altResultReg, dstReg = caseResultReg }
84+
-- TODO: maybe put altName into "A" as well?
85+
_ -> error $ "Effect tracking: a case alternative did not return a register. Scrutinee was: " ++ show (PP val)
8086
pure $ R caseResultReg
8187

8288
-- NOTE: Currently, the names of the alternatives are ignored by the analysis.
83-
AltF _ n exp -> do
89+
AltF cpat n exp -> do
8490
altNameReg <- newReg
8591
addReg n altNameReg
86-
exp
92+
pure $ A cpat altNameReg exp
8793

8894
SAppF name args -> getExternal name >>= \case
8995
Just ext -> do

‎grin/src/AbstractInterpretation/ExtendedSyntax/EffectTracking/CodeGenBase.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -76,7 +76,7 @@ type CG = State CGState
7676
data Result
7777
= R IR.Reg
7878
| Z
79-
| A CPat (CG Result)
79+
| A CPat IR.Reg (CG Result)
8080

8181
emit :: IR.Instruction -> CG ()
8282
emit inst = modify' $ \s@CGState{..} -> s {_sInstructions = inst : _sInstructions}

‎grin/src/AbstractInterpretation/ExtendedSyntax/HeapPointsTo/CodeGen.hs‎

Lines changed: 19 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -227,7 +227,7 @@ codeGenM = cata folder where
227227
-}
228228
alts <- sequence alts_
229229

230-
forM_ alts $ \(A cpat altM) -> do
230+
forM_ alts $ \(A cpat altNameReg altM) -> do
231231
let codeGenAlt bindM = codeGenBlock_ $ do
232232
bindM
233233
altM >>= \case
@@ -249,6 +249,11 @@ codeGenM = cata folder where
249249
, srcReg = scrutReg
250250
, dstReg = altScrutReg
251251
}
252+
-- The altNameReg is just an explicit version of the restricted scrutinee
253+
emit IR.Move
254+
{ srcReg = altScrutReg
255+
, dstReg = altNameReg
256+
}
252257

253258
-- bind pattern variables
254259
forM_ (zip [0..] vars) $ \(idx, name) -> do
@@ -267,11 +272,17 @@ codeGenM = cata folder where
267272
, srcReg = scrutReg
268273
, dstReg = altScrutReg
269274
}
275+
-- The altNameReg is just an explicit version of the restricted scrutinee
276+
emit IR.Move
277+
{ srcReg = altScrutReg
278+
, dstReg = altNameReg
279+
}
280+
270281
-- QUESTION: Redundant IF. Just for consistency?
271282
emit IR.If {condition = IR.SimpleTypeExists (litToSimpleType lit), srcReg = scrutReg, instructions = altInstructions}
272283

273284
DefaultPat -> do
274-
tags <- Set.fromList <$> sequence [getTag tag | A (NodePat tag _) _ <- alts]
285+
tags <- Set.fromList <$> sequence [getTag tag | A (NodePat tag _) _ _ <- alts]
275286
altInstructions <- codeGenAlt $ do
276287
-- restrict scrutinee to alternative's domain
277288
altScrutReg <- newReg
@@ -281,6 +292,11 @@ codeGenM = cata folder where
281292
, srcReg = scrutReg
282293
, dstReg = altScrutReg
283294
}
295+
-- The altNameReg is just an explicit version of the restricted scrutinee
296+
emit IR.Move
297+
{ srcReg = altScrutReg
298+
, dstReg = altNameReg
299+
}
284300
-- QUESTION: Redundant IF. Just for consistency?
285301
emit IR.If {condition = IR.AnyNotIn tags, srcReg = scrutReg, instructions = altInstructions}
286302

@@ -289,11 +305,10 @@ codeGenM = cata folder where
289305

290306
pure $ R caseResultReg
291307

292-
-- NOTE: Currently, the names of the alternatives are ignored by the analysis.
293308
AltF cpat n exp -> do
294309
altNameReg <- newReg
295310
addReg n altNameReg
296-
pure $ A cpat exp
311+
pure $ A cpat altNameReg exp
297312

298313
SAppF name args -> do
299314
-- copy args to definition's variables ; read function result register

‎grin/src/AbstractInterpretation/ExtendedSyntax/HeapPointsTo/CodeGenBase.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -65,7 +65,7 @@ type CG = State CGState
6565
data Result
6666
= R IR.Reg
6767
| Z
68-
| A CPat (CG Result)
68+
| A CPat IR.Reg (CG Result)
6969

7070
emit :: IR.Instruction -> CG ()
7171
emit inst = modify' $ \s@CGState{..} -> s {_sInstructions = inst : _sInstructions}

‎grin/src/AbstractInterpretation/ExtendedSyntax/LiveVariable/CodeGen.hs‎

Lines changed: 6 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -316,7 +316,7 @@ codeGenM e = (cata folder >=> const setMainLive) e
316316
-- restoring scrut reg
317317
addReg scrutName origScrutReg
318318

319-
forM_ alts $ \(A cpat altM) -> do
319+
forM_ alts $ \(A cpat altNameReg altM) -> do
320320

321321
let codeGenAltExists tag before = codeGenAlt scrut
322322
originalScrutineeReg
@@ -350,6 +350,7 @@ codeGenM e = (cata folder >=> const setMainLive) e
350350
-- NOTE: should be altResultRegister
351351
caseResultReg `isLiveThenM` setTagLive irTag altScrutReg
352352
caseResultReg `hasSideEffectsThenM` setTagLive irTag altScrutReg
353+
varPatternDataFlow altNameReg altScrutReg
353354
-- bind pattern variables
354355
forM_ (zip [1..] vars) $ \(idx, name) -> do
355356
argReg <- newReg
@@ -367,13 +368,15 @@ codeGenM e = (cata folder >=> const setMainLive) e
367368
-- NOTE: should be altResultRegister
368369
caseResultReg `isLiveThenM` setBasicValLive originalScrutineeReg
369370
caseResultReg `hasSideEffectsThenM` setBasicValLive originalScrutineeReg
371+
varPatternDataFlow altNameReg originalScrutineeReg
370372
altM >>= processAltResult
371373

372374
DefaultPat -> do
373-
tags <- Set.fromList <$> sequence [getTag tag | A (NodePat tag _) _ <- alts]
375+
tags <- Set.fromList <$> sequence [getTag tag | A (NodePat tag _) _ _ <- alts]
374376
altInstructions <- codeGenAltNotIn tags $ \altScrutReg -> do
375377
caseResultReg `isLiveThenM` (setBasicValLive altScrutReg >> setAllTagsLive altScrutReg)
376378
caseResultReg `hasSideEffectsThenM` (setBasicValLive altScrutReg >> setAllTagsLive altScrutReg)
379+
varPatternDataFlow altNameReg altScrutReg
377380

378381
let canBeLiteral = null tags
379382
{- NOTE: Since, we are not tracking simple types (literals),
@@ -396,11 +399,10 @@ codeGenM e = (cata folder >=> const setMainLive) e
396399

397400
pure $ R caseResultReg
398401

399-
-- NOTE: Currently, the names of the alternatives are ignored by the analysis.
400402
AltF cpat n exp -> do
401403
altNameReg <- newReg
402404
addReg n altNameReg
403-
pure $ A cpat exp
405+
pure $ A cpat altNameReg exp
404406

405407
SAppF name args -> do
406408
appReg <- newReg

‎grin/src/AbstractInterpretation/ExtendedSyntax/LiveVariable/CodeGenBase.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -61,7 +61,7 @@ type CG = State CGState
6161
data Result
6262
= R IR.Reg
6363
| Z
64-
| A CPat (CG Result)
64+
| A CPat IR.Reg (CG Result)
6565

6666
emit :: IR.Instruction -> CG ()
6767
emit inst = modify' $ \s@CGState{..} -> s {_sInstructions = inst : _sInstructions}

‎grin/test/AbstractInterpretation/ExtendedSyntax/CreatedBySpec.hs‎

Lines changed: 11 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -193,7 +193,7 @@ spec = do
193193
, ("xs", producerXS)
194194

195195
, ("z0", emptyProducerSet)
196-
, ("_1", emptyProducerSet)
196+
, ("_1", producerN1)
197197
]
198198
producerN0 = mkProducerSet [(Tag C "Nil", ["n0"])]
199199
producerN1 = mkProducerSet [(Tag C "Cons", ["n1"])]
@@ -243,8 +243,8 @@ spec = do
243243

244244
, ("z0", emptyProducerSet)
245245
, ("z1", emptyProducerSet)
246-
, ("_1", emptyProducerSet)
247-
, ("_2", emptyProducerSet)
246+
, ("_1", producerX0)
247+
, ("_2", producerX1)
248248
, ("_3", emptyProducerSet)
249249
, ("_4", emptyProducerSet)
250250
, ("_5", emptyProducerSet)
@@ -299,8 +299,8 @@ spec = do
299299

300300
, ("z0", emptyProducerSet)
301301
, ("z1", emptyProducerSet)
302-
, ("_1", emptyProducerSet)
303-
, ("_2", emptyProducerSet)
302+
, ("_1", producerX0)
303+
, ("_2", producerX1)
304304
, ("_3", emptyProducerSet)
305305
, ("_4", emptyProducerSet)
306306
, ("_5", emptyProducerSet)
@@ -379,14 +379,14 @@ spec = do
379379
, ("z0", emptyProducerSet)
380380
, ("z1", emptyProducerSet)
381381
, ("z2", emptyProducerSet)
382-
, ("_1", emptyProducerSet)
383-
, ("_2", emptyProducerSet)
382+
, ("_1", producerX0)
383+
, ("_2", producerX1)
384384
, ("_3", emptyProducerSet)
385385
, ("_4", emptyProducerSet)
386386
, ("_5", emptyProducerSet)
387-
, ("_6", emptyProducerSet)
387+
, ("_6", producerX0)
388388
, ("_7", emptyProducerSet)
389-
, ("_8", emptyProducerSet)
389+
, ("_8", producerA1)
390390
]
391391
producerX0 = mkProducerSet [(Tag C "Int", ["x0"])]
392392
producerX1 = mkProducerSet [(Tag C "Bool", ["x1"])]
@@ -597,8 +597,8 @@ spec = do
597597

598598
, ("z0", tySetFromTypes [T_Int64])
599599
, ("z1", tySetFromNodeSet $ mkNodeSet [ (cInt, [ [T_Int64] ]) ])
600-
, ("_1", tySetFromTypes [])
601-
, ("_2", tySetFromTypes [])
600+
, ("_1", tySetFromTypes [T_Int64])
601+
, ("_2", tySetFromTypes [T_Int64])
602602
, ("_3", tySetFromNodeSet $ mkNodeSet [ (cNode, [ [T_UnspecifiedLocation] ]) ])
603603
]
604604
unspecLocExpectedFunctions = M.singleton "grinMain" (mkSimpleMain T_Unit)

‎grin/test/AbstractInterpretation/ExtendedSyntax/HptSpec.hs‎

Lines changed: 54 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -113,15 +113,15 @@ spec = do
113113
test a b =
114114
c <- _prim_int_add a b
115115
case c of
116-
0@_1 ->
117-
k <- pure 100
118-
pure (CInt k)
119-
1@_2 ->
120-
e0 <- pure c
121-
pure (CInt e0)
122-
#default@_3 ->
123-
e1 <- pure c
124-
pure (CInt e1)
116+
0 @ _1 ->
117+
k <- pure 100
118+
pure (CInt k)
119+
1 @ _2 ->
120+
e0 <- pure c
121+
pure (CInt e0)
122+
#default@_3 ->
123+
e1 <- pure c
124+
pure (CInt e1)
125125
|]
126126
let result = inferTypeEnv code
127127
exptected = emptyTypeEnv
@@ -138,9 +138,9 @@ spec = do
138138
, ("k", int64_t)
139139
, ("_v", T_NodeSet $ cnode_t "Int" [TypeEnv.T_Int64])
140140

141-
, ("_1", dead_t)
142-
, ("_2", dead_t)
143-
, ("_3", dead_t)
141+
, ("_1", int64_t)
142+
, ("_2", int64_t)
143+
, ("_3", int64_t)
144144
]
145145
, TypeEnv._function = mconcat
146146
[ fun_t "_prim_int_add" [int64_t, int64_t] int64_t
@@ -212,10 +212,10 @@ spec = do
212212
grinMain =
213213
k0 <- pure 0
214214
p0 <- case k0 of
215-
0@_1 ->
215+
0 @ _1 ->
216216
nil <- pure (CNil)
217217
store nil
218-
1@_2 ->
218+
1 @ _2 ->
219219
pure (#undefined :: #ptr)
220220
n0 <- fetch p0
221221
n1 <- pure (#undefined :: {CNode[#ptr]})
@@ -241,8 +241,46 @@ spec = do
241241
, ("x0", tySetFromTypes [])
242242
, ("nil", tySetFromNodes nodeSetN0)
243243

244-
, ("_1", tySetFromTypes [])
245-
, ("_2", tySetFromTypes [])
244+
, ("_1", tySetFromTypes [HPT.T_Int64])
245+
, ("_2", tySetFromTypes [HPT.T_Int64])
246+
]
247+
(calcHPTResult exp) `shouldBe` expected
248+
249+
it "simple_case_node" $ do
250+
let exp = [prog|
251+
grinMain =
252+
k0 <- pure 0
253+
p0 <- case k0 of
254+
0 @ _1 ->
255+
one <- pure (COne)
256+
store one
257+
1 @ _2 ->
258+
two <- pure (CTwo)
259+
store two
260+
n0 <- fetch p0
261+
case n0 of
262+
(COne) @ _3 -> pure ()
263+
(CTwo) @ _4 -> pure ()
264+
|]
265+
let expected = HPTResult
266+
{ HPT._memory = V.fromList [ nodeSetOne, nodeSetTwo ]
267+
, HPT._register = unspecLocExpectedRegisters
268+
, HPT._function = Map.singleton "grinMain" (mkSimpleMain HPT.T_Unit)
269+
}
270+
nodeSetOne = mkNodeSet [(cOne, [])]
271+
nodeSetTwo = mkNodeSet [(cTwo, [])]
272+
273+
unspecLocExpectedRegisters = Map.fromList
274+
[ ("k0", tySetFromTypes [HPT.T_Int64])
275+
, ("p0", tySetFromTypes [HPT.T_Location 0, HPT.T_Location 1])
276+
, ("n0", tySetFromNodes (nodeSetOne <> nodeSetTwo))
277+
, ("one", tySetFromNodes nodeSetOne)
278+
, ("two", tySetFromNodes nodeSetTwo)
279+
280+
, ("_1", tySetFromTypes [HPT.T_Int64])
281+
, ("_2", tySetFromTypes [HPT.T_Int64])
282+
, ("_3", tySetFromNodes nodeSetOne)
283+
, ("_4", tySetFromNodes nodeSetTwo)
246284
]
247285
(calcHPTResult exp) `shouldBe` expected
248286

0 commit comments

Comments
 (0)