Extending the syntax of GRIN

grin/grin.cabal

@@ -66,6 +66,18 @@ library
     Grin.PrimOpsPrelude
     Grin.Nametable
     Grin.Research
+    Grin.ExtendedSyntax.Syntax
+    Grin.ExtendedSyntax.SyntaxDefs
+    Grin.ExtendedSyntax.Grin
+    Grin.ExtendedSyntax.EffectMap
+    Grin.ExtendedSyntax.Parse
+    Grin.ExtendedSyntax.Parse.AST
+    Grin.ExtendedSyntax.Parse.Basic
+    Grin.ExtendedSyntax.Parse.TypeEnv
+    Grin.ExtendedSyntax.Pretty
+    Grin.ExtendedSyntax.TH
+    Grin.ExtendedSyntax.TypeEnv
+    Grin.ExtendedSyntax.TypeEnvDefs
     Pipeline.Eval
     Pipeline.Optimizations
     Pipeline.Pipeline
@@ -85,6 +97,9 @@ library
     Test.IO
     Test.Test
     Test.Util
+    Test.ExtendedSyntax.Assertions
+    Test.ExtendedSyntax.Old.Grammar
+    Test.ExtendedSyntax.Old.Test
     Transformations.BindNormalisation
     Transformations.CountVariableUse
     Transformations.EffectMap
@@ -94,6 +109,7 @@ library
     Transformations.StaticSingleAssignment
     Transformations.UnitPropagation
     Transformations.Util
+    Transformations.ExtendedSyntax.Conversion
     Transformations.Optimising.ArityRaising
     Transformations.Optimising.CaseCopyPropagation
     Transformations.Optimising.CaseHoisting
@@ -225,6 +241,8 @@ test-suite grin-test
                      , inline-c
 
   other-modules:
+                     ExtendedSyntax.ParserSpec
+                     Transformations.ExtendedSyntax.ConversionSpec
                      Transformations.Simplifying.RegisterIntroductionSpec
                      Transformations.Simplifying.CaseSimplificationSpec
                      Transformations.Simplifying.SplitFetchSpec

grin/src/Grin/ExtendedSyntax/EffectMap.hs

@@ -0,0 +1,83 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell #-}
+module Grin.ExtendedSyntax.EffectMap
+  ( EffectMap(..)
+  , Effects(..)
+  , hasPossibleSideEffect
+  , storesEff
+  , primopEff
+  , updatesEff
+  , hasTrueSideEffect
+  ) where
+
+import Data.Map (Map)
+import Data.Set (Set)
+import Data.Monoid
+
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
+import Lens.Micro.Platform
+
+import Grin.ExtendedSyntax.Grin
+
+-- | Contains the name of all the effectful primops used by the function,
+-- and a list of heap locations updated by it.
+data Effects
+  = Effects
+  { _effectfulPrimops :: Set Name
+  , _updateLocs       :: Set Int
+  , _storeLocs        :: Set Int
+  }
+  deriving (Eq, Ord, Show)
+
+instance Semigroup Effects where
+  (<>) (Effects primops1 updateLocs1 storeLocs1) (Effects primops2 updateLocs2 storeLocs2)
+    = Effects (primops1 <> primops2) (updateLocs1 <> updateLocs2) (storeLocs1 <> storeLocs2)
+
+instance Monoid Effects where
+  mempty = Effects mempty mempty mempty
+
+
+
+-- | Mapping of function names to their respective side effects.
+newtype EffectMap = EffectMap { _effects :: Map Name Effects }
+  deriving (Eq, Ord, Show, Semigroup, Monoid)
+
+concat <$> mapM makeLenses [''Effects, '' EffectMap]
+
+
+primopEff :: Name -> Effects
+primopEff f = Effects (Set.singleton f) mempty mempty
+
+updatesEff :: [Int] -> Effects
+updatesEff locs = Effects mempty (Set.fromList locs) mempty
+
+storesEff :: [Int] -> Effects
+storesEff locs = Effects mempty mempty (Set.fromList locs)
+
+
+hasSomeEffect :: (Effects -> Set a) -> Name -> EffectMap -> Bool
+hasSomeEffect selectEff f (EffectMap effMap)
+  | Just effects <- Map.lookup f effMap
+  = not . null . selectEff $ effects
+  | otherwise = False
+
+hasSideEffectingPrimop :: Name -> EffectMap -> Bool
+hasSideEffectingPrimop = hasSomeEffect _effectfulPrimops
+
+hasUpdates :: Name -> EffectMap -> Bool
+hasUpdates = hasSomeEffect _updateLocs
+
+hasStores :: Name -> EffectMap -> Bool
+hasStores = hasSomeEffect _storeLocs
+
+-- | Checks whether a function has a true side effect
+-- , meaning it calls a side-effecting primop.
+hasTrueSideEffect :: Name -> EffectMap -> Bool
+hasTrueSideEffect = hasSideEffectingPrimop
+
+-- | Checks whether a function has a possible side effect
+-- , meaning it either has a true side effect
+-- , or it updates a location, which can cause a side effect.
+hasPossibleSideEffect :: Name -> EffectMap -> Bool
+hasPossibleSideEffect f effMap = hasTrueSideEffect f effMap || hasUpdates f effMap

grin/src/Grin/ExtendedSyntax/Grin.hs

@@ -0,0 +1,109 @@
+{-# LANGUAGE FlexibleInstances, DeriveFunctor, RankNTypes, LambdaCase #-}
+module Grin.ExtendedSyntax.Grin
+  ( module Grin.ExtendedSyntax.Grin
+  , module Grin.ExtendedSyntax.Syntax
+  ) where
+
+import Data.Functor.Foldable as Foldable
+import Debug.Trace (trace)
+import Lens.Micro.Platform
+import Data.Maybe
+import Data.Text (pack, unpack)
+import Data.List (nub)
+
+import Grin.ExtendedSyntax.Syntax
+import Grin.ExtendedSyntax.TypeEnvDefs
+
+class FoldNames n where
+  foldNames :: (Monoid m) => (Name -> m) -> n -> m
+
+instance FoldNames Val where
+  foldNames f = \case
+    ConstTagNode  _tag vals -> foldMap f vals
+    Var name                -> f name
+    _                       -> mempty
+
+instance FoldNames BPat where
+  foldNames f = \case
+    VarPat v    -> f v
+    AsPat v val -> f v <> foldNames f val
+
+
+instance FoldNames CPat where
+  foldNames f = \case
+    NodePat _ names -> foldMap f names
+    LitPat _        -> mempty
+    DefaultPat      -> mempty
+
+instance FoldNames n => FoldNames [n] where
+  foldNames f = foldMap (foldNames f)
+
+dCoAlg :: (a -> String) -> (a -> ExpF b) -> (a -> ExpF b)
+dCoAlg dbg f = f . (\x -> trace (dbg x) x)
+
+dAlg :: (b -> String) -> (ExpF a -> b) -> (ExpF a -> b)
+dAlg dbg f = (\x -> trace (dbg x) x) . f
+
+match :: Traversal' a b -> a -> Bool
+match t x = isJust $ x ^? t
+
+isLit :: Val -> Bool
+isLit = match _Lit
+
+_Lit :: Traversal' Val Lit
+_Lit f (Lit l) = Lit <$> f l
+_Lit _ rest    = pure rest
+
+_Var :: Traversal' Val Name
+_Var f (Var name) = Var <$> f name
+_Var _ rest       = pure rest
+
+_CNode :: Traversal' Val (Tag, [Name])
+_CNode f (ConstTagNode tag params) = uncurry ConstTagNode <$> f (tag, params)
+_CNode _ rest = pure rest
+
+isBasicCPat :: CPat -> Bool
+isBasicCPat = \case
+  LitPat _ -> True
+  _        -> False
+
+isBasicValue :: Val -> Bool
+isBasicValue Unit{}   = True
+isBasicValue Lit{}    = True
+isBasicValue _'       = True
+
+isPrimitiveExp :: Exp -> Bool
+isPrimitiveExp = \case
+  SApp    _ _ -> True
+  SReturn _   -> True
+  SStore  _   -> True
+  SFetch  _   -> True
+  SUpdate _ _ -> True
+  _           -> False
+
+isSimpleExp :: Exp -> Bool
+isSimpleExp e | isPrimitiveExp e = True
+isSimpleExp e = case e of
+  SBlock  _   -> True
+  _           -> False
+
+unpackName :: Name -> String
+unpackName (NM name) = unpack name
+
+packName :: String -> Name
+packName = NM . pack
+
+showTS :: Show a => a -> Name
+showTS = packName . show
+
+concatPrograms :: [Program] -> Program
+concatPrograms prgs = Program (nub $ concat exts) (concat defs) where
+  (exts, defs) = unzip [(e, d) | Program e d <- prgs]
+
+-- NOTE: @ is no longer an allowed special (due to as-patterns)
+-- indetifier rules for parser and pretty printer
+allowedSpecial :: String
+allowedSpecial = "._':!-"
+
+allowedInitial :: String
+allowedInitial = "._" ++ ['a'..'z'] ++ ['A'..'Z']

grin/src/Grin/ExtendedSyntax/Parse.hs

@@ -0,0 +1,18 @@
+module Grin.ExtendedSyntax.Parse
+  ( module Grin.ExtendedSyntax.Parse.AST
+  , module Grin.ExtendedSyntax.Parse.TypeEnv
+  , module Grin.ExtendedSyntax.Parse
+  ) where
+
+import Data.Void
+import Data.Text
+import Text.Megaparsec
+
+import Grin.ExtendedSyntax.Grin
+import Grin.ExtendedSyntax.TypeEnvDefs
+
+import Grin.ExtendedSyntax.Parse.AST
+import Grin.ExtendedSyntax.Parse.TypeEnv
+
+parseGrinWithTypes :: String -> Text -> Either (ParseError Char Void) (TypeEnv, Exp)
+parseGrinWithTypes filename content = (,) <$> parseMarkedTypeEnv filename content <*> parseGrin filename content