mirror of
https://github.com/grin-compiler/grin.git
synced 2024-10-26 08:41:51 +03:00
split transformation module; introduce SFetchI
This commit is contained in:
parent
43ac66b0d6
commit
804f6758e7
@ -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
|
||||
|
||||
|
@ -24,6 +24,7 @@ library
|
||||
ReduceGrin
|
||||
STReduceGrin
|
||||
Transformations
|
||||
TrafoPlayground
|
||||
AbstractRunGrin
|
||||
|
||||
build-depends:
|
||||
|
13
src/Grin.hs
13
src/Grin.hs
@ -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
117
src/TrafoPlayground.hs
Normal 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
|
@ -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
|
||||
{-
|
||||
|
Loading…
Reference in New Issue
Block a user