grin-compiler/grin
1
1
Fork 0
mirror of https://github.com/grin-compiler/grin.git synced 2024-10-26 08:41:51 +03:00
Code Issues Projects Releases Wiki Activity

split transformation module; introduce SFetchI

Browse Source
This commit is contained in:
Csaba Hruska 2017-09-08 20:14:15 +01:00
parent 43ac66b0d6
commit 804f6758e7
5 changed files with 131 additions and 105 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
app/Main.hs
View File

@ -12,6 +12,7 @@ import Grin
import Pretty
import PrettyHPT
import Transformations
import TrafoPlayground
import AbstractRunGrin
import Data.IntMap as IntMap
@ -34,7 +35,7 @@ main = do
putStrLn $ unlines result
putStrLn . show . ondullblack . pretty . vectorisation $ Program grin
putStrLn . show . ondullgreen . pretty . splitFetch . vectorisation $ Program grin
putStrLn . show . collectTagInfoPure $ Program grin
putStrLn . show . collectTagInfo $ Program grin
putStrLn . show . ondullblue . pretty . pipeline $ Program grin
printGrin $ Program grin

1
grin.cabal
View File

@ -24,6 +24,7 @@ library
ReduceGrin
STReduceGrin
Transformations
TrafoPlayground
AbstractRunGrin
build-depends:

13
src/Grin.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE DeriveGeneric, DeriveAnyClass, DeriveFunctor, TypeFamilies #-}
{-# LANGUAGE DeriveFoldable, DeriveTraversable #-}
{-# LANGUAGE DeriveFoldable, DeriveTraversable, PatternSynonyms #-}
module Grin where
import Data.Functor.Foldable as Foldable
@ -26,7 +26,7 @@ data Exp
| SApp Name [SimpleVal]
| SReturn Val
| SStore Val
| SFetch Name
| SFetchI Name (Maybe Int) -- fetch a full node or a single node item
-- | SFetchItem Name Int
| SUpdate Name Val
| SBlock Exp
@ -34,6 +34,9 @@ data Exp
| Alt CPat Exp
deriving (Generic, NFData, Eq, Show)
pattern SFetch name = SFetchI name Nothing
pattern SFetchF name = SFetchIF name Nothing
type LPat = Val
type SimpleVal = Val
-- TODO: use data types a la carte style to build different versions of Val?
@ -81,7 +84,7 @@ data ExpF a
| SAppF Name [SimpleVal]
| SReturnF Val
| SStoreF Val
| SFetchF Name
| SFetchIF Name (Maybe Int)
| SUpdateF Name Val
| SBlockF a
-- Alt
@ -99,7 +102,7 @@ instance Recursive Exp where
project (SApp name simpleVals) = SAppF name simpleVals
project (SReturn val) = SReturnF val
project (SStore val) = SStoreF val
project (SFetch name) = SFetchF name
project (SFetchI name index) = SFetchIF name index
project (SUpdate name val) = SUpdateF name val
project (SBlock exp) = SBlockF exp
-- Alt
@ -115,7 +118,7 @@ instance Corecursive Exp where
embed (SAppF name simpleVals) = SApp name simpleVals
embed (SReturnF val) = SReturn val
embed (SStoreF val) = SStore val
embed (SFetchF name) = SFetch name
embed (SFetchIF name index) = SFetchI name index
embed (SUpdateF name val) = SUpdate name val
embed (SBlockF exp) = SBlock exp
-- Alt

117
src/TrafoPlayground.hs Normal file
View File

@ -0,0 +1,117 @@
{-# LANGUAGE LambdaCase, TupleSections #-}
module TrafoPlayground where
import Data.Maybe
import Data.List (intercalate)
import Data.Set (Set, singleton, toList)
import qualified Data.Map as Map
import Data.Monoid hiding (Alt)
import Control.Arrow (second)
import Control.Monad
import Control.Monad.Gen
import Control.Monad.Writer hiding (Alt)
import Data.Functor.Foldable as Foldable
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Foldable
import Control.Comonad.Cofree
import Grin
countStores :: Exp -> Int
countStores = cata folder where
folder = \case
SStoreF {} -> 1
e -> Data.Foldable.sum e
collectTagInfo2 :: Exp -> Set Tag
collectTagInfo2 = execWriter . cata folder where
folder = \case
-- Exp
ECaseF val alts -> add val >> sequence_ alts
-- Simple Exp
SReturnF val -> add val
SStoreF val -> add val
SUpdateF _ val -> add val
e -> sequence_ e
add :: Val -> Writer (Set Tag) ()
add = \case
ConstTagNode (Tag tagtype name _) args -> tell $ singleton (Tag tagtype name (length args))
ValTag tag -> tell $ singleton tag
_ -> pure ()
collectTagInfoPure :: Exp -> Set Tag
collectTagInfoPure = cata folder where
folder = \case
ProgramF a -> mconcat a
DefF _ _ a -> a
-- Exp
EBindF a _ b -> a <> b
ECaseF val alts -> mconcat $ add val : alts
-- Simple Exp
SAppF name vals -> mconcat $ map add vals
SReturnF val -> add val
SStoreF val -> add val
SUpdateF _ val -> add val
SFetchF _ -> mempty
SBlockF a -> a
-- Alt
AltF _ a -> a
add = \case
ConstTagNode (Tag tagtype name _) args -> singleton (Tag tagtype name (length args))
ValTag tag -> singleton tag
_ -> mempty
renameVaribales :: Map.Map Name Name -> Exp -> Exp
renameVaribales substituitons = ana builder where
builder :: Exp -> ExpF Exp
builder = \case
Program defs -> ProgramF defs
Def name names exp -> DefF name (substName <$> names) exp
-- Exp
EBind simpleExp lpat exp -> EBindF simpleExp (subst lpat) exp
ECase val alts -> ECaseF (subst val) alts
-- Simple Exp
SApp name simpleVals -> SAppF (substName name) (subst <$> simpleVals)
SReturn val -> SReturnF (subst val)
SStore val -> SStoreF (subst val)
SFetch name -> SFetchF name
SUpdate name val -> SUpdateF name (subst val)
SBlock exp -> SBlockF exp
-- Alt
Alt pat exp -> AltF (substCPat pat) exp
subst :: Val -> Val
subst (Var name) = Var $ substName name
subst (ConstTagNode tag simpleVals) = ConstTagNode (substTag tag) (subst <$> simpleVals)
subst (ValTag tag) = ValTag (substTag tag)
subst other = other
substName :: Name -> Name
substName old = case Map.lookup old substituitons of
Nothing -> old
Just new -> new
substTag :: Tag -> Tag
substTag (Tag ttype name arity) = Tag ttype (substName name) arity
substCPat :: CPat -> CPat
substCPat = \case
NodePat tag names -> NodePat (substTag tag) (substName <$> names)
TagPat tag -> TagPat (substTag tag)
LitPat lit -> LitPat lit
idAna :: Exp -> Exp
idAna e = ana builder ([], e) where
builder :: (String, Exp) -> ExpF (String, Exp)
builder (path, exp) =
case exp of
SStore val -> SStoreF val
e -> ([],) <$> project e

102
src/Transformations.hs
View File

@ -19,12 +19,6 @@ import Control.Comonad.Cofree
import Grin
countStores :: Exp -> Int
countStores = cata folder where
folder = \case
SStoreF {} -> 1
e -> Data.Foldable.sum e
type GenM = Gen Integer
type VectorisationAccumulator = (Map.Map Name Val, Exp)
@ -53,53 +47,8 @@ vectorisation expression = apo folder (Map.empty, expression)
replaceVar var = var
forwardRecursion = fmap (\subExpression -> Right (nameStore, subExpression)) (project expression)
{-
TODO:
write a monoid version instead of writer monad
write ana version of if possible at all
-}
collectTagInfo :: Exp -> Set Tag
collectTagInfo = execWriter . cata folder where
folder = \case
-- Exp
ECaseF val alts -> add val >> sequence_ alts
-- Simple Exp
SReturnF val -> add val
SStoreF val -> add val
SUpdateF _ val -> add val
e -> sequence_ e
add :: Val -> Writer (Set Tag) ()
add = \case
ConstTagNode (Tag tagtype name _) args -> tell $ singleton (Tag tagtype name (length args))
ValTag tag -> tell $ singleton tag
_ -> pure ()
collectTagInfoPure :: Exp -> Set Tag
collectTagInfoPure = cata folder where
folder = \case
ProgramF a -> mconcat a
DefF _ _ a -> a
-- Exp
EBindF a _ b -> a <> b
ECaseF val alts -> mconcat $ add val : alts
-- Simple Exp
SAppF name vals -> mconcat $ map add vals
SReturnF val -> add val
SStoreF val -> add val
SUpdateF _ val -> add val
SFetchF _ -> mempty
SBlockF a -> a
-- Alt
AltF _ a -> a
add = \case
ConstTagNode (Tag tagtype name _) args -> singleton (Tag tagtype name (length args))
ValTag tag -> singleton tag
_ -> mempty
collectTagInfoPure2 :: Exp -> Set Tag
collectTagInfoPure2 = cata folder where
collectTagInfo = cata folder where
folder = \case
-- Exp
ECaseF val alts -> mconcat $ add val : alts
@ -115,7 +64,7 @@ collectTagInfoPure2 = cata folder where
_ -> mempty
generateEval :: Program -> Program
generateEval program@(Program defs) = Program $ defs ++ [evalDef (collectTagInfoPure program)]
generateEval program@(Program defs) = Program $ defs ++ [evalDef (collectTagInfo program)]
generateEval _ = error "generateEval - Program required"
evalDef :: Set Tag -> Def
@ -141,44 +90,6 @@ evalDef tagInfo = Def "generated_eval" ["p"] $
newNames n = ['_' : show i | i <- [1..n]]
renameVaribales :: Map.Map Name Name -> Exp -> Exp
renameVaribales substituitons = ana builder where
builder :: Exp -> ExpF Exp
builder = \case
Program defs -> ProgramF defs
Def name names exp -> DefF name (substName <$> names) exp
-- Exp
EBind simpleExp lpat exp -> EBindF simpleExp (subst lpat) exp
ECase val alts -> ECaseF (subst val) alts
-- Simple Exp
SApp name simpleVals -> SAppF (substName name) (subst <$> simpleVals)
SReturn val -> SReturnF (subst val)
SStore val -> SStoreF (subst val)
SFetch name -> SFetchF name
SUpdate name val -> SUpdateF name (subst val)
SBlock exp -> SBlockF exp
-- Alt
Alt pat exp -> AltF (substCPat pat) exp
subst :: Val -> Val
subst (Var name) = Var $ substName name
subst (ConstTagNode tag simpleVals) = ConstTagNode (substTag tag) (subst <$> simpleVals)
subst (ValTag tag) = ValTag (substTag tag)
subst other = other
substName :: Name -> Name
substName old = case Map.lookup old substituitons of
Nothing -> old
Just new -> new
substTag :: Tag -> Tag
substTag (Tag ttype name arity) = Tag ttype (substName name) arity
substCPat :: CPat -> CPat
substCPat = \case
NodePat tag names -> NodePat (substTag tag) (substName <$> names)
TagPat tag -> TagPat (substTag tag)
LitPat lit -> LitPat lit
splitFetch :: Exp -> Exp
splitFetch = cata folder where
@ -190,7 +101,7 @@ splitFetch = cata folder where
newBinds name [] = SReturn Unit
newBinds name ((i, var) : vars) = EBind (fetchItem name i) var $ newBinds name vars
fetchItem name i = SFetch name -- TODO: use FetchItem
fetchItem name i = SFetchI name (Just i)
newVarName :: Exp -> Maybe [String]
@ -270,13 +181,6 @@ registerIntroduction e = ana builder ([], e) where
(\(Just t) vs -> context $ VarTagNode t (tail vs))
((ValTag tag):vals)
idAna :: Exp -> Exp
idAna e = ana builder ([], e) where
builder :: (VariablePath, Exp) -> ExpF (VariablePath, Exp)
builder (path, exp) =
case exp of
SStore val -> SStoreF val
e -> ([],) <$> project e
-- Work In Progress
{-