Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Extended Syntax: LVA fix #97

Merged
merged 5 commits into from
Apr 26, 2020
Merged
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
Original file line number Diff line number Diff line change
@@ -23,8 +23,6 @@ import qualified AbstractInterpretation.ExtendedSyntax.IR as IR
import AbstractInterpretation.ExtendedSyntax.IR (Instruction(..), AbstractProgram(..), AbstractMapping(..))
import AbstractInterpretation.ExtendedSyntax.LiveVariable.CodeGenBase

import AbstractInterpretation.ExtendedSyntax.EffectTracking.Result

-- NOTE: For a live variable, we could store its type information.

-- Live variable analysis program.
@@ -230,26 +228,34 @@ codeGenM e = (cata folder >=> const setMainLive) e
lhs <- leftExp
let R lhsReg = lhs

let mkRegsThenVarPatternDataFlow v = do
varReg <- newReg
addReg v varReg
varPatternDataFlow varReg lhsReg

case bPat of
VarPat v -> mkRegsThenVarPatternDataFlow v
VarPat v -> do
varReg <- newReg
addReg v varReg
varPatternDataFlow varReg lhsReg
AsPat tag args v -> do
varReg <- newReg
addReg v varReg
varPatternDataFlow varReg lhsReg

irTag <- getTag tag
setTagLive irTag lhsReg
bindInstructions <- codeGenBlock_ $ forM (zip [1..] args) $ \(idx, arg) -> do
argReg <- newReg
addReg arg argReg
nodePatternDataFlow argReg lhsReg irTag idx

-- propagating liveness info backwards
emit IR.Extend
{ srcReg = argReg
, dstSelector = IR.NodeItem irTag idx
, dstReg = varReg
}
emit IR.If
{ condition = IR.NodeTypeExists irTag
, srcReg = lhsReg
, instructions = bindInstructions
}
mkRegsThenVarPatternDataFlow v
-- QUESTION: what about undefined?
_ -> error $ "unsupported bpat " ++ show (PP bPat)

@@ -400,17 +406,21 @@ codeGenM e = (cata folder >=> const setMainLive) e
argRegs <- mapM getReg args

mExt <- getExternal name
(funResultReg, funArgRegs) <- getOrAddFunRegs name $ length args
varPatternDataFlow appReg funResultReg

case mExt of
Nothing -> do -- regular function
(funResultReg, funArgRegs) <- getOrAddFunRegs name $ length args
-- no effect data-flow between formal and actual arguments
zipWithM_ livenessDataFlow funArgRegs argRegs
zipWithM_ (\src dst -> emit $ copyStructureWithPtrInfo src dst) argRegs funArgRegs

varPatternDataFlow appReg funResultReg
Just ext | eEffectful ext -> do mapM_ setBasicValLive argRegs
mapM_ setBasicValLive funArgRegs
setBasicValSideEffecting appReg
| otherwise -> do allArgsLive <- codeGenBlock_ $ mapM_ setBasicValLive argRegs
setBasicValSideEffecting funResultReg
| otherwise -> do allArgsLive <- codeGenBlock_ $ do
mapM_ setBasicValLive argRegs
mapM_ setBasicValLive funArgRegs
emit $ appReg `isLiveThen` allArgsLive

pure $ R appReg
19 changes: 18 additions & 1 deletion grin/src/Test/ExtendedSyntax/Util.hs
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedStrings, MultiWayIf #-}
module Test.ExtendedSyntax.Util where

-- TODO: Remove this module
@@ -12,14 +12,19 @@ import Data.Text (Text)

import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.List as L (isSuffixOf)
import qualified Data.Vector as V
import qualified Data.Text.IO as T (readFile)

import System.Directory (getCurrentDirectory)

import Grin.ExtendedSyntax.Grin
import Grin.ExtendedSyntax.Parse
import Grin.ExtendedSyntax.PrimOpsPrelude
import AbstractInterpretation.ExtendedSyntax.HeapPointsTo.Result as HPT

import Test.Hspec
import Test.Hspec.Core.Spec (SpecM)
import Test.ExtendedSyntax.Assertions

cInt :: Tag
@@ -100,3 +105,15 @@ mkBeforeAfterTestCase name beforeDir afterDir = (before, after, specFun)
expected <- runIO $ T.readFile after'
let expected' = parseProg expected
it name $ transformed `sameAs` expected'

loadTestData :: FilePath -> IO Exp
loadTestData path = do
pwd <- getCurrentDirectory
-- There is a difference between the 'stack ghci --test' and 'stack test'.
-- Stack test uses the grin/grin meanwhile stack ghci uses 'grin' directory
let testDataDir = if | "/grin/grin" `L.isSuffixOf` pwd -> "test-data/ExtendedSyntax"
| "/grin" `L.isSuffixOf` pwd -> "grin/test-data/ExtendedSyntax"
| otherwise -> error "Impossible: stack did not run inside the project dir."

file <- T.readFile (testDataDir </> path)
pure $ withPrimPrelude . parseProg $ file
Original file line number Diff line number Diff line change
@@ -0,0 +1,54 @@
grinMain = n1 <- pure (CInt 1)
t1 <- store n1
n2 <- pure (CInt 10000)
t2 <- store n2
n3 <- pure (Fupto t1 t2)
t3 <- store n3
n4 <- pure (Flength t3)
t4 <- store n4
n5 <- eval t4
(CInt r') <- pure n5
_prim_int_print r'

upto m n = n6 <- eval m
(CInt m') <- pure n6
n7 <- eval n
(CInt n') <- pure n7
b' <- _prim_int_gt m' n'
if b' then
n8 <- pure (CNil)
pure n8
else
m1' <- _prim_int_add m' 1
n9 <- pure (CInt m1')
m1 <- store n9
n10 <- pure (Fupto m1 n)
p <- store n10
n11 <- pure (CCons.0 p)
pure n11

length l = l2 <- eval l
case l2 of
(CNil) ->
n12 <- pure (CInt 0)
pure n12
(CCons.0 xs) ->
x <- pure (#undefined :: #ptr)
n13 <- length xs
(CInt l') <- pure n13
len <- _prim_int_add l' 1
n14 <- pure (CInt len)
pure n14

eval q = v <- fetch q
case v of
(CInt x'1) -> pure v
(CNil) -> pure v
(CCons.0 ys) -> y <- pure (#undefined :: #ptr)
pure v
(Fupto a b) -> w <- upto a b
update q w
pure w
(Flength c) -> z <- length c
update q z
pure z
Original file line number Diff line number Diff line change
@@ -0,0 +1,50 @@
grinMain = n1 <- pure (CInt 1)
t1 <- store n1
n2 <- pure (CInt 10000)
t2 <- store n2
n3 <- pure (Fupto t1 t2)
t3 <- store n3
n4 <- pure (Flength t3)
t4 <- store n4
n5 <- eval t4
(CInt r') <- pure n5
_prim_int_print r'

upto m n = n6 <- eval m
(CInt m') <- pure n6
n7 <- eval n
(CInt n') <- pure n7
b' <- _prim_int_gt m' n'
if b' then
n8 <- pure (CNil)
pure n8
else
m1' <- _prim_int_add m' 1
n9 <- pure (CInt m1')
m1 <- store n9
n10 <- pure (Fupto m1 n)
p <- store n10
n11 <- pure (CCons m p)
pure n11

length l = l2 <- eval l
case l2 of
(CNil) -> n12 <- pure (CInt 0)
pure n12
(CCons x xs) -> n13 <- length xs
(CInt l') <- pure n13
len <- _prim_int_add l' 1
n14 <- pure (CInt len)
pure n14

eval q = v <- fetch q
case v of
(CInt x'1) -> pure v
(CNil) -> pure v
(CCons y ys) -> pure v
(Fupto a b) -> w <- upto a b
update q w
pure w
(Flength c) -> z <- length c
update q z
pure z
Original file line number Diff line number Diff line change
@@ -0,0 +1,75 @@
grinMain =
a0 <- pure (CInt 5)
a1 <- pure (CInt 5)
a2 <- pure (CInt 5)
p0 <- store a0
p1 <- store a1
p2 <- store a2

foo3 <- pure (P3foo)
pfoo3 <- store foo3

foo3ap <- pure (Fap pfoo3 p0)
pfoo3ap <- store foo3ap
foo2 <- eval pfoo3ap
pfoo2 <- store foo2

foo2ap <- pure (Fap pfoo2 p1)
pfoo2ap <- store foo2ap
foo1 <- eval pfoo2ap
pfoo1 <- store foo1

foo1ap <- pure (Fap pfoo1 p2)
pfoo1ap <- store foo1ap
fooRet <- eval pfoo1ap

pure fooRet


foo x0 y0 z0 =
y0' <- eval y0
pure y0'

-- apply always gets the function node in whnf
apply pf cur =
case pf of
(P3foo) ->
n0 <- pure (P2foo cur)
pure n0
(P2foo v0) ->
n1 <- pure (P1foo v0 cur)
pure n1
(P1foo v1 v2) ->
n2 <- foo v1 v2 cur
pure n2

ap f x =
f' <- eval f
apply f' x

eval p =
v <- fetch p
case v of
(CInt n) -> pure v

(P3foo) -> pure v
(P2foo v3) -> pure v
(P1foo v4 v5) -> pure v

(Ffoo.0) ->
b2 <- pure (#undefined :: T_Dead)
b1 <- pure (#undefined :: T_Dead)
b0 <- pure (#undefined :: T_Dead)
w0 <- foo b0 b1 b2
update p w0
pure w0
(Fapply.0) ->
y <- pure (#undefined :: T_Dead)
g <- pure (#undefined :: T_Dead)
w1 <- apply g y
update p w1
pure w1
(Fap h z) ->
w2 <- ap h z
update p w2
pure w2
Original file line number Diff line number Diff line change
@@ -0,0 +1,84 @@
{-
Heap locations have way too general type sets.
This is due to the fact that apply can produce
many differenct node types.
(All partial applications and return values of all functions).
apply is called by ap, which is called by eval.
This means that all pointers will have this overly general type information.
So for example the second argument of foo could be CInt or any Pfoo node.
As a consequence, since foo's return value is the return value of grinMain,
all partial applications of foo will be completely live (this is not intended).

Eval inlining + apply inlining should solve this issue.
-}

grinMain =
a0 <- pure (CInt 5)
a1 <- pure (CInt 5)
a2 <- pure (CInt 5)
p0 <- store a0
p1 <- store a1
p2 <- store a2

foo3 <- pure (P3foo)
pfoo3 <- store foo3

foo3ap <- pure (Fap pfoo3 p0)
pfoo3ap <- store foo3ap
foo2 <- eval pfoo3ap
pfoo2 <- store foo2

foo2ap <- pure (Fap pfoo2 p1)
pfoo2ap <- store foo2ap
foo1 <- eval pfoo2ap
pfoo1 <- store foo1

foo1ap <- pure (Fap pfoo1 p2)
pfoo1ap <- store foo1ap
fooRet <- eval pfoo1ap

pure fooRet


foo x0 y0 z0 =
y0' <- eval y0
pure y0'

-- apply always gets the function node in whnf
apply pf cur =
case pf of
(P3foo) ->
n0 <- pure (P2foo cur)
pure n0
(P2foo v0) ->
n1 <- pure (P1foo v0 cur)
pure n1
(P1foo v1 v2) ->
n2 <- foo v1 v2 cur
pure n2

ap f x =
f' <- eval f
apply f' x

eval p =
v <- fetch p
case v of
(CInt n) -> pure v

(P3foo) -> pure v
(P2foo v3) -> pure v
(P1foo v4 v5) -> pure v

(Ffoo b0 b1 b2) ->
w0 <- foo b0 b1 b2
update p w0
pure w0
(Fapply g y) ->
w1 <- apply g y
update p w1
pure w1
(Fap h z) ->
w2 <- ap h z
update p w2
pure w2
Loading