diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,7 @@ +# Revision history for language-lustre + +## next -- TBA + +## 1.0.0 -- 2026-07-06 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,13 @@ +Copyright (c) 2018 Iavor Diatchki + +Permission to use, copy, modify, and/or distribute this software for any purpose +with or without fee is hereby granted, provided that the above copyright notice +and this permission notice appear in all copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH +REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, +INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS +OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER +TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF +THIS SOFTWARE. diff --git a/Language/Lustre/AST.hs b/Language/Lustre/AST.hs new file mode 100644 --- /dev/null +++ b/Language/Lustre/AST.hs @@ -0,0 +1,656 @@ +-- | Reference: +-- http://www-verimag.imag.fr/DIST-TOOLS/SYNCHRONE/lustre-v6/doc/lv6-ref-man.pdf +module Language.Lustre.AST + ( Program(..) + + -- * Packages + + {- | We don't support packages beyond parsing them. -} + + , PackDecl(..) + , Package(..) + , PackageProvides(..) + + + -- * Top-Level Declarations + , TopDecl(..) + + -- ** Types + , TypeDecl(..) + , TypeDef(..) + , Type(..) + , FieldType(..) + , CType(..) + , IClock(..) + , CVar(..) + + -- ** Constants + , ConstDef(..) + + -- ** Nodes + , NodeDecl(..) + , NodeInstDecl(..) + , NodeProfile(..) + , Safety(..) + , NodeType(..) + + , InputBinder(..) + , Binder(..) + + , NodeBody(..) + , LocalDecl(..) + , Equation(..) + , AssertType(..) + , LHS(..) + , Selector(..) + , ArraySlice(..) + + , Expression(..) + , MergeCase(..) + , ClockExpr(..) + , NodeInst(..) + + + + -- ** Contracts + -- {- | Support for contracts is incomplete. -} + , Contract(..) + , ContractItem(..) + , ContractDecl(..) + + + + , eOp1 + , eOp2 + , eITE + , eOpN + + , Callable(..) + , PrimNode(..) + , Iter(..) + + , StaticParam(..) + , StaticArg(..) + + , Literal(..) + + , Field(..) + + + , Op1(..) + , Op2(..) + , OpN(..) + + , exprRangeMaybe + , typeRangeMaybe + , argRangeMaybe + , eqnRangeMaybe + + , HasRange(..) + , SourceRange(..) + , SourcePos(..) + ) where + +import Data.Maybe(fromMaybe) + +import AlexTools(SourceRange(..), SourcePos(..), HasRange(..), (<->)) + +import Language.Lustre.Panic +import Language.Lustre.Name + +-- | A Lustre program. Currently we don't support packages beyond parsing. +data Program = ProgramDecls [TopDecl] -- ^ Some declarations + | ProgramPacks [PackDecl] -- ^ Some packages + deriving Show + +-- | A package declaration. We can parse these, but not do anything with +-- them yet. +data PackDecl = PackDecl Package + | PackInst Ident Ident [ (Ident, StaticArg) ] + deriving Show + +-- | This is used for both packages and models. +data Package = Package + { packageName :: !Ident + , packageUses :: ![Ident] + , packageParams :: ![StaticParam] -- ^ Empty list for pacakges + , packageProvides :: ![PackageProvides] + , packageBody :: ![TopDecl] + , packageRange :: !SourceRange + } deriving Show + +data PackageProvides = + ProvidesConst !Ident !Type !(Maybe Expression) + | ProvidesNode !NodeDecl + | ProvidesType !TypeDecl + deriving Show + + +data TopDecl = + DeclareType !TypeDecl + | DeclareConst !ConstDef + | DeclareNode !NodeDecl + | DeclareNodeInst !NodeInstDecl + | DeclareContract !ContractDecl + deriving Show + +-- | Declare a named type. +data TypeDecl = TypeDecl + { typeName :: !Ident + , typeDef :: !(Maybe TypeDef) + -- ^ Types with no definitions are abstract. + -- We do not have good support for abstract types at the moment. + } deriving Show + + + +-- | A definition for a named type. +data TypeDef = IsType !Type -- ^ A type alias. + | IsEnum ![ Ident ] -- ^ An enumeration type. + | IsStruct ![ FieldType ] -- ^ A record type. + deriving Show + +-- | The type of value or a constant. +data Type = + NamedType Name -- ^ A named type. See 'TypeDef'. + | ArrayType Type Expression + -- ^ An array type. The 'Expression' is for the size of the array. + + | IntType -- ^ Type of integers. + | RealType -- ^ Type of real numbers. + | BoolType -- ^ Type of boolean values. + + | IntSubrange Expression Expression + -- ^ An interval subset of the integers. The 'Expression's are bounds. + -- Their values are included in the interval. + + | TypeRange SourceRange Type + -- ^ A type annotated with a source location. + + deriving Show + + +-- | The type of the field of a structure. +data FieldType = FieldType + { fieldName :: Label -- ^ The name of the field. + , fieldType :: Type -- ^ The field's type. + , fieldDefault :: Maybe Expression + -- ^ Optional default constant value, used if the field is omitted. + } deriving Show + + +-- | Note: only one of the type or definition may be "Nothing". +data ConstDef = ConstDef + { constName :: Ident + , constType :: Maybe Type -- ^ Optional type annotation. + , constDef :: Maybe Expression + {- ^ Optional definition. If the definition is omitted, then the constant + is abstract. In that case, the type cannot be omitted. + + Note that at the moment we don't have good support for abstract + constants. -} + } deriving Show + + +data Contract = Contract + { contractRange :: SourceRange + , contractItems :: [ContractItem] + } deriving Show + +data ContractItem = GhostConst ConstDef + | GhostVar Binder Expression + | Assume Label Expression + | Guarantee Label Expression + | Mode Ident [Expression] [Expression] + | Import Ident [Expression] [Expression] + deriving Show + +data ContractDecl = ContractDecl + { cdName :: Ident + , cdProfile :: NodeProfile + , cdItems :: [ContractItem] + , cdRange :: SourceRange + } deriving Show + + +-- | The declaration of a node. +data NodeDecl = NodeDecl + { nodeSafety :: Safety + , nodeExtern :: Bool + , nodeType :: NodeType + , nodeName :: Ident + , nodeStaticInputs :: [StaticParam] + , nodeProfile :: NodeProfile + , nodeContract :: Maybe Contract + , nodeDef :: Maybe NodeBody + -- Must be "Nothing" if "nodeExtern" is set to "True" + , nodeRange :: !SourceRange + } deriving Show + +-- | A named instantiation of a node with static parameters. +data NodeInstDecl = NodeInstDecl + { nodeInstSafety :: Safety + , nodeInstType :: NodeType + , nodeInstName :: Ident + , nodeInstStaticInputs :: [StaticParam] + , nodeInstProfile :: Maybe NodeProfile + , nodeInstDef :: NodeInst + } deriving Show + + +data NodeProfile = NodeProfile + { nodeInputs :: [InputBinder] + , nodeOutputs :: [Binder] + } deriving Show + + +data Safety = Safe -- ^ No side effects + | Unsafe -- ^ May have side effects + deriving (Show,Eq) + +data NodeType = Node -- ^ Nodes may have memory (e.g., use @pre@) + | Function -- ^ Functions do not have memory + deriving (Show, Eq) + +{- | These are used to support the notation where constant parameters +are intermixed with normal parameters, rather then bing factored +out before. -} +data InputBinder = InputBinder Binder + | InputConst Ident Type + deriving Show + +-- | Introduces a local variable (not constant). +data Binder = Binder + { binderDefines :: Ident + , binderType :: CType + } deriving Show + + +data NodeBody = NodeBody + { nodeLocals :: [LocalDecl] + , nodeEqns :: [Equation] + } deriving Show + +data LocalDecl = LocalVar Binder + | LocalConst ConstDef + deriving Show + +data Equation = Assert Label AssertType Expression -- ^ Assuming this + | Property Label Expression -- ^ Prove this + | IsMain SourceRange -- ^ This is the main node, + -- use it if nothing specified + | IVC [Ident] + | Realizable [Ident] + | Define [LHS Expression] Expression + deriving Show + +data AssertType = AssertPre -- failure of this assertion indicates an + -- error in the system. + + | AssertEnv -- failure of this assertion idicates an + -- unreachable system state. + deriving Show + +data LHS e = LVar Ident + | LSelect (LHS e) (Selector e) + deriving (Show,Eq,Ord) + +data Selector e = SelectField Label + | SelectElement e + | SelectSlice (ArraySlice e) + deriving (Show, Eq, Ord) + +data ArraySlice e = ArraySlice + { arrayStart :: e + , arrayEnd :: e + , arrayStep :: Maybe e + } deriving (Show, Eq, Ord) + + +data Expression = ERange !SourceRange !Expression + | Var !Name + | Lit !Literal + + | Const Expression CType + {- ^ A use of a constant expression. These are introduced + by the type checker---the parser does not generate them.-} + + | Expression `When` ClockExpr + + | Tuple ![Expression] + -- ^ These are more like unboxed tuples in Haskell + + + | Array ![Expression] + | Select Expression (Selector Expression) + | Struct Name [Field Expression] + -- ^ Create a new struct value. 'Name' is the struct type + + | UpdateStruct (Maybe Name) Expression [Field Expression] + {- ^ Update a struct. + The 'Name' is the struct type. + The expression is the struct being updated. -} + + | WithThenElse Expression Expression Expression + {- ^ Used for recursive definitions. + The decision is evaluated in an earlier phase (i.e., + it is static), and then we get either the one stream or + the other (i.e., it is not done point-wise as + for if-then-else) -} + + | Merge Ident [MergeCase Expression] + {- ^ Merge different clocked values. The branches are + clocked on different values for the ident. -} + + | Call NodeInst [Expression] IClock (Maybe [CType]) + {- ^ Call a function. + The clock expression allows for the node to be + called only when the clock is active. This also + includes the return types when they are known; + prior to type checking, this will be Nothing. Once + type checking has been performed, this will be the + types of this call's results. + -} + deriving Show + +-- | The first expression (the "pattern") should be a constant. +-- In fact, to check clocks, it is restricted to @true@, @false@, or a @Name@. +data MergeCase e = MergeCase Expression e + deriving Show + +-- | The clock activates when the identifier has the given expression. +-- In the surface syntax, the expression is restricted to +-- @true@, @false@, or a @Name@ (e.g., for to use an enum). +-- However, allowing arbitrary expressions is more convenient for manipulating +-- already validated syntax (e.g., we can allow arbitrary values). +data ClockExpr = WhenClock SourceRange Expression Ident + deriving Show + + +data NodeInst = NodeInst Callable [StaticArg] + deriving Show + +eOp1 :: SourceRange -> Op1 -> Expression -> Maybe [CType] -> Expression +eOp1 r op e tys = Call (NodeInst (CallPrim r (Op1 op)) []) [e] BaseClock tys + +eOp2 :: SourceRange -> Op2 -> Expression -> Expression -> Maybe [CType] -> Expression +eOp2 r op e1 e2 tys = Call (NodeInst (CallPrim r (Op2 op)) []) [e1,e2] BaseClock tys + +eITE :: SourceRange -> Expression -> Expression -> Expression -> Maybe [CType] -> Expression +eITE r e1 e2 e3 tys = Call (NodeInst (CallPrim r ITE) []) [e1,e2,e3] BaseClock tys + +eOpN :: SourceRange -> OpN -> [Expression] -> Maybe [CType] -> Expression +eOpN r op es tys = Call (NodeInst (CallPrim r (OpN op)) []) es BaseClock tys + +-- | Things that may be called +data Callable = CallUser Name -- ^ A user-defined node + | CallPrim SourceRange PrimNode -- ^ A built-in node + deriving Show + +data PrimNode = Iter Iter + | Op1 Op1 + | Op2 Op2 + | OpN OpN + | ITE -- (bool,a,a) -> a -- (bool,a,a) -> a + deriving Show + +-- | Built-in array iterators +data Iter = IterFill -- ^ Like @unfold@, but returns state; + -- can generate multiple arrays at once + + | IterRed -- ^ Like @fold@, but can fold multiple + -- arrays at once + + | IterFillRed -- ^ @fill@ and @red@ at the same time: + -- the folding accumulator is the unfolding + -- state + + | IterMap -- ^ Like @fillred@ but with no accumulator + + | IterBoolRed -- ^ Check if number of @True@s is within + -- some bound + deriving Show + +data StaticParam = TypeParam Ident + | ConstParam Ident Type + | NodeParam Safety NodeType Ident NodeProfile + deriving Show + +data StaticArg = TypeArg Type + | ExprArg Expression + | NodeArg NodeType NodeInst + | ArgRange SourceRange StaticArg + deriving Show + + +data Literal = Int Integer | Real Rational | Bool Bool + deriving (Show,Eq) + +data Field e = Field { fName :: Label, fValue :: e } + deriving Show + +instance Functor Field where + fmap f (Field l e) = Field l (f e) + +instance Foldable Field where + foldMap f (Field _ e) = f e + +instance Traversable Field where + traverse f (Field l e) = Field l <$> f e + + +data Op1 = Not -- bool -> bool + | Neg -- Num a => a -> a + | Pre -- a -> a + | Current -- a -> a + | IntCast -- real -> int + | FloorCast -- real -> int + | RealCast -- int -> real + deriving (Show, Eq, Ord) + +data Op2 = FbyArr -- a -> a -> a + | Fby -- a -> a -> a + | CurrentWith -- like `current` but with a default value to use + -- at the start instead of nil + | And -- bool -> bool -> boo + | Or -- bool -> bool -> boo + | Xor -- bool -> bool -> boo + | Implies -- bool -> bool -> boo + | Eq -- a -> a -> bool + | Neq -- a -> a -> bool + | Lt -- Num a => a -> a -> bool + | Leq -- Num a => a -> a -> bool + | Gt -- Num a => a -> a -> bool + | Geq -- Num a => a -> a -> bool + | Mul | Mod | Div | Add | Sub | Power -- Num a => a -> a -> a + | Replicate -- a -> (n:Int) -> a^n + -- XXX: the `n` is a constante so perhaps we should + -- represent it as a static parametere. + + + | Concat -- a^M -> a^N -> a^(M+N) + deriving (Show, Eq, Ord) + +data OpN = AtMostOne | Nor + deriving (Show, Eq, Ord) + + +-------------------------------------------------------------------------------- +-- Type checking + +-- | The type of a non-constant expression. We keep track of the clock, +-- and when the value may be updated. +data CType = CType { cType :: Type, cClock :: IClock } + deriving Show + +-- | A clock for a value. +data IClock = + BaseClock + {- ^ At the root node, this is the system's base clock. + For other nodes, this refers to the clock of of the + current node invocation. See the 'Call' expression. -} + + | KnownClock ClockExpr + -- ^ A specific clock expression. + + | ClockVar CVar + -- ^ A placeholder for a clock that is being inferred. + -- Used only during type-checking + deriving Show + +-- | A clock variable, used during type checking to infer the clock of +-- some expressions. +newtype CVar = CVar Int deriving (Eq,Ord,Show) + + + +-------------------------------------------------------------------------------- + +instance HasRange e => HasRange (Field e) where + range (Field x y) = x <-> y + +instance HasRange ClockExpr where + range (WhenClock r _ _) = r + +-- | Get the source range associated with an expression, if any. +exprRangeMaybe :: Expression -> Maybe SourceRange +exprRangeMaybe expr = + case expr of + ERange r _ -> Just r + Var x -> Just (range x) + e `When` c -> Just (e <-> c) + + Const e _ -> exprRangeMaybe e + + Lit {} -> Nothing + Tuple {} -> Nothing + Array {} -> Nothing + Select {} -> Nothing + WithThenElse {} -> Nothing + Merge {} -> Nothing + Call {} -> Nothing + Struct {} -> Nothing + UpdateStruct {} -> Nothing + + +-- | Get the source range associated with a type, if any. +typeRangeMaybe :: Type -> Maybe SourceRange +typeRangeMaybe ty = + case ty of + TypeRange r _ -> Just r + NamedType n -> Just (range n) + ArrayType {} -> Nothing + IntType {} -> Nothing + RealType {} -> Nothing + BoolType {} -> Nothing + IntSubrange {} -> Nothing + + +-- | Get the source range of a static argument, if any. +argRangeMaybe :: StaticArg -> Maybe SourceRange +argRangeMaybe arg = + case arg of + ArgRange r _ -> Just r + TypeArg t -> typeRangeMaybe t + ExprArg e -> exprRangeMaybe e + NodeArg {} -> Nothing + + +-- | Get the source range of an equation, if any. +eqnRangeMaybe :: Equation -> Maybe SourceRange +eqnRangeMaybe eqn = + case eqn of + Assert _ _ e -> exprRangeMaybe e + Property _ e -> exprRangeMaybe e + IsMain r -> Just r + IVC is -> + case is of + [] -> Nothing + _ -> Just (range (head is) <-> range (last is)) + Realizable is -> + case is of + [] -> Nothing + _ -> Just (range (head is) <-> range (last is)) + + + + Define ls e -> + case ls of + [] -> exprRangeMaybe e + l:_ -> Just $ case exprRangeMaybe e of + Nothing -> range l + Just r -> range l <-> r + +-- | Note that this is a partial function: it will panic if the +-- expression does not have an exact location. +instance HasRange Type where + range ty = case typeRangeMaybe ty of + Just r -> r + Nothing -> panic "range@Type" [ "Type has no location" + , show ty ] + +-- | Note that this is a partial function: it will panic if the +-- expression does not have an exact location. +instance HasRange Expression where + range expr = + case exprRangeMaybe expr of + Just r -> r + Nothing -> panic "range@Expression" [ "Expression has no location" + , show expr ] + +-- | Note that this is a partial function: it will panic if the +-- expression does not have an exact location. +instance HasRange StaticArg where + range arg = + case argRangeMaybe arg of + Just r -> r + Nothing -> panic "range@StaticArg" [ "Static argument has no location" + , show arg ] + +instance HasRange NodeInst where + range (NodeInst x _) = range x -- or args? + +instance HasRange Callable where + range c = + case c of + CallUser n -> range n + CallPrim r _ -> r + +instance HasRange Package where + range = packageRange + +instance HasRange e => HasRange (LHS e) where + range lhs = + case lhs of + LVar i -> range i + LSelect x y -> range x <-> range y + + +instance HasRange e => HasRange (Selector e) where + range s = + case s of + SelectField f -> range f + SelectElement e -> range e + SelectSlice a -> range a + +instance HasRange e => HasRange (ArraySlice e) where + range a = + range (arrayStart a) <-> range (fromMaybe (arrayEnd a) (arrayStep a)) + +instance HasRange StaticParam where + range param = + case param of + TypeParam i -> range i + ConstParam i t -> range i <-> range t + NodeParam _ _ i _ -> range i + +instance HasRange NodeDecl where + range = nodeRange + +instance HasRange Contract where + range = contractRange + +instance HasRange ContractDecl where + range = cdRange + + diff --git a/Language/Lustre/Core.hs b/Language/Lustre/Core.hs new file mode 100644 --- /dev/null +++ b/Language/Lustre/Core.hs @@ -0,0 +1,349 @@ +{-# Language OverloadedStrings #-} +module Language.Lustre.Core + (module Language.Lustre.Core, Literal(..)) where + +import Data.Text(Text) +import Data.Map(Map) +import qualified Data.Map as Map +import Data.Set(Set) +import qualified Data.Set as Set +import Data.Graph(SCC(..)) +import Data.Graph.SCC(stronglyConnComp) +import Text.PrettyPrint( Doc, text, (<+>), vcat + , hsep, nest, parens, punctuate, comma, ($$) ) +import qualified Text.PrettyPrint as PP + +import Language.Lustre.AST (Literal(..)) +import Language.Lustre.Name +import Language.Lustre.Pretty +import Language.Lustre.Panic(panic) + + +newtype CoreName = CoreName OrigName + deriving (Show,Eq,Ord) + +data Type = TInt | TReal | TBool + deriving Show + +-- | A boolean clock. The base clock is always @true@. +data Clock = BaseClock | WhenTrue Atom + deriving Show + +-- | Type on a boolean clock. +data CType = Type `On` Clock + deriving Show + +typeOfCType :: CType -> Type +typeOfCType (t `On` _) = t + +clockOfCType :: CType -> Clock +clockOfCType (_ `On` c) = c + +data Binder = CoreName ::: CType + deriving Show + +data Atom = Lit Literal CType + | Var CoreName + | Prim Op [Atom] [CType] + deriving Show + +data Expr = Atom Atom + | (Atom, CType) :-> Atom + | Pre Atom + | Atom `When` Atom + | Current Atom + | Merge (CoreName, CType) [(Literal, Atom)] + deriving Show + +data Op = Not | Neg + | IntCast | RealCast | FloorCast + | And | Or | Xor | Implies + | Eq | Neq | Lt | Leq | Gt | Geq + | Mul | Mod | Div | Add | Sub | Power + | ITE + | AtMostOne | Nor + deriving Show + +data Eqn = Binder := Expr + deriving Show + +infix 1 := +infix 2 ::: +infix 3 `On` + +data Node = Node { nName :: Ident + -- ^ Node name + , nInputs :: [Binder] + , nOutputs :: [Binder] + , nAbstract :: [Binder] + -- ^ Locals with no definitions + + , nAssuming :: [(Label,CoreName)] + -- ^ Assuming that these are true + + , nShows :: [(Label,CoreName)] + -- ^ Need to show that these are also true + + , nEqns :: [EqnGroup] + -- ^ Groups of recursive equations. + } deriving Show + +-- | One or more equations. +data EqnGroup = NonRec Eqn -- ^ A non-recursive equation + | Rec [Eqn] -- ^ A group of recursive equations. + deriving Show + +grpEqns :: EqnGroup -> [Eqn] +grpEqns g = + case g of + NonRec e -> [e] + Rec es -> es + + +-------------------------------------------------------------------------------- +-- Ordering equations + +usesAtom :: Atom -> Set CoreName +usesAtom atom = + case atom of + Lit _ _ -> Set.empty + Var x -> Set.singleton x + Prim _ as _ -> Set.unions (map usesAtom as) + +usesExpr :: Expr -> Set CoreName +usesExpr expr = + case expr of + Atom a -> usesAtom a + (a1, _) :-> a2 -> Set.union (usesAtom a1) (usesAtom a2) + Pre _ -> Set.empty -- refer to values at previous instance + a1 `When` a2 -> Set.union (usesAtom a1) (usesAtom a2) + Current a -> usesAtom a + Merge (i, _) bs -> Set.unions $ (usesAtom $ Var i) : ((usesAtom . snd) <$> bs) + +usesClock :: Clock -> Set CoreName +usesClock c = + case c of + BaseClock -> Set.empty + WhenTrue a -> usesAtom a + +-- | Order the equations. Returns cycles on the left, if there are some. +orderedEqns :: [Eqn] -> [EqnGroup] +orderedEqns eqns = map cvt (stronglyConnComp graph) + where + graph = [ (eqn, x, Set.toList (Set.union (usesClock c) (usesExpr e))) + | eqn <- eqns, let (x ::: _ `On` c) := e = eqn ] + cvt x = case x of + AcyclicSCC e -> NonRec e + CyclicSCC es -> Rec es + +coreNameTextName :: CoreName -> Text +coreNameTextName (CoreName x) = origNameTextName x + +coreNameUID :: CoreName -> Int +coreNameUID (CoreName x) = rnUID x + +coreNameFromOrig :: OrigName -> CoreName +coreNameFromOrig = CoreName + +-------------------------------------------------------------------------------- +-- Pretty Printing + + +-- | Local identifier numbering. See `identVariants`. +type PPInfo = Map CoreName Int + +noInfo :: PPInfo +noInfo = Map.empty + +ppPrim :: Op -> Doc +ppPrim = text . show + +ppIdent :: PPInfo -> CoreName -> Doc +ppIdent info i = + case Map.lookup i info of + Nothing -> pp (coreNameTextName i) PP.<> "$u" PP.<> PP.int (coreNameUID i) + Just 0 -> pp i + Just n -> pp i PP.<> "$" PP.<> PP.int n + +ppType :: Type -> Doc +ppType ty = + case ty of + TInt -> text "int" + TReal -> text "real" + TBool -> text "bool" + +ppCType :: PPInfo -> CType -> Doc +ppCType env (t `On` c) = + case c of + BaseClock -> ppType t + WhenTrue a -> ppType t <+> "when" <+> ppAtom env a + +ppBinder :: PPInfo -> Binder -> Doc +ppBinder env (x ::: t) = ppIdent env x <+> text ":" <+> ppCType env t + +ppAtom :: PPInfo -> Atom -> Doc +ppAtom env atom = + case atom of + Lit l c -> case clockOfCType c of + BaseClock -> pp l + WhenTrue a -> pp l <+> "/* when" <+> ppAtom env a <+> "*/" + Var x -> ppIdent env x + Prim f as _ -> ppPrim f PP.<> ppTuple (map (ppAtom env) as) + +ppExpr :: PPInfo -> Expr -> Doc +ppExpr env expr = + case expr of + Atom a -> ppAtom env a + (a, _) :-> b -> ppAtom env a <+> text "->" <+> ppAtom env b + Pre a -> text "pre" <+> ppAtom env a + a `When` b -> ppAtom env a <+> text "when" <+> ppAtom env b + Current a -> text "current" <+> ppAtom env a + Merge (a, ty) bs -> + text "merge" <+> ppAtom env (Var a) <+> vcat (ppBranch <$> bs) + where + ppBranch (lit, body) = + ppAtom env (Lit lit ty) <+> "=>" <+> ppAtom env body + +ppTuple :: [Doc] -> Doc +ppTuple ds = parens (hsep (punctuate comma ds)) + +ppEqn :: PPInfo -> Eqn -> Doc +ppEqn env (b := e) = + ppBinder env b $$ nest 2 ("=" <+> ppExpr env e) + +ppEqnGroup :: PPInfo -> EqnGroup -> Doc +ppEqnGroup env grp = + case grp of + NonRec eqn -> ppEqn env eqn + Rec eqns -> "rec" $$ nest 2 (vcatSep (map (ppEqn env) eqns)) + +binderName :: Binder -> CoreName +binderName (c ::: _) = c + +ppBinderName :: PPInfo -> Binder -> Doc +ppBinderName env b = ppIdent env $ binderName b + +ppNode :: Node -> Doc +ppNode node = + text "node" <+> pp (nName node) <+> ppTuple (map (ppBinder env) (nInputs node)) + $$ nest 2 ( text "returns" <+> ppTuple (map (ppBinderName env) (nOutputs node)) + $$ text "assumes" <+> ppTuple (map (ppIdent env . snd) + (nAssuming node)) + $$ text "shows" <+> ppTuple (map (ppIdent env .snd) (nShows node)) + ) + $$ vcat [ "var" <+> ppBinder env b | b <- nAbstract node ] + $$ text "let" + $$ nest 2 (vcatSep (map (ppEqnGroup env) (nEqns node))) + $$ text "tel" + where + env = identVariants node + + + +-- | Pick a normalized number for the identifier in a node. +-- Identifiers with the same text name are going to get different numbers. +-- Identifiers that only have one version around will get the number 0. +-- This is handy for pretty printing and exporting to external tools. +identVariants :: Node -> Map CoreName Int +identVariants node = Map.fromList + $ concat + $ Map.elems + $ fmap (`zip` [ 0 .. ]) + $ Map.fromListWith (++) + $ map binderInfo + $ nInputs node ++ + nAbstract node ++ + [ b | g <- nEqns node, b := _ <- grpEqns g] + + where + binderInfo (x ::: _) = (coreNameTextName x, [x]) + + + + +instance Pretty Op where + ppPrec _ = ppPrim + +instance Pretty Type where + ppPrec _ = ppType + +instance Pretty CType where + ppPrec _ = ppCType noInfo + +instance Pretty Binder where + ppPrec _ = ppBinder noInfo + +instance Pretty Atom where + ppPrec _ = ppAtom noInfo + +instance Pretty Expr where + ppPrec _ = ppExpr noInfo + +instance Pretty Eqn where + ppPrec _ = ppEqn noInfo + +instance Pretty Node where + ppPrec _ = ppNode + +instance Pretty CoreName where + ppPrec n (CoreName x) = ppPrec n x + + +-------------------------------------------------------------------------------- +-- Computing the the type of an expression. + + +-- | Compute the typing environment for a node. +nodeEnv :: Node -> Map CoreName CType +nodeEnv nd = Map.fromList $ map fromB (nInputs nd) ++ + map fromB (nOutputs nd) ++ + map fromB (nAbstract nd) ++ + map fromE (concatMap grpEqns (nEqns nd)) + where + fromB (x ::: t) = (x,t) + fromE (b := _) = fromB b + +clockParent :: Map CoreName CType -> Clock -> Maybe Clock +clockParent env c = + case c of + BaseClock -> Nothing + WhenTrue a -> Just (clockOfCType (typeOf env a)) + +class TypeOf t where + -- | Get the type of something well-formed (panics if not). + typeOf :: Map CoreName CType -> t -> CType + +instance TypeOf Atom where + typeOf env atom = + case atom of + Var x -> case Map.lookup x env of + Just t -> t + Nothing -> panic "typeOf" ["Undefined variable: " ++ showPP x] + Lit _ ty -> ty + + prim@(Prim op as tys) -> + case op of + ITE -> case as of + _ : b : _ -> typeOf env b + _ -> panic "typeOf" ["Malformed ITE"] + + _ -> case tys of + [ty] -> ty + _ -> panic "typeOf" ["Prim has unexpected types:", show prim] + +instance TypeOf Expr where + typeOf env expr = + case expr of + Atom a -> typeOf env a + (_, ty) :-> _ -> ty + Pre a -> typeOf env a + a `When` b -> let t `On` _ = typeOf env a + in t `On` WhenTrue b + Current a -> let t `On` c = typeOf env a + Just c1 = clockParent env c + in t `On` c1 + Merge (_, (_ `On` c1)) ((_, e):_) -> + let t `On` _ = typeOf env e + in t `On` c1 + Merge {} -> error "typeOf: malformed Merge" + diff --git a/Language/Lustre/Defines.hs b/Language/Lustre/Defines.hs new file mode 100644 --- /dev/null +++ b/Language/Lustre/Defines.hs @@ -0,0 +1,140 @@ +{-# Language OverloadedStrings, DataKinds, GeneralizedNewtypeDeriving #-} +module Language.Lustre.Defines + ( getDefs + , Defines(..) + , Defs + , noDefs + , defNames + , mergeDefs + ) where + +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Foldable(traverse_) +import MonadLib + +import Language.Lustre.Name +import Language.Lustre.AST +import Language.Lustre.Monad + + +-- | Identifiers groupes by namespace +type Defs = Map NameSpace (Set OrigName) + +-- | Empty set of definitinos +noDefs :: Defs +noDefs = Map.empty + +-- | Merge two sets of definitions +mergeDefs :: Defs -> Defs -> Defs +mergeDefs = Map.unionWith Set.union + +-- | Collect all names in a definition map. +defNames :: Defs -> Set OrigName +defNames = Set.unions . Map.elems + + + + +getDefs :: Defines a => + a {- ^ Get definitions of this -} -> + Maybe ModName {- ^ Where are we -} -> + LustreM Defs +getDefs a mn = + do (_,defs) <- runStateT [] $ runReaderT mn $ unDefM $ defines a + pure (Map.fromListWith Set.union (map one defs)) + where + one i = (thingNS (rnThing i), Set.singleton i) + +newtype DefM a = DefM { unDefM :: + WithBase LustreM + [ ReaderT (Maybe ModName) + , StateT [OrigName] + ] a } + deriving (Functor,Applicative,Monad) + + +addDef :: Ident -> Thing -> DefM () +addDef x t = DefM $ + do m <- ask + n <- inBase newInt + sets_ $ \is -> OrigName { rnModule = m + , rnThing = t + , rnIdent = x + , rnUID = n } : is + + +class Defines t where + defines :: t -> DefM () + + +instance Defines TopDecl where + defines ts = + case ts of + DeclareType td -> defines td + DeclareConst cd -> defines cd + DeclareNode nd -> defines nd + DeclareNodeInst nid -> defines nid + DeclareContract cd -> defines cd + +instance Defines ConstDef where + defines x = addDef (constName x) AConst + +instance Defines TypeDecl where + defines td = do addDef (typeName td) AType + traverse_ defines (typeDef td) + +instance Defines StaticParam where + defines sp = + case sp of + TypeParam t -> addDef t AType + ConstParam c _ -> addDef c AConst + NodeParam _ _ i _ -> addDef i ANode + +instance Defines InputBinder where + defines ib = + case ib of + InputBinder b -> addDef (binderDefines b) AVal + InputConst c _ -> addDef c AConst + +-- | Note that binders are always used for values, not constants. +instance Defines Binder where + defines b = addDef (binderDefines b) AVal + +instance Defines TypeDef where + defines td = + case td of + IsType _ -> pure () + IsEnum xs -> sequence_ [ addDef x AConst | x <- xs ] + IsStruct _ -> pure () + + +instance Defines NodeInstDecl where + defines nd = addDef (nodeInstName nd) ANode + +instance Defines NodeDecl where + defines nd = addDef (nodeName nd) ANode + +instance Defines LocalDecl where + defines ld = + case ld of + LocalVar b -> addDef (binderDefines b) AVal + LocalConst c -> defines c + +instance Defines ContractItem where + defines ci = + case ci of + GhostConst d -> defines d + GhostVar b _ -> addDef (binderDefines b) AVal + Assume _ _ -> pure () + Guarantee _ _ -> pure () + Mode _ _ _ -> pure () -- XXX: node references? + Import _ _ _ -> pure () -- XXX: node references + +instance Defines ContractDecl where + defines c = addDef (cdName c) AContract + + + diff --git a/Language/Lustre/Driver.hs b/Language/Lustre/Driver.hs new file mode 100644 --- /dev/null +++ b/Language/Lustre/Driver.hs @@ -0,0 +1,214 @@ +-- | Process a collection of declarations all the way. +module Language.Lustre.Driver where + +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.List(foldl',sortBy) +import Data.Text(Text) +import AlexTools(sourceFrom,sourceIndex) +import Text.PrettyPrint(Doc) + +import Language.Lustre.Name +import qualified Language.Lustre.AST as P +import qualified Language.Lustre.Core as C +import Language.Lustre.Monad +import Language.Lustre.Pretty(pp,vcatSep) +import Language.Lustre.Phase +import Language.Lustre.Transform.OrderDecls +import Language.Lustre.TypeCheck +import Language.Lustre.Transform.NoStatic +import Language.Lustre.Transform.NoStruct +import Language.Lustre.Transform.Inline +import Language.Lustre.Transform.ToCore + + +-- | Export a given node to core. +-- Note that currently we process all declarations, even if some +-- of them are not needed to process the given module. +quickNodeToCore :: + Maybe Text {- ^ Node to translate -} -> + [P.TopDecl] {- ^ Source decls -} -> + LustreM (ModelInfo, C.Node) +quickNodeToCore mb ds = + do (info,ds1) <- quickDeclsSimp ds + nodeToCore mb info ds1 + +data Env = Env + { envNodes :: Map OrigName ModelFunInfo + , envEnums :: EnumInfo + } + +-- | Process a bunch of declarations in preparation for translating to core. +-- This function works only on standalone declarations, not accounting +-- for a broader context. +quickDeclsSimp :: [P.TopDecl] -> + LustreM (Env, [P.TopDecl]) +quickDeclsSimp ds = + do ds1 <- quickOrderTopDecl ds + let enums = getEnumInfo ds1 + + dumpPhase PhaseRename $ vcatSep $ map pp ds1 + ds2 <- quickCheckDecls ds1 + dumpPhase PhaseTypecheck $ vcatSep $ map pp ds2 + + (csMap,ds3) <- noConst ds2 + dumpPhase PhaseNoStatic $ vcatSep $ map pp ds3 + + let nosIn = NosIn + { nosiStructs = Map.empty + , nosiCallSites = csMap + } + (nosOut,ds4) <- noStruct nosIn ds3 + dumpPhase PhaseNoStruct $ vcatSep $ map pp ds4 + + (rens,ds5) <- inlineCalls [] ds4 + dumpPhase PhaseInline $ vcatSep $ map pp ds5 + + pure (Env { envNodes = mfiMap ds1 nosOut rens + , envEnums = enums + } + , ds5) + +dumpPhase :: LustrePhase -> Doc -> LustreM () +dumpPhase ph doc = + lustreIfDumpAfter ph $ + do let msg = show ph + logMessage msg + logMessage (replicate (length msg) '=') + logMessage "" + logMessage (show doc) + logMessage "" + +nodeToCore :: + Maybe Text {- ^ Node to translate -} -> + Env {- ^ Info about the environment -} -> + [P.TopDecl] {- ^ Simplified top decls -} -> + LustreM (ModelInfo, C.Node) +nodeToCore mb env ds = + do nd <- findNode mb ds + core <- evalNodeDecl (envEnums env) nd + dumpPhase PhaseToCore (pp core) + pure (ModelInfo { infoNodes = envNodes env + , infoTop = identOrigName (P.nodeName nd) + , infoEnums = envEnums env + } + , core) + + +findNode :: + Maybe Text {- ^ Name hint -} -> + [P.TopDecl] {- ^ Simplified declarations -} -> + LustreM P.NodeDecl +findNode mb ds = + case [ nd | nd <- nodes, selected nd ] of + [nd] -> pure nd + [] | nd : _ <- sortBy later nodes -> pure nd + nds -> reportError $ BadEntryPoint + [ identOrigName (P.nodeName nd) | nd <- nds ] + where + nodes = [ nd | P.DeclareNode nd <- ds ] + + selected = + case mb of + Nothing -> hasMain + Just t -> \nd -> identText (P.nodeName nd) == t + + hasMain nd + | Just b <- P.nodeDef nd = any isMain (P.nodeEqns b) + | otherwise = False + + + isMain eqn = case eqn of + P.IsMain _ -> True + _ -> False + + -- XXX: assumes all declaration in the same file. + locId = sourceIndex . sourceFrom . identRange . P.nodeName + later x y = compare (locId y) (locId x) + +-------------------------------------------------------------------------------- +-- | Information for mapping traces back to source Lustre +data ModelInfo = ModelInfo + { infoNodes :: Map OrigName ModelFunInfo + -- ^ Translation information for nodes. + + , infoTop :: OrigName + -- ^ Name for top node + + , infoEnums :: !EnumInfo + -- ^ Information about enums + } + + + +-------------------------------------------------------------------------------- + + + +-- | Collected information about a translated node. +-- Mostly stuff we need to map from Core models, back to original source. +data ModelFunInfo = ModelFunInfo + { mfiCallSites :: Map CallSiteId [OrigName] + {- ^ For each call site, rememebr the identifiers keeping the results + of the call. -} + + , mfiStructs :: Map OrigName (StructData OrigName) + {- ^ Identifiers of strucutred types (e.g., structs, arrays) are + "exploded" into multiple variables. This mapping remembers how + we did that: the key is a value of a strucutred type, and + the entry in the map is the value for it -} + + , mfiInlined :: Map [OrigName] (OrigName, Renaming) + {- ^ Information about what we called, and how things got renamed + when we inlined things. + For each call site (identified by its return values), + we have a map from the original names in the function, to the + new names used in the inlined version. -} + + , mfiSource :: P.NodeDecl + -- ^ The renamed, but otherwise unsimplified code for the node + -- that implemnets this function. See 'nodeSourceMap' for details. + } + + + +mfiMap :: [P.TopDecl] -> NosOut -> AllRenamings -> Map OrigName ModelFunInfo +mfiMap ordDs nos rens = + Map.fromList $ map build + $ Set.toList + $ Set.unions [ Map.keysSet (nosoCallSites nos) + , Map.keysSet (nosoExpanded nos) + , Map.keysSet rens ] + where + build k = (k, ModelFunInfo { mfiCallSites = lkpMap k (nosoCallSites nos) + , mfiStructs = lkpMap k (nosoExpanded nos) + , mfiInlined = lkpMap k rens + , mfiSource = srcMap Map.! k + }) + + lkpMap = Map.findWithDefault Map.empty + + srcMap = nodeSourceMap ordDs + + + +-- | Compute a mapping from node names to the actual source that implements +-- them. For example, consider the declaration @f = g <<3>>@. If we want to +-- see how @f@ works, we should really look for the code for @g@. +nodeSourceMap :: [P.TopDecl] -> Map OrigName P.NodeDecl +nodeSourceMap = foldl' add Map.empty + where + add mp tde = + case tde of + P.DeclareNode nd -> Map.insert (identOrigName (P.nodeName nd)) nd mp + P.DeclareNodeInst nid -> + case P.nodeInstDef nid of + P.NodeInst (P.CallUser f) _ + | Just nd <- Map.lookup (nameOrigName f) mp -> + Map.insert (identOrigName (P.nodeInstName nid)) nd mp + _ -> mp + P.DeclareType {} -> mp + P.DeclareConst {} -> mp + + diff --git a/Language/Lustre/Error.hs b/Language/Lustre/Error.hs new file mode 100644 --- /dev/null +++ b/Language/Lustre/Error.hs @@ -0,0 +1,99 @@ +{-# Language OverloadedStrings #-} +module Language.Lustre.Error where + +import Text.PrettyPrint hiding ((<>)) +import qualified Text.PrettyPrint as PP +import Control.Exception + +import Language.Lustre.AST(SourceRange(..),range) +import Language.Lustre.Name +import Language.Lustre.Pretty + + +data LustreError = + ResolverError ResolverError + | TCError [SourceRange] Doc + | BadEntryPoint [ OrigName ] + deriving Show + +instance Exception LustreError + +data LustreWarning = + ResolverWarning ResolverWarning + + +-- | Various things that can go wrong when resolving names. +data ResolverError = + InvalidConstantExpression String + | UndefinedName Name + | AmbiguousName Name OrigName OrigName + | RepeatedDefinitions [OrigName] + | BadRecursiveDefs [OrigName] + deriving Show + +-- | Potential problems, but not fatal. +data ResolverWarning = + Shadows OrigName OrigName + +-------------------------------------------------------------------------------- + +instance Pretty LustreError where + ppPrec n err = + case err of + ResolverError re -> ppPrec n re + TCError locs d -> case locs of + [] -> d + l : _ -> pp l PP.<> colon <+> d + BadEntryPoint xs -> + case xs of + [] -> "Failed to find an entry point, please use %MAIN" + _ -> nested "Found multiple entry points:" + (vcat (map pp xs)) + +instance Pretty LustreWarning where + ppPrec n warn = + case warn of + ResolverWarning rw -> ppPrec n rw + +instance Pretty ResolverError where + ppPrec _ err = + case err of + + InvalidConstantExpression x -> + "Construct" <+> backticks (text x) <+> + "may not appear in constant expressions." + + UndefinedName x -> + located (range x) + [ "The name" <+> backticks (pp x) <+> "is undefined." ] + + AmbiguousName x a b -> + located (range x) + [ "The name" <+> backticks (pp x) <+> "is ambiguous." + , block "It may refer to:" [ppOrig a, ppOrig b] + ] + + RepeatedDefinitions xs -> + block "Multiple declaratoins for the same name:" (map ppOrig xs) + + BadRecursiveDefs xs -> + block "Invalid recursive declarations:" (map ppOrig xs) + + where + block x ys = nested x (bullets ys) + located r xs = block ("At" <+> pp r) xs + +ppOrig :: OrigName -> Doc +ppOrig x = backticks (pp x) PP.<> "," + <+> "defined at" <+> pp (identRange (rnIdent x)) + <+> parens ("unqiue" <+> pp (rnUID x)) + + +instance Pretty ResolverWarning where + ppPrec _ warn = + case warn of + Shadows x y -> + ppOrig x <+> "shadows" <+> ppOrig y + + + diff --git a/Language/Lustre/ModelState.hs b/Language/Lustre/ModelState.hs new file mode 100644 --- /dev/null +++ b/Language/Lustre/ModelState.hs @@ -0,0 +1,205 @@ +module Language.Lustre.ModelState + ( -- * Locations and Navigation + Loc, locTop, ModelInfo, locCalls, enterCall, exitCall, locName, + + -- * Call sites + CallSiteId, callSiteName, + + -- * Accessing Variables + S, Vars(..), lookupVars, locVars, + -- * Names + CoreValue, SourceValue, + ) where + +import Data.Map (Map) +import qualified Data.Map as Map + +import Language.Lustre.Name +import qualified Language.Lustre.AST as P +import Language.Lustre.Core(CoreName,coreNameFromOrig) +import Language.Lustre.Transform.NoStatic(CallSiteId,callSiteName) +import Language.Lustre.Transform.NoStruct(StructData(..)) +import Language.Lustre.Transform.Inline(Renaming(..)) +import Language.Lustre.Transform.ToCore(enumFromVal) +import Language.Lustre.Driver(ModelInfo(..), ModelFunInfo(..)) +import qualified Language.Lustre.Semantics.Core as L +import qualified Language.Lustre.Semantics.Value as V +import Language.Lustre.Panic(panic) + +-- | A state for a core lustre program. +type S = Map CoreName CoreValue +type CoreValue = L.Value -- ^ Value for a core expression +type SourceValue = V.Value -- ^ Value for full Lustre + +-------------------------------------------------------------------------------- + +-- | A 'Loc' is an instantiation of a function with specific arguments. +-- It helps is traverse the call tree at a specific state in the system. +data Loc = Loc + { lModel :: ModelInfo + {- ^ Read only. For convenience we pass around the whole model info, + so that we can access global thing (e.g., the lustre to core variable + mapping) -} + + , lFunInfo :: ModelFunInfo + {- ^ Information about the translation of the specific function we are in -} + + , lSubst :: Map OrigName OrigName + {- ^ Accumulated renamings for variables resulting from Lustre-Lustre + translations -} + + , lVars :: Vars (OrigName, P.Type) + -- ^ These are the variables we are observing. + + , lAbove :: Maybe Loc + -- ^ Locations on the current call path. This is for navigation, + -- so we can go back to our parent. + + , lRange :: P.SourceRange + -- ^ Location in the source code for this node + } + +-- | Get the name of node corresponding to the current location. +locName :: Loc -> OrigName +locName = identOrigName . P.nodeName . mfiSource . lFunInfo + +instance P.HasRange Loc where + range = lRange + +-- | The location corresponding to the main function being verified. +locTop :: ModelInfo -> Maybe Loc +locTop mi = + do let top = infoTop mi + fi <- Map.lookup top (infoNodes mi) + let nd = mfiSource fi + pure Loc { lModel = mi + , lFunInfo = fi + , lSubst = Map.empty + , lVars = nodeVars nd + , lAbove = Nothing + , lRange = P.range nd + } + +-- | Given a location and a call site in it, get the location corresponding +-- to the given call. +enterCall :: Loc -> CallSiteId -> Maybe Loc +enterCall l cs = + do let mf = lFunInfo l + xs <- Map.lookup cs (mfiCallSites mf) + (f,ren) <- Map.lookup xs (mfiInlined mf) + let su = renVarMap ren + let mi = lModel l + fi <- Map.lookup f (infoNodes mi) + let nd = mfiSource fi + let vars = nodeVars nd + su1 = fmap (\i -> Map.findWithDefault i i (lSubst l)) su + pure l { lFunInfo = fi + , lSubst = su1 + , lVars = vars + , lAbove = Just l + , lRange = P.range nd + } + +-- | What are the callsites avaialable at a location. +locCalls :: Loc -> [CallSiteId] +locCalls = Map.keys . mfiCallSites . lFunInfo + +-- | Got back to the parent of a location. +exitCall :: Loc -> Maybe Loc +exitCall = lAbove + + +-------------------------------------------------------------------------------- + +-- | The variables at this location. +locVars :: Loc -> Vars (OrigName, P.Type) +locVars = lVars + +-- | Get the values for all varialbes in a location. +lookupVars :: Loc -> S -> Vars (OrigName, P.Type, Maybe SourceValue) +lookupVars l s = fmap lkp (lVars l) + where lkp (i,t) = (i, t, lookupVar l s t i) + + +-- | Get the value for a variable in a location, in a specific state. +lookupVar :: Loc -> S -> P.Type -> OrigName -> Maybe SourceValue +lookupVar l s t i0 = + case Map.lookup i (mfiStructs (lFunInfo l)) of + Just si -> + do si1 <- traverse (lookupVar l s t) si + pure (restruct si1) + Nothing -> + do v1 <- Map.lookup (coreNameFromOrig i) s + reval l t v1 + where + i = Map.findWithDefault i0 i0 (lSubst l) + + +-- | Change representations of values. +reval :: Loc -> P.Type -> L.Value -> Maybe SourceValue +reval loc t val = + case val of + L.VInt n + | P.NamedType tn <- t + , let tno = nameOrigName tn + , Just c <- Map.lookup (tno,n) (enumFromVal (infoEnums (lModel loc))) + -> Just (V.VEnum tno c) + | otherwise -> Just (V.VInt n) + L.VBool n -> Just (V.VBool n) + L.VReal n -> Just (V.VReal n) + L.VNil -> Nothing + + +-- | Change of representations. +restruct :: StructData SourceValue -> SourceValue +restruct str = + case str of + SLeaf a -> a + SArray xs -> V.VArray (map restruct xs) + SStruct x vs -> V.VStruct x (fmap (fmap restruct) vs) + STuple {} -> panic "restruct" ["Unexpected tuple"] + + + +-------------------------------------------------------------------------------- +-- | This is what we report +data Vars i = Vars + { vIns :: [i] + , vLocs :: [i] + , vOuts :: [i] + } deriving Show + +instance Functor Vars where + fmap f vs = Vars { vIns = fmap f (vIns vs) + , vLocs = fmap f (vLocs vs) + , vOuts = fmap f (vOuts vs) + } + +instance Foldable Vars where + foldMap f vs = mconcat [ foldMap f (vIns vs) + , foldMap f (vLocs vs) + , foldMap f (vOuts vs) + ] + +instance Traversable Vars where + traverse f vs = Vars <$> traverse f (vIns vs) + <*> traverse f (vLocs vs) + <*> traverse f (vOuts vs) + + +-- | Get the variables from a node. +nodeVars :: P.NodeDecl -> Vars (OrigName, P.Type) +nodeVars nd = Vars { vIns = fromB [ b | P.InputBinder b <- P.nodeInputs prof ] + , vLocs = fromB locs + , vOuts = fromB (P.nodeOutputs prof) + } + where + prof = P.nodeProfile nd + locs = case P.nodeDef nd of + Nothing -> [] + Just d -> [ b | P.LocalVar b <- P.nodeLocals d ] + fromB bs = [ ( identOrigName (P.binderDefines b) + , P.cType (P.binderType b) + ) + | b <- bs ] + diff --git a/Language/Lustre/Monad.hs b/Language/Lustre/Monad.hs new file mode 100644 --- /dev/null +++ b/Language/Lustre/Monad.hs @@ -0,0 +1,184 @@ +{-# Language DataKinds, GeneralizedNewtypeDeriving #-} +{-# Language MultiParamTypeClasses #-} +-- | "Global" monad for Lustre processing. +module Language.Lustre.Monad + ( -- * The Lustre monad + runLustre + , LustreConf(..) + , LustreM + + -- ** Errors and Warnings + , reportError + , addWarning + , getWarnings + , module Language.Lustre.Error + + -- ** Access to the Name Seed + , getNameSeed + , setNameSeed + , newInt + + -- ** Logging + , setVerbose + , logMessage + , lustreIfDumpAfter + + -- * Name seeds + , NameSeed + , nextNameSeed + , nameSeedToInt + , invalidNameSeed + , isValidNameSeed + + ) where + + +import System.IO(Handle,hPutStrLn,hFlush) +import MonadLib +import Control.Exception(throwIO) +import Data.Set(Set) +import qualified Data.Set as Set + +import Language.Lustre.Error +import Language.Lustre.Panic +import Language.Lustre.Phase + +-- | A common monad for all lustre passes +newtype LustreM a = LustreM + { unLustreM :: + WithBase IO + [ ReaderT GlobalLustreEnv + , ExceptionT LustreError + , StateT GlobalLustreState + ] a + } deriving (Functor,Applicative,Monad) + +instance BaseM LustreM LustreM where + inBase = id + + +data GlobalLustreEnv = GlobalLustreEnv + { luLogHandle :: !Handle + , luDumpAfter :: !(Set LustrePhase) + } + + +-- | Generic state commong the lustre implementation +data GlobalLustreState = GlobalLustreState + { luWarnings :: ![LustreWarning] + , luNameSeed :: !NameSeed + , luVerbose :: !Bool + } + +-- | An abstract type for generating names. +newtype NameSeed = NameSeed Int deriving Show + + +-- | A new name seed. +nextNameSeed :: NameSeed -> NameSeed +nextNameSeed (NameSeed x) = NameSeed (x + 1) + +-- | Name seed rendered as a number. +nameSeedToInt :: NameSeed -> Int +nameSeedToInt (NameSeed x) = x + +-- | In a few places we have name seeds that should not be used. +-- To enforce this invariant, we use 'invalidNameSeeds', so that it +-- is fairly easy to notice if messed up. +-- (we cannot use 'error' as the NameSeed is strict) +invalidNameSeed :: Int -> NameSeed +invalidNameSeed x = if x < 0 then NameSeed x else NameSeed (negate x) + +-- | Is this a valid name seed. +isValidNameSeed :: NameSeed -> Bool +isValidNameSeed (NameSeed x) = x >= 0 + +-- | Configuration for running Lustre computations. +data LustreConf = LustreConf + { lustreInitialNameSeed :: Maybe NameSeed + , lustreLogHandle :: !Handle + , lustreDumpAfter :: !(Set LustrePhase) + } + +-- | Execute a Lustre computation. +-- May throw `LustreError` +runLustre :: LustreConf -> LustreM a -> IO a +runLustre conf m = + do let env = GlobalLustreEnv { luLogHandle = lustreLogHandle conf + , luDumpAfter = lustreDumpAfter conf + } + st = GlobalLustreState + { luNameSeed = case lustreInitialNameSeed conf of + Nothing -> NameSeed 0 + Just s -> s + , luVerbose = False + , luWarnings = [] + } + (res,_) <- runM (unLustreM m) env st + case res of + Left err -> throwIO err + Right a -> pure a + +-- | Log something, if we are verbose. +logMessage :: String -> LustreM () +logMessage msg = + LustreM $ do verb <- luVerbose <$> get + when verb $ + do h <- luLogHandle <$> ask + inBase $ do hPutStrLn h msg + hFlush h + +-- | Set verbosity. 'True' means enable logging. Affect `lustreLog`. +setVerbose :: Bool -> LustreM () +setVerbose b = LustreM $ sets_ $ \s -> s { luVerbose = b } + +-- | Abort further computation with the given error. +reportError :: LustreError -> LustreM a +reportError e = LustreM (raise e) + +-- | Record a warning. +addWarning :: LustreWarning -> LustreM () +addWarning w = + LustreM $ sets_ $ \s -> s { luWarnings = w : luWarnings s } + +-- | Get the warnings collected so far. +getWarnings :: LustreM [LustreWarning] +getWarnings = LustreM $ luWarnings <$> get + +-- | Get the current name seed. +getNameSeed :: LustreM NameSeed +getNameSeed = LustreM $ luNameSeed <$> get + +-- | Set the current name seed to something. +setNameSeed :: NameSeed -> LustreM () +setNameSeed newSeed = + LustreM $ sets_ $ \s -> + let oldSeed = luNameSeed s + in if nameSeedToInt oldSeed > nameSeedToInt newSeed + then panic "Language.Lustre.Monad.lustreSetSeed" + [ "New seed is smaller than the current seed." + , "*** Old seed: " ++ show oldSeed + , "*** New seed: " ++ show newSeed + ] + else s { luNameSeed = newSeed } + + +-- | Use the name see to generate a new int. +newInt :: LustreM Int +newInt = + do seed <- getNameSeed + unless (isValidNameSeed seed) $ + panic "newName" [ "Attempt ot generate a new name in invald context." + , "*** Name seed hint: " ++ show seed + ] + setNameSeed (nextNameSeed seed) + pure (nameSeedToInt seed) + + +-- | Execute the given action---presumably for printing---only if +-- dumping after the given phase is enables. +lustreIfDumpAfter :: LustrePhase -> LustreM () -> LustreM () +lustreIfDumpAfter ph (LustreM m) = + LustreM $ do du <- luDumpAfter <$> ask + when (ph `Set.member` du) m + diff --git a/Language/Lustre/Name.hs b/Language/Lustre/Name.hs new file mode 100644 --- /dev/null +++ b/Language/Lustre/Name.hs @@ -0,0 +1,213 @@ +module Language.Lustre.Name where + +import Data.Text(Text) +import AlexTools(SourceRange(..), HasRange(..)) + +import Language.Lustre.Panic(panic) + +{- | Just a textual name. Used to remember the user specified names of +things, as well as for things that are not quite names (e.g., field +labels) -} +data Label = Label + { labText :: !Text + -- ^ The label's text. + + , labRange :: !SourceRange + -- ^ The location of the lable in the source program. + } deriving Show + + +{- | The type of unqualified names +Used when we define things and at some use sites that can only refer to +locally defined things. -} +data Ident = Ident + { identLabel :: !Label + , identResolved :: !(Maybe OrigName) + } deriving Show + +-- | The text associates with an identifier. +identText :: Ident -> Text +identText = labText . identLabel + +-- | The location of the idnetifier in the source program. +identRange :: Ident -> SourceRange +identRange = labRange . identLabel + +-- | Do something with a resolve idnetifier. +-- Panics if the identifier is not resolved. +withResolved :: (OrigName -> a) -> Ident -> a +withResolved k i = case identResolved i of + Just info -> k info + Nothing -> panic "withResolved" + [ "The identifier is not resolved." + , "*** Name: " ++ show (identText i) + , "*** Range: " ++ show (identRange i) + ] + +-- | Access the definition site for the given resolved identifier. +identOrigName :: Ident -> OrigName +identOrigName = withResolved id + +-- | Access the unique identifier of a resolved identifier. +identUID :: Ident -> Int +identUID = withResolved rnUID + +-- | Access the module, if any, of a resolved identifier. +identModule :: Ident -> Maybe ModName +identModule = withResolved rnModule + +-- | Get information about what sort of thing this resolved identifier +-- refers to. +identThing :: Ident -> Thing +identThing = withResolved rnThing + + +-- | A possibly qualified name. Used at use sites where qualifier might be +-- OK. Mostly used to refer to types and constants in other modules. +data Name = + Unqual Ident + -- ^ After name resolution, the 'identResolved' field of the + -- identifier should always be filled in. + + | Qual ModName Ident + -- ^ Qualified name. Produced in the parser. Should not appear + -- after name resolution, where all names should be unqualified resolved + -- identifiers. + deriving Show + + +-- | Get the original name of a resolved name. +nameOrigName :: Name -> OrigName +nameOrigName nm = + case nm of + Unqual i -> identOrigName i + Qual {} -> panic "nameOrigName" + [ "Unexpected qualified name:" + , "*** Name: " ++ show nm + ] + +-------------------------------------------------------------------------------- + + +-- | Comapred by text. +instance Eq Label where + x == y = labText x == labText y + +-- | Comapred by text. +instance Ord Label where + compare x y = compare (labText x) (labText y) + + + +-- | Comapred by original name, if available, or by text otherwise. +-- Resolved and unresolved names are different. +instance Eq Ident where + x == y = case (identResolved x, identResolved y) of + (Just a, Just b) -> a == b + (Nothing,Nothing) -> identText x == identText y + _ -> False + +-- | Same as 'Eq' +instance Ord Ident where + compare i j = + case (identResolved i, identResolved j) of + (Just x, Just y) -> compare x y + (Nothing, Nothing) -> compare (identText i) (identText j) + + -- This are arbitrary, and somehwat questionable. + -- Perhaps we should panic instead? + (Nothing, Just _) -> LT + (Just _, Nothing) -> GT + + + +instance Eq Name where + m == n = case (m,n) of + (Unqual a, Unqual b) -> a == b + (Qual x y, Qual p q) -> (x,y) == (p,q) + _ -> False + +instance Ord Name where + compare m n = case (m,n) of + (Unqual x, Unqual y) -> compare x y + (Unqual {}, _) -> LT + (_, Unqual {}) -> GT + (Qual x y, Qual p q) -> compare (x,y) (p,q) + + +-------------------------------------------------------------------------------- + + +instance HasRange Label where + range = labRange + +instance HasRange Ident where + range = identRange + +instance HasRange Name where + range nm = + case nm of + Unqual i -> range i + Qual _ i -> range i + + +-- | Information about the definition of an identifier. +data OrigName = OrigName + { rnUID :: !Int -- ^ A unique identifier + , rnModule :: !(Maybe ModName) -- ^ Module where this is defined, if any + , rnIdent :: !Ident -- ^ Original (unresolved) identifier at + -- definition site. Useful for location, + -- pragmas, etc. + , rnThing :: !Thing -- ^ What are we + } deriving Show + +origNameToIdent :: OrigName -> Ident +origNameToIdent d = (rnIdent d) { identResolved = Just d } + +origNameToName :: OrigName -> Name +origNameToName = Unqual . origNameToIdent + +-- | The textual name of an original name, without module. +origNameTextName :: OrigName -> Text +origNameTextName n = identText (rnIdent n) + +instance HasRange OrigName where + range = range . rnIdent + +instance Eq OrigName where + x == y = rnUID x == rnUID y + +instance Ord OrigName where + compare x y = compare (rnUID x) (rnUID y) + + +-- | The name of a module. +newtype ModName = Module Text + deriving (Eq,Ord,Show) + + +-- | What sorts of things can be defined +data Thing = AType | ANode | AContract | AConst | AVal + deriving (Show,Eq,Ord) + + +-- | Various name spaces. +data NameSpace = NSType | NSNode | NSContract | NSVal + deriving (Show,Eq,Ord) + +-- | In what namespace do things live in. +thingNS :: Thing -> NameSpace +thingNS th = + case th of + AType -> NSType + ANode -> NSNode + AContract -> NSContract + AVal -> NSVal + AConst -> NSVal + + + + + + + diff --git a/Language/Lustre/Panic.hs b/Language/Lustre/Panic.hs new file mode 100644 --- /dev/null +++ b/Language/Lustre/Panic.hs @@ -0,0 +1,16 @@ +{-# Language TemplateHaskell #-} +module Language.Lustre.Panic (panic) where + +import Panic hiding (panic) +import qualified Panic + +data Lustre = Lustre + +instance PanicComponent Lustre where + panicComponentName _ = "Lustre" + panicComponentIssues _ = "https://github.com/GaloisInc/lustre" + panicComponentRevision = $useGitRevision + +panic :: HasCallStack => String -> [String] -> a +panic = Panic.panic Lustre + diff --git a/Language/Lustre/Parser.y b/Language/Lustre/Parser.y new file mode 100644 --- /dev/null +++ b/Language/Lustre/Parser.y @@ -0,0 +1,1138 @@ +{ +{-# Language OverloadedStrings #-} +module Language.Lustre.Parser + ( parse, parseStartingAt + , parseProgramFrom + , parseProgramFromFileUTF8 + , parseProgramFromFileLatin1 + , program, expression + , ParseError(..) + , prettySourcePos, prettySourcePosLong + , prettySourceRange, prettySourcePosLong + ) where + +import AlexTools +import Data.Semigroup +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import qualified Data.Text.Encoding as Text +import qualified Data.ByteString as BS +import Data.Semigroup ((<>)) +import Control.Exception(throwIO) +import Control.Monad(foldM) + +import Language.Lustre.Parser.Lexer +import Language.Lustre.Parser.Monad +import Language.Lustre.Name +import Language.Lustre.AST +import Language.Lustre.Pretty(showPP) +import Language.Lustre.Panic +} + + +%tokentype { Lexeme Token } + +%token + + 'package' { Lexeme { lexemeRange = $$, lexemeToken = TokKwPackage } } + 'model' { Lexeme { lexemeRange = $$, lexemeToken = TokKwModel } } + 'is' { Lexeme { lexemeRange = $$, lexemeToken = TokKwIs } } + 'uses' { Lexeme { lexemeRange = $$, lexemeToken = TokKwUses } } + 'needs' { Lexeme { lexemeRange = $$, lexemeToken = TokKwNeeds } } + 'provides' { Lexeme { lexemeRange = $$, lexemeToken = TokKwProvides } } + 'body' { Lexeme { lexemeRange = $$, lexemeToken = TokKwBody } } + 'end' { Lexeme { lexemeRange = $$, lexemeToken = TokKwEnd } } + + 'if' { Lexeme { lexemeRange = $$, lexemeToken = TokKwIf } } + 'then' { Lexeme { lexemeRange = $$, lexemeToken = TokKwThen } } + 'else' { Lexeme { lexemeRange = $$, lexemeToken = TokKwElse } } + 'with' { Lexeme { lexemeRange = $$, lexemeToken = TokKwWith } } + 'merge' { Lexeme { lexemeRange = $$, lexemeToken = TokKwMerge } } + + 'and' { Lexeme { lexemeRange = $$, lexemeToken = TokKwAnd } } + 'not' { Lexeme { lexemeRange = $$, lexemeToken = TokKwNot } } + 'or' { Lexeme { lexemeRange = $$, lexemeToken = TokKwOr } } + 'xor' { Lexeme { lexemeRange = $$, lexemeToken = TokKwXor } } + 'nor' { Lexeme { lexemeRange = $$, lexemeToken = TokKwNor } } + '#' { Lexeme { lexemeRange = $$, lexemeToken = TokHash } } + '=>' { Lexeme { lexemeRange = $$, lexemeToken = TokImplies } } + + '<' { Lexeme { lexemeRange = $$, lexemeToken = TokLt } } + '<=' { Lexeme { lexemeRange = $$, lexemeToken = TokLeq } } + '=' { Lexeme { lexemeRange = $$, lexemeToken = TokEq } } + ':=' { Lexeme { lexemeRange = $$, lexemeToken = TokColonEq } } + '>=' { Lexeme { lexemeRange = $$, lexemeToken = TokGeq } } + '>' { Lexeme { lexemeRange = $$, lexemeToken = TokGt } } + '<>' { Lexeme { lexemeRange = $$, lexemeToken = TokNotEq } } + + 'extern' { Lexeme { lexemeRange = $$, lexemeToken = TokKwExtern } } + 'imported' { Lexeme { lexemeRange = $$, lexemeToken = TokKwImported } } + 'unsafe' { Lexeme { lexemeRange = $$, lexemeToken = TokKwUnsafe } } + 'node' { Lexeme { lexemeRange = $$, lexemeToken = TokKwNode } } + 'function' { Lexeme { lexemeRange = $$, lexemeToken = TokKwFunction } } + 'returns' { Lexeme { lexemeRange = $$, lexemeToken = TokKwReturns } } + + 'type' { Lexeme { lexemeRange = $$, lexemeToken = TokKwType } } + 'const' { Lexeme { lexemeRange = $$, lexemeToken = TokKwConst } } + 'var' { Lexeme { lexemeRange = $$, lexemeToken = TokKwVar } } + 'struct' { Lexeme { lexemeRange = $$, lexemeToken = TokKwStruct } } + 'enum' { Lexeme { lexemeRange = $$, lexemeToken = TokKwEnum } } + + 'contract' { Lexeme { lexemeRange = $$, lexemeToken = TokKwContract } } + 'import' { Lexeme { lexemeRange = $$, lexemeToken = TokKwImport } } + 'assert' { Lexeme { lexemeRange = $$, lexemeToken = TokKwAssert } } + 'assume' { Lexeme { lexemeRange = $$, lexemeToken = TokKwAssume } } + 'guarantee' { Lexeme { lexemeRange = $$, lexemeToken = TokKwGuarantee } } + 'mode' { Lexeme { lexemeRange = $$, lexemeToken = TokKwMode } } + 'require' { Lexeme { lexemeRange = $$, lexemeToken = TokKwRequire } } + 'ensure' { Lexeme { lexemeRange = $$, lexemeToken = TokKwEnsure } } + '--%PROPERTY' { Lexeme { lexemeRange = $$, lexemeToken = TokPragmaProperty } } + '--%MAIN' { Lexeme { lexemeRange = $$, lexemeToken = TokPragmaMain } } + '--%IVC' { Lexeme { lexemeRange = $$, lexemeToken = TokPragmaIVC } } + '--%REALIZABLE' { Lexeme { lexemeRange = $$, + lexemeToken = TokPragmaRealizable } } + + 'when' { Lexeme { lexemeRange = $$, lexemeToken = TokKwWhen } } + 'current' { Lexeme { lexemeRange = $$, lexemeToken = TokKwCurrent } } + 'currentWith'{ Lexeme { lexemeRange = $$, lexemeToken = TokKwCurrentWith } } + 'condact' { Lexeme { lexemeRange = $$, lexemeToken = TokKwCondact } } + 'callWhen' { Lexeme { lexemeRange = $$, lexemeToken = TokKwCallWhen } } + 'pre' { Lexeme { lexemeRange = $$, lexemeToken = TokKwPre } } + 'fby' { Lexeme { lexemeRange = $$, lexemeToken = TokKwFby } } + '->' { Lexeme { lexemeRange = $$, lexemeToken = TokRightArrow } } + + 'div' { Lexeme { lexemeRange = $$, lexemeToken = TokKwDiv } } + 'mod' { Lexeme { lexemeRange = $$, lexemeToken = TokKwMod } } + '+' { Lexeme { lexemeRange = $$, lexemeToken = TokPlus } } + '-' { Lexeme { lexemeRange = $$, lexemeToken = TokMinus } } + '*' { Lexeme { lexemeRange = $$, lexemeToken = TokStar } } + '**' { Lexeme { lexemeRange = $$, lexemeToken = TokStarStar } } + '/' { Lexeme { lexemeRange = $$, lexemeToken = TokDiv } } + 'floor' { Lexeme { lexemeRange = $$, lexemeToken = TokKwFloor } } + + + 'step' { Lexeme { lexemeRange = $$, lexemeToken = TokKwStep } } + '|' { Lexeme { lexemeRange = $$, lexemeToken = TokBar } } + '^' { Lexeme { lexemeRange = $$, lexemeToken = TokHat } } + '..' { Lexeme { lexemeRange = $$, lexemeToken = TokDotDot } } + + 'int' { Lexeme { lexemeRange = $$, lexemeToken = TokKwInt } } + 'real' { Lexeme { lexemeRange = $$, lexemeToken = TokKwReal } } + 'bool' { Lexeme { lexemeRange = $$, lexemeToken = TokKwBool } } + 'subrange' { Lexeme { lexemeRange = $$, lexemeToken = TokKwSubrange } } + 'of' { Lexeme { lexemeRange = $$, lexemeToken = TokKwOf } } + + + ':' { Lexeme { lexemeRange = $$, lexemeToken = TokColon } } + ',' { Lexeme { lexemeRange = $$, lexemeToken = TokComma } } + ';' { Lexeme { lexemeRange = $$, lexemeToken = TokSemi } } + '.' { Lexeme { lexemeRange = $$, lexemeToken = TokDot } } + + + 'let' { Lexeme { lexemeRange = $$, lexemeToken = TokKwLet } } + 'tel' { Lexeme { lexemeRange = $$, lexemeToken = TokKwTel } } + '(' { Lexeme { lexemeRange = $$, lexemeToken = TokOpenParen } } + ')' { Lexeme { lexemeRange = $$, lexemeToken = TokCloseParen } } + '<<' { Lexeme { lexemeRange = $$, lexemeToken = TokOpenTT } } + '>>' { Lexeme { lexemeRange = $$, lexemeToken = TokCloseTT } } + '[' { Lexeme { lexemeRange = $$, lexemeToken = TokOpenBracket } } + ']' { Lexeme { lexemeRange = $$, lexemeToken = TokCloseBracket } } + '{' { Lexeme { lexemeRange = $$, lexemeToken = TokOpenBrace } } + '}' { Lexeme { lexemeRange = $$, lexemeToken = TokCloseBrace } } + + '%' { Lexeme { lexemeRange = $$, lexemeToken = TokMod } } + + '/*@contract' + { Lexeme { lexemeRange = $$, lexemeToken = TokStartSlashCommentContract } } + '*/' { Lexeme { lexemeRange = $$, lexemeToken = TokEndSlashComment } } + '(*@contract' + { Lexeme { lexemeRange = $$, lexemeToken = TokStartParenCommentContract } } + '*)' { Lexeme { lexemeRange = $$, lexemeToken = TokEndParenComment } } + + + IDENT { $$@Lexeme { lexemeToken = TokIdent {} } } + QIDENT { $$@Lexeme { lexemeToken = TokQualIdent {} } } + INT { $$@Lexeme { lexemeToken = TokInt {} } } + REAL { $$@Lexeme { lexemeToken = TokReal {} } } + BOOL { $$@Lexeme { lexemeToken = TokBool {} } } + +%name program program +%name package packDecl +%name model modelDecl +%name expression expression + +%lexer { happyGetToken } { Lexeme { lexemeToken = TokEOF } } +%monad { Parser } + +%left 'else' +%left '|' +%nonassoc '->' +%right '=>' +%left 'or' 'xor' +%left 'and' +%nonassoc '<' '<=' '=' '>=' '>' '<>' +%nonassoc 'not' +%left '+' '-' +%left '*' '/' '%' 'mod' 'div' +%left '**' +%nonassoc 'when' +%nonassoc 'int' 'real' 'floor' +%nonassoc UMINUS 'pre' 'current' +%left '^' '.' +%right '[' '{' +%right 'fby' + + +%% + +program :: { Program } + : packBody { ProgramDecls $1 } + | ListOf1(packTop) { ProgramPacks $1 } + +packTop :: { PackDecl } + : packDecl { PackDecl $1 } + | modelDecl { PackDecl $1 } + | 'package' ident eq_is ident '(' SepBy1(staticArgSep,staticNamedArg) ')' ';' + { PackInst $2 $4 $6 } + + +eq_is :: { SourceRange } + : '=' { $1 } + | 'is' { $1 } + + +-- Packages -------------------------------------------------------------------- + +packDecl + : 'package' ident packUses packProvides 'body' packBody 'end' + { Package { packageName = $2 + , packageUses = $3 + , packageParams = [] + , packageProvides = $4 + , packageBody = $6 + , packageRange = $1 <-> $7 + } + } + +packUses :: { [Ident] } + : 'uses' SepBy1(',',ident) ';' { $2 } + | {- empty -} { [] } + +packProvides :: { [PackageProvides] } + : 'provides' EndBy1(';',packProvide) { $2 } + | {- empty -} { [] } + +packProvide :: { PackageProvides } + : 'const' ident ':' type Opt(provideDef) { ProvidesConst $2 $4 $5 } + | 'type' typeDecl { ProvidesType $2 } + | Perhaps('unsafe') nodeType ident staticParams nodeProfile + { ProvidesNode + NodeDecl { nodeExtern = False + , nodeSafety = isUnsafe $1 + , nodeType = thing $2 + , nodeName = $3 + , nodeStaticInputs = $4 + , nodeProfile = thing $5 + , nodeDef = Nothing + , nodeRange = optR $1 $2 <-> $5 + } } + +provideDef :: { Expression } + : '=' expression { $2 } + + +packBody :: { [TopDecl] } + : ListOf1(topDecl) { concat $1 } + + +-- Models ---------------------------------------------------------------------- + +modelDecl :: { Package } + : 'model' ident packUses 'needs' EndBy1(';',staticParam) packProvides + 'body' packBody 'end' + { Package { packageName = $2 + , packageUses = $3 + , packageParams = $5 + , packageProvides = $6 + , packageBody = $8 + , packageRange = $1 <-> $9 + } + } + + + + +-------------------------------------------------------------------------------- + +topDecl :: { [TopDecl] } + : 'const' EndBy1(';',constDef) { map DeclareConst (concat $2) } + | 'type' EndBy1(';',typeDecl) { map DeclareType $2 } + | extDecl { [ DeclareNode $1 ] } + | nodeDecl { [ DeclareNode $1 ] } + | nodeInstDecl { [ DeclareNodeInst $1 ] } + | contractDecl { [ DeclareContract $1 ] } + + +-- Constant Declarations ------------------------------------------------------- + +constDef :: { [ConstDef] } + : ident ':' type { toConstDef ($1,$3) } + | ident ',' SepBy1(',',ident) ':' type { toConstDef ($1,$3,$5) } + | ident '=' expression { toConstDef ($1,$3) } + | ident ':' type '=' expression { toConstDef ($1,$3,$5) } + + +-- Type Declarations ----------------------------------------------------------- + +typeDecl :: { TypeDecl } + : ident { toTypeDecl $1 Nothing } + | ident '=' typeDef { toTypeDecl $1 (Just $3) } + +typeDef :: { TypeDef } + : type { IsType $1 } + | 'enum' '{' SepBy1(',',ident) '}' { IsEnum $3 } + | Perhaps('struct') '{' SepEndBy1(';',fieldType) '}' { IsStruct (concat $3) } + + +fieldType :: { [FieldType] } + : label ':' type '=' expression { toFieldType ($1,$3,$5) } + | label ':' type { toFieldType ($1,$3) } + | label ',' SepBy1(',',label) ':' type { toFieldType ($1, $3, $5) } + + +-- Types ----------------------------------------------------------------------- + +type :: { Type } + : builtInType { $1 } + | name { NamedType $1 } + | type '^' expression { at $1 $3 (ArrayType $1 $3) } + -- jkind notation + | type '[' expression ']' { at $1 $4 (ArrayType $1 $3) } + +simpleType :: { Type } + : builtInType { $1 } + | simpleType '^' expression { at $1 $3 (ArrayType $1 $3) } + +builtInType :: { Type } + : 'int' { at $1 $1 IntType } + | 'real' { at $1 $1 RealType } + | 'bool' { at $1 $1 BoolType } + | 'subrange' + '[' expression ',' expression ']' + 'of' 'int' { at $1 $8 (IntSubrange $3 $5) } + + + + +-- Node Declarations ----------------------------------------------------------- + +extDecl :: { NodeDecl } + : Perhaps('unsafe') 'extern' nodeType ident nodeProfile Perhaps(';') + Opt(contract) + {% desugarContract NodeDecl + { nodeSafety = isUnsafe $1 + , nodeExtern = True + , nodeType = thing $3 + , nodeName = $4 + , nodeStaticInputs = [] -- XXX + , nodeProfile = thing $5 + , nodeDef = Nothing + , nodeRange = optR $1 $2 <-> optR $6 $5 + , nodeContract = $7 + } + } + +-- We treat 'imported' the same as 'extern'. Hopefully that's the intention. +extDecl :: { NodeDecl } + : Perhaps('unsafe') nodeType 'imported' ident nodeProfile Perhaps(';') + Opt(contract) + {% desugarContract NodeDecl + { nodeSafety = isUnsafe $1 + , nodeExtern = True + , nodeType = thing $2 + , nodeName = $4 + , nodeStaticInputs = [] -- XXX + , nodeProfile = thing $5 + , nodeDef = Nothing + , nodeRange = optR $1 $2 <-> optR $6 $5 + , nodeContract = $7 + } + } + + + + +nodeDecl :: { NodeDecl } + : Perhaps('unsafe') nodeType ident staticParams nodeProfile Perhaps(';') + Opt(contract) + localDecls body Perhaps(';') + {% desugarContract NodeDecl + { nodeSafety = isUnsafe $1 + , nodeExtern = False + , nodeType = thing $2 + , nodeName = $3 + , nodeStaticInputs = $4 + , nodeProfile = thing $5 + , nodeContract = $7 + , nodeDef = Just NodeBody { nodeLocals = $8, nodeEqns = thing $9 } + , nodeRange = optR $1 $2 <-> optR $10 $9 + } + } + +contractDecl :: { ContractDecl } + : 'contract' ident nodeProfile Perhaps(';') + 'let' ListOf1(contractItem) 'tel' + { ContractDecl + { cdName = $2 + , cdProfile = thing $3 + , cdItems = $6 + , cdRange = $1 <-> $7 + } + } + +contract :: { Contract } + : '/*@contract' ListOf1(contractItem) '*/' { mkContract $1 $2 $3 } + | '(*@contract' ListOf1(contractItem) '*)' { mkContract $1 $2 $3 } + +contractItem :: { ContractItem } + : 'const' ident '=' expression Perhaps(';') { GhostConst + (toConstDef1 ($2,$4)) } + | 'const' ident ':' type + '=' expression Perhaps(';') { GhostConst + (toConstDef1 ($2,$4,$6)) } + | 'var' ident ':' type + '=' expression Perhaps(';') { GhostVar (simpBinder $2 $4) $6 } + | 'assume' expression Perhaps(';') { Assume (propName $1 $2) $2 } + | 'guarantee' expression Perhaps(';') { Guarantee (propName $1 $2) $2 } + | 'mode' ident '(' ListOf(require) + ListOf(ensure) + ')' Perhaps(';') { Mode $2 $4 $5 } + | 'import' ident '(' exprList ')' + 'returns' '(' exprList ')' Perhaps(';') { Import $2 $4 $8 } + +require :: { Expression } + : 'require' expression Perhaps(';') { $2 } + +ensure :: { Expression } + : 'ensure' expression Perhaps(';') { $2} + +nodeInstDecl :: { NodeInstDecl } + : Perhaps('unsafe') nodeType ident staticParams Opt(nodeProfile) + '=' effNode Perhaps(';') + { NodeInstDecl + { nodeInstSafety = isUnsafe $1 + , nodeInstType = thing $2 + , nodeInstName = $3 + , nodeInstStaticInputs = $4 + , nodeInstProfile = thing `fmap` $5 + , nodeInstDef = $7 + } + } + + +nodeProfile :: { Located NodeProfile } + : params(inputParam) 'returns' params(varDecl) { mkNodeProfile $1 $3 } + +nodeType :: { Located NodeType } + : 'node' { lat $1 Node } + | 'function' { lat $1 Function } + +staticParams :: { [StaticParam] } + : {- empty -} { [] } + | '<<' SepBy1(';',staticParam) '>>' { $2 } + +-- Description of a static parameter (i.e., this is the formal parameter) +staticParam :: { StaticParam } + : 'type' ident { TypeParam $2 } + | 'const' ident ':' type { ConstParam $2 $4 } + | Perhaps('unsafe') + nodeType + ident nodeProfile { NodeParam (isUnsafe $1) (thing $2) $3 + (thing $4) } + +localDecls :: { [LocalDecl] } + : {- empty -} { [] } + | ListOf1(localDecl) { concat $1 } + +localDecl :: { [LocalDecl] } + : 'var' EndBy1(';',varDecl) { map LocalVar (concat $2) } + | 'const' EndBy1(';',constDef) { map LocalConst (concat $2) } + +body :: { Located [Equation] } + : 'let' ListOf1(equation) 'tel' { lat ($1 <-> $3) $2 } + +equation :: { Equation } + : 'assert' expression ';' { Assert (propName $1 $2) + AssertPre $2 } + | '--%PROPERTY' expression ';' { Property (propName $1 $2) $2 } + | '--%MAIN' opt_semi { IsMain $1 } + | '--%IVC' SepBy1(',',ident) ';' { IVC $2 } + | '--%REALIZABLE' SepBy1(',',ident) ';' { Realizable $2 } + | SepBy1(',',LHS) '=' expression ';' { Define $1 $3 } + | '(' SepBy1(',',LHS) ')' '=' expression ';' { Define $2 $5 } + | '(' ')' '=' expression ';' { Define [] $4 } + +opt_semi :: { () } + : {- empty -} { () } + | ';' { () } + +LHS :: { LHS Expression } + : ident { LVar $1 } + | LHS '.' label { LSelect $1 (SelectField $3) } + | LHS '[' arraySel ']' { LSelect $1 $3 } + + +-- Variable Declarations ------------------------------------------------------- + +params(par) :: { Located par } + : '(' ')' { lat ($1 <-> $2) [] } + | '(' SepEndBy1(';',par) ')' { lat ($1 <-> $3) (concat $2) } + +inputParam :: { [InputBinder] } + : varDecl { map InputBinder $1 } + | 'const' typedIdents { [ InputConst i (snd $2) | i <- fst $2 ] } + +varDecl :: { [Binder] } + : typedIdents { toVarDeclBase $1 } + | typedIdents 'when' clockExpr { toVarDecl $1 $3 } + | '(' typedIdents ')' 'when' clockExpr { toVarDecl $2 $5 } + +typedIdents :: { ( [Ident], Type ) } + : SepBy1(',', ident) ':' type { ($1, $3) } + + + +-- Expressions ----------------------------------------------------------------- + +expression :: { Expression } + : INT { toLit $1 } + | REAL { toLit $1 } + | BOOL { toLit $1 } + + | name { Var $1 } + + | 'not' expression { toE1 Not $1 $2 } + | '-' expression %prec UMINUS { toE1 Neg $1 $2 } + | 'pre' expression { toE1 Pre $1 $2 } + | 'current' expression { toE1 Current $1 $2 } + | 'int' expression { toE1 IntCast $1 $2 } + | 'real' expression { toE1 RealCast $1 $2 } + | 'floor' expression { toE1 FloorCast $1 $2 } + + | expression 'when' clockExpr { $1 `When` $3 } + | expression 'fby' expression { toE2 $1 $2 Fby $3 } + | expression '->' expression { toE2 $1 $2 FbyArr $3 } + | expression 'and' expression { toE2 $1 $2 And $3 } + | expression 'or' expression { toE2 $1 $2 Or $3 } + | expression 'xor' expression { toE2 $1 $2 Xor $3 } + | expression '=>' expression { toE2 $1 $2 Implies $3 } + | expression '=' expression { toE2 $1 $2 Eq $3 } + | expression '<>' expression { toE2 $1 $2 Neq $3 } + | expression '<' expression { toE2 $1 $2 Lt $3 } + | expression '<=' expression { toE2 $1 $2 Leq $3 } + | expression '>' expression { toE2 $1 $2 Gt $3 } + | expression '>=' expression { toE2 $1 $2 Geq $3 } + | expression 'div' expression { toE2 $1 $2 Div $3 } + | expression 'mod' expression { toE2 $1 $2 Mod $3 } + | expression '-' expression { toE2 $1 $2 Sub $3 } + | expression '+' expression { toE2 $1 $2 Add $3 } + | expression '/' expression { toE2 $1 $2 Div $3 } + | expression '*' expression { toE2 $1 $2 Mul $3 } + | expression '**' expression { toE2 $1 $2 Power $3 } + + | expression '^' expression { toE2 $1 $2 Replicate $3 } + | expression '|' expression { toE2 $1 $2 Concat $3 } + + | 'if' expression + 'then' expression + 'else' expression { toITE $1 $2 $4 $6 } + + | 'with' expression + 'then' expression + 'else' expression { at $1 $6 (WithThenElse $2 $4 $6) } + + | 'merge' ident ListOf1(mergeCase) { toMerge $1 $2 $3 } + + | '#' '(' exprList ')' { toEN AtMostOne $1 $4 $3 } + | 'nor' '(' exprList ')' { toEN Nor $1 $4 $3 } + + | '[' exprList ']' { at $1 $3 (Array $2) } + + | expression '[' arraySel ']' { at $1 $4 (Select $1 $3) } + | expression '.' label { at $1 $3 (Select $1 (SelectField $3))} + + + | 'currentWith' '(' expression ',' expression ')' + { at $1 $6 (eOp2 $1 CurrentWith $3 $5 Nothing) } + | 'callWhen' '(' clockExpr ',' expression ')' + {% mkCallWhen $1 $6 $3 $5 } + + | effNode '(' exprList ')' { at $1 $4 (Call $1 $3 BaseClock Nothing) } + + | 'condact' '(' clockExpr ',' expression ',' expression ')' + {% mkCondact $1 $8 $3 $5 (Just $7)} + | 'condact' '(' clockExpr ',' expression ')' + {% mkCondact $1 $6 $3 $5 Nothing } + | 'condact' '(' BOOL',' expression ',' expression ')' + { mkConstCondact $3 $5 $7 } + | record { $1 } + | tuple { $1 } + + +tuple :: { Expression } + : '(' exprList ')' { at $1 $3 (tuple $2) } + +record :: { Expression } + : expression '{' '}' {% mkStruct $1 $3 [] } + | expression '{' SepEndBy1(';',field) '}' {% mkStruct $1 $4 $3 } + | expression '{' name 'with' SepEndBy1(';',field) '}' + {% mkStructU $1 $6 $3 $5 } + | expression '{' updFiled '}' { at $1 $4 (UpdateStruct Nothing $1 [$3])} + + + + + +mergeCase :: { (SourceRange, MergeCase Expression) } + : '(' mergePat '->' expression ')' { ($1 <-> $5, MergeCase $2 $4) } + +mergePat :: { Expression } + : name { Var $1 } + | BOOL { toLit $1 } + +simpExpr :: { Expression } + : INT { toLit $1 } + | REAL { toLit $1 } + | BOOL { toLit $1 } + | name { Var $1 } + | 'not' simpExpr { toE1 Not $1 $2 } + | '-' simpExpr %prec UMINUS { toE1 Neg $1 $2 } + + | simpExpr 'and' simpExpr { toE2 $1 $2 And $3 } + | simpExpr 'or' simpExpr { toE2 $1 $2 Or $3 } + | simpExpr 'xor' simpExpr { toE2 $1 $2 Xor $3 } + | simpExpr '=>' simpExpr { toE2 $1 $2 Implies $3 } + | simpExpr '=' simpExpr { toE2 $1 $2 Eq $3 } + | simpExpr '<>' simpExpr { toE2 $1 $2 Neq $3 } + | simpExpr '<' simpExpr { toE2 $1 $2 Lt $3 } + | simpExpr '<=' simpExpr { toE2 $1 $2 Leq $3 } + | simpExpr '>' simpExpr { toE2 $1 $2 Gt $3 } + | simpExpr '>=' simpExpr { toE2 $1 $2 Geq $3 } + | simpExpr 'div' simpExpr { toE2 $1 $2 Div $3 } + | simpExpr 'mod' simpExpr { toE2 $1 $2 Mod $3 } + | simpExpr '-' simpExpr { toE2 $1 $2 Sub $3 } + | simpExpr '+' simpExpr { toE2 $1 $2 Add $3 } + | simpExpr '/' simpExpr { toE2 $1 $2 Div $3 } + | simpExpr '*' simpExpr { toE2 $1 $2 Mul $3 } + | simpExpr '**' simpExpr { toE2 $1 $2 Power $3 } + + | 'if' simpExpr + 'then' simpExpr + 'else' simpExpr { toITE $1 $2 $4 $6 } + + | '(' ')' { at $1 $2 (Tuple []) } + | '(' simpExpr ')' { at $1 $3 $2 } + | '(' simpExpr ',' SepBy1(',',simpExpr) ')' { at $1 $3 (Tuple ($2 : $4)) } + + +field :: { Field Expression } + : label '=' expression { Field $1 $3 } + +updFiled :: { Field Expression } + : label ':=' expression { Field $1 $3 } + +clockExpr :: { ClockExpr } + : name '(' ident ')' { WhenClock ($1 <-> $4) (Var $1) $3 } + | ident { WhenClock (range $1) (Lit (Bool True)) $1 } + | 'not' ident { WhenClock ($1 <-> $2) (Lit (Bool False)) $2 } + | 'not' '(' ident ')' { WhenClock ($1 <-> $4) (Lit (Bool False)) $3 } + +arraySel :: { Selector Expression } + : expression { SelectElement $1 } + | arraySlice { SelectSlice $1 } + +arraySlice :: { ArraySlice Expression } + : expression '..' expression Opt(step) { ArraySlice $1 $3 $4 } + +step :: { Expression } + : 'step' expression { $2 } + +exprList :: { [Expression] } + : SepBy1(',',expression) { $1 } + | {- empty -} { [] } + +effNode :: { NodeInst } + : name { toNodeInst $1 [] } + | name '<<' SepBy1(staticArgSep,staticArg) '>>' { toNodeInst $1 $3 } + + +-- Static Arguments ------------------------------------------------------------ +-- The specific value for a static parameter. + +staticArgSep :: { () } + : ';' { () } + | ',' { () } + +staticArg :: { StaticArg } + : staticArgGen(noName) { snd $1 } + +noName :: { () } + : {- empty -} { () } + + +staticNamedArg :: { (Ident, StaticArg) } + : staticArgGen(withName) { $1 } + +withName :: { Ident } + : ident '=' { $1 } + +staticArgGen(nm) :: { (nm,StaticArg) } + : 'type' nm type { ($2, TypeArg $3) } + | 'const' nm expression { ($2, ExprArg $3) } + | nodeType nm effNode { ($2, NodeArg (thing $1) $3) } + | nm 'not' { ($1, op1Arg $2 Not) } + | nm 'fby' { ($1, op2Arg $2 Fby) } + | nm 'pre' { ($1, op1Arg $2 Pre) } + | nm 'current' { ($1, op1Arg $2 Current) } + | nm '->' { ($1, op2Arg $2 FbyArr) } + | nm 'and' { ($1, op2Arg $2 And) } + | nm 'or' { ($1, op2Arg $2 Or) } + | nm 'xor' { ($1, op2Arg $2 Xor) } + | nm '=>' { ($1, op2Arg $2 Implies) } + | nm '=' { ($1, op2Arg $2 Eq) } + | nm '<>' { ($1, op2Arg $2 Neq) } + | nm '<' { ($1, op2Arg $2 Lt) } + | nm '<=' { ($1, op2Arg $2 Leq) } + | nm '>' { ($1, op2Arg $2 Gt) } + | nm '>=' { ($1, op2Arg $2 Geq) } + | nm 'div' { ($1, op2Arg $2 Div) } + | nm 'mod' { ($1, op2Arg $2 Mod) } + | nm '-' { ($1, op2Arg $2 Sub) } + | nm '+' { ($1, op2Arg $2 Add) } + | nm '/' { ($1, op2Arg $2 Div) } + | nm '*' { ($1, op2Arg $2 Mul) } + | nm 'if' { ($1, opIf $2) } + | nm name '<<' SepBy1(staticArgSep,staticArg) '>>' + { ($1, NodeArg Node (toNodeInst $2 $4) )} + | nm simpleType { ($1, TypeArg $2) } + | nm simpExpr { ($1, ExprArg $2) } + + +-- Names and Identifiers ------------------------------------------------------- + +name :: { Name } + : ident { Unqual $1 } + | QIDENT { toQIdent $1 } + + +label :: { Label } + : IDENT { toLabel $1 } + | 'mode' { Label "mode" $1 } + +ident :: { Ident } + : label { toIdent $1 } + + +-- Combinators ----------------------------------------------------------------- + + +Perhaps(x) :: { Maybe SourceRange } + : {- nothing -} { Nothing } + | x { Just (range $1) } + +Opt(x) :: { Maybe x } + : {- nothing -} { Nothing } + | x { Just $1 } + +ListOf(thing) :: { [thing] } + : { [] } + | ListOf1(thing) { $1 } + +ListOf1(thing) :: { [thing] } + : ListOf1_rev(thing) { reverse $1 } + +ListOf1_rev(thing) :: { [thing] } + : thing { [$1] } + | ListOf1_rev(thing) thing { $2 : $1 } + +SepBy1(sep,thing) :: { [thing] } + : SepBy1_rev(sep,thing) { reverse $1 } + +SepBy1_rev(sep,thing) :: { [thing] } + : thing { [$1] } + | SepBy1_rev(sep,thing) sep thing { $3 : $1 } + + +EndBy1(sep,thing) :: { [thing] } + : EndBy1_rev(sep,thing) { reverse $1 } + +EndBy1_rev(sep,thing) :: { [thing] } + : thing sep { [$1] } + | EndBy1_rev(sep,thing) thing sep { $2 : $1 } + + +SepEndBy1(sep,thing) :: { [thing] } + : thing { [$1] } + | thing sep { [$1] } + | thing sep SepEndBy1(sep,thing) { $1 : $3 } + + + + +{ + +class At t where + at :: (HasRange a, HasRange b) => a -> b -> t -> t + +instance At Expression where + at x y = ERange (x <-> y) + +instance At Type where + at x y = TypeRange (x <-> y) + +instance At StaticArg where + at x y = ArgRange (x <-> y) + +data Located a = Located { loc :: SourceRange, thing :: a } + +instance HasRange (Located a) where + range = loc + +optR :: (HasRange a, HasRange b) => Maybe a -> b -> SourceRange +optR x y = case x of + Nothing -> range y + Just a -> range a + +lat :: HasRange a => a -> b -> Located b +lat x y = Located { loc = range x, thing = y } + +mkNodeProfile :: + Located [InputBinder] -> Located [Binder] -> Located NodeProfile +mkNodeProfile xs ys = + Located { loc = loc xs <-> loc ys + , thing = NodeProfile { nodeInputs = thing xs + , nodeOutputs = thing ys } + } + + +-------------------------------------------------------------------------------- + +toE1 :: Op1 -> SourceRange -> Expression -> Expression +toE1 op rng expr = ERange (rng <-> expr) (callPrim rng (Op1 op) [expr]) + +toE2 :: Expression -> SourceRange -> Op2 -> Expression -> Expression +toE2 e1 rng op e2 = ERange (e1 <-> e2) (callPrim rng (Op2 op) [e1,e2]) + +toEN :: OpN -> SourceRange -> SourceRange -> [Expression] -> Expression +toEN op r1 r2 es = ERange (r1 <-> r2) (callPrim r1 (OpN op) es) + +toITE :: SourceRange -> Expression -> Expression -> Expression -> Expression +toITE r e1 e2 e3 = ERange (r <-> e3) (callPrim r ITE [e1,e2,e3]) + +-------------------------------------------------------------------------------- + +toLabel :: Lexeme Token -> Label +toLabel l = Label { labText = lexemeText l + , labRange = lexemeRange l + } + +toIdent :: Label -> Ident +toIdent l = Ident { identLabel = l + , identResolved = Nothing + } + +toQIdent :: Lexeme Token -> Name +toQIdent l = + case lexemeToken l of + TokQualIdent p n -> Qual (Module p) + Ident { identLabel = Label { labText = n + , labRange = lexemeRange l + } + , identResolved = Nothing + } + _ -> panic "toQIdent" [ "Not a qualified identifier", show l ] + + +toLit :: Lexeme Token -> Expression +toLit l = + ERange (lexemeRange l) $ + Lit $ + case lexemeToken l of + TokInt n -> Int n + TokReal n -> Real n + TokBool n -> Bool n + _ -> panic "toLit" [ "Unexcpected literal", show l ] + +toMerge :: SourceRange -> Ident -> + [(SourceRange,MergeCase Expression)] -> Expression +toMerge r1 x opts = at r1 (last rs) (Merge x cs) + where + (rs,cs) = unzip opts + +-------------------------------------------------------------------------------- + +toTypeDecl :: Ident -> Maybe TypeDef -> TypeDecl +toTypeDecl i d = TypeDecl { typeName = i, typeDef = d } + +class ToFieldType t where + toFieldType :: t -> [FieldType] + +instance ToFieldType (Label, Type, Expression) where + toFieldType (x,t,e) = [ FieldType { fieldName = x, fieldType = t + , fieldDefault = Just e } ] + +instance ToFieldType (Label, Type) where + toFieldType (x,t) = [ FieldType { fieldName = x, fieldType = t + , fieldDefault = Nothing } ] + +instance ToFieldType (Label, [Label], Type) where + toFieldType (i,is,t) = [ d | x <- i : is, d <- toFieldType (x,t) ] + +-------------------------------------------------------------------------------- + + +class ToConstDef1 t where + toConstDef1 :: t -> ConstDef + +instance ToConstDef1 (Ident, Type) where + toConstDef1 (i,t) = ConstDef { constName = i + , constType = Just t + , constDef = Nothing + } + +instance ToConstDef1 (Ident,Expression) where + toConstDef1 (i,e) = ConstDef { constName = i + , constType = Nothing + , constDef = Just e + } + +instance ToConstDef1 (Ident,Type,Expression) where + toConstDef1 (i,t,e) = ConstDef { constName = i + , constType = Just t + , constDef = Just e + } + + +class ToConstDef t where + toConstDef :: t -> [ ConstDef ] + +instance ToConstDef (Ident, Type) where + toConstDef x = [ toConstDef1 x ] + +instance ToConstDef (Ident, [Ident], Type) where + toConstDef (i, is, t) = [ d | x <- i:is, d <- toConstDef (i,t) ] + +instance ToConstDef (Ident,Expression) where + toConstDef x = [ toConstDef1 x ] + +instance ToConstDef (Ident,Type,Expression) where + toConstDef x = [ toConstDef1 x ] + +-------------------------------------------------------------------------------- + +simpBinder :: Ident -> Type -> Binder +simpBinder i t = Binder { binderDefines = i + , binderType = CType { cType = t, cClock = BaseClock } + } + +toVarDeclBase :: ([Ident], Type) -> [ Binder ] +toVarDeclBase (xs,t) = [ simpBinder x t | x <- xs ] + +toVarDecl :: ([Ident], Type) -> ClockExpr -> [ Binder ] +toVarDecl (xs,t) c = [ Binder { binderDefines = x + , binderType = CType { cType = t + , cClock = KnownClock c } + } | x <- xs ] + +isUnsafe :: Maybe SourceRange -> Safety +isUnsafe unsafe = case unsafe of + Just _ -> Unsafe + Nothing -> Safe + +-------------------------------------------------------------------------------- + +toNodeInst :: Name -> [ StaticArg ] -> NodeInst +toNodeInst nm xs = NodeInst c xs + where + c = case nm of + Unqual i + -- XXX: Use KW? Or maybe just use names everywhere and + -- identify built-ins in some name resultion pass... + | txt == "fill" -> iter IterFill + | txt == "red" -> iter IterRed + | txt == "fillred" -> iter IterFillRed + | txt == "map" -> iter IterMap + | txt == "boolred" -> iter IterBoolRed + where + txt = identText i + iter x = CallPrim (identRange i) (Iter x) + _ -> CallUser nm + +primArg :: SourceRange -> PrimNode -> StaticArg +primArg r p = NodeArg Function (NodeInst (CallPrim r p) []) + +op1Arg :: SourceRange -> Op1 -> StaticArg +op1Arg r p = primArg r (Op1 p) +op2Arg r p = primArg r (Op2 p) +opIf r = primArg r ITE + +-- | Call a primitive with no static parameters +callPrim :: SourceRange -> PrimNode -> [Expression] -> Expression +callPrim r p es = Call (NodeInst (CallPrim r p) []) es BaseClock Nothing + + +-------------------------------------------------------------------------------- + +tuple :: [Expression] -> Expression +tuple xs = + case xs of + [x] -> x + _ -> Tuple xs + + +mkStruct :: Expression -> SourceRange -> [Field Expression] -> Parser Expression +mkStruct e r2 fs = + do x <- toName e + pure $ at e r2 $ Struct x fs + where + toName e0 = + case e0 of + ERange _ e1 -> toName e1 + Var x -> pure x + _ -> happyErrorAt (sourceFrom (range e)) + +mkStructU :: + Expression -> SourceRange -> Name -> [Field Expression] -> Parser Expression +mkStructU e r2 y fs = + do x <- toName e + pure $ at e r2 $ UpdateStruct (Just x) (Var y) fs + where + toName e0 = + case e0 of + ERange _ e1 -> toName e1 + Var x -> pure x + _ -> happyErrorAt (sourceFrom (range e)) + + + + +-------------------------------------------------------------------------------- + +mkContract :: SourceRange -> [ContractItem] -> SourceRange -> Contract +mkContract r1 cs r2 = Contract { contractRange = r1 <-> r2 + , contractItems = cs } + + +-------------------------------------------------------------------------------- + + +mkConstCondact :: Lexeme Token -> Expression -> Expression -> Expression +mkConstCondact l e1 e2 = + case lexemeToken l of + TokBool b -> if b then e1 else e2 + _ -> panic "mkConstCondact" [ "Unexcpected literal", show l ] + +mkCondact :: SourceRange -> SourceRange -> + ClockExpr -> Expression -> Maybe Expression -> Parser Expression +mkCondact r1 r2 c e mb = + do e1 <- checkCall r1 e + pure $ at r1 r2 + $ case mb of + Nothing -> eOp1 r1 Current e1 Nothing + Just d -> eOp2 r1 CurrentWith d e1 Nothing + where + checkCall l e = + case e of + ERange r e1 -> ERange r <$> checkCall r e1 + Call f es BaseClock mTys -> + pure (Call f [ e `When` c | e <- es ] (KnownClock c) mTys) + _ -> happyErrorAt (sourceFrom l) + +mkCallWhen :: + SourceRange -> SourceRange -> ClockExpr -> Expression -> Parser Expression +mkCallWhen r1 r2 c e = at r1 r2 <$> checkCall r1 e + where + checkCall l e = + case e of + ERange r e1 -> ERange r <$> checkCall r e1 + Call f es BaseClock mTys -> pure (Call f es (KnownClock c) mTys) + _ -> happyErrorAt (sourceFrom l) + + +-------------------------------------------------------------------------------- + +propName :: SourceRange -> Expression -> Label +propName rng e = case e of + ERange _ e1 -> propName rng e1 + Var x -> Label + { labText = Text.pack (showPP x) + , labRange = rng + } + _ -> Label + { labText = synthName + , labRange = rng + } + where + synthName = "Prop on line " <> Text.pack (show (sourceLine (sourceFrom rng))) + + + +addContractItemBody :: NodeBody -> ContractItem -> Parser NodeBody +addContractItemBody bod ci = + case ci of + Assume l e -> pure bod { nodeEqns = Assert l AssertPre e : nodeEqns bod } + Guarantee l e -> pure bod { nodeEqns = Property l e : nodeEqns bod } + GhostConst d -> pure bod { nodeLocals = LocalConst d : nodeLocals bod } + GhostVar b e -> pure bod { nodeLocals = LocalVar b : nodeLocals bod + , nodeEqns = Define [ LVar (binderDefines b) ] e + : nodeEqns bod + } + Mode i _ _ -> happyErrorAt (sourceFrom (range i)) + Import i _ _ -> happyErrorAt (sourceFrom (range i)) + +desugarContract :: NodeDecl -> Parser NodeDecl +desugarContract d = + case nodeContract d of + Nothing -> pure d + Just c -> + do b <- foldM addContractItemBody bod0 (contractItems c) + pure d { nodeDef = Just b, nodeContract = Nothing } + where + bod0 = case nodeDef d of + Nothing -> NodeBody { nodeLocals = [], nodeEqns = [] } + Just b -> b + + + + +-------------------------------------------------------------------------------- + + + +-------------------------------------------------------------------------------- + +-- | Parse a program from the given source. +-- We throw a 'ParseError' exception if we fail to parse a program. +parseProgramFrom :: Text {- ^ Label for parse errors -} -> + IO Text {- ^ The text to parse -} -> + IO Program {- ^ The parsed program, or exception -} +parseProgramFrom lab io = + do txt <- io + case parse program lab txt of + Left err -> throwIO err + Right a -> pure a + +-- | Parse a program from a UTF-8 encoded file. +-- May throw 'ParseEror' or exceptions related to reading and decoding the file. +parseProgramFromFileUTF8 :: FilePath -> IO Program +parseProgramFromFileUTF8 file = + parseProgramFrom (Text.pack file) (Text.readFile file) + +-- | Parse a program from a Latin-1 encoded file. +-- May throw 'ParseEror' or exceptions related to reading and decoding the file. +parseProgramFromFileLatin1 :: FilePath -> IO Program +parseProgramFromFileLatin1 file = + parseProgramFrom (Text.pack file) (Text.decodeLatin1 <$> BS.readFile file) + +} diff --git a/Language/Lustre/Parser/Lexer.x b/Language/Lustre/Parser/Lexer.x new file mode 100644 --- /dev/null +++ b/Language/Lustre/Parser/Lexer.x @@ -0,0 +1,427 @@ +{ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module Language.Lustre.Parser.Lexer + ( lexer + , testLexer + , Lexeme(..) + , Token(..) + , Input(..), initialInput + , SourceRange(..) + , SourcePos(..) + , prettySourceRange + ) where +import Data.Text(Text) +import qualified Data.Text as Text +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Char(isAscii,toLower) +import Data.Ratio((%)) + +import AlexTools +} + + +$letter = [a-zA-Z_] +$octdigit = 0-7 +$digit = 0-9 +$hexdigit = [0-9a-fA-F] + +@ident = $letter ($letter | $digit)* +@qident = @ident "::" @ident + +@digs8 = [0-7]+ +@digs16 = [0-9A-Fa-f]+ + +@sign = [\+\-] +@num8 = "0o" @digs8 +@num10 = [0-9]+ +@num16 = "0x" @digs16 + + +@exp10 = [Ee] @sign? @num10 +@exp16 = [Pp] @sign? @num10 +@float10 = @num10 @exp10 + | (@num10 "." @num10?) @exp10? + | (@num10? "." @num10) @exp10? +@float16 = @num16 @exp16 + | (@num16 "." @digs16?) @exp16? + | ("0x" @digs16? "." @digs16) @exp16? + +@line_comment = "--"[^\%].* | "--" +@special_comment = "--%"($letter|$digit)* +@special_block = ("(*@" | "/*@")($letter|$digit)* + +:- + + { +"*)" { setLexerState 0 >> pure [] } +. ; +\n ; +} + + { +"*/" { setLexerState 0 >> pure [] } +. ; +\n ; +} + + +<0> { +$white+ ; +@line_comment ; +@special_comment { specialComment specialLine } + +"(*" { setLexerState parenBlockComment >> pure [] } +"/*" { setLexerState slashBlockComment >> pure [] } +@special_block { specialComment specialBlock } +"*/" { lexeme TokEndSlashComment } +"*)" { lexeme TokEndParenComment } + +"package" { lexeme TokKwPackage } +"model" { lexeme TokKwModel } +"uses" { lexeme TokKwUses } +"needs" { lexeme TokKwNeeds } +"provides" { lexeme TokKwProvides } +"is" { lexeme TokKwIs } +"body" { lexeme TokKwBody } +"end" { lexeme TokKwEnd } + +"when" { lexeme TokKwWhen } +"current" { lexeme TokKwCurrent } +"currentWith" { lexeme TokKwCurrentWith } +"condact" { lexeme TokKwCondact } +"callWhen" { lexeme TokKwCallWhen } +"pre" { lexeme TokKwPre } +"fby" { lexeme TokKwFby } +"->" { lexeme TokRightArrow } + +"div" { lexeme TokKwDiv } +"mod" { lexeme TokKwMod } +"+" { lexeme TokPlus } +"-" { lexeme TokMinus } +"*" { lexeme TokStar } +"**" { lexeme TokStarStar } +"/" { lexeme TokDiv } + + +"with" { lexeme TokKwWith } +"if" { lexeme TokKwIf } +"else" { lexeme TokKwElse } +"then" { lexeme TokKwThen } +"merge" { lexeme TokKwMerge } + +"step" { lexeme TokKwStep } +".." { lexeme TokDotDot } +"|" { lexeme TokBar } +"^" { lexeme TokHat } + +"#" { lexeme TokHash } +"not" { lexeme TokKwNot } +"xor" { lexeme TokKwXor } +"or" { lexeme TokKwOr } +"and" { lexeme TokKwAnd } +"nor" { lexeme TokKwNor } +"true" { lexeme (TokBool True) } +"false" { lexeme (TokBool False) } + +"=>" { lexeme TokImplies } +"<" { lexeme TokLt } +"<=" { lexeme TokLeq } +"=" { lexeme TokEq } +">=" { lexeme TokGeq } +">" { lexeme TokGt } +"<>" { lexeme TokNotEq } +":=" { lexeme TokColonEq } + + +"int" { lexeme TokKwInt } +"real" { lexeme TokKwReal } +"bool" { lexeme TokKwBool } +"floor" { lexeme TokKwFloor } -- jkind +"subrange" { lexeme TokKwSubrange } -- jkind +"of" { lexeme TokKwOf } -- jkind + +"unsafe" { lexeme TokKwUnsafe } +"extern" { lexeme TokKwExtern } +"imported" { lexeme TokKwImported } +"node" { lexeme TokKwNode } +"function" { lexeme TokKwFunction } +"returns" { lexeme TokKwReturns } + +"type" { lexeme TokKwType } +"const" { lexeme TokKwConst } +"var" { lexeme TokKwVar } +"struct" { lexeme TokKwStruct } +"enum" { lexeme TokKwEnum } +"contract" { lexeme TokKwContract } +"import" { lexeme TokKwImport } +"assert" { lexeme TokKwAssert } +"assume" { lexeme TokKwAssume } +"guarantee" { lexeme TokKwGuarantee } +"mode" { lexeme TokKwEnsure } +"require" { lexeme TokKwRequire } +"ensure" { lexeme TokKwEnsure } + +"%" { lexeme TokMod } +":" { lexeme TokColon } +"," { lexeme TokComma } +";" { lexeme TokSemi } +"." { lexeme TokDot } +"(" { lexeme TokOpenParen } +")" { lexeme TokCloseParen } +"<<" { lexeme TokOpenTT } +">>" { lexeme TokCloseTT } +"[" { lexeme TokOpenBracket } +"]" { lexeme TokCloseBracket } +"{" { lexeme TokOpenBrace } +"}" { lexeme TokCloseBrace } +"let" { lexeme TokKwLet } +"tel" { lexeme TokKwTel } + +@ident { lexeme TokIdent } +@ident "::" @ident { qualIdent } +@num8 { lexeme' . TokInt . integerAtBase 8 =<< matchText } +@num10 { lexeme' . TokInt . integerAtBase 10 =<< matchText } +@num10 ".." { numDotDot } -- to avoid conflict with slices +@num16 { lexeme' . TokInt . integerAtBase 16 =<< matchText } +@float10 { lexeme' . TokReal . floating 10 =<< matchText } +@float16 { lexeme' . TokReal . floating 16 =<< matchText } + +. { lexeme TokError } +} + +{ + +data Token = + TokIdent + | TokQualIdent Text Text + | TokInt !Integer + | TokReal !Rational + + | TokKwPackage | TokKwModel + | TokKwIs + | TokKwUses | TokKwNeeds | TokKwProvides + | TokKwBody | TokKwEnd + + | TokKwIf | TokKwThen | TokKwElse + | TokKwWith | TokKwMerge + + + | TokKwExtern + | TokKwUnsafe + | TokKwImported + | TokKwNode + | TokKwFunction + | TokKwReturns + + | TokKwType + | TokKwConst + | TokKwVar + | TokKwLet + | TokKwTel + | TokKwStruct + | TokKwEnum + + | TokKwContract + | TokKwAssert + | TokKwAssume + | TokKwGuarantee + | TokKwMode + | TokKwRequire + | TokKwEnsure + | TokKwImport + | TokStartSlashCommentContract + | TokEndSlashComment + | TokStartParenCommentContract + | TokEndParenComment + + + + | TokKwCurrent + | TokKwCurrentWith + | TokKwCondact + | TokKwCallWhen + | TokKwPre + | TokKwWhen + + | TokKwAnd + | TokKwNot + | TokKwOr + | TokKwXor + | TokKwNor + | TokBool Bool + + | TokKwDiv + | TokKwMod + + | TokKwInt + | TokKwReal + | TokKwBool + | TokKwFloor + + | TokKwStep + | TokKwFby + + | TokPragmaProperty + | TokPragmaMain + | TokPragmaIVC + | TokPragmaRealizable + + | TokColon + | TokComma + | TokSemi + | TokDot + | TokDotDot + | TokColonEq + + | TokOpenParen + | TokCloseParen + | TokOpenTT + | TokCloseTT + | TokOpenBracket + | TokCloseBracket + | TokOpenBrace + | TokCloseBrace + + | TokRightArrow + | TokImplies + | TokLt | TokLeq | TokEq | TokGeq | TokGt | TokNotEq + | TokPlus | TokMinus | TokStar | TokStarStar | TokDiv | TokMod + | TokHash + | TokHat + | TokBar + + | TokKwSubrange + | TokKwOf + + | TokEOF + | TokError + deriving (Eq,Show) + + +lexeme' :: Token -> Action s [Lexeme Token] +lexeme' t = lexeme $! t + +numDotDot :: Action s [ Lexeme Token ] +numDotDot = + do (num,dots) <- Text.break (== '.') <$> matchText + SourceRange { sourceFrom = from, sourceTo = to } <- matchRange + let mid = prevPos to + return [ Lexeme { lexemeText = num + , lexemeToken = TokInt (integerAtBase 10 num) + , lexemeRange = SourceRange { sourceFrom = from + , sourceTo = prevPos mid } } + , Lexeme { lexemeText = dots + , lexemeToken = TokDotDot + , lexemeRange = SourceRange { sourceFrom = mid + , sourceTo = to } } + ] + + +specialComment :: Map Text Token -> Action s [ Lexeme Token ] +specialComment known = + do txt <- matchText + rng <- matchRange + pure [ Lexeme { lexemeText = txt + , lexemeToken = Map.findWithDefault TokError txt known + , lexemeRange = rng } ] + +specialBlock :: Map Text Token +specialBlock = Map.fromList + [ ("(*@contract", TokStartParenCommentContract) + , ("/*@contract", TokStartSlashCommentContract) + ] + +specialLine :: Map Text Token +specialLine = Map.fromList + [ ("--%PROPERTY", TokPragmaProperty) + , ("--%MAIN", TokPragmaMain) + , ("--%IVC", TokPragmaIVC) + , ("--%REALIZABLE", TokPragmaRealizable) + ] + + + +qualIdent :: Action s [ Lexeme Token ] +qualIdent = + do ~[a,b] <- Text.splitOn "::" <$> matchText + lexeme (TokQualIdent a b) + +integerAtBase :: Integer -> Text -> Integer +integerAtBase base txt = if sgn == "-" then negate aval else aval + where + aval = Text.foldl' addDig 0 digs + (sgn,txt0) = splitSign (Text.map toLower txt) + digs = Text.dropWhile (\x -> x == '0' || x == 'x' || x == 'o') txt0 + + addDig s x = s * base + (if y < a then y - z else 10 + (y - a)) + where + y = val x + a = val 'a' + z = val '0' + val = fromIntegral . fromEnum + +splitSign :: Text -> (Text,Text) +splitSign = Text.span (\x -> x == '+' || x == '-') + +floating :: Integer -> Text -> Rational +floating fb txt = + case Text.splitOn exSym (Text.map toLower txt) of + [base] -> parseBase base + [base,ex] + | e >= 0 -> b * fromInteger exVal ^ e + | otherwise -> b / fromInteger exVal ^ abs e + where + e = integerAtBase 10 ex + b = parseBase base + + _ -> error "[bug] unexpected floating number" + where + (exSym,exVal,dbase) = if fb == 10 then ("e",10,10) else ("p",2,16) + + parseBase base = + let (sign,rest) = splitSign base + addSign = if sign == "-" then negate else id + in addSign + $ case Text.splitOn "." rest of + [x] -> fromInteger (integerAtBase dbase x) + [x,y] -> fromInteger (integerAtBase dbase x) + + integerAtBase dbase y % dbase ^ Text.length y + _ -> error "[bug] unexpected floating number base" + + +alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) +alexGetByte = makeAlexGetByte toByte + where + toByte ch | isAscii ch = fromIntegral (fromEnum ch) + | otherwise = 0 -- Should cause an error token to be emitted + +lexer :: Input -> [Lexeme Token] +lexer = $makeLexer cfg { lexerEOF = \_ p -> [eof p] } + where eof p = Lexeme { lexemeToken = TokEOF + , lexemeText = "" + , lexemeRange = AlexTools.range p + } + err p = Lexeme { lexemeToken = TokError + , lexemeText = "Unterminated comment." + , lexemeRange = AlexTools.range p + } + cfg = LexerConfig { lexerInitialState = 0 + , lexerStateMode = id + , lexerEOF = \s p -> + [ if s == 0 then eof p else err p ] + } + +testLexer :: String -> [Lexeme Token] +testLexer txt = lexer + Input { inputPos = p0 + , inputText = Text.pack txt + , inputPrev = prevPos p0 + , inputPrevChar = '\n' + } + where p0 = startPos "(test)" +} + + diff --git a/Language/Lustre/Parser/Monad.hs b/Language/Lustre/Parser/Monad.hs new file mode 100644 --- /dev/null +++ b/Language/Lustre/Parser/Monad.hs @@ -0,0 +1,109 @@ +{-# Language OverloadedStrings #-} +module Language.Lustre.Parser.Monad + ( Parser + , parseStartingAt + , parse + , happyGetToken + , happyError + , happyErrorAt + , ParseError(..) + ) where + +import Control.Monad(liftM,ap) +import Control.Exception (Exception) +import Data.Text(Text) +import AlexTools(prevPos, startPos, range) +import Text.PrettyPrint + +import Language.Lustre.Parser.Lexer +import Language.Lustre.Pretty +import Language.Lustre.Panic + +newtype Parser a = Parser (PState -> Either ParseError (a, PState)) + +data PState = PState + { curToken :: Maybe (Lexeme Token) + , nextToknes :: [Lexeme Token] + } + +{-| Run the given parser on the input text. We always try to parse the +whole text, starting at the input, and report an error if there was +left-overs at the end. + +The given source position should correspond to the first character in +the text. -} +parseStartingAt :: + Parser a {- ^ Describes how to parse the input -} -> + SourcePos {- ^ Location for the first character in the text -} -> + Text {- ^ Parse this text -} -> + Either ParseError a +parseStartingAt (Parser m) p txt = + case m s0 of + Left err -> Left err + Right (a,sFin) -> + case nextToknes sFin of + [] -> Right a + l : _ -> Left $ ParseError $ lexemeRange l + where + s0 = PState { curToken = Nothing, nextToknes = lexer input } + + input = Input { inputPos = p + , inputText = txt + , inputPrev = pPos + , inputPrevChar = + if sourceLine pPos == sourceLine p then ' ' else '\n' + } + pPos = prevPos p + +parse :: Parser a {- ^ Describes how to parse -} -> + Text {- ^ Name for the input text (e.g., file name) -} -> + Text {- ^ The text to parse -} -> + Either ParseError a +parse p inp = p `parseStartingAt` startPos inp + + + + +instance Functor Parser where + fmap = liftM + +instance Applicative Parser where + pure a = Parser (\ls -> Right (a,ls)) + (<*>) = ap + +instance Monad Parser where + Parser m >>= k = Parser (\ls -> case m ls of + Left err -> Left err + Right (a,ls1) -> + let Parser m1 = k a + in m1 ls1) + +happyGetToken :: (Lexeme Token -> Parser a) -> Parser a +happyGetToken k = Parser $ \s -> + case nextToknes s of + [] -> panic "happyGetToken" ["We run out of tokens.", "Missing TokEOF?"] + t : ts -> let Parser m = k t + in m PState { curToken = Just t, nextToknes = ts } + +newtype ParseError = ParseError SourceRange + deriving Show + +instance Exception ParseError + +happyErrorAt :: SourcePos -> Parser a +happyErrorAt p = Parser (\_ -> Left (ParseError (range p))) + +happyError :: Parser a +happyError = Parser $ \s -> + Left $ ParseError + $ case curToken s of + Nothing -> + case nextToknes s of + [] -> panic "happyGetToken" ["We run out of tokens.", "Missing TokEOF?"] + t : _ -> lexemeRange t + Just t -> lexemeRange t + +instance Pretty ParseError where + ppPrec _ (ParseError x) = + text (prettySourceRange x ++ ": Parse error.") + diff --git a/Language/Lustre/Phase.hs b/Language/Lustre/Phase.hs new file mode 100644 --- /dev/null +++ b/Language/Lustre/Phase.hs @@ -0,0 +1,22 @@ +module Language.Lustre.Phase where + +import Data.Set(Set) +import qualified Data.Set as Set + +data LustrePhase = PhaseRename + | PhaseTypecheck + | PhaseNoStatic + | PhaseNoStruct + | PhaseInline + | PhaseToCore + deriving (Show,Eq,Ord,Enum,Bounded) + +noPhases :: Set LustrePhase +noPhases = Set.empty + +allPhases :: Set LustrePhase +allPhases = Set.fromList [ minBound .. maxBound ] + +phases :: [LustrePhase] -> Set LustrePhase +phases = Set.fromList + diff --git a/Language/Lustre/Pretty.hs b/Language/Lustre/Pretty.hs new file mode 100644 --- /dev/null +++ b/Language/Lustre/Pretty.hs @@ -0,0 +1,539 @@ +{-# Language OverloadedStrings #-} +module Language.Lustre.Pretty where + +import Data.Semigroup ( (<>) ) +import Data.Text (Text) +import Data.List(intersperse) +import qualified Data.Text as Text +import Text.PrettyPrint hiding ( (<>) ) +import qualified Text.PrettyPrint as PP +import Numeric(showGFloat) +import Data.Ratio(numerator,denominator) + +import Language.Lustre.AST +import Language.Lustre.Name +import Language.Lustre.Panic(panic) +import AlexTools(prettySourceRange) + +class Pretty t where + ppPrec :: Int -> t -> Doc + +-- | Pretty print with precedence 0. +pp :: Pretty t => t -> Doc +pp = ppPrec 0 + +-- | Pretty print with precedence 0, then convert to a 'String'. +showPP :: Pretty t => t -> String +showPP = show . pp + +-- | Join vertically, with a space between each element. +vcatSep :: [Doc] -> Doc +vcatSep = vcat . intersperse " " + +commaSep :: [Doc] -> Doc +commaSep = hsep . punctuate comma + +bullet :: Doc +bullet = "•" + +bullets :: [Doc] -> Doc +bullets xs = vcat [ bullet <+> x | x <- xs ] + +backticks :: Doc -> Doc +backticks x = "`" PP.<> x PP.<> "`" + +nested :: Doc -> Doc -> Doc +nested x y = x $$ nest 2 y + +instance Pretty Text where + ppPrec _ = text . Text.unpack + +instance Pretty SourceRange where + ppPrec _ = text . prettySourceRange + +instance Pretty Ident where + ppPrec n i = ppPrec n (identText i) {- <> _mbId -} + where _mbId = case identResolved i of + Nothing -> "?" + Just on -> int (rnUID on) + +instance Pretty Name where + ppPrec n nam = + case nam of + Unqual i -> ppPrec n i + Qual x y -> ppPrec n x PP.<> "::" PP.<> ppPrec n y + +-------------------------------------------------------------------------------- + +instance Pretty Integer where + ppPrec _ = integer + +instance Pretty Int where + ppPrec _ x = text (show x) + +instance Pretty TopDecl where + ppPrec n td = + case td of + DeclareType dt -> ppPrec n dt + DeclareConst cd -> ppPrec n cd <> semi + DeclareNode nd -> ppPrec n nd + DeclareNodeInst nid -> ppPrec n nid + DeclareContract cd -> ppPrec n cd + +instance Pretty ConstDef where + ppPrec _ def = "const" <+> pp (constName def) <+> + opt ":" (constType def) <+> + opt "=" (constDef def) + where + opt x y = case y of + Nothing -> empty + Just a -> x <+> pp a + +instance Pretty TypeDecl where + ppPrec _ t = "type" <+> pp (typeName t) <+> mbDef + where mbDef = case typeDef t of + Nothing -> semi + Just d -> "=" <+> pp d PP.<> semi + +instance Pretty TypeDef where + ppPrec _ td = + case td of + IsType t -> pp t + IsEnum is -> "enum" <+> braces (hsep (punctuate comma (map pp is))) + IsStruct fs -> braces (vcat (punctuate semi (map pp fs))) + +instance Pretty NodeInstDecl where + ppPrec _ nid = + ppSafetyOpt (nodeInstSafety nid) <+> + pp (nodeInstType nid) <+> + pp (nodeInstName nid) <+> + ppSaticParams (nodeInstStaticInputs nid) <+> + profDoc <+> + "=" <+> pp (nodeInstDef nid) PP.<> semi + where + profDoc = + case nodeInstProfile nid of + Nothing -> empty + Just p -> pp p + +ppSaticParams :: [StaticParam] -> Doc +ppSaticParams xs = + case xs of + [] -> empty + _ -> "<<" PP.<> hsep (punctuate semi (map pp xs)) PP.<> ">>" + +instance Pretty NodeProfile where + ppPrec _ np = + parens (hsep (punctuate semi (map pp (nodeInputs np)))) <+> + "returns" <+> parens (hsep (punctuate semi (map pp (nodeOutputs np)))) + +instance Pretty InputBinder where + ppPrec n ib = + case ib of + InputBinder b -> ppPrec n b + InputConst i t -> "const" <+> pp i <+> ":" <+> pp t + +instance Pretty Binder where + ppPrec _ b = pp (binderDefines b) <+> ":" <+> pp (cType ty) <+> clockDoc + where + ty = binderType b + clockDoc = case cClock ty of + BaseClock -> empty + KnownClock c -> "when" <+> pp c + ClockVar i -> "when" <+> pp i + +instance Pretty StaticParam where + ppPrec _ sp = + case sp of + TypeParam i -> "type" <+> pp i + ConstParam i t -> "const" <+> pp i <+> ":" <+> pp t + NodeParam s nt f p -> ppSafetyOpt s <+> pp nt <+> pp f <+> pp p + + +instance Pretty NodeDecl where + ppPrec _ nd = + ppSafetyOpt (nodeSafety nd) <+> + (if nodeExtern nd then "extern" else empty) <+> + pp (nodeType nd) <+> + pp (nodeName nd) <+> + ppSaticParams (nodeStaticInputs nd) <+> + pp (nodeProfile nd) $$ + maybe empty pp (nodeContract nd) $$ + bodyDoc + where bodyDoc = case nodeDef nd of + Nothing -> semi + Just x -> pp x + +instance Pretty NodeBody where + ppPrec _ nb = + nest 2 (vcat [ pp d <> semi | d <- nodeLocals nb ]) $$ + "let" $$ + nest 2 (vcat [ pp d <> semi | d <- nodeEqns nb ]) $$ + "tel" + +instance Pretty LocalDecl where + ppPrec _ ld = + case ld of + LocalVar b -> "var" <+> pp b + LocalConst c -> "const" <+> pp c + +instance Pretty Equation where + ppPrec _ eqn = + case eqn of + Assert _ ty e -> "assert" <+> tyd <+> pp e + where tyd = case ty of + AssertPre -> empty + AssertEnv -> "/*env*/" + Define ls e -> lhs <+> "=" <+> pp e + where lhs = case ls of + [] -> "()" + _ -> hsep (map pp ls) + IsMain _ -> "--%MAIN" + IVC is -> "--%IVC" <+> commaSep (map pp is) + Realizable is -> "--%REALIZABLE" <+> commaSep (map pp is) + Property _ e -> "--%PROPERTY" <+> pp e + +instance Pretty e => Pretty (LHS e) where + ppPrec _ lhs = + case lhs of + LVar x -> pp x + LSelect l s -> pp l <> pp s + +-------------------------------------------------------------------------------- + + +instance Pretty FieldType where + ppPrec _ ft = pp (fieldName ft) <+> pp (fieldType ft) <+> optVal + where optVal = case fieldDefault ft of + Nothing -> empty + Just e -> "=" <+> pp e + +instance Pretty Type where + ppPrec n ty = + case ty of + NamedType x -> pp x + ArrayType t e -> pp t <+> "^" <+> pp e -- precedence? + IntType -> "int" + RealType -> "real" + BoolType -> "bool" + IntSubrange e1 e2 -> + "subrange" <+> brackets (hsep (punctuate comma (map pp [e1,e2]))) + <+> "of" <+> "int" + TypeRange _ t -> ppPrec n t + + +instance Pretty Literal where + ppPrec _ lit = + case lit of + Int n -> integer n + Bool b -> if b then "true" else "false" + Real r | toRational t == r -> text (showGFloat Nothing t "") + | otherwise -> parens (sh (numerator r) <+> "/" <+> + sh (denominator r)) + where + t = fromRational r :: Double + sh x = integer x <> ".0" + +{- +Precedences: +1 %left '|' +2 %nonassoc '->' +3 %right '=>' +4 %left 'or' 'xor' +5 %left 'and' +6 %nonassoc '<' '<=' '=' '>=' '>' '<>' +7 %nonassoc 'not' PREF +8 %left '+' '-' +9 %left '*' '/' '%' 'mod' 'div' +10 %left '**' +11 %nonassoc 'when' +12 %nonassoc 'int' 'real' PREF +13 %nonassoc UMINUS 'pre' 'current' PREF +14 %left '^' '.' +15 %right 'fby' +16 %right '[' '{' +-} +instance Pretty Expression where + ppPrec n expr = + case expr of + ERange _ e -> ppPrec n e + Var x -> pp x + Const e t -> pp e <+> mbClock + where mbClock = case cClock t of + BaseClock -> empty + _ -> "/*" <+> pp (cClock t) <+> "*/" + Lit l -> pp l + e `When` ce -> parenIf (n > 10) doc + where doc = ppPrec 11 e <+> "when" <+> ppPrec 11 ce + + Tuple es -> parens (commaSep (map pp es)) + Array es -> brackets (commaSep (map pp es)) + Select e s -> ppPrec 13 e <> pp s + Struct s fs -> pp s <+> braces (vcat (punctuate semi (map pp fs))) + UpdateStruct mb x fs -> + case mb of + Just s -> pp s <+> braces (pp x <+> "with" <+> + vcat (punctuate semi (map pp fs))) + Nothing -> ppPrec 16 x <+> hsep (map ppF fs) + where ppF f = braces (pp (fName f) <+> ":=" <+> pp (fValue f)) + + WithThenElse e1 e2 e3 -> parenIf (n > 0) doc + where doc = "with" <+> pp e1 $$ nest 2 ("then" <+> ppPrec 0 e2) + $$ nest 2 ("else" <+> ppPrec 0 e3) + + Merge i as -> parenIf (n > 1) doc + where doc = "merge" <+> pp i $$ nest 2 (vcat (map pp as)) + + Call f es cl _ -> + case (f,cl) of + (NodeInst (CallPrim _ prim) [], BaseClock) -> + case (prim, es) of + + (Op1 op, [e]) -> parenIf (n >= p) doc + where doc = pp op <+> ppPrec p e + p = case op of + Not -> 7 + IntCast -> 12 + RealCast -> 12 + FloorCast -> 12 + Neg -> 13 + Pre -> 13 + Current -> 13 + + (Op2 CurrentWith,_) -> dflt -- not infix + + (Op2 op, [e1,e2]) -> parenIf (n >= p) doc + where doc = ppPrec lp e1 <+> pp op <+> ppPrec rp e2 + left x = (x-1,x,x) + right x = (x,x,x-1) + non x = (x,x,x) + + (lp,p,rp) = case op of + Concat -> left 1 + FbyArr -> non 2 + Implies -> right 3 + CurrentWith -> panic "pp" ["currentWith?"] + Or -> left 4 + Xor -> left 4 + And -> left 5 + Lt -> non 6 + Leq -> non 6 + Gt -> non 6 + Geq -> non 6 + Eq -> non 6 + Neq -> non 6 + Add -> left 8 + Sub -> left 8 + Mul -> left 9 + Div -> left 9 + Mod -> left 9 + Power -> left 10 + Replicate -> left 14 + Fby -> right 15 + + (ITE,[e1,e2,e3]) -> parenIf (n > 0) doc + where doc = "if" <+> pp e1 $$ nest 2 ("then" <+> ppPrec 0 e2) + $$ nest 2 ("else" <+> ppPrec 0 e3) + + _ -> dflt + + _ -> dflt + where + argTuple = parens (commaSep (map pp es)) + dflt = case cl of + BaseClock -> pp f <+> argTuple + KnownClock c -> "callWhen" <+> + parens (commaSep [ pp c, pp f <+> argTuple]) + ClockVar c -> "callWhen" <+> pp c + +parenIf :: Bool -> Doc -> Doc +parenIf p d = if p then parens d else d + + +instance Pretty e => Pretty (MergeCase e) where + ppPrec _ (MergeCase cv e) = parens (pp cv <+> "->" <+> pp e) + +instance Pretty e => Pretty (Field e) where + ppPrec _ (Field x e) = pp x <+> "=" <+> pp e + +instance Pretty e => Pretty (Selector e) where + ppPrec _ sel = + case sel of + SelectField i -> "." <> pp i + SelectElement e -> brackets (pp e) + SelectSlice e -> brackets (pp e) + +instance Pretty e => Pretty (ArraySlice e) where + ppPrec _ as = pp (arrayStart as) <+> ".." <+> pp (arrayEnd as) <+> mbStep + where mbStep = case arrayStep as of + Nothing -> empty + Just e -> "step" <+> pp e + +instance Pretty ClockExpr where + ppPrec _ (WhenClock _ cv i) = + case cv of + Lit (Bool True) -> pp i + Lit (Bool False) -> "not" <+> pp i + _ -> ppPrec 16 cv <> parens (pp i) + +instance Pretty NodeInst where + ppPrec _ (NodeInst x as) = + case as of + [] -> pp x + _ -> pp x <+> "<<" PP.<> hsep (punctuate comma (map pp as)) PP.<> ">>" + +instance Pretty Callable where + ppPrec p c = + case c of + CallUser n -> ppPrec p n + CallPrim _ i -> ppPrec p i + +instance Pretty PrimNode where + ppPrec p x = + case x of + Iter i -> ppPrec p i + Op1 op -> ppPrec p op + Op2 op -> ppPrec p op + OpN op -> ppPrec p op + ITE -> "if" + +instance Pretty Iter where + ppPrec _ i = + case i of + IterFill -> "fill" + IterRed -> "red" + IterFillRed -> "fillred" + IterMap -> "map" + IterBoolRed -> "boolred" + +instance Pretty StaticArg where + ppPrec n arg = + case arg of + TypeArg t -> "type" <+> pp t + ExprArg e -> "const" <+> pp e + NodeArg nf x -> case x of + NodeInst (CallUser _) _ -> pp nf <+> pp x + _ -> pp x + ArgRange _ a -> ppPrec n a + +instance Pretty NodeType where + ppPrec _ nt = + case nt of + Node -> "node" + Function -> "function" + +-- | Pretty print a safety, but don't say anything if safe. +ppSafetyOpt :: Safety -> Doc +ppSafetyOpt saf = + case saf of + Safe -> empty + Unsafe -> "unsafe" + +instance Pretty Safety where + ppPrec _ saf = + case saf of + Safe -> "/* safe */" -- so that it makes sense when printed + -- on its own + Unsafe -> "unsafe" + +instance Pretty Op1 where + ppPrec _ op = + case op of + Not -> "not" + Neg -> "-" + Pre -> "pre" + Current -> "current" + IntCast -> "int" + FloorCast -> "floor" + RealCast -> "real" + +instance Pretty Op2 where + ppPrec _ op = + case op of + FbyArr -> "->" + Fby -> "fby" + CurrentWith -> "currentWith" + And -> "and" + Or -> "or" + Xor -> "xor" + Implies -> "=>" + Eq -> "=" + Neq -> "<>" + Lt -> "<" + Leq -> "<=" + Gt -> ">" + Geq -> ">=" + Mul -> "*" + Mod -> "mod" + Div -> "/" + Add -> "+" + Sub -> "-" + Power -> "**" + Replicate -> "^" + Concat -> "|" + +instance Pretty OpN where + ppPrec _ op = + case op of + AtMostOne -> "#" + Nor -> "nor" + +-------------------------------------------------------------------------------- + +instance Pretty Contract where + ppPrec _ c = "/*@contract" $$ nest 2 (vcat (map pp (contractItems c))) $$ "*/" + +instance Pretty ContractItem where + ppPrec _ item = + case item of + GhostConst d -> pp d + GhostVar b e -> "var" <+> pp b <+> "=" <+> pp e PP.<> semi + Assume _ e -> "assume" <+> pp e PP.<> semi + Guarantee _ e -> "guarantee" <+> pp e PP.<> semi + Mode i res ens -> "mode" <+> pp i <+> "(" + $$ nest 2 (vcat (map (ppClause "requre") res)) + $$ nest 2 (vcat (map (ppClause "ensure") ens)) + $$ ")" PP.<> semi + where ppClause x e = x <+> pp e PP.<> semi + Import i eis eos -> + "import" <+> pp i PP.<> parens (commaSep (map pp eis)) + <+> parens (commaSep (map pp eos)) + +instance Pretty ContractDecl where + ppPrec _ cd = + "contract" <+> pp (cdName cd) <+> pp (cdProfile cd) PP.<> semi + $$ "let" $$ nest 2 (vcat (map pp (cdItems cd))) $$ "tel" + + + +instance Pretty Thing where + ppPrec _ th = + case th of + AType -> "type" + ANode -> "node" + AContract -> "contract" + AConst -> "constant" + AVal -> "value" + + +instance Pretty ModName where + ppPrec _ (Module t) = pp t + +instance Pretty Label where + ppPrec _ = pp . labText + + +instance Pretty OrigName where + ppPrec _ x = pp (origNameToIdent x) + + +instance Pretty IClock where + ppPrec n c = case c of + BaseClock -> "base clock" + KnownClock k -> ppPrec n k + ClockVar v -> pp v + +instance Pretty CVar where + ppPrec _ (CVar i) = "cv_" PP.<> pp i + + diff --git a/Language/Lustre/Semantics/BuiltIn.hs b/Language/Lustre/Semantics/BuiltIn.hs new file mode 100644 --- /dev/null +++ b/Language/Lustre/Semantics/BuiltIn.hs @@ -0,0 +1,250 @@ +module Language.Lustre.Semantics.BuiltIn + ( -- * Constants + sInt, sReal, sBool + + -- ** Coercions + , sReal2Int, sInt2Real, sReal2IntFloor + + -- ** Logical operators + , sNot, sAnd, sOr, sXor, sImplies, sBoolRed + + -- ** Relations and choices + , sEq, sNeq, sLt, sGt, sLeq, sGeq, sITE + + -- ** Arithmetic + , sNeg, sAdd, sSub, sMul, sDiv, sMod, sPow, eucledean_div_mod + + -- * Data structures + , sArray, sReplicate, sConcat, sSelectIndex, sSelectSlice + , sSelectField + + ) where + +import Data.List(genericReplicate,genericDrop,genericIndex,genericLength) + +import Language.Lustre.Name +import Language.Lustre.AST +import Language.Lustre.Semantics.Value + + + +-------------------------------------------------------------------------------- +-- Static + +sInt :: Integer -> EvalM Value +sInt x = pure (VInt x) + +sReal :: Rational -> EvalM Value +sReal x = pure (VReal x) + +sBool :: Bool -> EvalM Value +sBool x = pure (VBool x) + +sArray :: [Value] -> EvalM Value +sArray x = pure (VArray x) + +sNot :: Value -> EvalM Value +sNot v = + case v of + VBool x -> sBool (not x) + _ -> typeError "not" "a `bool`" + +sNeg :: Value -> EvalM Value +sNeg v = + case v of + VInt x -> sInt (negate x) + VReal x -> sReal (negate x) + _ -> typeError "uminus" "a `real` or a `number`" + +sReal2Int :: Value -> EvalM Value +sReal2Int v = + case v of + VReal x -> sInt (truncate x) + _ -> typeError "real2int" "a `real`" + +sReal2IntFloor :: Value -> EvalM Value +sReal2IntFloor v = + case v of + VReal x -> sInt (floor x) + _ -> typeError "real2intFloor" "a `real`" + + + +sInt2Real :: Value -> EvalM Value +sInt2Real v = + case v of + VInt x -> sReal (fromInteger x) + _ -> typeError "int2real" "an `int`" + + +sOp2 :: (Value -> Value -> EvalM Value) -> Value -> Value -> EvalM Value +sOp2 f u v = + case (u,v) of + _ -> f u v + +sBoolOp2 :: String -> (Bool -> Bool -> Bool) -> Value -> Value -> EvalM Value +sBoolOp2 name f = + sOp2 $ \u v -> + case (u,v) of + (VBool x, VBool y) -> sBool (f x y) + _ -> typeError name "`(bool,bool)`" + +sAnd, sOr, sXor, sImplies :: Value -> Value -> EvalM Value +sAnd = sBoolOp2 "and" (&&) +sOr = sBoolOp2 "or" (||) +sXor = sBoolOp2 "xor" (/=) +sImplies = sBoolOp2 "implies" (\p q -> not p || q) + +sEq :: Value -> Value -> EvalM Value +sEq = sOp2 $ \u v -> sBool (u == v) + +sNeq :: Value -> Value -> EvalM Value +sNeq = sOp2 $ \u v -> sBool (u /= v) + +sCmpOp :: String -> (Ordering -> Bool) -> Value -> Value -> EvalM Value +sCmpOp name f = sOp2 $ \u v -> + case (u,v) of + (VInt x, VInt y) -> sBool (f (compare x y)) + (VReal x, VReal y) -> sBool (f (compare x y)) + _ -> typeError name "`(int,int)` or `(real,real)`" + +sLt, sGt, sLeq, sGeq :: Value -> Value -> EvalM Value +sLt = sCmpOp "lt" (== LT) +sGt = sCmpOp "gt" (== GT) +sLeq = sCmpOp "leq" (\x -> x == LT || x == EQ) +sGeq = sCmpOp "geq" (\x -> x == GT || x == EQ) + +sMul, sDiv, sMod, sPow, sAdd, sSub :: Value -> Value -> EvalM Value + +sMul = sOp2 $ \u v -> + case (u,v) of + (VInt x, VInt y) -> sInt (x * y) + (VReal x, VReal y) -> sReal (x * y) + _ -> typeError "times" "`(int,int)` or `(real,real)`" + +sDiv = sOp2 $ \u v -> + case (u,v) of + (VInt x, VInt y) -> + case eucledean_div_mod x y of + Just (q,_) -> sInt q + Nothing -> crash "div" "Division by 0" + (VReal x, VReal y) + | y /= 0 -> sReal (x / y) + | otherwise -> crash "div" "Division by 0" + + _ -> typeError "div" "`(int,int)` or `(real,real)`" + +sMod = sOp2 $ \u v -> + case (u,v) of + (VInt x, VInt y) -> + case eucledean_div_mod x y of + Just (_,r) -> sInt r + Nothing -> crash "mod" "Division by 0" + _ -> typeError "mod" "`(int,Int)`" + +sAdd = sOp2 $ \u v -> + case (u,v) of + (VInt x, VInt y) -> sInt (x + y) + (VReal x, VReal y) -> sReal (x + y) + _ -> typeError "add" "`(int,int)` or `(real,real)`" + + +sSub = sOp2 $ \u v -> + case (u,v) of + (VInt x, VInt y) -> sInt (x - y) + (VReal x, VReal y) -> sReal (x - y) + _ -> typeError "sub" "`(int,int)` or `(real,real)`" + +sPow = sOp2 $ \u v -> + case (u,v) of + (VInt x, VInt y) -> sInt (x ^ y) + (VReal x, VInt y) -> sReal (x ^ y) + _ -> typeError "pow" "`(int,int)` or `(real,int)`" + + +-- | Convenient operator used by various boolean functions. +-- The integeras ar the minimum and maximum number of true in the list of value. +sBoolRed :: String -> Integer -> Integer -> [Value] -> EvalM Value +sBoolRed name i j = count 0 + where + count n as = case as of + [] -> pure (VBool (n >= i)) + VBool b : bs + | b -> if n == j then pure (VBool False) + else count (n+1) bs + + _ -> typeError name "a `bool`" + +sITE :: Value -> Value -> Value -> EvalM Value +sITE u v w = + case u of + VBool b -> pure (if b then v else w) + _ -> typeError "ite" "a `bool`" + + +sReplicate :: Value {-^ Replicate this -} -> Value {-^ Number of times -} -> + EvalM Value +sReplicate = sOp2 $ \u v -> + case v of + VInt x -> sArray (genericReplicate x u) + _ -> typeError "replicate" "an `int`" + +sConcat :: Value -> Value -> EvalM Value +sConcat = sOp2 $ \u v -> + case (u,v) of + (VArray xs, VArray ys) -> sArray (xs ++ ys) + _ -> typeError "concat" "(array,array)" + + +sSelectField :: Label -> Value -> EvalM Value +sSelectField f v = + case v of + VStruct _ fs -> + case [ fv | Field f1 fv <- fs, f1 == f ] of + fv : _ -> pure fv + [] -> crash "select-field" "Missing struct field" + _ -> typeError "select-field" "a struct type." + +sSelectIndex :: Value {-^ index -} -> Value {- ^ array -} -> EvalM Value +sSelectIndex = sOp2 $ \i v -> + case (v,i) of + (VArray vs, VInt iv) + | iv < 0 -> outOfBounds + | otherwise -> case genericDrop iv vs of + [] -> outOfBounds + x : _ -> pure x + where outOfBounds = typeError "sSelectIndex" "array index out of bounds" + + _ -> typeError "select-element" "`(array,int)`" + +sSelectSlice :: ArraySlice Value -> Value -> EvalM Value +sSelectSlice sl v = + case (v, start, end, step) of + (VArray vs, VInt f, VInt t, VInt s) + | f >= 0 && t >= f && t < genericLength vs && s > 0 -> + sArray [ genericIndex vs i | i <- [ f, f + s .. t ] ] + | otherwise -> crash "get-slice" "Bad arguments" + + _ -> typeError "get-slice" "(array,int,int,int)" + where + start = arrayStart sl + end = arrayEnd sl + step = case arrayStep sl of + Just s -> s + Nothing -> VInt 1 + + + +eucledean_div_mod :: Integer -> Integer -> Maybe (Integer,Integer) +eucledean_div_mod x y = + do q <- doDiv x y + let r = x - q * y + pure (q, r) + where + doDiv a b = case compare b 0 of + LT -> Just (negate (doDivPos a (negate b))) + EQ -> Nothing + GT -> Just (doDivPos a b) + + doDivPos a b = floor (toRational a / toRational b) + diff --git a/Language/Lustre/Semantics/Const.hs b/Language/Lustre/Semantics/Const.hs new file mode 100644 --- /dev/null +++ b/Language/Lustre/Semantics/Const.hs @@ -0,0 +1,220 @@ +module Language.Lustre.Semantics.Const + ( evalConst, evalSel, evalSelFun, Env(..), emptyEnv, evalIntConst, valToExpr + , Value(..) + ) + where + +import Data.Map ( Map ) +import qualified Data.Map as Map +import Control.Monad(msum) + +import Language.Lustre.Name +import Language.Lustre.AST +import Language.Lustre.Pretty(showPP) +import Language.Lustre.Semantics.Value +import Language.Lustre.Semantics.BuiltIn + +data Env = Env + { envConsts :: Map OrigName Value + , envStructs :: Map OrigName [ (Label, Maybe Value) ] + } + +emptyEnv :: Env +emptyEnv = Env { envConsts = Map.empty + , envStructs = Map.empty + } + + +-- | Evaluate a constant expression of type @int@. +evalIntConst :: Env -> Expression -> EvalM Integer +evalIntConst env e = + do v <- evalConst env e + case v of + VInt i -> pure i + _ -> typeError "evalIntConst" "an `int`" + + +-- | Evaluate a constant expression. +-- Note this does not produce 'Nil' values, unless some came in the 'Env'. +evalConst :: Env -> Expression -> EvalM Value +evalConst env expr = + case expr of + + ERange _ e -> evalConst env e + + Lit l -> + case l of + Int n -> sInt n + Real n -> sReal n + Bool n -> sBool n + + WithThenElse be t e -> + do bv <- evalConst env be + case bv of + VBool b -> if b then evalConst env t else evalConst env e + _ -> typeError "with-then-else" "A `bool`" + + Const e _ -> evalConst env e + + When {} -> bad "`when` is not a constant expression." + Merge {} -> bad "`merge` is not a constant expression." + + Var x -> + case Map.lookup (nameOrigName x) (envConsts env) of + Just v -> pure v + Nothing -> bad ("Undefined variable `" ++ show x ++ "`.") + + Tuple {} -> bad "Unexpected constant tuple." + + Array es -> sArray =<< mapM (evalConst env) es + + Struct s fes -> + case Map.lookup name (envStructs env) of + Nothing -> bad ("Undefined struct type `" ++ show s ++ "`.") + Just structDef -> + do fs <- Map.fromList <$> mapM (evalField env) fes + let mkField (f,mb) = + case msum [ Map.lookup f fs, mb ] of + Just v -> pure (Field f v) + Nothing -> bad ("Missing field `" ++ show f ++ "`.") + fs1 <- mapM mkField structDef + pure (VStruct name fs1) + where name = nameOrigName s + + UpdateStruct mbS y fes -> + do uv <- evalConst env y + fs <- Map.fromList <$> mapM (evalField env) fes + case uv of + VStruct s fs1 + | maybe True ((== s) . nameOrigName) mbS -> + pure $ VStruct s + [ Field i v1 + | Field i v <- fs1 + , let v1 = Map.findWithDefault v i fs + ] + | otherwise -> typeError "struct update" + ("a `" ++ showPP s ++ "`") + + _ -> typeError "struct update" "a struct" + + Select e sel -> + do s <- evalSel env sel + evalSelFun s =<< evalConst env e + + Call (NodeInst (CallPrim _ p) []) es cl _ -> + do case cl of + BaseClock -> pure () + _ -> bad "calls with a clock do not make sense for constants" + vs <- mapM (evalConst env) es + case (p, vs) of + + (ITE, [b,t,e]) -> sITE b t e + + (Op1 op, [v]) -> + case op of + Not -> sNot v + Neg -> sNeg v + IntCast -> sReal2Int v + RealCast -> sInt2Real v + FloorCast -> sReal2IntFloor v + + Pre -> bad "`pre` is not a constant" + Current -> bad "`current` is not a constant" + + (Op2 op, [x,y]) -> + case op of + Fby -> bad "`fby` is not a constant" + FbyArr -> bad "`->` is not a constant" + CurrentWith-> bad "`current` is not a constant" + + And -> sAnd x y + Or -> sOr x y + Xor -> sXor x y + Implies -> sImplies x y + + Eq -> sEq x y + Neq -> sNeq x y + + Lt -> sLt x y + Leq -> sLeq x y + Gt -> sGt x y + Geq -> sGeq x y + + Mul -> sMul x y + Mod -> sMod x y + Div -> sDiv x y + Add -> sAdd x y + Sub -> sSub x y + Power -> sPow x y + + Replicate -> sReplicate x y + Concat -> sConcat x y + + (OpN op, _) -> + case op of + AtMostOne -> sBoolRed "at-most-one" 0 1 vs + Nor -> sBoolRed "nor" 0 0 vs + + (_, _) -> bad ("Unknown primitive expression: " ++ showPP p) + + + Call {} -> bad "`call` is not a constant expression." + + where + bad = crash "evalConst" + + +evalField :: Env -> Field Expression -> EvalM (Label, Value) +evalField env (Field f v) = do v1 <- evalConst env v + pure (f,v1) + +-- | Evaluate a selector. +evalSel :: Env -> Selector Expression -> EvalM (Selector Value) +evalSel env sel = + case sel of + + SelectField f -> + pure (SelectField f) + + SelectElement ei -> + do i <- evalConst env ei + pure (SelectElement i) + + SelectSlice s -> + do start <- evalConst env (arrayStart s) + end <- evalConst env (arrayEnd s) + step <- mapM (evalConst env) (arrayStep s) + pure (SelectSlice ArraySlice { arrayStart = start + , arrayEnd = end + , arrayStep = step + }) + + +-- | Evaluate a selector to a selecting function. +evalSelFun :: Selector Value -> Value -> EvalM Value +evalSelFun sel v = + case sel of + SelectField f -> sSelectField f v + SelectElement i -> sSelectIndex i v + SelectSlice s -> sSelectSlice s v + + +-- | Convert an evaluated expression back into an ordinary expression. +-- Note that the resulting expression does not have meaninful position +-- information. +valToExpr :: Value -> Expression +valToExpr val = + case val of + VInt i -> Lit (Int i) + VBool b -> Lit (Bool b) + VReal r -> Lit (Real r) + + -- we keep enums as variables, leaving representation choice for later. + VEnum _ x -> Var (origNameToName x) + VStruct s fs -> Struct (origNameToName s) (fmap (fmap valToExpr) fs) + + VArray vs -> Array (map valToExpr vs) + + + + diff --git a/Language/Lustre/Semantics/Core.hs b/Language/Lustre/Semantics/Core.hs new file mode 100644 --- /dev/null +++ b/Language/Lustre/Semantics/Core.hs @@ -0,0 +1,392 @@ +{-# Language OverloadedStrings #-} +module Language.Lustre.Semantics.Core where + +import Data.List(foldl') +import Data.Maybe(fromMaybe) +import Data.Map ( Map ) +import qualified Data.Map as Map +import Data.Set ( Set ) +import qualified Data.Set as Set +import Text.PrettyPrint + +import Language.Lustre.Panic +import Language.Lustre.Pretty +import Language.Lustre.Core +import Language.Lustre.Semantics.BuiltIn(eucledean_div_mod) + +data Value = VInt !Integer + | VBool !Bool + | VReal !Rational + | VNil + deriving Show + +isNil :: Value -> Bool +isNil v = + case v of + VNil -> True + _ -> False + +isBool :: Value -> Maybe Bool +isBool v = + case v of + VBool b -> Just b + _ -> Nothing + +ppValue :: Value -> Doc +ppValue val = + case val of + VInt x -> integer x + VBool x -> text (show x) + VReal x -> double (fromRational x) + VNil -> text "nil" + +instance Pretty Value where + ppPrec _ = ppValue + + +data State = State + { sValues :: Map CoreName Value + -- ^ Values for identifiers. + -- If a value is missing, then its value is assumed to be 'VNil'. + + , sInitialized :: Set CoreName + -- ^ Additional state to implement @a -> b@ + -- Contains the identifiers that have transition to the second phase. + } + +ppState :: PPInfo -> State -> Doc +ppState info s = + vcat [ "values:" + , nest 2 (vcat (map ppV (Map.toList (sValues s)))) + , "initialized:" <+> commaSep (map ppI (Set.toList (sInitialized s))) + ] + where + ppI = ppIdent info + ppV (x,y) = ppI x <+> "=" <+> pp y + + + +instance Pretty State where + ppPrec _ = ppState noInfo + +initNode :: Node -> + Maybe (Map CoreName Value) {- Optional inital values -} -> + (State, State -> Map CoreName Value -> State) +initNode node mbStart = (s0, stepNode node env) + where + s0 = State { sInitialized = Set.empty + , sValues = fromMaybe Map.empty mbStart + } + env = nodeEnv node + + +stepNode :: Node {- ^ Node, with equations properly ordered -} -> + (Map CoreName CType) {- ^ Types of identifiers -} -> + State {- ^ Current state -} -> + Map CoreName Value {- ^ Inputs -} -> + State {- ^ Next state -} +stepNode node env old ins = foldl' (evalEqnGrp env old) new (nEqns node) + where + new = State { sInitialized = sInitialized old + , sValues = ins + } + + +-- | The meaning of a literal. +evalLit :: Literal -> Value +evalLit lit = + case lit of + Int i -> VInt i + Real r -> VReal r + Bool b -> VBool b + +-- | Lookup the value of a variable. +evalVar :: State -> CoreName -> Value +evalVar s x = Map.findWithDefault VNil x (sValues s) + +-- | Interpret an atom in the given state. +evalAtom :: State {-^ Environment to for values of variables -} -> + Atom {-^ Evaluate this -} -> + Value {-^ Value of the atom -} +evalAtom s atom = + case atom of + Lit l _ -> evalLit l + Var x -> evalVar s x + Prim op as _ -> evalPrimOp op (map (evalAtom s) as) + + +evalEqnGrp :: Map CoreName CType -> + State -> + State -> + EqnGroup -> + State +evalEqnGrp env old new grp = + case grp of + NonRec eqn -> evalEqn env old new eqn + Rec es -> + let evEq = evalEqn env old fin + sts = map evEq es + getVal (x ::: _ := _) s = (x,Map.findWithDefault VNil x (sValues s)) + newMap = Map.fromList (zipWith getVal es sts) + fin = State { sInitialized = Set.unions (map sInitialized sts) + , sValues = Map.union newMap (sValues new) + } + in fin + + + + +evalEqn :: Map CoreName CType {- ^ Types of identifier -} -> + State {- ^ Old state -} -> + State {- ^ New state (partial) -} -> + Eqn {- ^ Equation to evaluate -} -> + State {- ^ Updated new state -} + +evalEqn env old new (x ::: _ `On` c := expr) = + case expr of + + Atom a -> guarded $ done $ evalAtom new a + Current a -> done (evalAtom new a) + + a `When` _ -> + guarded $ done $ + evalAtom new a + + Pre a -> + guarded $ done $ + evalAtom old a + + (a, _) :-> b -> + guarded $ + if x `Set.member` sInitialized old + then done (evalAtom new b) + else initialized $ done $ evalAtom new a + + Merge (n, ty) alts -> + let nameAtom = Var n + in guarded $ done $ + let go [] = VNil + go ((lit, e):rest) = + let cond = Prim Eq [ Lit lit ty, e ] [TBool `On` c] + in case evalAtom new cond of + VBool b -> if b + then evalAtom new e + else go rest + VNil -> VNil + _ -> panic "evalEqn" [ "Merge expected a bool" ] + in go alts + + + where + done v = new { sValues = Map.insert x v (sValues new) } + initialized s = s { sInitialized = Set.insert x (sInitialized s) } + + guarded = guardedOn c + + guardedOn cl s = + case cl of + BaseClock -> s + WhenTrue a -> + case evalAtom new a of + VBool True -> guardedOn cl1 s + where Just cl1 = clockParent env cl + _ -> hold + where hold = new { sValues = Map.insert x (evalVar old x) (sValues new) } + + + + + +-- | Semantics of primitive operators. +evalPrimOp :: Op -> [Value] -> Value +evalPrimOp op vs = + case op of + Not -> + case vs of + [ VNil ] -> VNil + [ VBool b ] -> VBool (not b) + _ -> bad "1 bool" + + Neg -> + case vs of + [ VNil ] -> VNil + [ VInt n ] -> VInt (negate n) + [ VReal n ] -> VReal (negate n) + _ -> bad "1 number" + + IntCast -> + case vs of + [ VNil ] -> VNil + [ VReal r ] -> VInt (truncate r) + _ -> bad "1 real" + + FloorCast -> + case vs of + [ VNil ] -> VNil + [ VReal r ] -> VInt (floor r) + _ -> bad "1 real" + + RealCast -> + case vs of + [ VNil ] -> VNil + [ VInt n ] -> VReal (fromInteger n) + _ -> bad "1 int" + + And -> + case vs of + [ VNil, _ ] -> VNil + [ _, VNil ] -> VNil + [ VBool x, VBool y ] -> VBool (x && y) + _ -> bad "2 bools" + + Or -> + case vs of + [ VNil, _ ] -> VNil + [ _, VNil ] -> VNil + [ VBool x, VBool y ] -> VBool (x || y) + _ -> bad "2 bools" + + Xor -> + case vs of + [ VNil, _ ] -> VNil + [ _, VNil ] -> VNil + [ VBool x, VBool y ] -> VBool (x /= y) + _ -> bad "2 bools" + + Implies -> + case vs of + [ VNil, _ ] -> VNil + [ _, VNil ] -> VNil + [ VBool x, VBool y ] -> VBool (not x || y) + _ -> bad "2 bools" + + Eq -> + case vs of + [ VNil, _ ] -> VNil + [ _, VNil ] -> VNil + [ VBool x, VBool y ] -> VBool (x == y) + [ VInt x, VInt y ] -> VBool (x == y) + [ VReal x, VReal y ] -> VBool (x == y) + _ -> bad "2 of the same type" + + Neq -> + case vs of + [ VNil, _ ] -> VNil + [ _, VNil ] -> VNil + [ VBool x, VBool y ] -> VBool (x /= y) + [ VInt x, VInt y ] -> VBool (x /= y) + [ VReal x, VReal y ] -> VBool (x /= y) + _ -> bad "2 of the same type" + + Lt -> + case vs of + [ VNil, _ ] -> VNil + [ _, VNil ] -> VNil + [ VInt x, VInt y ] -> VBool (x < y) + [ VReal x, VReal y ] -> VBool (x < y) + _ -> bad "2 numbers" + + Leq -> + case vs of + [ VNil, _ ] -> VNil + [ _, VNil ] -> VNil + [ VInt x, VInt y ] -> VBool (x <= y) + [ VReal x, VReal y ] -> VBool (x <= y) + _ -> bad "2 numbers" + + Gt -> + case vs of + [ VNil, _ ] -> VNil + [ _, VNil ] -> VNil + [ VInt x, VInt y ] -> VBool (x > y) + [ VReal x, VReal y ] -> VBool (x > y) + _ -> bad "2 numbers" + + Geq -> + case vs of + [ VNil, _ ] -> VNil + [ _, VNil ] -> VNil + [ VInt x, VInt y ] -> VBool (x >= y) + [ VReal x, VReal y ] -> VBool (x >= y) + _ -> bad "2 numbers" + + Add -> + case vs of + [ VNil, _ ] -> VNil + [ _, VNil ] -> VNil + [ VInt x, VInt y ] -> VInt (x + y) + [ VReal x, VReal y ] -> VReal (x + y) + _ -> bad "2 numbers" + + Sub -> + case vs of + [ VNil, _ ] -> VNil + [ _, VNil ] -> VNil + [ VInt x, VInt y ] -> VInt (x - y) + [ VReal x, VReal y ] -> VReal (x - y) + _ -> bad "2 numbers" + + Mul -> + case vs of + [ VNil, _ ] -> VNil + [ _, VNil ] -> VNil + [ VInt x, VInt y ] -> VInt (x * y) + [ VReal x, VReal y ] -> VReal (x * y) + _ -> bad "2 numbers" + + Div -> + case vs of + [ VNil, _ ] -> VNil + [ _, VNil ] -> VNil + [ VInt x, VInt y ] -> case eucledean_div_mod x y of + Just (q,_) -> VInt q + Nothing -> VNil -- ? + [ VReal x, VReal y ] -> VReal (x / y) + _ -> bad "2 numbers" + + Mod -> + case vs of + [ VNil, _ ] -> VNil + [ _, VNil ] -> VNil + [ VInt x, VInt y ] -> case eucledean_div_mod x y of + Just (_,r) -> VInt r + Nothing -> VNil -- ? + _ -> bad "2 ints" + + Power -> + case vs of + [ VNil, _ ] -> VNil + [ _, VNil ] -> VNil + [ VInt x, VInt y ] -> VInt (x ^ y) + [ VReal x, VInt y ] -> VReal (x ^ y) + _ -> bad "1 number and 1 int" + + ITE -> + case vs of + [ VNil, _, _ ] -> VNil + [ VBool b, x, y ] -> if b then x else y -- should we check for Nil? + _ -> bad "1 bool, and 2 of the same type" + + AtMostOne + | any isNil vs -> VNil + | Just bs <- mapM isBool vs -> VBool $ case filter id bs of + _ : _ : _ -> False + _ -> True + | otherwise -> bad "all bool" + + Nor + | any isNil vs -> VNil + | Just bs <- mapM isBool vs -> VBool (not (or bs)) + | otherwise -> bad "all booleans" + + where + bad y = panic "evalExpr" [ "Type error:" + , "*** Operator: " ++ show op + , "*** Expected: " ++ y + , "*** Got: " ++ show vs ] + + + + + + diff --git a/Language/Lustre/Semantics/Value.hs b/Language/Lustre/Semantics/Value.hs new file mode 100644 --- /dev/null +++ b/Language/Lustre/Semantics/Value.hs @@ -0,0 +1,80 @@ +{-# Language OverloadedStrings #-} +module Language.Lustre.Semantics.Value where + +import Text.PrettyPrint as P +import Language.Lustre.Name +import Language.Lustre.AST +import Language.Lustre.Pretty + +-- | The universe of basic values. +-- These are the values used for a specific time instance. +data Value = VInt !Integer + | VBool !Bool + | VReal !Rational + | VEnum !OrigName !OrigName -- ^ Type, value + | VStruct !OrigName ![Field Value] -- ^ Type, fields + | VArray ![Value] + deriving Show + + +instance Eq Value where + x == y = + case (x,y) of + (VInt a, VInt b) -> a == b + (VBool a, VBool b) -> a == b + (VReal a, VReal b) -> a == b + (VEnum t1 a, VEnum t2 b) -> t1 == t2 && a == b + (VArray as, VArray bs) -> cmpArr as bs + (VStruct t1 as, VStruct t2 bs) | t1 == t2 -> cmpStr as bs + _ -> False -- Type error + + where + cmpArr as bs = + case (as,bs) of + ([],[]) -> True + (a : xs, b : ys) -> a == b && cmpArr xs ys + _ -> False + + cmpStr as bs = + case (as,bs) of + ([],[]) -> True + (Field f v:more, fs) -> + case getField f fs of + Nothing -> False + Just (v2,fs') -> v == v2 && cmpStr more fs' + _ -> False -- Malformed structs + + getField nm fs = + case fs of + [] -> Nothing + Field f a : more -> if nm == f + then Just (a,more) + else do (a',more') <- getField nm more + return (a', Field f a : more') + + + +-- | The evaluation monad. +type EvalM = Either Error +type Error = String + +-- | Crash evaluation. We'd like to avoid calls to this. +crash :: String -> String -> EvalM a +crash x y = Left (x ++ ": " ++ y) + +typeError :: String -> String -> EvalM a +typeError x y = crash x ("Type error, expected " ++ y) + + +-------------------------------------------------------------------------------- + +instance Pretty Value where + ppPrec _ val = + case val of + VInt n -> integer n + VBool b -> text (show b) + VReal r -> double (fromRational r) -- XXX + VEnum _ a -> pp a + VStruct _ fs -> braces (commaSep (map pp fs)) + VArray vs -> brackets (hsep (punctuate comma (map pp vs))) + diff --git a/Language/Lustre/Transform/Inline.hs b/Language/Lustre/Transform/Inline.hs new file mode 100644 --- /dev/null +++ b/Language/Lustre/Transform/Inline.hs @@ -0,0 +1,455 @@ +{-# Language OverloadedStrings, GeneralizedNewtypeDeriving, DataKinds #-} + +{- | This module inlines all functions at their call sites. +Assumptions: + * Functions have been named, so they only appear at the top-level + if equations.(see nameCallSites in NoStatic) + * Top-level instance have been expaned (see expandNodeInsts in NoStatic) + * Equations contan only simple (i.e., 'LVar') 'LHS's. + * No constants +-} +module Language.Lustre.Transform.Inline + (inlineCalls, AllRenamings, Renaming(..)) where + +import Data.Map (Map) +import qualified Data.Map as Map +import MonadLib +import Data.Traversable(for) + +import Language.Lustre.Name +import Language.Lustre.AST +import Language.Lustre.Monad +import Language.Lustre.Pretty +import Language.Lustre.Panic +import Language.Lustre.Utils + +-- | Inline the calls from the given top declarations. Resturns information +-- about how things got renames, as well as new list of declarations. +inlineCalls :: [NodeDecl] {- ^ Already inline decls from environment -} -> + [TopDecl] {- ^ More decls to process -} -> + LustreM (AllRenamings,[TopDecl]) +inlineCalls ini ds = runInM ini (mapM inlineDecl ds) + + +{- The plan: + +Given: + +node f (a : A; b : B) returns (c : C; d : D) + var e : E; +let + e = e3 + c = e4 + d = e5 + assume e6 + show e7 + GLOBAL assume e8 +tel + + +And a use site within some node `g`: + +node g (...) returns (..) + var ... + +let + ... + x,y = f ((e1,e2) when t) + ... +tel + +Transform `g` as follows: + +1. Compute name renaming: + a -> a1 -- choose non-clashing names inputs + b -> b1 -- ditto + e -> e1 -- choose non-clashing name for locals + c -> x -- match output with LHS + d -> y -- ditto + + +2. New definition of `g`: + +node g(...) returns (...) + var ... + var a1 when t : A; -- non-clashing names for params + var b1 when t : B; -- non-clashing names for params + var e1 when t : E; -- non-clashing names for locals +let + ... + a1 = e1 -- renamed params + a2 = e2 -- ditto + e1 = e3 [renaming] + x = e4 [renaming] + y = e5 [renaming] + show (e6 [renaming]) -- prove that concrete values match expectations + args_ok = e6[renaming] and ... others ... + show (args_ok => e7 [renaming]) + -- note: no polarity switching, but we assume that inputs were OK + -- this ensure that the spec on `f` was OK + GLOBAL assume e8[renaming] + -- no plarity switchin on global assumptions, as these are assumptions + -- about the environment that we just inheirt in our spec. + + +3. Modular Reasoning + +Consider: + f (x : real) returns (y : real) + let + assume e1 + show e2 + tel + +Sometimes we may want to construct a proof which *assumes* that `f` +is working correctly. In that case, we translate `g` a bit different: + +node g(...) returns (...) + var ... + var a1 when t : A; -- non-clashing names for params + var b1 when t : B; -- non-clashing names for params +let + ... + a1 = e1 -- renamed params + a2 = e2 -- ditto + -- no definitions for results + show (e6 [renaming]) -- prove that concrete values match expectations + args_ok = e6[renaming] and ... others ... + GLOBAL assume (args_ok => e7 [renaming]) + + NOTE: this assumes that guarantees do not mention any local variables. + if they do, then we'd have to also add the definitions of those variables. + ... +-} + + +-- | Change the name of a binder to avoid name clasehs. +freshBinder :: Binder -> InM Binder +freshBinder b = do n <- freshName (binderDefines b) + pure b { binderDefines = n } + + +-- | A mapping from old names to their clash-avoiding versions. +data Renaming = Renaming + { renVarMap :: Map OrigName OrigName + -- ^ Mapping of names. + + , renClock :: IClock + -- ^ Clock at the call site, if any. + -- If this is set, then we have to replace base clocks with this clock + -- in the inlined code. + } + + +-- | Compute the renaming to be used when instantiating the given node. +computeRenaming :: + IClock {- ^ Clock at the call site -} -> + [LHS Expression] {- ^ LHS of call site -} -> + NodeDecl {- ^ Function being called -} -> + InM (Renaming, [LocalDecl], [OrigName]) + -- ^ renaming of identifiers, new locals to add + -- Last result is a "call site id", which is used for showing traces + -- (i.e., a kind of inverse) +computeRenaming cl lhs nd = + do newBinders <- + for oldBinders $ \b -> + do n <- freshBinder b + pure $ case cl of + BaseClock -> n -- still need to apply subst to clocks + KnownClock c -> + case cClock (binderType n) of + BaseClock -> + let ct = binderType n + in n { binderType = ct { cClock = KnownClock c } } + KnownClock _ -> n -- still need to apply su + ClockVar i -> panic "computeRenaming" + [ "Unexpected clock variable", showPP i ] + + ClockVar i -> panic "computeRenaming" + [ "Unexpected clock variable", showPP i ] + + let renaming = Renaming + { renVarMap = Map.fromList $ + zipExact renOut (nodeOutputs prof) lhs ++ + zipExact renBind oldBinders newBinders + , renClock = cl + } + renB b = b { binderType = rename renaming (binderType b) } + pure (renaming, map (LocalVar . renB) newBinders, map lhsIdent lhs) + where + prof = nodeProfile nd + def = case nodeDef nd of + Just b -> b + Nothing -> panic "computeRenaming" + [ "The node has no definition." + , "*** Node: " ++ showPP nd ] + + + oldBinders = map inputBinder (nodeInputs prof) ++ + map localBinder (nodeLocals def) + + lhsIdent l = case l of + LVar i -> identOrigName i + _ -> panic "computeRenaming" + [ "LHS is not a simple identifier." + , "*** LHS: " ++ showPP l ] + + renOut b l = (identOrigName (binderDefines b), lhsIdent l) + renBind old new = ( identOrigName (binderDefines old) + , identOrigName (binderDefines new) + ) + + +inputBinder :: InputBinder -> Binder +inputBinder ib = + case ib of + InputBinder b -> b + InputConst i t -> panic "inputBinder" + [ "Unexpected constant parameter." + , "Constants should have been eliminated by now." + , "*** Name: " ++ showPP i + , "*** Type: " ++ showPP t ] + +localBinder :: LocalDecl -> Binder +localBinder l = case l of + LocalVar b -> b + LocalConst cd -> + panic "localBinder" + [ "Unexpected local constant." + , "Constants should have been eliminated by now." + , "*** Constant: " ++ showPP cd + ] + + + +-------------------------------------------------------------------------------- +-- Applying a renaming, used when instantiatiating inlined functions. + +-- | We don't visit constant expressions, as they should contain no variables +-- by this stage (i.e., they ought to be constant values). +class Rename t where + rename :: Renaming -> t -> t + +instance Rename a => Rename [a] where + rename su xs = rename su <$> xs + +instance Rename a => Rename (Maybe a) where + rename su xs = rename su <$> xs + +instance Rename Ident where + rename su i = case Map.lookup (identOrigName i) (renVarMap su) of + Just n -> origNameToIdent n + Nothing -> i + +instance Rename Name where + rename su x = case Map.lookup (nameOrigName x) (renVarMap su) of + Just n -> origNameToName n + Nothing -> x + +instance Rename Expression where + rename su expr = + case expr of + ERange r e -> ERange r (rename su e) + Const e t -> Const e (rename su t) + Var x -> Var (rename su x) + Lit _ -> bad "literal, not under Const" + + e `When` ce -> rename su e `When` rename su ce + + Merge i ms -> Merge (rename su i) (rename su ms) + Call ni es c mTys -> Call ni (rename su es) (rename su c) (rename su mTys) + + Tuple {} -> bad "tuple" + Array {} -> bad "array" + Select {} -> bad "select" + Struct {} -> bad "struct" + UpdateStruct {} -> bad "struct update" + WithThenElse {} -> bad "with-then-else" + where + bad x = panic "rename" [ "Unexepected " ++ x ] + +instance Rename e => Rename (Field e) where + rename su (Field l e) = Field l (rename su e) + +instance Rename ClockExpr where + rename su (WhenClock r e i) = WhenClock r e (rename su i) + +instance Rename CType where + rename su ct = ct { cClock = rename su (cClock ct) } + +instance Rename IClock where + rename su clk = + case clk of + BaseClock -> renClock su + KnownClock c -> KnownClock (rename su c) + ClockVar {} -> panic "Inline.rename" [ "Unexpected clock variable." ] + +instance Rename e => Rename (MergeCase e) where + rename su (MergeCase a b) = MergeCase a (rename su b) + + +instance Rename a => Rename (LHS a) where + rename su lhs = + case lhs of + LVar b -> LVar (rename su b) + LSelect {} -> panic "rename" [ "Unexepected LHS select" ] + +instance Rename Equation where + rename su eqn = + case eqn of + Assert x ty e -> Assert x ty (rename su e) -- XXX: change names? + Property x e -> Property x (rename su e) -- XXX: change names? + IsMain r -> IsMain r + Define ls e -> Define (rename su ls) (rename su e) + IVC is -> IVC (rename su is) + Realizable is -> Realizable (rename su is) + +-------------------------------------------------------------------------------- + +-- | Inline the "normal" calls in a node declaration. +-- We assume that the calls in the definition have been already inlined, +-- so we don't continue inlining recursively. +inlineCallsNode :: + NodeDecl -> InM (Map [OrigName] (OrigName,Renaming), NodeDecl) +inlineCallsNode nd = + case nodeDef nd of + Nothing -> pure (Map.empty,nd) + Just def + | null (nodeStaticInputs nd) -> + do ready <- doneNodes + (newLocs,newEqs,rens) <- renameEqns ready (nodeEqns def) + pure ( rens + , nd { nodeDef = Just NodeBody + { nodeLocals = newLocs ++ nodeLocals def + , nodeEqns = newEqs + } } + ) + + | otherwise -> + panic "inlineCalls" [ "Unexpected static arguments." + , "*** Node: " ++ showPP nd ] + + where + isCall e = + case e of + ERange _ e1 -> isCall e1 + Call (NodeInst (CallUser f) []) es cl _ -> Just (f,es,cl) + _ -> Nothing + + renameEqns ready eqns = + case eqns of + [] -> pure ([],[],Map.empty) + eqn : more -> + case eqn of + Define ls e + | Just (f,es,cl) <- isCall e + , let fo = nameOrigName f + , Just cnd <- Map.lookup fo ready + , Just def <- nodeDef cnd -> + do let prof = nodeProfile cnd + (su, newLocals, key) <- computeRenaming cl ls cnd + let paramDef b p = Define [LVar (rename su (binderDefines b))] p + paramDefs = zipExact paramDef + (map inputBinder (nodeInputs prof)) es + thisEqns = updateProps (nodeExtern cnd) + (rename su (nodeEqns def)) + (otherDefs,otherEqns,rens) <- renameEqns ready more + pure ( newLocals ++ otherDefs + , paramDefs ++ thisEqns ++ otherEqns + , Map.insert key (fo,su) rens + ) + + _ -> do (otherDefs, otherEqns, rens) <- renameEqns ready more + pure (otherDefs, eqn : otherEqns, rens) + + updateProps extern eqns = + let asmps = [ e | Assert _ AssertPre e <- eqns ] + + boolTy = CType BoolType BaseClock + + addAsmps e1 = case asmps of + [] -> e1 + [a] -> eOp2 (range e1) Implies a e1 (Just [boolTy]) + as -> eOp2 (range e1) Implies + (foldr1 (\a b -> eOp2 (range e1) And a b (Just [boolTy])) as) + e1 + (Just [boolTy]) + upd eqn = case eqn of + Assert x ty e -> + case ty of + AssertPre -> Property x e + AssertEnv -> Assert x AssertEnv e + + Property x e + | extern -> Assert x AssertEnv (addAsmps e) + | otherwise -> Property x (addAsmps e) + _ -> eqn + in map upd eqns + +inlineDecl :: TopDecl -> InM TopDecl +inlineDecl d = + case d of + DeclareNode nd -> + do (thisRens,nd1) <- inlineCallsNode nd + addNodeDecl thisRens nd1 + pure (DeclareNode nd1) + _ -> pure d + +-------------------------------------------------------------------------------- +-- Resugar + +-- | Maps (node name, call_site as list of name, function called, renamed) +-- XXX: Identifying call sites by something other than list of ids. +type AllRenamings = Map OrigName {-node name-} ( + Map [OrigName] {-call site-} + ( OrigName {-called node-} + , Renaming {-how names changed, and we called-} + ) + ) + +-------------------------------------------------------------------------------- + +newtype InM a = InM { unInM :: StateT RW LustreM a } + deriving (Functor,Applicative,Monad) + +data RW = RW + { inlinedNodes :: !(Map OrigName NodeDecl) + -- ^ Nodes that have been processed already. + + , renamings :: AllRenamings + -- ^ How we renamed things, for propagating answers back. + } + +runInM :: [NodeDecl] -> InM a -> LustreM (AllRenamings, a) +runInM ini m = + do (a,s1) <- runStateT s $ unInM m + pure (renamings s1, a) + where + s = RW { inlinedNodes = Map.fromList (map entry ini) + , renamings = Map.empty + } + entry nd = (identOrigName (nodeName nd), nd) + +-- | Add an inlined node to the collection of processed nodes. +addNodeDecl :: + Map [OrigName] (OrigName,Renaming) {- ^ Info about inlined vars -} -> + NodeDecl {- ^ Inlined function -} -> + InM () +addNodeDecl rens nd = InM $ + sets_ $ \s -> s { inlinedNodes = Map.insert i nd (inlinedNodes s) + , renamings = Map.insert i rens (renamings s) } + where i = identOrigName (nodeName nd) + +doneNodes :: InM (Map OrigName NodeDecl) +doneNodes = InM $ inlinedNodes <$> get + +{- | Generate a new version of the given identifier. -} +freshName :: Ident -> InM Ident +freshName i = + do u <- InM (inBase newInt) + let newON = (identOrigName i) { rnUID = u } + pure i { identResolved = Just newON } + + + + diff --git a/Language/Lustre/Transform/NoStatic.hs b/Language/Lustre/Transform/NoStatic.hs new file mode 100644 --- /dev/null +++ b/Language/Lustre/Transform/NoStatic.hs @@ -0,0 +1,1321 @@ +{-# Language OverloadedStrings, DataKinds #-} +{-| NOTE: At the moment the transformation in this pass are not really +optional, as the following passes expect them. + +XXX: This is quite complex, and it should probably be split into +the code that names call sites, and the code that actually instantiates +static parameters. + +This module removes static arguments and constants. +Calls to functions with static arguments are lifted to the top-level +and given an explicit name. + +Optionally (flag 'expandNodeInstDecl'), we can also expand functions +applied to static arguments to functions using a specialized definition instead. + +Optionally (flag 'nameCallSites), we can add explicit names for nested call +sites. For example, if @f(x,y)@ is a call that appears somewhere in an +expression, we add a new equation: + +p,q,r = f (x,y) + +and replace the function call with @(p,q,r)@. + +This will help with the following transformations: + + 1. when removing structured data, it is convenient if structured data is + either explicit or a variable: we can work around that for "simple" + expressions such as "when" and "merge", however we don't want to + duplicate function calls, so naming them is useful. + + 2. if function calls are named, it should be simpler to inline the + function's definition, as we can use the equations from `f` to + define `p`, `q`, and `r`. + +NOTE: We do NOT name calls to primitives that return a single result +(e.g., +, #, |, or ITE) +-} + +module Language.Lustre.Transform.NoStatic + ( noConst + , CallSiteMap + , CallSiteId, idFromRange, callSiteName + ) where + +import Data.Function(on) +import Data.Either(partitionEithers) +import Data.Map(Map) +import Data.Foldable(foldl') +import qualified Data.Map as Map +import Data.Text (Text) +import qualified Data.Text as Text +import MonadLib hiding (Label) +import Text.PrettyPrint(punctuate,comma,hsep) + +import Language.Lustre.Name +import Language.Lustre.AST +import Language.Lustre.Monad +import qualified Language.Lustre.Semantics.Const as C +import Language.Lustre.Semantics.Const (valToExpr) +import Language.Lustre.Semantics.Value +import Language.Lustre.Panic(panic) +import Language.Lustre.Pretty + +-- | Currently assumes an empty environment. +noConst :: [TopDecl] -> LustreM (CallSiteMap, [TopDecl]) +noConst ds = + do seed <- getNameSeed + let env = evalTopDecls (emptyEnv seed) + { expandNodeInsts = True + , nameCallSites = True + , envCurMod = Nothing + } ds + setNameSeed (envNameInstSeed env) + pure (envCallSiteMap env, reverse (readyDecls env)) + + +-- | Evaluate a top-level declaration. +evalTopDecl :: Env -> TopDecl -> Env +evalTopDecl env td = + case td of + DeclareType tde -> evalTypeDecl env tde + DeclareConst cd -> evalConstDef env cd + DeclareNode nd -> evalNodeDecl env nd + DeclareNodeInst nid -> evalNodeInstDecl env nid + DeclareContract {} -> + panic "evalTopDecl" + [ "Declaring top-level contracts is not yet supported." ] + +-- | Evaluate multiple top-level declarations from the same modeule. +evalTopDecls :: Env -> [TopDecl ] -> Env +evalTopDecls = foldl' evalTopDecl + + +-- | Maps node definitions to the places in the source where they are called. +-- For each call, we keep track of the left-hand-sides storing the results +-- of the call. +type CallSiteMap = Map OrigName (Map CallSiteId [LHS Expression]) + +-- | Identifies a call site uniquely. +-- Currently, it is computed from the location in the source. +-- XXX: Needs to be augmented to support multiple files/modules. +data CallSiteId = CallSiteId { csId :: (Int,Int), csRange :: SourceRange } + deriving (Show) + +-- | An identifer for a call site. This is computed from the location in the +-- source and so it should be unique wrt to a file, but not when multiple +-- file are involved. +callSiteName :: CallSiteId -> String +callSiteName x = "cs_" ++ show a ++ "_" ++ show b + where (a,b) = csId x + +instance HasRange CallSiteId where + range = csRange + +instance Eq CallSiteId where + (==) = (==) `on` csId + +instance Ord CallSiteId where + compare = compare `on` csId + +-- | This ignores files, so it only makes sense for ranges in the same file. +idFromRange :: SourceRange -> CallSiteId +idFromRange r = CallSiteId { csId = (pos sourceFrom, pos sourceTo) + , csRange = r } + where + pos f = sourceIndex (f r) + + +-------------------------------------------------------------------------------- +-- Evaluation Context and State + + + +data Env = Env + + { cEnv :: C.Env + -- ^ Environment for evaluating constants. + + , nodeInfo :: Map OrigName NodeProfile + -- ^ Types of the nodes that are in scope. + -- This is used to determine how to name the call sites. + -- It is also used to figure out which parameters are constants + -- when we call a function. + + , nodeTemplates :: Map OrigName TopDecl + -- ^ Nodes with static parameters, used when we expand definitions. + -- These declarations are NOT evaluated, instead we make a new copy + -- for each instantiation. + + , typeAliases :: Map OrigName Type + -- ^ Maps type names to evaluated types. + -- The only named types in an evaluated type are either structs or enums, + -- there should be no aliases to other types. + -- We also use this field when we are instantiating a node parameterized + -- by a type: the type parameters go in this map, temporarily. + + , envCurMod :: Maybe ModName + -- ^ Use this in the original name, when generating fresh top-level names. + -- (e.g., for naming instantiate things, or call sites). + + , expandNodeInsts :: Bool + {- ^ Should we expand node instances, or leave them named at the + top level. Note that we don't do any sharing at the moment, + so multiple identical instantiations would be simply copies + of each other. + NOTE: Later passes assumes that this is True + -} + + , nameCallSites :: Bool + {- ^ Should we add explicit equations for each call site? + NOTE: Later passes assume that this is True + -} + + , envNameInstSeed :: !NameSeed + -- ^ For generating names for function instantiations (not-expanded) + + , envCurRange :: Maybe SourceRange + -- ^ Whereabouts are we + + , readyDecls :: [TopDecl] + -- ^ Declarations that we've already processed. + -- These are the output of the algorithm. + + , nodeArgs :: Map OrigName NodeInst + -- ^ Instantiated node arguments: if the node argument was an instantiation, + -- then we first instantiate the template, give it a name, and use + -- that name. So, we should never have any remaining static + -- arguments. + + + , envCallSiteMap :: CallSiteMap + {- ^ For each node, maps a range in the source to a call site. + The call site is identified by the variables storing the results + of the call. This is useful so that we can propagate results from + later passes back to the calls they correspond to. + -} + + } + +inRange :: SourceRange -> Env -> Env +inRange r env = env { envCurRange = Just r } + + +-- | Does not expand node instances +emptyEnv :: NameSeed -> Env +emptyEnv seed = + Env { cEnv = C.emptyEnv + , nodeInfo = Map.empty + , typeAliases = Map.empty + , nodeTemplates = Map.empty + , readyDecls = [] + , nodeArgs = Map.empty + , expandNodeInsts = False + , nameCallSites = False + , envNameInstSeed = seed + , envCurRange = Nothing + , envCallSiteMap = Map.empty + , envCurMod = Nothing + } + +lookupNodeTemplateInfo :: + OrigName -> Env -> Maybe ([StaticParam], Either NodeProfile NodeInst) +lookupNodeTemplateInfo x env = + do temp <- Map.lookup x (nodeTemplates env) + case temp of + DeclareNode nd -> pure ( nodeStaticInputs nd ++ getConstParams p + , Left p + ) + where p = nodeProfile nd + + DeclareNodeInst nid -> + pure (nodeInstStaticInputs nid, Right (nodeInstDef nid)) + it -> panic "lookupNodeTemplateInfo" + [ "Unexpected template for " ++ showPP x + , "*** Declaration:" + , showPP it + ] + +getConstParams :: NodeProfile -> [ StaticParam ] +getConstParams p = [ ConstParam i t | InputConst i t <- nodeInputs p ] + + +-------------------------------------------------------------------------------- +-- Evaluation of types + +-- | Evaluate a type declaration. +evalTypeDecl :: Env -> TypeDecl -> Env +evalTypeDecl env td = + case typeDef td of + Nothing -> panic "evalTypeDecls" [ "Unsupported abstract type:" + , "*** Name: " ++ showPP name + ] + Just tdef -> + case tdef of + IsType x -> addAlias env name (evalType env x) + + -- Add the enumeration constants to the constant environemnt. + IsEnum xs -> env { cEnv = update (cEnv env) } + where + update cenv = + cenv { C.envConsts = foldr addVal (C.envConsts cenv) xs } + addVal i = let nm = identOrigName i + in Map.insert nm (VEnum name nm) + + IsStruct xs -> + env { cEnv = update (cEnv env) + , readyDecls = DeclareType td { typeDef = Just (IsStruct ds) } + : readyDecls env + } + where + update cenv = + cenv { C.envStructs = Map.insert name fs (C.envStructs cenv) } + + (fs,ds) = unzip (map doField xs) + + doField x = + ( (fieldName x, evalExprToVal env <$> fieldDefault x) + + , x { fieldType = evalType env (fieldType x) + , fieldDefault = Nothing + } + ) + + where + name = identOrigName (typeName td) + + + +-- | Evaluate a type: resolves named types, and evaluates array sizes. +evalType :: Env -> Type -> Type +evalType env ty = + case ty of + TypeRange r t -> TypeRange r (evalType env t) + + ArrayType t e -> ArrayType (evalType env t) (evalIntExpr env e) + + IntSubrange e1 e2 -> IntSubrange (evalIntExpr env e1) (evalIntExpr env e2) + + -- XXX: Note that the locations in the expanded type will be those + -- of the definition site, not the ones at the use site. + NamedType n -> case Map.lookup (nameOrigName n) (typeAliases env) of + Just t1 -> t1 + Nothing -> NamedType n + + IntType -> IntType + RealType -> RealType + BoolType -> BoolType + + +-- | Add a new name for the given type. If the named type is a struct, +-- then also add appropriate entries to the other maps, +-- so we can do direct look-ups without having to consult the alias map. +addAlias :: Env -> OrigName -> Type -> Env +addAlias env x t = + case t of + NamedType n -> + case checkEnum `mplus` checkStruct of + Just env2 -> env2 + Nothing -> panic "addAlias" + [ "Named type is neither `enum`, nor `struct`:" + , "*** Name: " ++ showPP n + ] + where + checkEnum = pure env1 + + checkStruct = + do let cenv = cEnv env + i <- Map.lookup (nameOrigName n) (C.envStructs cenv) + let newMap = Map.insert x i (C.envStructs cenv) + pure env1 { cEnv = cenv { C.envStructs = newMap } } + + _ -> env1 + where + env1 = env { typeAliases = Map.insert x t (typeAliases env) } + + + + +-------------------------------------------------------------------------------- +-- Evaluation of constants + +-- | Evaluate the definition of a constant, adding its values to the +-- environment. +evalConstDef :: Env -> ConstDef -> Env +evalConstDef env cd = env { cEnv = newCEnv } + where + cenv = cEnv env + val = case constDef cd of + Just e -> evalExprToVal env e + Nothing -> panic "evalConstDef" + [ "Uninterpreted constants are not supported." + , "*** Name: " ++ showPP (constName cd) + ] + + newCEnv = cenv { C.envConsts = Map.insert name val (C.envConsts cenv) } + name = identOrigName (constName cd) + + + +-- | Evaluate a constant expression of integer type. +evalIntExpr :: Env -> Expression -> Expression +evalIntExpr env expr = + case expr of + ERange r e -> ERange r (evalIntExpr (inRange r env) e) + _ -> case C.evalIntConst (cEnv env) expr of + Right i -> Lit (Int i) + Left err -> panic "evalIntExpr" [err] + +-- | Evaluate a constant expression to a value. +evalExprToVal :: Env -> Expression -> Value +evalExprToVal env expr = + case expr of + ERange r e -> evalExprToVal (inRange r env) e + _ -> case C.evalConst (cEnv env) expr of + Right val -> val + Left err -> panic "evalExprToVal" [err] + +-- | Evaluate a constant expression. +evalExpr :: Env -> Expression -> Expression +evalExpr env expr = + case expr of + ERange r e -> ERange r (evalExpr (inRange r env) e) + _ -> valToExpr (evalExprToVal env expr) + + +-- | Evaluate a selector. The indixes in a selector are constants. +evalSel :: Env -> Selector Expression -> Selector Expression +evalSel env sel = + case sel of + SelectField i -> SelectField i + SelectElement e -> SelectElement (evalIntExpr env e) + SelectSlice s -> SelectSlice (evalSlice env s) + + +-- | Eval an array slice. The indexes in the slice are constants. +evalSlice :: Env -> ArraySlice Expression -> ArraySlice Expression +evalSlice env s = ArraySlice { arrayStart = evalIntExpr env (arrayStart s) + , arrayEnd = evalIntExpr env (arrayEnd s) + , arrayStep = evalIntExpr env <$> arrayStep s + } + +-- | Evaluate a clock expression. The value activating the clock +-- is a constnat, and the identifier is definatly not. +evalClockExpr :: Env -> ClockExpr -> ClockExpr +evalClockExpr env (WhenClock r e i) = WhenClock r (evalExpr env e) i + +evalCType :: Env -> CType -> CType +evalCType env ct = CType { cType = evalType env (cType ct) + , cClock = evalIClock env (cClock ct) + } + +evalIClock :: Env -> IClock -> IClock +evalIClock env clk = + case clk of + BaseClock -> BaseClock + KnownClock c -> KnownClock (evalClockExpr env c) + ClockVar {} -> panic "NoStatic.evalIClock" [ "Unexpected clock variable." ] + + + +-------------------------------------------------------------------------------- +-- Evaluation of Nodes + + +{- | Evaluate a node declaration. +Nodes with static parameters are added to the template map, while "normal" +nodes are evaluated and added to the declaration list. -} +evalNodeDecl :: Env -> NodeDecl -> Env +evalNodeDecl env nd = + case nodeStaticInputs nd ++ getConstParams (nodeProfile nd) of + [] -> evalNode env nd [] + ps -> env { nodeTemplates = Map.insert name (DeclareNode nd) + (nodeTemplates env) + , nodeInfo = Map.insert name (nodeProfile nd) (nodeInfo env) + } + where + name = identOrigName (nodeName nd) + + +-- | Evaluate and instantiate a node with the given static parameters. +-- We assume that the arguments have been evaluated already. +evalNode :: Env -> NodeDecl -> [StaticArg] -> Env +evalNode env nd args = + envRet2 { readyDecls = DeclareNode newNode : readyDecls envRet2 + , nodeInfo = Map.insert name newProf (nodeInfo envRet2) + } + where + name = identOrigName (nodeName nd) + + -- 1. bind the provided static arguments. + env0 = addStaticParams (nodeStaticInputs nd) args env + newProf = evalNodeProfile env0 (nodeProfile nd) + + -- 2. evaluate constants in the locals + (bs,env1) = evalLocalDecls env0 $ case nodeDef nd of + Nothing -> [] + Just body -> nodeLocals body + + -- 3. "blackhole" the name seed, which should not be used. + -- This a strict field, so we can't put a panic there, so instead + -- we just make up a very invalid value, which would hopefully be + -- easy to spot, in case it get used accidentally. + env2 = env1 { envNameInstSeed = invalidNameSeed 77 } + + -- 4. Evaluate the equations in the body of a node. + ((eqs,ctr),newLs,insts,info,newS) = + runNameStatic (envNameInstSeed env) + (envCurMod env) $ + do newCtr <- traverse (evalContract env2) (nodeContract nd) + -- XXX: here we assume that locals are in scope in the contract? + -- also, function calls in the contract become ordinary locals, + -- instead of ghost variables, and we may want to distinguish + -- between this (e.g., if generating code). + + newEqs <- case nodeDef nd of + Nothing -> pure [] + Just body -> traverse (evalEqn env2) (nodeEqns body) + pure (concat newEqs, newCtr) + + -- Results, updating the *original* environment. + envRet1 = env { envNameInstSeed = newS + , envCallSiteMap = Map.insert name info (envCallSiteMap env) + } + envRet2 = addEvaluatedNodeInsts envRet1 insts + + + newDef = case nodeDef nd of + Nothing -> Nothing + Just _ -> Just NodeBody + { nodeLocals = map LocalVar (newLs ++ bs) + , nodeEqns = eqs + } + + newNode = nd { nodeStaticInputs = [] + , nodeProfile = newProf + , nodeContract = ctr + , nodeDef = newDef + } + + + + +-- | Evaluate a binder.have been evaluated already. +evalBinder :: Env -> Binder -> Binder +evalBinder env b = b { binderType = evalCType env (binderType b) } + + +-- | Evaluate the binders in the type of a node. +evalNodeProfile :: Env -> NodeProfile -> NodeProfile +evalNodeProfile env np = + NodeProfile { nodeInputs = map (evalInputBinder env) (nodeInputs np) + , nodeOutputs = map (evalBinder env) (nodeOutputs np) + } + + +evalInputBinder :: Env -> InputBinder -> InputBinder +evalInputBinder env ib = + case ib of + InputBinder b -> InputBinder (evalBinder env b) + InputConst i t -> panic "evalInputBinder" + [ "Unexpected constant parameter." + , "It should have been desugared by now." + , "*** Name: " ++ showPP i + , "*** Type: " ++ showPP t ] + + +-- | Evaluate a bunch of locals: the constants are added to the environment, +-- and we get the binders for the variables. +evalLocalDecls :: Env -> [ LocalDecl ] -> ([Binder], Env) +evalLocalDecls env ds = ( [ evalBinder env1 b | LocalVar b <- ds ] + , env1 + ) + where + env1 = foldl' evalConstDef env [ c | LocalConst c <- ds ] + + +evalContract :: Env -> Contract -> M Contract +evalContract env c = + do cis <- mapM (evalContractItem env) (contractItems c) + pure c { contractItems = cis } + +evalContractItem :: Env -> ContractItem -> M ContractItem +evalContractItem env ci = + case ci of + Assume l e -> Assume l <$> evalDynExpr NestedExpr env e + Guarantee l e -> Guarantee l <$> evalDynExpr NestedExpr env e + _ -> panic "evalContractItem" + [ "Unsupported contract iterm. For now just `assume`/`guarante`."] +{- + GhostConst c mbT e -> GhostConst c + GhostVar b e -> + Mode m as ts -> + Import c is os -> +-} + +-- | Evaluate an equation. +evalEqn :: Env -> Equation -> M [Equation] +evalEqn env eqn = + collectFunEqns $ + case eqn of + Assert x t e -> Assert x t <$> evalDynExpr NestedExpr env e + Property x e -> Property x <$> evalDynExpr NestedExpr env e + Define ls e -> let lhs = map (evalLHS env) ls + in Define lhs <$> evalDynExpr (TopExpr lhs) env e + IsMain r -> pure (IsMain r) + IVC is -> pure (IVC is) + Realizable is -> pure (Realizable is) + +-- | Evaluate a left-hand-side of an equation. +evalLHS :: Env -> LHS Expression -> LHS Expression +evalLHS env lhs = + case lhs of + LVar x -> LVar x + LSelect l s -> LSelect (evalLHS env l) (evalSel env s) + + +-------------------------------------------------------------------------------- +-- Evaluating and Expanding Node Instances + +-- | Evaluate a node-instance declaration. +-- Parameterized ones are added to the template map. +evalNodeInstDecl :: Env -> NodeInstDecl -> Env +evalNodeInstDecl env nid = + case nodeInstStaticInputs nid of + [] -> evalNodeInst env nid [] + ps -> env { nodeTemplates = Map.insert name (DeclareNodeInst nid) + (nodeTemplates env) + } + where + name = identOrigName (nodeInstName nid) + + +-- | Evaluate a node-instance declaration using the given static arguments. +-- The static arguments should have been evaluated already. +evalNodeInst :: Env -> NodeInstDecl -> [StaticArg] -> Env +evalNodeInst env nid args = addEvaluatedNodeInst envRet2 newInst + where + env0 = addStaticParams (nodeInstStaticInputs nid) args env + env1 = env0 { envNameInstSeed = invalidNameSeed 78 } + -- Do not use! Bogus value for sanity. + -- (strict, so no error/undefined) + + nameNodeInstDef (NodeInst f as) = + case as of + [] | CallUser nm <- f + , Just ni <- Map.lookup (nameOrigName nm) (nodeArgs env1) -> pure ni + _ -> do bs <- mapM (evalStaticArg env1) as + pure (NodeInst f bs) + + (newDef,[],insts,info,newS) = runNameStatic + (envNameInstSeed env) + (envCurMod env) + (nameNodeInstDef (nodeInstDef nid)) + + envRet1 = env { envNameInstSeed = newS + , envCallSiteMap = + let nm = identOrigName (nodeInstName nid) + in Map.insert nm info (envCallSiteMap env) } + envRet2 = addEvaluatedNodeInsts envRet1 insts + + -- Note that we leave the name as is because this is the right thing + -- for nodes with no static parameters. If, OTOH, we are instantiating + -- a template, then we've already put the correct name in the template. + + newInst = nid { nodeInstStaticInputs = [] + , nodeInstProfile = Nothing + , nodeInstDef = newDef + } + + + + +-- | Add an already evaluated node instance to the environment. +-- This is where we expand instances, if the flag in the environment is set. +addEvaluatedNodeInst :: Env -> NodeInstDecl -> Env +addEvaluatedNodeInst env ni + | expandNodeInsts env = expandNodeInstDecl env ni + | otherwise = doAddNodeInstDecl ni env + +-- | Add an already evaluated node instance to the environment. +-- This is where we expand instances, if the flag in the environment is set. +addEvaluatedNodeInsts :: Env -> [NodeInstDecl] -> Env +addEvaluatedNodeInsts = foldl' addEvaluatedNodeInst + +-- | Replace a previously evaluated node-instance with its expanded version +-- @f = g<> --> node f(...) instantiated `g`@ +expandNodeInstDecl :: Env -> NodeInstDecl -> Env +expandNodeInstDecl env nid = + case nodeInstStaticInputs nid of + [] -> + case nodeInstDef nid of + NodeInst (CallUser f) ps@(_ : _) -> + case Map.lookup (nameOrigName f) (nodeTemplates env) of + Just nt -> + case nt of + + DeclareNode nd -> + let prof = nodeProfile nd + (cs,is') = inputBindersToParams (nodeInputs prof) + prof' = prof { nodeInputs = is' } + in evalNode env nd { nodeName = nodeInstName nid + , nodeProfile = prof' + , nodeStaticInputs = + nodeStaticInputs nd ++ cs + } ps + + DeclareNodeInst nd -> + evalNodeInst env nd { nodeInstName = nodeInstName nid } ps + + _ -> panic "expandNodeInstDecl" + [ "Non-node template:" + , "*** template: " ++ showPP nt + ] + + _ -> panic "expandNodeInstDecl" $ + [ "Unknown template:" + , "*** Name: " ++ showPP f + , "*** Available: " + ] ++ [ " " ++ showPP x + | x <- Map.keys (nodeTemplates env) ] + + _ -> doAddNodeInstDecl nid env + + _ -> panic "expandNodeInstDecl" + [ "Trying to expand a template!" + , "*** Name: " ++ showPP (nodeInstName nid) + ] + + + +-- expandIterAt :: Env -> [Binder] -> Iter -> [StaticArg] -> +{- +expandIterAt env resTys it args = undefined + case (it,args) of + (IterFill, [ NodeArg _ _ni, sz ], [s]) -> undefined + {- let s1, x1, y1 = ni s + s2, x2, y2 = ni s1 + s3, x3, y3 = ni s2 + ... + sN, xN, yN = ni s{N-1} + in (sN, [ x1 .. xN ], [ y1 .. yN ]) -} + + (IterRed, [ NodeArg _ ni, sz ], (s : xs)) -> undefined + {- let s1 = ni (s , x1, y1) + s2 = ni (s1, x2, y2) + ... + sN = ni (s{N-1}, xN, Yn) + in sN -} + + (IterFill, [ NodeArg _ ni, sz ], (s : xs)) -> undefined + {- let s1, a1, b1 = ni (s, x1, y1) + s2, a2, b2 = ni (s1, x2, y2) + ... + sN, aN, bN = ni (s{N-1}, xN, yN) + in (sN, [ a1 .. aN ], [b1 .. bN]) -} + + + (IterMap, [ NodeArg _ ni, sz ], xs) -> undefined + {- let a1, b1 = ni (x1,y1) + a2, b2 = ni (x2,y2) + ... + aN, bN = ni (xN,yN) + in ([a1..N], [b1..bN]) -} + + (IterBoolRed, [ i, j, n ], [xs]) -> undefined + {- let n1 = if x1 then 1 else 0 + n2 = if x2 then n1 + 1 else n1 + ... + nN = if xN then n{N-1} + 1 else n{N-1} + in i <= nN && nN <= j + -} +-} + + + +-- | Add a finished node instance declaration to the environment. +doAddNodeInstDecl :: NodeInstDecl -> Env -> Env +doAddNodeInstDecl ni env = + env { readyDecls = DeclareNodeInst ni : readyDecls env + , nodeInfo = case getNodeInstProfile env (nodeInstDef ni) of + Just prof -> Map.insert name prof (nodeInfo env) + Nothing -> nodeInfo env + } + where name = identOrigName (nodeInstName ni) + + +-------------------------------------------------------------------------------- +-- Typing of Node Instances +-- XXX: This should have happened in the type checker? + +{- | Determine the type of a node instance. +Returns 'Maybe' because in some cases we can't determine the +(e.g. some primitives are polymorphic). We don't name the call sites +for such primitces. -} +getNodeInstProfile :: Env -> NodeInst -> Maybe NodeProfile +getNodeInstProfile env (NodeInst c as) = + case c of + CallUser f -> + case as of + [] -> case Map.lookup (nameOrigName f) (nodeInfo env) of + Just a -> Just a + Nothing -> panic "getNodeInstProfile" + [ "Unknown profile for node:" + , "*** Node name: " ++ showPP f + ] + _ -> case lookupNodeTemplateInfo (nameOrigName f) env of + Just (ps,lrProf) -> + let env1 = addStaticParams ps as env + in case lrProf of + Left prof -> Just (evalNodeProfile env1 prof) + Right ni -> getNodeInstProfile env1 ni + _ -> panic "getNodeInstProfile" + [ "Unknown profile for parameterized node:" + , "*** Node name: " ++ showPP f + ] + + + CallPrim _ p -> + case p of + Iter it -> + case it of + IterFill -> + case as of + [ NodeArg _ ni, ExprArg n ] -> + do prof <- getNodeInstProfile env ni + case nodeOutputs prof of + b : bs -> Just prof { nodeOutputs = b : map (toArr n) bs} + _ -> bad + _ -> bad + + IterRed -> + case as of + [ NodeArg _ ni, ExprArg n ] -> + do prof <- getNodeInstProfile env ni + case nodeInputs prof of + b : bs -> Just prof + { nodeInputs = b : map (toArrI n) bs } + _ -> bad + _ -> bad + + + IterFillRed -> + case as of + [ NodeArg _ ni, ExprArg n ] -> + do prof <- getNodeInstProfile env ni + case (nodeInputs prof, nodeOutputs prof) of + (i:is,o:os) -> + Just NodeProfile + { nodeInputs = i : map (toArrI n) is + , nodeOutputs = o : map (toArr n) os + } + + _ -> bad + _ -> bad + + + IterMap -> + case as of + [ NodeArg _ ni, ExprArg n ] -> + do prof <- getNodeInstProfile env ni + Just NodeProfile + { nodeInputs = map (toArrI n) (nodeInputs prof) + , nodeOutputs = map (toArr n) (nodeOutputs prof) + } + _ -> bad + + + IterBoolRed -> + panic "getNodeInstProfile" + [ "Not yet implemented, IterBoolRed" ] + + where + setTy x f = x { binderType = let ct = binderType x + in ct { cType = f (cType ct) } } + toArr n x = setTy x (`ArrayType` n) + toArrI n x = + case x of + InputBinder b -> InputBinder (setTy b (`ArrayType` n)) + InputConst i t -> InputConst i (ArrayType t n) + + bad = panic "getNodeInstProfile" + [ "Unexpecetd iterator instantiation." + , "*** Iterator: " ++ showPP it + , "*** Arguments: " ++ show ( hsep $ punctuate comma + $ map pp as ) + ] + Op1 _ -> Nothing + Op2 _ -> Nothing + OpN _ -> Nothing + ITE -> Nothing + + +-------------------------------------------------------------------------------- +-- Static Arguments + +addStaticParams :: [ StaticParam ] -> [ StaticArg ] -> Env -> Env +addStaticParams ps as env = + case (ps,as) of + ([], []) -> env + (p : ps1, a : as1) -> addStaticParams ps1 as1 (addStaticParam p a env) + _ -> panic "addStaticParams" [ "Mismatch in static aruments" ] + + +addStaticParam :: StaticParam -> StaticArg -> Env -> Env +addStaticParam p a env + | ArgRange _ a1 <- a = addStaticParam p a1 env -- XXX: use location? + | otherwise = + case p of + + TypeParam i -> + case a of + TypeArg t -> + env { typeAliases = Map.insert (identOrigName i) t + (typeAliases env) } + _ -> panic "addStaticParam" + [ "Invalid static parameter:" + , "*** Expected: a type for " ++ showPP i + , "*** Got: " ++ showPP a + ] + + + ConstParam i t -> + case a of + ExprArg e -> + let cenv = cEnv env + val = evalExprToVal env e + in env { cEnv = cenv { C.envConsts = Map.insert + (identOrigName i) val + (C.envConsts cenv) } } + _ -> panic "addStaticParam" + [ "Invalid static parameter:" + , "*** Expected: a constant for " ++ + showPP i ++ " : " ++ showPP t + , "*** Got: " ++ showPP a + ] + + + NodeParam _ _ f prof -> + case a of + NodeArg _ ni -> + let nm = identOrigName f + in env { nodeArgs = Map.insert nm ni (nodeArgs env) + , nodeInfo = Map.insert nm prof (nodeInfo env) } + + _ -> panic "addStaticParam" + [ "Invalid static parameter:" + , "*** Expected: a node for " ++ showPP f + , "*** Got: " ++ showPP a + ] + + + + + + +-------------------------------------------------------------------------------- +-- Evaluation of expressions + + +-- | Keep track if we are at the top or nested, to determine +-- when we should name call sites. +data ExprLoc = TopExpr [LHS Expression] | NestedExpr + +-- | Rewrite an expression that is not neccessarily constant. +evalDynExpr :: ExprLoc -> Env -> Expression -> M Expression +evalDynExpr eloc env expr = + case expr of + ERange r e -> ERange r <$> evalDynExpr eloc (inRange r env) e + + Const e t -> pure (Const (evalExpr env e) (evalCType env t)) + + Var {} -> pure expr + + Lit _ -> panic "evalDynExpr" [ "Unexpected `Lit` outside `Const`" ] + + + e1 `When` e2 -> do e1' <- evalDynExpr NestedExpr env e1 + pure (e1' `When` evalClockExpr env e2) + + Tuple es -> Tuple <$> mapM (evalDynExpr NestedExpr env) es + Array es -> Array <$> mapM (evalDynExpr NestedExpr env) es + Select e s -> do e' <- evalDynExpr NestedExpr env e + pure (Select e' (evalSel env s)) + + + -- INVARIANT: the fields in a struct value are in the same order is + -- in the declaration. + Struct s fs -> evalNewStruct env s fs + + -- INVARIANT: the fields in a struct value are in the same order is + -- in the declaration. + UpdateStruct ~(Just s) e fs -> evalUpdExprStruct env s e fs + + WithThenElse e1 e2 e3 -> + case evalExprToVal env e1 of + VBool b -> if b then evalDynExpr eloc env e2 + else evalDynExpr eloc env e3 + v -> panic "evalDynExpr" + [ "Decision in `with-then-else` is not a `bool`" + , "*** Value: " ++ showPP (valToExpr v) + ] + + Merge i ms -> + case Map.lookup (identOrigName i) (C.envConsts (cEnv env)) of + Just v -> evalMergeConst env v ms + Nothing -> Merge i <$> mapM (evalMergeCase env) ms + + Call f es cl0 mTys -> + do let cl = evalIClock env cl0 + (cs,es0) <- + case f of + NodeInst (CallUser c) _ -> + let nm = nameOrigName c + in case Map.lookup nm (nodeInfo env) of + Just p -> pure (inputBindersToArgs (nodeInputs p) es) + Nothing -> panic "evalDynExpr" + [ "Missing node profile for function." + , "*** Function: " ++ showPP c + ] + _ -> pure ([],es) + es' <- do args <- mapM (evalDynExpr NestedExpr env) es0 + pure $ case args of + [ e ] | Just xs <- isTuple e -> xs + _ -> args + ni <- case (f,cs) of + (NodeInst c [],[]) -> + pure $ + case c of + CallUser i + | Just ni <- Map.lookup (nameOrigName i) (nodeArgs env) + -> ni + + _ -> NodeInst c [] + (NodeInst c as, _) -> + nameInstance env (NodeInst c (as ++ cs)) + + shouldName <- case eloc of + TopExpr ls -> + do case f of + NodeInst (CallUser _) _ -> + recordCallSite (range f) ls + _ -> pure () + pure False + NestedExpr -> pure (nameCallSites env) + if shouldName + then nameCallSite env ni es' cl mTys + else pure (Call ni es' cl mTys) + + where + isTuple e = + case e of + ERange _ e1 -> isTuple e1 + Tuple es -> Just es + _ -> Nothing + + + +-- | Identify which of the inputs are really static constant parameters. +inputBindersToParams :: [InputBinder] -> ([StaticParam],[InputBinder]) +inputBindersToParams = partitionEithers . map classify + where + classify ib = case ib of + InputBinder _ -> Right ib + InputConst i t -> Left (ConstParam i t) + +inputBindersToArgs :: + [InputBinder] -> [Expression] -> ([StaticArg],[Expression]) +inputBindersToArgs ins es = + case (ins,es) of + ([],[]) -> ([],[]) + (i:is,e:rest) -> + let (cs,vs) = inputBindersToArgs is rest + in case i of + InputBinder _ -> (cs,e:vs) + InputConst {} -> (ExprArg e : cs,vs) + _ -> panic "inputBindersToArgs" [ "Type argument mismatch in call."] + + + + +-- | Name a call site, by adding an additional equation for the call, +-- and replacing the call with a tuple containing the results. +-- We leave primitives with a single result as calls though. +nameCallSite :: + Env -> NodeInst -> [Expression] -> IClock -> Maybe [CType] -> M Expression +nameCallSite env ni es cl mTys = + do mb <- findInstProf env ni + case mb of + Just prof -> + do let ins = map inB (nodeInputs prof) + outs = nodeOutputs prof + + let baseName = Text.pack (show (pp ni)) + oName o = case outs of + [_] -> baseName + _ -> Text.concat + [ baseName, "_", identText (binderDefines o) ] + let newId o = do i <- newIdent (range ni) Nothing (oName o) AVal + pure (origNameToIdent i) + ns <- mapM newId outs + let names = map binderDefines (ins ++ outs) + let nameMap = Map.fromList + $ zip names (map isIdent es ++ map Just ns) + + renClock (WhenClock r e i) = -- loc? + WhenClock r (evalExpr env e) $ + case Map.lookup i nameMap of + Just (Just j) -> j + Just Nothing -> + panic "nameCallSite" + [ "Output's clock depends on an input." -- ? + , "The clock parameter must be an identifier." + , "*** Clock: " ++ showPP i + ] + _ -> panic "nameCallSite" + [ "Undefined clock variable." + , "*** Clock: " ++ showPP i ] + + toBind n b = + Binder + { binderDefines = n + , binderType = + let ct = binderType b + in ct { cClock = + case cClock ct of + BaseClock -> cl + KnownClock curCl -> + KnownClock (renClock curCl) + ClockVar i -> + panic "nameCallSite.toBind" + [ "Unexpected clock variable", showPP i ] + } + } + binds = zipWith toBind ns outs + let lhs = map LVar ns + recordCallSite (range ni) lhs + addFunEqn binds (Define lhs (Call ni es cl (Just $ binderType <$> binds))) + pure $ case map (Var . Unqual) ns of + [one] -> one + notOne -> Tuple notOne + Nothing -> pure (Call ni es cl mTys) + where + isIdent expr = + case expr of + ERange _ e -> isIdent e + Var (Unqual i) -> Just i + _ -> Nothing + + inB inb = + case inb of + InputBinder b -> b + InputConst i t -> panic "nameCallSite" + [ "Unexpecetd constant parameter" + , "*** Name: " ++ showPP i + , "*** Type: " ++ showPP t ] + + + +-- | Use a constant to select a branch in a merge. +evalMergeConst :: Env -> Value -> [MergeCase Expression] -> M Expression +evalMergeConst env v ms = + case ms of + MergeCase p e : more + | evalExprToVal env p == v -> evalDynExpr NestedExpr env e + | otherwise -> evalMergeConst env v more + [] -> panic "evalMergeConst" [ "None of the branches of a merge matched:" + , "*** Value: " ++ showPP (valToExpr v) + ] + +-- | Evaluate a case branch of a merge construct. +evalMergeCase :: Env -> MergeCase Expression -> M (MergeCase Expression) +evalMergeCase env (MergeCase p e) = + MergeCase (evalExpr env p) <$> evalDynExpr NestedExpr env e + +-- | Evaluate an update to a struct that is not a constant. +evalUpdExprStruct :: + Env -> Name -> Expression -> [Field Expression] -> M Expression +evalUpdExprStruct env s e fs = + do e1 <- evalDynExpr NestedExpr env e + fs' <- mapM evalField fs + pure (UpdateStruct (Just s) e1 fs') + where + evalField (Field l e1) = Field l <$> evalDynExpr NestedExpr env e1 + + +-- | Evaluate a dynamic expression declaring a struct literal. +-- Missing fields are added by using the default values declared in the type. +evalNewStruct :: Env -> Name -> [Field Expression] -> M Expression +evalNewStruct env s fs = + evalNewStructWithDefs env s fs $ + case Map.lookup (nameOrigName s) (C.envStructs (cEnv env)) of + Just def -> def + Nothing -> panic "evalNewStruct" [ "Undefined struct type:" + , "*** Name: " ++ showPP s + ] + + +{- | Evaluate a dynamic expression declaring a struct literal, using +the given list of fields. The list if fields should contain all fields +in the struct, and the 'Maybe' value is an optional default--if it is +'Nothing', then the filed must be defined, otherwise the default is used +in case the filed ismissing. -} +evalNewStructWithDefs :: + Env -> Name -> [Field Expression] -> [(Label, Maybe Value)] -> M Expression +evalNewStructWithDefs env s fs def = + do fld <- Map.fromList <$> mapM evalField fs + pure (Struct s (map (setField fld) def)) + where + evalField (Field l e) = + do e1 <- evalDynExpr NestedExpr env e + return (l,e1) + + setField fld (f,mbV) = + Field f $ + case Map.lookup f fld of + Just e -> e + Nothing -> + case mbV of + Just v -> valToExpr v + Nothing -> panic "evalNewStructWithDefs" + [ "Missing field in struct:" + , "*** Name: " ++ showPP f + ] + + + + +-- | Generate a new top-level declaration for this node instance. +nameInstance :: Env -> NodeInst -> M NodeInst +nameInstance env (NodeInst fu xs) = + case xs of + [] -> pure (NodeInst fu xs) + _ -> do ys <- mapM (evalStaticArg env) xs + g <- addNameInstDecl fu ys + pure (NodeInst (CallUser g) []) + +evalStaticArg :: Env -> StaticArg -> M StaticArg +evalStaticArg env sa = + case sa of + ArgRange r sa1 -> ArgRange r <$> evalStaticArg env sa1 + NodeArg fu ni -> NodeArg fu <$> nameInstance env ni + + TypeArg t -> pure (TypeArg (evalType env t)) + ExprArg e -> pure (ExprArg (evalExpr env e)) + + + + +-------------------------------------------------------------------------------- +-- Expression Evalutaion Monad + +type M = WithBase Id [ ReaderT RO + , StateT RW + ] + +runNameStatic :: + NameSeed {- ^ Start generating names using this seed -} -> + Maybe ModName {- ^ What module are we working on at the moment. + 'Nothing' means use "global" module -} -> + M a {- ^ This is what we want to do -} -> + (a, [Binder], [ NodeInstDecl ], Map CallSiteId [LHS Expression], NameSeed) + -- ^ result, new locals, new instances, call site info, new name seed +runNameStatic seed cm m + | not (isValidNameSeed seed) = + panic "runNameStatic" + [ "Incorrect use of `envNameInstSeed`" + , "*** Negative seed: " ++ show seed + ] + | otherwise = (a, newLocals rw1, reverse (instances rw1) + , csInfo rw1 + , nameSeed rw1) + where + (a,rw1) = runId (runStateT rw (runReaderT cm m)) + rw = RW { nameSeed = seed, instances = [], funEqns = [], newLocals = [] + , csInfo = Map.empty } + +type RO = Maybe ModName + +data RW = RW + { nameSeed :: !NameSeed -- ^ Generate new names + , instances :: [ NodeInstDecl ] -- ^ Generated declarations + , newLocals :: [ Binder ] -- ^ New locals to declare for 'funEqns' + , funEqns :: [ Equation ] -- ^ Generated named function call sites + , csInfo :: Map CallSiteId [LHS Expression] + -- ^ Identified call sites + } + +recordCallSite :: SourceRange -> [LHS Expression] -> M () +recordCallSite r xs = + sets_ $ \s -> s { csInfo = Map.insert (idFromRange r) xs (csInfo s) } + + +{- | Name the given instantiation. +XXX: For the moment, all new nodes are "safe nodes". +Eventually, we should probably be more accurate and keep track of the +safety & functionality of declarations. +-} +addNameInstDecl :: Callable -> [StaticArg] -> M Name +addNameInstDecl c as = + do cm <- ask + i <- newIdent (range c) cm (Text.pack (show (pp c))) ANode + addInst NodeInstDecl + { nodeInstSafety = Safe + , nodeInstType = Node + , nodeInstName = origNameToIdent i + , nodeInstStaticInputs = [] + , nodeInstProfile = Nothing + , nodeInstDef = NodeInst c as + } + pure (origNameToName i) + + + + +-- | Generate a fresh name associated with the given source location. +newIdent :: SourceRange -> Maybe ModName -> Text -> Thing -> M OrigName +newIdent r md txt th = sets $ \s -> + let uid = nameSeed s + lab = Label { labText = txt, labRange = r } + origI = Ident { identLabel = lab + , identResolved = Nothing + } + origN = OrigName { rnUID = nameSeedToInt uid + , rnModule = md + , rnIdent = origI + , rnThing = th + } + + s1 = s { nameSeed = nextNameSeed uid } + in s1 `seq` (origN, s1) + + +-- | Remember the given instance. +addInst :: NodeInstDecl -> M () +addInst ni = sets_ $ \s -> s { instances = ni : instances s } + +findInstProf :: Env -> NodeInst -> M (Maybe NodeProfile) +findInstProf env ni@(NodeInst c as) = + case (c,as) of + (CallUser n, []) + | Unqual i <- n -> search (identText i) + where + search t = do is <- instances <$> get + case filter ((t ==) . identText . nodeInstName) is of + d : _ -> findInstProf env (nodeInstDef d) + _ -> pure (getNodeInstProfile env ni) + + _ -> pure (getNodeInstProfile env ni) + + +-- | Run a computation and collect all named function call sites, +-- returning them. The result of the computation is added last to the list. +collectFunEqns :: M Equation -> M [Equation] +collectFunEqns m = + do e <- m + sets $ \s -> (reverse (e : funEqns s), s { funEqns = [] }) + +-- | Record a new function equation. +addFunEqn :: [Binder] -> Equation -> M () +addFunEqn bs eqn = sets_ $ \s -> s { newLocals = bs ++ newLocals s + , funEqns = eqn : funEqns s } diff --git a/Language/Lustre/Transform/NoStruct.hs b/Language/Lustre/Transform/NoStruct.hs new file mode 100644 --- /dev/null +++ b/Language/Lustre/Transform/NoStruct.hs @@ -0,0 +1,985 @@ +{-# Language OverloadedStrings, GeneralizedNewtypeDeriving, DataKinds #-} +{- | The purpose of this module is to eliminate structured data. +It should be called after constants have been eliminated, as we then +know the shape of all data. We also assume that function calls have +been named, see "Language.Lustre.Transform.NoStatic". -} +module Language.Lustre.Transform.NoStruct + ( NosIn(..), NosOut(..) + , SimpleCallSiteMap, StructInfo, StructData(..) + , noStruct + ) where + +import Data.Map(Map) +import qualified Data.Map as Map +import qualified Data.Text as Text +import Data.Maybe(fromMaybe) +import Data.List(genericDrop,genericReplicate) +import Data.Traversable(for) +import Text.PrettyPrint((<+>), braces, brackets, parens) +import MonadLib hiding (Label) + +import Language.Lustre.Name +import Language.Lustre.AST +import Language.Lustre.Pretty +import Language.Lustre.Transform.NoStatic(CallSiteMap,CallSiteId) +import Language.Lustre.Monad +import Language.Lustre.Utils +import Language.Lustre.Panic + +-- | Information needed to perform the no-structure pass. +data NosIn = NosIn + { nosiStructs :: Map OrigName [(Label,Type)] + -- ^ Structs from other modules + + , nosiCallSites :: CallSiteMap + -- ^ Call sites information from the no-static pass + } + +data NosOut = NosOut + { nosoExpanded :: Map OrigName StructInfo + -- ^ Specifies how various identifiers got expanded + + , nosoCallSites :: SimpleCallSiteMap + -- ^ Processed call sites. + } + +runNosM :: NosIn -> NosM a -> LustreM (NosOut, a) +runNosM ni (NosM m) = + do (a,s) <- runStateT rw $ runReaderT ro m + let out = NosOut { nosoExpanded = rwCollectedInfo s + , nosoCallSites = rwSimpleCallSiteMap s + } + pure (out, a) + where + ro = RO { roStructs = nosiStructs ni + , roCallSiteTodo = nosiCallSites ni + } + rw = RW { rwCollectedInfo = Map.empty + , rwStructured = Map.empty + , rwSimpleCallSiteMap = Map.empty + } + + + +type SimpleCallSiteMap = Map OrigName (Map CallSiteId [OrigName]) + +noStruct :: NosIn -> [TopDecl] -> LustreM (NosOut, [TopDecl]) +noStruct ni ds = runNosM ni (go [] ds) + where + go done todo = case todo of + [] -> pure (reverse done) + d : more -> evalTopDecl d $ \mb -> + case mb of + Nothing -> go done more + Just d1 -> go (d1 : done) more + + +data StructData a = SLeaf a + | SArray [StructData a] + | STuple [StructData a] + | SStruct OrigName [Field (StructData a)] + +instance Functor StructData where + fmap f st = + case st of + SLeaf a -> SLeaf (f a) + SArray vs -> SArray (fmap (fmap f) vs) + STuple vs -> STuple (fmap (fmap f) vs) + SStruct s fs -> SStruct s (fmap (fmap (fmap f)) fs) + +instance Foldable StructData where + foldMap f st = + case st of + SLeaf a -> f a + SArray vs -> foldMap (foldMap f) vs + STuple vs -> foldMap (foldMap f) vs + SStruct _ fs -> foldMap (foldMap (foldMap f)) fs + +instance Traversable StructData where + traverse f st = + case st of + SLeaf a -> SLeaf <$> f a + SArray vs -> SArray <$> traverse (traverse f) vs + STuple vs -> STuple <$> traverse (traverse f) vs + SStruct x fs -> SStruct x <$> traverse (traverse (traverse f)) fs + + + +instance Pretty a => Pretty (StructData a) where + ppPrec n sd = + case sd of + SLeaf a -> ppPrec n a + SArray as -> brackets (commaSep (map pp as)) + STuple as -> parens (commaSep (map pp as)) + SStruct s fs -> pp s <+> braces (commaSep (map pp fs)) + +-- | Convert a potentially structured expression (already evaluated) +-- into a list of expressions. +flatStructData :: StructData a -> [a] +flatStructData sd = + case sd of + SArray es -> concatMap flatStructData es + STuple es -> concatMap flatStructData es + + -- Here we are assuming that fields are already ordered in some normal form. + -- Currently, this invariant should be enforced by `NoStatic`, which + -- places explicit struct fields in the order specified by the struct + -- declaration. + SStruct _ fs -> [ v | Field _ e <- fs, v <- flatStructData e ] + + SLeaf a -> [ a ] + + + + + +-------------------------------------------------------------------------------- +-- Evaluation of Top Level Declarations + +evalTopDecl :: TopDecl -> (Maybe TopDecl -> NosM a) -> NosM a +evalTopDecl td k = + case td of + DeclareType tde -> evalTypeDecl tde k + + DeclareConst cd -> panic "evalTopDecl" + [ "Unexpecetd constant declaration." + , "*** Declaration: " ++ showPP cd ] + + DeclareNode nd -> do node <- evalNode nd + k (Just (DeclareNode node)) + + DeclareNodeInst nid -> panic "evalTopDecl" + [ "Node instance declarations should be expanded." + , "*** Node instance: " ++ showPP nid + ] + +-- | Add a structure definition to the environemnt, or do nothing. +evalTypeDecl :: TypeDecl -> (Maybe TopDecl -> NosM a) -> NosM a +evalTypeDecl td k = + case typeDef td of + Just (IsStruct fs) -> doAddStructDef (typeName td) fs (k Nothing) + _ -> k (Just (DeclareType td)) + + +-- | Evaluate a node, expanding structured data. +evalNode :: NodeDecl -> NosM NodeDecl +evalNode nd = + do let prof = nodeProfile nd + inBs <- expandBinders (map inB (nodeInputs prof)) + outBs <- expandBinders (nodeOutputs prof) + let newProf = NodeProfile { nodeInputs = map InputBinder inBs + , nodeOutputs = outBs + } + + newC <- traverse evalContract (nodeContract nd) + + (simp,newDef) <- + case nodeDef nd of + Nothing -> pure (Map.empty, Nothing) + Just body -> + do todoCS <- getCSTodo (identOrigName (nodeName nd)) + (simp, body1) <- evalNodeBody todoCS body + pure (simp, Just body1) + + finishNode (identOrigName (nodeName nd)) simp + + pure nd { nodeProfile = newProf + , nodeContract = newC + , nodeDef = newDef } + + +inB :: InputBinder -> Binder +inB ib = + case ib of + InputBinder b -> b + InputConst i t -> panic "inB" + [ "Unexpected input constant:" + , "*** Name: " ++ showPP i + , "*** Type: " ++ showPP t ] + +-- | Evaluate a node's definition. Expands the local variables, +-- and rewrites the equations. +evalNodeBody :: + Map a [LHS Expression] -> + NodeBody -> + NosM (Map a [OrigName], NodeBody) +evalNodeBody csTodo body = + do locBs <- expandBinders [ b | LocalVar b <- nodeLocals body ] + simpCS <- traverse (fmap concat . traverse expandLHS') csTodo + eqns <- concat <$> traverse evalEqn (nodeEqns body) + pure ( simpCS + , NodeBody { nodeLocals = map LocalVar locBs + , nodeEqns = eqns + } + ) + + + +-------------------------------------------------------------------------------- +-- Mappings between structured types/data and flat representations. + +-- | Compute the list of atomic types in a type. +-- Also returns a boolean to indicate if this was a structured type. +expandType :: Map OrigName [(Label,Type)] -> Type -> (Bool, [([SubName],Type)]) +expandType env ty = + case ty of + TypeRange r t -> (b, [ (n,TypeRange r u) | (n,u) <- ts ]) + where (b,ts) = expandType env t + + -- Named types are either structs or enums. + NamedType s | Just fs <- Map.lookup (nameOrigName s) env -> + ( True, [ (StructEl x : n, t) + | (x,ts) <- fs + , (n,t) <- snd (expandType env ts) + ] + ) + + ArrayType t e -> + ( True, [ (ArrEl i : n, u) + | let done = snd (expandType env t) + , i <- [ 0 .. exprToInteger e - 1 ] + , (n,u) <- done + ] + ) + + _ -> (False, [([],ty)]) + +data SubName = ArrEl Integer | StructEl Label + + +-- | Given a type and epxressions for the leaves of a structured value, +-- rebuild the actual value. +-- For example: if @S = { x : int; y : int^3 }@ +-- And we are given the leaves: @[e1,e2,e3,e4]@ +-- then, the result will be: @{ x = e1, y = [e2,e3,e4] }@ +toNormE :: Map OrigName [ (Label, Type) ] -> Type -> [a] -> StructData a +toNormE env t0 es0 = + case go es0 t0 of + ([], e) -> e + _ -> panic "toNormE" [ "Left over expressions after rebuilt" ] + where + goMany inEs tys = + case tys of + [] -> (inEs , []) + t : more -> let (rest, outE) = go inEs t + (rest', outEs) = goMany rest more + in (rest', outE : outEs) + + go es ty = + case ty of + TypeRange _ t -> go es t + NamedType s | Just fs <- Map.lookup (nameOrigName s) env -> + + let (es', outEs) = goMany es (map snd fs) + in (es', SStruct (nameOrigName s) + [ Field l e | ((l,_) ,e) <- zip fs outEs ]) + + ArrayType t e -> + let (es', outEs) = goMany es (genericReplicate (exprToInteger e) t) + in (es', SArray outEs) + + _ -> case es of + e : more -> (more, SLeaf e) + [] -> panic "toNormE" ["Not enogh expressions"] + + + +-------------------------------------------------------------------------------- + + +-- | Expand multiple binders. For details, have a look at 'expandBinder'. +expandBinders :: [Binder] -> NosM [Binder] +expandBinders bs = concat <$> traverse expandBinder bs + +{- | Expand a binder to a list of binder (non-structured binder are left as is). +For structured binders we also return a mapping from the original name, +to its normal form. For example: + +> x : int ^ 3 when t + +results in + +> x1 : int when t; x2 : int when t; x3 : int when t + +and a mapping: + +> x = [ x1, x2, x3 ] +-} +expandBinder :: Binder -> NosM [Binder] +expandBinder b = + do env <- getStructInfo + case expandType env (cType (binderType b)) of + (False, _) -> pure [b] + (True, ts) -> + do bs <- traverse (newSubName b) ts + let is = map (identOrigName . binderDefines) bs + expr = toNormE env (cType (binderType b)) is + addStructured (identOrigName (binderDefines b)) expr + pure bs + + + + + + + +-------------------------------------------------------------------------------- + +-- | Expan an equation. If structured data was involved, the result might +-- be multiple equations. +-- Note that the only equations that have multiple binders on the LHS +-- are ones that have a call on the RHS. +evalEqn :: Equation -> NosM [Equation] +evalEqn eqn = + case eqn of + + Assert x ty e -> + do e' <- evalExpr e + pure (case e' of + SLeaf b -> [ Assert x ty b ] + _ -> panic "evalEqn" ["Assert expects a bool"]) + + Property x e -> + do e' <- evalExpr e + pure (case e' of + SLeaf b -> [ Property x b ] + _ -> panic "evalEqn" ["PROPERTY expects a bool"]) + + IsMain r -> pure [ IsMain r ] + + IVC is -> pure . IVC . concat <$> for is expandIdent + Realizable is -> pure . Realizable . concat <$> for is expandIdent + + Define lhs e -> + do es <- flatStructData <$> evalExpr e + ls <- concat <$> traverse expandLHS lhs + pure (case es of + [e1] | isCall e1 -> [ Define ls e1 ] + _ | otherwise -> zipExact def ls es) + + where + def l a = Define [l] a + isCall ex = case ex of + ERange _ ex1 -> isCall ex1 + Call {} -> True + _ -> False + + where + expandIdent :: Ident -> NosM [Ident] + expandIdent i = do mb <- lkpStrName (Unqual i) + case mb of + Nothing -> pure [i] + Just sd -> pure (map origNameToIdent (flatStructData sd)) + +expandLHS :: LHS Expression -> NosM [ LHS a ] +expandLHS lhs = map (LVar . origNameToIdent) <$> expandLHS' lhs + +-- | Convert a possible complex LHS, to a simple (i.e., identifier) LHS +-- on primitive types. +expandLHS' :: LHS Expression -> NosM [ OrigName ] +expandLHS' lhs = map exprIdLhs . flatStructData <$> evalExpr (lhsToExpr lhs) + where + exprIdLhs e = + case e of + ERange _ e1 -> exprIdLhs e1 + Var n -> nameOrigName n + _ -> panic "expandLHS" [ "LHS is not an identifier" + , "*** Expression: " ++ showPP e ] + +-- | Convert a LHS to an expression corresponding to thing being defined. +lhsToExpr :: LHS Expression -> Expression +lhsToExpr lhs = + case lhs of + LVar x -> Var (Unqual x) + LSelect l s -> Select (lhsToExpr l) s + +-------------------------------------------------------------------------------- + + +{- | Move @when@ to the leaves of a structured expressions. +The parameters should be already evaluated. + +@[a,b] when c --> [a when c, b when c ]@ + +Note that clock expressions (e.g., `c` above) are small, +so it is OK to duplicate them. -} + +evalWhen :: StructData Expression -> ClockExpr -> StructData Expression +evalWhen ev ce = + case ev of + STuple xs -> STuple [ x `evalWhen` ce | x <- xs ] + SArray xs -> SArray [ x `evalWhen` ce | x <- xs ] + SStruct s fs -> SStruct s [ Field l (f `evalWhen` ce) | Field l f <- fs ] + SLeaf e1' -> SLeaf (e1' `When` ce) + + +{- | Move a @merege@ to the leaves of structured data. + +@ merge c (A -> [1,2]; B -> [3,4]) --> +becomes +[ merge c (A -> 1; B -> 3), merge c (A -> 2; B -> 4) ] +@ + +Again here we assume that patterns are simple things, as they should be +-} + +evalMerge :: Ident -> [MergeCase (StructData Expression)] -> + StructData Expression +evalMerge i as = + case as of + [] -> panic "evalMerge" [ "Empty merge case" ] + opts@(MergeCase _ o : _) -> + case getShape o of + Left _ -> SLeaf (Merge i (map fromLeaf opts)) + where + fromLeaf a = case a of + MergeCase p sh -> + case sh of + SLeaf e -> MergeCase p e + _ -> panic "Type error in merge branch" + [ "Branch: " ++ showPP p + , "Expected: non-structured" + , "Got: structured" ] + + + Right sh -> rebuildShape sh mk [ e | MergeCase _ e <- opts ] Nothing + where + mk es' _ = evalMerge i + [ MergeCase p e | (MergeCase p _, e) <- zip opts es' ] + + +-- | Lift a binary operator to the leaves of structured data. +-- Assumes that the arguments have the same types, and hence the same shapes. +evalBin :: (Expression -> Expression -> Maybe [CType] -> Expression) -> + StructData Expression -> + StructData Expression -> + Maybe [CType] -> + StructData Expression +evalBin f e1 e2 mTys = + case (getShape e1,getShape e2) of + (Left a, Left b) -> SLeaf (f a b mTys) + (Right sh1, Right sh2) + | sh1 == sh2 -> rebuildShape sh1 (\ ~[x,y] tys -> evalBin f x y tys) [e1,e2] mTys + | otherwise -> panic "Type error in binary operator" + [ "Shape 1:" ++ showPP sh1 + , "Shape 2:" ++ showPP sh2 + ] + _ -> panic "Type error in binary operator (structured vs. not)" [] + + + + +-- | Evaluate a struct update +evalStructUpdate :: + OrigName {- type -} -> + Expression -> [Field Expression] -> NosM (StructData Expression) +evalStructUpdate s expr es = + do ev <- evalExpr expr + case ev of + SStruct s' oldVal | s == s' -> + do newVals <- traverse evalField es -- user provided values + let newMap = Map.fromList [ (l,e) | Field l e <- newVals ] + pure $ SStruct s + [ Field l (Map.findWithDefault v l newMap) + | Field l v <- oldVal ] + + _ -> bad [ "Unexpected value to update:" + , "*** Expected: a struct" + , "*** Expression: " ++ showPP ev + ] + where + bad = panic "evalStructUpdate" + +-- | Select an item from an array. +selectFromArray :: + Pretty a => [StructData a] -> Selector Integer -> StructData a +selectFromArray vs s = + case s of + + SelectField f -> + panic "selectFromArray" + [ "Attempt to select a field from an array." + , "*** Field: " ++ showPP f + , "*** Array: " ++ showPP (SArray vs) + ] + + SelectElement i -> getIx i + + SelectSlice sl -> + let step = fromMaybe 1 (arrayStep sl) + start = arrayStart sl + ixes = [ start, start + step .. arrayEnd sl ] + in SArray (map getIx ixes) + + where + getIx i = case genericDrop i vs of + v : _ -> v + _ -> panic "selectFromArray" + [ "Selector out of bounds:" + , "*** Index: " ++ show i + , "*** Array length: " ++ show (length vs) + ] + +-- | Select an item from a struct. +selectFromStruct :: Pretty a => OrigName -> [Field a] -> Selector Integer -> a +selectFromStruct ty fs s = + case s of + + SelectField i -> + case [ v | Field l v <- fs, l == i ] of + v : _ -> v + _ -> panic "selectFromStruct" + [ "Undefined field in selection:" + , "*** Field: " ++ showPP i + , "*** Struct: " ++ showPP ty + , "*** Fields: " ++ show (commaSep (map pp fs)) + ] + + _ -> panic "selectFromStruct" + [ "Type error in selector." + , "*** Selector: " ++ showPP s + , "*** Struct: " ++ showPP ty + , "*** Fields: " ++ show (commaSep (map pp fs)) + ] + + + + + +-- | Normalize an expression, lifting out structured data to the top. +evalExpr :: Expression -> NosM (StructData Expression) +evalExpr expr = + case expr of + + ERange _ e -> evalExpr e + + Var x -> + do mb <- lkpStrName x + pure (case mb of + Nothing -> SLeaf expr + Just y -> Var . origNameToName <$> y) + + Const e t -> liftConst t =<< evalExpr e + + Lit _ -> pure (SLeaf expr) + + -- The clock expression are syntactically restricted to not + -- contain structured data so we don't need to evaluate them. + e1 `When` ce -> + do e1' <- evalExpr e1 + pure (evalWhen e1' ce) + + Tuple es -> STuple <$> traverse evalExpr es + Array es -> SArray <$> traverse evalExpr es + + Struct s fs -> SStruct (nameOrigName s) <$> traverse evalField fs + UpdateStruct ~(Just s) e es -> evalStructUpdate (nameOrigName s) e es + + Select e sel -> + do e1 <- evalExpr e + let s = evalSelect sel + pure (case e1 of + SArray vs -> selectFromArray vs s + SStruct ty fs -> selectFromStruct ty fs s + ev -> panic "selectFromStruct" + [ "Unexpected selection:" + , "*** StructData: " ++ showPP ev + ]) + + WithThenElse {} -> panic "evalExpr" + [ "Unexpected with-then-else" + , "*** Should have been eliminated by 'NoStatic'" + ] + + Merge i as -> evalMerge i <$> traverse evBranch as + where evBranch (MergeCase p e) = MergeCase p <$> evalExpr e + + -- XXX: ITERATORS + Call f es cl mTys -> + do es' <- traverse evalExpr es + + let bin r op x y tys = + case cl of + BaseClock -> eOp2 r op x y tys + _ -> panic "notClocked" + [ "Unexpected clock on primitive call." ] + pure $ + case (f, es') of + + -- [x1,x2] | [y1,y2] ~~> [ x1,x2,y1,y2 ] + (NodeInst (CallPrim _ (Op2 Concat)) [], [e1,e2]) -> + SArray (asArray e1 ++ asArray e2) + where asArray x = case x of + SArray xs -> xs + _ -> panic "evalExpr.asArray" + [ "Not an array:" + , "*** Expression: " ++ showPP x ] + + -- XXX: This duplicates stuff, perhaps bad + -- x ^ 2 ~~> [x,x] + (NodeInst (CallPrim _ (Op2 Replicate)) [], [e1,_]) -> + SArray (genericReplicate (exprToInteger (es !! 1)) e1) + -- NOTE: The second argument is a constant. + + -- [x1, x2] fby [y1,y2] ~~~> [ x1 ~~> y1, x2 ~~> y2 ] + (NodeInst (CallPrim r (Op2 Fby)) [], [e1,e2]) -> + evalBin (bin r Fby) e1 e2 mTys + + -- [x1, x2] fby [y1,y2] ~~~> [ x1 ~~> y1, x2 ~~> y2 ] + (NodeInst (CallPrim r (Op2 FbyArr)) [], [e1,e2]) -> + evalBin (bin r FbyArr) e1 e2 mTys + + -- pre [x,y] ~~~> [pre x, pre y] + (NodeInst (CallPrim _ (Op1 Pre)) [], args) -> + case args of + [e] -> pre <$> e + _ -> STuple [ pre <$> e | e <- args ] + where pre a = Call f [a] cl Nothing + + -- current [x,y] -> [current x, current y] + (NodeInst (CallPrim _ (Op1 Current)) [], args) -> + case args of + [e] -> cur <$> e + _ -> STuple [ cur <$> e | e <- args ] + where cur a = Call f [a] cl Nothing + + -- currentWith [a,b] [x,y] -> [currentWith a x, currentWith b y] + (NodeInst (CallPrim r (Op2 CurrentWith)) [], [e1,e2]) -> + evalBin (bin r CurrentWith) e1 e2 mTys + + + -- if a then [x1,x2] else [y1,y2] ~~> + -- [ if a then x1 else y1, if a then x2 else y2 ] + -- XXX: Duplicates `a` + (NodeInst (CallPrim r ITE) [], [e1,e2,e3]) -> evalBin ite e2 e3 mTys + where + ite x y tys = + case e1 of + SLeaf b -> Call (NodeInst (CallPrim r ITE) []) [b,x,y] cl tys + _ -> panic "evalExpr" [ "ITE expects a boolean" ] + + -- [x1, x2] = [y1,y2] ~~~> (x1 = x2) && (y1 = y2) + (NodeInst (CallPrim r (Op2 Eq)) [], [e1,e2]) -> + SLeaf $ liftFoldBin (bin r Eq) (bin r And) fTrue e1 e2 mTys + + -- [x1, x2] <> [y1,y2] ~~~> (x1 <> x2) || (y1 <> y2) + (NodeInst (CallPrim r (Op2 Neq)) [], [e1,e2]) -> + SLeaf $ liftFoldBin (bin r Neq) (bin r Or) fFalse e1 e2 mTys + + -- f([x1,x2]) ~~~> f(x1,x2) + (_, evs) -> SLeaf + $ Call f [ v | e <- evs, v <- flatStructData e ] cl mTys + where + + + fTrue = Lit (Bool True) + fFalse = Lit (Bool False) + + liftFoldBin f cons nil e1 e2 mTys = + -- This just re-uses the same type list that came from the original + -- Call since this is only used for boolean expressions, in which + -- case the original type list would have been Just [boolType] and + -- it's appropriate to use it for all of the subexpressions here. + fold (\a b -> cons a b mTys) + nil (zipWith3 f (flatStructData e1) (flatStructData e2) (repeat mTys)) + + fold cons nil xs = + case xs of + [] -> nil + _ -> foldr1 cons xs + +evalField :: Field Expression -> NosM (Field (StructData Expression)) +evalField (Field l e) = Field l <$> evalExpr e + + +{- | Lift a type annotation through a structured expression. +Assumes that there are no 'TypeRange' in the types and names refer +directly to their types (see 'checkType' in "Language.Lustre.TypeCheck") -} +liftConst :: CType -> StructData Expression -> NosM (StructData Expression) +liftConst ty str = + + case str of + SArray es -> + case cType ty of + ArrayType t _ -> SArray <$> traverse (liftConst ty { cType = t }) es + _ -> bad "array" + + + SStruct x fs -> + case cType ty of + NamedType y | x == nameOrigName y -> + do env <- getStructInfo + case Map.lookup x env of + -- assumes struct fields are in their declared order + Just fsTs -> SStruct x <$> zipWithM (liftF x) fsTs fs + Nothing -> err [ "Undefined structure type: " ++ showPP y ] + _ -> bad ("struct " ++ showPP x) + + STuple {} -> err ["Type error, unexpected tuple."] + + SLeaf e -> pure (SLeaf (Const e ty)) + + where + liftF x (f,t) fi + | f == fName fi = traverse (liftConst ty { cType = t }) fi + | otherwise = err [ "Field order mismatch:" + , "*** Struct: " ++ showPP x + , "*** Expected: " ++ showPP f + , "*** Got: " ++ showPP (fName fi) + ] + + err = panic "NoStruct.liftConst" + + bad want = err [ "Type mismatch:" + , "*** Expected: " ++ want + , "*** Got: " ++ sh + ] + + sh = case str of + SArray {} -> "array" + STuple {} -> "tuple" + SStruct x _ -> "struct " ++ showPP x + SLeaf {} -> "leaf" + + + + + +-------------------------------------------------------------------------------- + +data Shape = ArrayShape Int | StructShape OrigName [Label] | TupleShape Int + deriving Eq + +instance Pretty Shape where + ppPrec _ sh = + case sh of + ArrayShape n -> "array" <+> pp n + StructShape n fs -> pp n <+> braces (commaSep (map pp fs)) + TupleShape n -> "tuple" <+> pp n + + +rebuildShape :: Shape -> + ([StructData Expression] -> Maybe [CType] -> StructData Expression) -> + [ StructData Expression ] -> + Maybe [CType] -> + StructData Expression +rebuildShape sh mk es mTys = + let tyList = case mTys of + -- Turn Nothing into a list of Nothings + Nothing -> repeat Nothing + + -- Turn Just tys in to Just a list of a singleton type + Just tys -> (Just . (:[])) <$> tys + + in case sh of + + ArrayShape n -> SArray [ mk (map (getN i) es) tys | i <- take n [ 0 .. ], tys <- tyList ] + where getN i v = case v of + SArray vs -> + case drop i vs of + el : _ -> el + [] -> panic "rebuildShape" + [ "Index out of bounds" + , "*** Index: " ++ show i ] + _ -> panic "rebuildShape" + [ "Shape mismatch" + , "*** Expected: an array" + , "*** Got: " ++ showPP v ] + + + TupleShape n -> STuple [ mk (map (getN i) es) tys | i <- take n [ 0 .. ], tys <- tyList ] + where getN i v = case v of + STuple vs -> + case drop i vs of + el : _ -> el + [] -> panic "rebuildShape" + [ "Index out of bounds" + , "*** Index: " ++ show i ] + _ -> panic "rebuildShape" + [ "Shape mismatch" + , "*** Expected: a tuple" + , "*** Got: " ++ showPP v ] + + StructShape s is -> SStruct s [ Field i (mk (map (getN i) es) tys) + | i <- is, tys <- tyList ] + where getN i v = case v of + SStruct s' vs | s == s' -> + case [ fv | Field l fv <- vs, l == i ] of + el : _ -> el + [] -> panic "rebuildShape" + [ "Unknown field" + , "*** Field: " ++ show i ] + _ -> panic "rebuildShape" + [ "Shape mismatch" + , "*** Expected: a struct" + , "*** Got: " ++ showPP v ] + + + + + + +-- | Get the outermost shape of an expressio +getShape :: StructData a -> Either a Shape +getShape expr = + case expr of + SArray vs -> Right (ArrayShape (length vs)) + SStruct s fs -> Right (StructShape s [ l | Field l _ <- fs ]) + STuple vs -> Right (TupleShape (length vs)) + SLeaf a -> Left a + + +-- | Convert a literal expression to integer, or panic. +exprToInteger :: Expression -> Integer +exprToInteger expr = + case expr of + ERange _ e -> exprToInteger e + Lit (Int x) -> x + _ -> panic "exprToInteger" + [ "The expression is not an integer constant:" + , "*** Expression: " ++ showPP expr + ] + +-- | Eval a selector. Since all comstants are expanded, the selectors +-- would be known integers. +evalSelect :: Selector Expression -> Selector Integer +evalSelect sel = + case sel of + SelectField i -> SelectField i + SelectElement e -> SelectElement (exprToInteger e) + SelectSlice s -> SelectSlice (evalSlice s) + +-- | Evaluate a sllice, replacing literal expressions with integers. +evalSlice :: ArraySlice Expression -> ArraySlice Integer +evalSlice s = ArraySlice { arrayStart = exprToInteger (arrayStart s) + , arrayEnd = exprToInteger (arrayEnd s) + , arrayStep = exprToInteger <$> arrayStep s + } + + +evalContract :: Contract -> NosM Contract +evalContract c = + do cis <- mapM evalContractItem (contractItems c) + pure c { contractItems = cis } + +evalContractItem :: ContractItem -> NosM ContractItem +evalContractItem ci = + case ci of + + Assume l e -> + do ~(SLeaf e1) <- evalExpr e + pure (Assume l e1) + + Guarantee l e -> + do ~(SLeaf e1) <- evalExpr e + pure (Guarantee l e1) + + _ -> panic "evalContractItem" ["Unsupported contract item."] + + + +-------------------------------------------------------------------------------- + +newtype NosM a = NosM { unNosM :: WithBase LustreM + [ ReaderT RO + , StateT RW + ] a } + deriving (Functor,Applicative,Monad) + +data RO = RO + { roStructs :: !(Map OrigName [(Label,Type)]) + -- ^ Information about struct type defs in scope. + + , roCallSiteTodo :: !CallSiteMap + -- ^ These call sites need to be simlified; + -- the result is in "rwSimpleCallSiteMap" + } + +data RW = RW + { rwCollectedInfo :: !(Map OrigName StructInfo) + -- ^ Struct info for already processed nodes. + + , rwStructured :: !StructInfo + -- ^ Structure info for the current node. See "StructInfo" + + , rwSimpleCallSiteMap :: !SimpleCallSiteMap + -- ^ Call site info for already processed nodes. + } + +{- | Contains the expansions for variables of strucutred types. +For example, if @x : T ^ 3@, then we shoud have a binding +@x = [ x1, x2, x2 ]@. +The expressions in the map should be in evaluated form, which +means that the strucutres data is at the "top" and then we have +variables at the leaves. +-} +type StructInfo = Map OrigName (StructData OrigName) + + + +-- | Make a new binder, naming a sub-component of the given binder. +newSubName :: Binder -> ([SubName],Type) -> NosM Binder +newSubName b (p,t) = NosM $ + do n <- inBase newInt + let oldName = binderDefines b + newText = newSubText (identText oldName) p + newLab = (identLabel oldName) { labText = newText } + newName = OrigName + { rnUID = n + , rnModule = Nothing + , rnIdent = oldName { identLabel = newLab + , identResolved = Nothing } + , rnThing = AVal + } + + pure Binder { binderDefines = origNameToIdent newName + , binderType = (binderType b) { cType = t } + } + where + newSubText u ps = Text.concat (u : map toText ps) + toText q = case q of + ArrEl n -> Text.pack ("[" ++ show n ++ "]") + StructEl f -> "." `Text.append` labText f + + +-- | Get information about the struct types that are in scope. +getStructInfo :: NosM (Map OrigName [ (Label,Type)]) +getStructInfo = NosM (roStructs <$> ask) + +-- | Get what call sites we need to process. +-- These are passed in from the the NoStatic pass. +getCSTodo :: OrigName -> NosM (Map CallSiteId [LHS Expression]) +getCSTodo nm = + do cs <- NosM (roCallSiteTodo <$> ask) + pure (Map.findWithDefault Map.empty nm cs) + +-- | Add information for an expanded local binder. +addStructured :: OrigName -> StructData OrigName -> NosM () +addStructured x i = NosM $ sets_ $ \s -> + s { rwStructured = Map.insert x i (rwStructured s) } + +-- | Lookup information about a strucutred local. +lkpStrName :: Name -> NosM (Maybe (StructData OrigName)) +lkpStrName n = Map.lookup (nameOrigName n) . rwStructured <$> NosM get + + + +-- | Record information about the expanded binders in a module, +-- and reset the field, so that we can process the next module correctly. +finishNode :: OrigName -> Map CallSiteId [OrigName] -> NosM () +finishNode nm simp = NosM $ sets_ $ \s -> + s { rwCollectedInfo = Map.insert nm (rwStructured s) (rwCollectedInfo s) + , rwStructured = Map.empty + , rwSimpleCallSiteMap = Map.insert nm simp (rwSimpleCallSiteMap s) + } + +-- | Add a struct definition to the environment. +doAddStructDef :: Ident -> [FieldType] -> NosM a -> NosM a +doAddStructDef i fs m = + do ro <- NosM ask + let def = [ (fieldName f, fieldType f) | f <- fs ] + ro1 = ro { roStructs = Map.insert (identOrigName i) def (roStructs ro)} + NosM (local ro1 (unNosM m)) + + + diff --git a/Language/Lustre/Transform/OrderDecls.hs b/Language/Lustre/Transform/OrderDecls.hs new file mode 100644 --- /dev/null +++ b/Language/Lustre/Transform/OrderDecls.hs @@ -0,0 +1,738 @@ +{-# Language DataKinds, GeneralizedNewtypeDeriving, TypeFamilies #-} +{-# Language OverloadedStrings #-} +module Language.Lustre.Transform.OrderDecls + ( orderTopDecls + , quickOrderTopDecl + , ScopeInfo(..) + , InScope + ) where + +import Data.Text(Text) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set(Set) +import qualified Data.Set as Set +import Data.Maybe(mapMaybe,isJust) +import Data.Graph(SCC(..)) +import Data.Graph.SCC(stronglyConnComp) +import Data.Foldable(traverse_) +import MonadLib + +import Language.Lustre.Name +import Language.Lustre.AST +import Language.Lustre.Pretty +import Language.Lustre.Monad (LustreM, LustreError(..), ResolverError(..) + , LustreWarning(..), ResolverWarning(..)) +import qualified Language.Lustre.Monad as L +import Language.Lustre.Panic(panic) +import Language.Lustre.Defines + + +-- | Resolve some declaration in an empty scope. +-- Useful to quickly test things, or if we are just doing a once off module. +quickOrderTopDecl :: [TopDecl] -> LustreM [TopDecl] +quickOrderTopDecl ds = orderTopDecls scp ds + where + scp = ScopeInfo { resInScope = Map.empty + , resModule = Nothing + } + + +orderTopDecls :: + ScopeInfo {- ^ Information of what's currently in scope -} -> + [TopDecl] {- ^ Declarations that need resolving -} -> + LustreM [TopDecl] + +orderTopDecls sci ds = runResolver sci (resolveGroup someRec ds pure) + +{- | Order an unordered set of declarations, in dependency order. +The result is a dependency-ordered sequence of strongly-connected +components, and the new names introduced by the declarations -} +resolveGroup :: + (Defines a, Resolve a) => + (SCC a -> ResolveM [a]) -> [a] -> ([a] -> ResolveM b) -> ResolveM b +resolveGroup check ds k = + do (namess, scope) <- defsOf ds + extendScope scope $ + do resolved <- zipWithM resolveWithFree namess ds + + let mkRep i ns = [ (n,i) | n <- Set.toList ns ] + keys = [ 0 .. ] :: [Int] + repFor = (`Map.lookup` mp) + where mp = Map.fromList $ concat $ zipWith mkRep keys namess + mkNode i (a,us) = (a, i, mapMaybe repFor (Set.toList us)) + comps = stronglyConnComp (zipWith mkNode keys resolved) + + k . concat =<< traverse check comps + + +-- | Resolve a list of declarations, where the results of each are in scope +-- of the next. The continuation is then executed in the newly computed scope. +-- Note that value identifiers still cannot shadow each other +-- so multiple declarations should still result in errors. +resolveOrderedGroup :: + (Defines a, Resolve a) => [a] -> ([a] -> ResolveM b) -> ResolveM b +resolveOrderedGroup ds0 k = go [] ds0 + where + go done todo = + case todo of + [] -> k (reverse done) + d : more -> + do (~[ds],scope) <- defsOf [d] + d1 <- resolveDef ds d + extendScope scope (go (d1 : done) more) + + + +-- | Check that a given SCC is not recursive. +noRec :: (a -> Ident) {- ^ Pick an identifier to use for the given entry. + This is used for error reporting. -} -> + SCC a -> ResolveM [a] +noRec nm x = + case x of + AcyclicSCC a -> pure [a] + CyclicSCC as -> reportError (BadRecursiveDefs (map (identOrigName . nm) as)) + + +{- | Check that only recursive SCCs are ones that feature only templates +(i.e., node declarations with static parameters). +The idea that this will auto resolve when we specialize the constants. -} +someRec :: SCC TopDecl -> ResolveM [TopDecl] +someRec x = + case x of + AcyclicSCC a -> pure [a] + CyclicSCC cs -> traverse (check cs) cs + where + check cs d = + case d of + DeclareNode nd | not (null (nodeStaticInputs nd)) -> pure d + DeclareNodeInst nid | not (null (nodeInstStaticInputs nid)) -> pure d + _ -> reportError (BadRecursiveDefs (map topDName cs)) + + topDName d = + identOrigName $ + case d of + DeclareNode nd -> nodeName nd + DeclareNodeInst nid -> nodeInstName nid + DeclareType td -> typeName td + DeclareConst cd -> constName cd + DeclareContract cd -> cdName cd + + + + + + +-------------------------------------------------------------------------------- + +class Resolve t where + + -- | Resolve something that may define things. + -- The first argument specified how to rewrite the defining sites. + resolveDef :: Set OrigName -> t -> ResolveM t + +-- | Resolve something that only uses names, but does not define any. +resolve :: Resolve t => t -> ResolveM t +resolve = resolveDef Set.empty + +instance Resolve TopDecl where + resolveDef ds ts = + case ts of + DeclareType td -> DeclareType <$> resolveDef ds td + DeclareConst cd -> DeclareConst <$> resolveDef ds cd + DeclareNode nd -> DeclareNode <$> resolveDef ds nd + DeclareNodeInst nid -> DeclareNodeInst <$> resolveDef ds nid + DeclareContract cd -> DeclareContract <$> resolveDef ds cd + +instance Resolve TypeDecl where + resolveDef ds t = + do t1 <- traverse (resolveDef ds) (typeDef t) + pure TypeDecl { typeName = lkpDef ds AType (typeName t) + , typeDef = t1 } + +instance Resolve TypeDef where + resolveDef ds td = + case td of + IsType t -> IsType <$> resolve t + IsEnum cs -> pure (IsEnum (map (lkpDef ds AConst) cs)) + IsStruct fs -> IsStruct <$> traverse resolve fs + +instance Resolve FieldType where + resolveDef _ ft = do t1 <- resolve (fieldType ft) + e1 <- traverse resolveConstExpr (fieldDefault ft) + pure ft { fieldType = t1, fieldDefault = e1 } + +resolveField :: (e -> ResolveM e) -> Field e -> ResolveM (Field e) +resolveField res (Field l e) = Field l <$> res e + +instance Resolve Type where + resolveDef _ ty = + case ty of + TypeRange r t -> TypeRange r <$> resolve t + + NamedType t -> NamedType <$> resolveName t AType + ArrayType t e -> ArrayType <$> resolve t <*> resolveConstExpr e + IntSubrange e1 e2 -> IntSubrange <$> resolveConstExpr e1 + <*> resolveConstExpr e2 + + IntType -> pure ty + RealType -> pure ty + BoolType -> pure ty + + +instance Resolve ConstDef where + resolveDef ds cd = + do t <- traverse resolve (constType cd) + e <- traverse resolveConstExpr (constDef cd) + pure ConstDef { constName = lkpDef ds AConst (constName cd) + , constType = t + , constDef = e } + + +instance Resolve StaticParam where + resolveDef ds sp = + case sp of + TypeParam p -> pure (TypeParam (lkpDef ds AType p)) + ConstParam c t -> ConstParam (lkpDef ds AConst c) <$> resolve t + NodeParam s f x p -> + NodeParam s f (lkpDef ds ANode x) <$> resolveProfile p pure + + +instance Resolve InputBinder where + resolveDef ds ib = + case ib of + InputBinder b -> InputBinder <$> resolveDef ds b + InputConst c t -> InputConst (lkpDef ds AConst c) <$> resolve t + +instance (Resolve a) => Resolve [a] where + resolveDef ds vs = mapM resolve vs + +instance (Resolve a) => Resolve (Maybe a) where + resolveDef _ Nothing = pure Nothing + resolveDef ds (Just v) = Just <$> resolve v + +instance Resolve CType where + resolveDef _ ct = + do t <- resolve (cType ct) + c <- resolve (cClock ct) + pure CType { cType = t, cClock = c } + +instance Resolve Binder where + resolveDef ds b = + do t <- resolve (binderType b) + pure Binder { binderDefines = lkpDef ds AVal (binderDefines b) + , binderType = t + } + + +instance Resolve IClock where + resolveDef _ cl = + case cl of + BaseClock -> pure cl + KnownClock c -> KnownClock <$> resolve c + ClockVar i -> panic "Resolve@IClock" [ "Unexpected clock variable" + , showPP i ] + + +instance Resolve StaticArg where + resolveDef _ sa = + case sa of + TypeArg t -> TypeArg <$> resolve t + ExprArg e -> ExprArg <$> resolveConstExpr e + NodeArg f ni -> NodeArg f <$> resolve ni + ArgRange r a -> ArgRange r <$> resolve a + + +resolveProfile :: NodeProfile -> (NodeProfile -> ResolveM a) -> ResolveM a +resolveProfile prof k = + resolveOrderedGroup (nodeInputs prof) $ \ins -> + resolveOrderedGroup (nodeOutputs prof) $ \outs -> + k NodeProfile { nodeInputs = ins, nodeOutputs = outs } + + + + +instance Resolve NodeInstDecl where + resolveDef ds nid = + inLocalScope $ + resolveOrderedGroup (nodeInstStaticInputs nid) $ \sinps -> + let k prof = do def <- resolve (nodeInstDef nid) + let nm = lkpDef ds ANode (nodeInstName nid) + pure nid { nodeInstName = nm + , nodeInstStaticInputs = sinps + , nodeInstProfile = prof + , nodeInstDef = def + } + in + case nodeInstProfile nid of + Nothing -> k Nothing + Just prof -> resolveProfile prof (k . Just) + + +instance Resolve NodeInst where + resolveDef _ (NodeInst x as) = NodeInst <$> resolve x <*> traverse resolve as + +instance Resolve Callable where + resolveDef _ c = + case c of + CallUser n -> CallUser <$> resolveName n ANode + CallPrim {} -> pure c + + +-- XXX: keep track of where we are, so if we report and error we can +-- point to it. +resolveConstExpr :: Expression -> ResolveM Expression +resolveConstExpr expr = + case expr of + ERange r e -> ERange r <$> resolveConstExpr e + Var x -> Var <$> resolveName x AConst + Lit _ -> pure expr + When {} -> bad "when" + Tuple es -> Tuple <$> traverse resolveConstExpr es + Array es -> Array <$> traverse resolveConstExpr es + Select e s -> Select <$> resolveConstExpr e <*> resolve s + + Struct x fs -> + do x1 <- resolveName x AType + fs1 <- traverse (resolveField resolveConstExpr) fs + pure (Struct x1 fs1) + + UpdateStruct x e fs -> + do x1 <- traverse (\a -> resolveName a AType) x + y1 <- resolveConstExpr e + fs1 <- traverse (resolveField resolveConstExpr) fs + pure (UpdateStruct x1 y1 fs1) + + WithThenElse e1 e2 e3 -> + WithThenElse <$> resolveConstExpr e1 + <*> resolveConstExpr e2 <*> resolveConstExpr e3 + + Call ni as c mTys + | BaseClock <- c -> + do ni1 <- resolve ni + as1 <- traverse resolveConstExpr as + mTys' <- case mTys of + Nothing -> return Nothing + Just tys -> Just <$> mapM resolve tys + pure (Call ni1 as1 BaseClock mTys') + | otherwise -> bad "call with a clock from a constant" + + Merge {} -> bad "merge" + Const {} -> panic "resolveConstExpr" [ "Unexpected `Const` expresssion." ] + + where + bad = reportError . InvalidConstantExpression + + +resolveExpr :: Expression -> ResolveM Expression +resolveExpr expr = + case expr of + ERange r e -> ERange r <$> resolveExpr e + Var x -> Var <$> inferName x + Lit _ -> pure expr + e1 `When` e2 -> When <$> resolveExpr e1 <*> resolve e2 + + Tuple es -> Tuple <$> traverse resolveExpr es + Array es -> Array <$> traverse resolveExpr es + Select e s -> Select <$> resolveExpr e <*> resolve s + + Struct x fs -> + do x1 <- resolveName x AType + fs1 <- traverse (resolveField resolveExpr) fs + pure (Struct x1 fs1) + + UpdateStruct x e fs -> + do x1 <- traverse (`resolveName` AType) x + e1 <- resolveExpr e + fs1 <- traverse (resolveField resolveExpr) fs + pure (UpdateStruct x1 e1 fs1) + + WithThenElse e1 e2 e3 -> + WithThenElse <$> resolveConstExpr e1 + <*> resolveExpr e2 <*> resolveExpr e3 + + Merge x es -> Merge <$> inferIdent x <*> traverse resolve es + Call f es c ts -> Call <$> resolve f <*> traverse resolveExpr es + <*> resolve c <*> resolve ts + + Const {} -> panic "resolveConstExpr" [ "Unexpected `Const` expresssion." ] + +instance (e ~ Expression) => Resolve (MergeCase e) where + resolveDef _ (MergeCase c v) = + MergeCase <$> resolveConstExpr c <*> resolveExpr v + +instance Resolve ClockExpr where + resolveDef _ (WhenClock r cv i) = + WhenClock r <$> resolveConstExpr cv <*> inferIdent i + + +instance Resolve NodeDecl where + resolveDef ds nd = + inLocalScope $ + resolveOrderedGroup (nodeStaticInputs nd) $ \sinps -> + resolveProfile (nodeProfile nd) $ \prof -> + do ctr <- traverse resolve (nodeContract nd) + body <- traverse resolve (nodeDef nd) + pure nd { nodeName = lkpDef ds ANode (nodeName nd) + , nodeStaticInputs = sinps + , nodeProfile = prof + , nodeContract = ctr + , nodeDef = body + } + +instance Resolve NodeBody where + resolveDef _ nb = + -- We do constants before local variables. + -- This matters if a local variable shadows a global constant. + -- In that case the, the constant definitions would resolve correctly. + -- XXX: It is a bit questionable if allowing such definitios is a good idea. + resolveGroup (noRec getIdent) cs $ \cs1 -> + resolveGroup (noRec getIdent) vs $ \vs1 -> + do eqs <- traverse resolve (nodeEqns nb) + pure NodeBody { nodeLocals = cs1 ++ vs1, nodeEqns = eqs } + where + cs = [ LocalConst c | LocalConst c <- nodeLocals nb ] + vs = [ LocalVar v | LocalVar v <- nodeLocals nb ] + getIdent x = case x of + LocalConst c -> constName c + LocalVar b -> binderDefines b + +instance Resolve LocalDecl where + resolveDef ds ld = + case ld of + LocalConst c -> LocalConst <$> resolveDef ds c + LocalVar v -> LocalVar <$> resolveDef ds v + + +instance Resolve Equation where + resolveDef _ eqn = + case eqn of + Assert n t e -> Assert n t <$> resolveExpr e + Property n e -> Property n <$> resolveExpr e + Define lhs e -> Define <$> traverse resolve lhs <*> resolveExpr e + IsMain _ -> pure eqn + IVC is -> IVC <$> traverse inferIdent is + Realizable is -> Realizable <$> traverse inferIdent is + +instance (e ~ Expression) => Resolve (LHS e) where + resolveDef _ lhs = + case lhs of + LVar i -> LVar <$> resolveIdent i AVal + LSelect x e -> LSelect <$> resolve x <*> resolve e + + +instance (e ~ Expression) => Resolve (Selector e) where + resolveDef _ sel = + case sel of + SelectField _ -> pure sel + SelectElement e -> SelectElement <$> resolveConstExpr e + SelectSlice e -> SelectSlice <$> resolve e + +instance (e ~ Expression) => Resolve (ArraySlice e) where + resolveDef _ as = + do s <- resolveConstExpr (arrayStart as) + e <- resolveConstExpr (arrayEnd as) + st <- traverse resolveConstExpr (arrayStep as) + pure ArraySlice { arrayStart = s, arrayEnd = e, arrayStep = st } + +instance Resolve Contract where + resolveDef _ ct = do is <- resolveContractItems (contractItems ct) + pure ct { contractItems = is } + +resolveContractItems :: [ContractItem] -> ResolveM [ContractItem] +resolveContractItems cits = + -- The comment on NodeBody also applies here + resolveGroup (noRec getIdent) cis $ \cs -> + resolveGroup (noRec getIdent) cvs $ \vs -> + do others <- traverse resolve (reverse cothers) + pure (cs ++ vs ++ others) + where + (cis,cvs,cothers) = foldr classify ([],[],[]) cits + + classify ci (cs,vs,others) = + case ci of + GhostConst {} -> (ci : cs, vs, others) + GhostVar {} -> (cs, ci : vs, others) + _ -> (cs, vs, ci : others) + + getIdent ci = case ci of + GhostConst d -> constName d + GhostVar b _ -> binderDefines b + _ -> panic "getIdent (in Contract)" + [ "Called on non-ghost var/const decl." ] + +instance Resolve ContractItem where + resolveDef ds ci = + case ci of + GhostConst d -> GhostConst <$> resolveDef ds d + GhostVar b e -> GhostVar <$> resolveDef ds b <*> resolveExpr e + Assume l e -> Assume l <$> resolveExpr e + Guarantee l e -> Guarantee l <$> resolveExpr e + -- XXX: resolve mode names + Mode x mas mgs -> Mode x <$> traverse resolveExpr mas + <*> traverse resolveExpr mgs + Import x as bs -> Import <$> resolveIdent x AContract + <*> traverse resolveExpr as + <*> traverse resolveExpr bs + + +instance Resolve ContractDecl where + resolveDef ds cd = + inLocalScope $ + resolveProfile (cdProfile cd) $ \prof -> + do is <- resolveContractItems (cdItems cd) + pure cd { cdName = lkpDef ds AContract (cdName cd) + , cdProfile = prof + , cdItems = is + } + + +-------------------------------------------------------------------------------- + +newtype ResolveM a = ResolveM { _unResolveM :: + WithBase LustreM + [ ReaderT ScopeInfo + , StateT ResS + ] a + } deriving (Functor,Applicative,Monad) + +-- | What's in scope for each module. +type InScope = Map (Maybe ModName) (Map NameSpace (Map Text OrigName)) + +-- | The "scoped" part of the resolver monad +data ScopeInfo = ScopeInfo + { resInScope :: InScope -- ^ What's in scope + , resModule :: Maybe ModName -- ^ Use this for current definitions + } + +-- | The "mutable" part of the resolver monad +newtype ResS = ResS + { resFree :: Set OrigName -- ^ Free used variables + } + + +runResolver :: + ScopeInfo -> + ResolveM a -> + LustreM a +runResolver r0 (ResolveM m) = + do let s0 = ResS { resFree = Set.empty } + (a,_finS) <- runStateT s0 $ runReaderT r0 m + pure a + + + +-- | Report the given error, aborting the analysis. +reportError :: L.ResolverError -> ResolveM a +reportError e = ResolveM $ inBase $ L.reportError $ ResolverError e + +-- | Record a warning. +addWarning :: L.ResolverWarning -> ResolveM () +addWarning w = ResolveM $ inBase $ L.addWarning $ ResolverWarning w + +-- | Record a use of the given name. +addUse :: OrigName -> ResolveM () +addUse rn = ResolveM $ sets_ $ \s -> s { resFree = Set.insert rn (resFree s) } + + +-- | Compute the definitions from a bunch of things, +-- checking that there are no duplicates. +-- Note that this operation is **effectful**, as it assignes unique +-- identifiers to the defined names. +defsOf :: Defines a => [a] -> ResolveM ([Set OrigName], InScope) +defsOf as = + do ds <- traverse defsOfOne as + mp <- traverse check (foldr mergeDefs noDefs ds) + mo <- ResolveM (resModule <$> ask) + pure (map defNames ds, Map.singleton mo mp) + where + check xs = fmap Map.fromList + $ mapM isOne + $ Map.elems + $ Map.fromListWith (++) + [ ((rnModule x, origNameTextName x), [x]) | x <- Set.toList xs ] + + isOne xs = case xs of + [a] -> pure (origNameTextName a, a) + _ -> reportError (RepeatedDefinitions xs) + + defsOfOne a = ResolveM $ + do l <- resModule <$> ask + inBase (getDefs a l) + +-- | Extend the current scope for the duration of the given computation. +-- The new entries shadow the existing ones. +extendScope :: InScope -> ResolveM a -> ResolveM a +extendScope ds (ResolveM m) = + do ro <- ResolveM ask + let new = shadowScope ds (resInScope ro) + traverse_ (traverse_ (traverse_ reportShadow)) (gotShadowed new) + a <- ResolveM (local ro { resInScope = newScope new } m) + -- remove uses of the locally added variables as they are not free + let isHere x = isJust $ do is <- Map.lookup (rnModule x) ds + let ns = thingNS (rnThing x) + Map.lookup ns is + ResolveM $ sets_ + $ \s -> s { resFree = Set.filter (not . isHere) (resFree s) } + pure a + + + where + reportShadow :: OrigName -> ResolveM () + reportShadow old = + case mb of + Nothing -> panic "extendScope" [ "Shadowed, but not?" + , "*** Name: " ++ showPP old ] + Just new -> + case rnThing old of + -- value identifiers cannot be shadowed + AVal -> reportError (RepeatedDefinitions [new, old]) + _ -> addWarning (Shadows new old) + + where + mb = do ids <- Map.lookup (rnModule old) ds + nms <- Map.lookup (thingNS (rnThing old)) ids + Map.lookup (origNameTextName old) nms + + + +-- | Extend the definitions in the second scope with the first. +-- New entries in the same namespace "shadow" existing ones. +shadowScope :: InScope -> InScope -> WithShadows InScope +shadowScope = joinWith (joinWith joinThings) + where + joinWith :: (Ord k, Ord k1) => + ShadowFun (Map k v) -> ShadowFun (Map k1 (Map k v)) + joinWith f m1 m2 = + let mp = Map.mergeWithKey (\_ a b -> Just (f a b)) noShadow noShadow m1 m2 + in WS { newScope = newScope <$> mp + , gotShadowed = Map.filter (not . Map.null) (gotShadowed <$> mp) + } + + noShadow m = fmap (\a -> WS { newScope = a, gotShadowed = Map.empty }) m + + joinThings :: ShadowFun (Map Text OrigName) + joinThings as bs = + WS { newScope = Map.union as bs + , gotShadowed = Map.intersectionWith (\_ old -> old) as bs + } + + +{- + joinThings :: ShadowFun (Map NameSpace (Set OrigName)) + joinThings as bs = + WS { newScope = Map.unionWith Set.union as bs + , gotShadowed = Map.intersectionWith (\_ old -> old) as bs + } +-} + + +data WithShadows a = WS { newScope :: a, gotShadowed :: a } +type ShadowFun a = a -> a -> WithShadows a + + + +-- | Specify the location of names for the scope of the given computation. +withModName :: Maybe ModName -> ResolveM a -> ResolveM a +withModName l (ResolveM m) = + ResolveM $ mapReader (\ro -> ro { resModule = l }) m + +inLocalScope :: ResolveM a -> ResolveM a +inLocalScope = withModName Nothing + +-- | Resolve something, and also return its free variables. +-- Note that the free variables are also saved in the state of the monad. +resolveWithFree :: Resolve a => Set OrigName -> a -> ResolveM (a, Set OrigName) +resolveWithFree ds a = + do free <- ResolveM $ sets $ \s -> (resFree s, s { resFree = Set.empty }) + a1 <- resolveDef ds a + newFree <- ResolveM $ sets$ \s -> + let newFree = resFree s + in (newFree, s { resFree = Set.union newFree free }) + pure (a1, newFree) + + +-------------------------------------------------------------------------------- +-- Resolving of names + +-- | Figure out what a name of the given flavor refers to. +resolveName :: Name -> Thing -> ResolveM Name +resolveName nm th = Unqual <$> newNm + where + newNm = case nm of + Unqual ide -> resolveIdent ide th + Qual q ide -> resolveIdentIn (Just q) ide th + +-- | Figure out what the given name referes to (either value or a constnat). +inferName :: Name -> ResolveM Name +inferName nm = Unqual <$> newNm + where + newNm = case nm of + Unqual ide -> inferIdent ide + Qual q ide -> inferIdentIn (Just q) ide + +resolveIdentIn :: Maybe ModName -> Ident -> Thing -> ResolveM Ident +resolveIdentIn mb i th = + case identResolved i of + Nothing -> + do mbi <- lkpIdent mb th i + case mbi of + Nothing -> reportError (UndefinedName (asName mb i)) + Just rn -> do addUse rn + pure i { identResolved = Just rn } + Just rn | rnThing rn == th -> pure i + | otherwise -> panic "resolveIdent" + [ "Wired-in identifier used in the wrong place" + , "*** Idnetifier: " ++ show i + , "*** Expected: " ++ show th + ] + +resolveIdent :: Ident -> Thing -> ResolveM Ident +resolveIdent = resolveIdentIn Nothing + +-- | Figure out what the given identifier refers (value or constnat) +inferIdentIn :: Maybe ModName -> Ident -> ResolveM Ident +inferIdentIn mb i = + do mb1 <- lkpIdent mb AConst i + mb2 <- lkpIdent mb AVal i + case (mb1,mb2) of + (Nothing, Nothing) -> reportError (UndefinedName (asName mb i)) + (Just p, Just q) + | p /= q -> reportError (AmbiguousName (asName mb i) p q) + | otherwise -> do addUse p + pure i { identResolved = Just p } + (Just rn,Nothing) -> do addUse rn + pure i { identResolved = Just rn } + (Nothing, Just rn) -> do addUse rn + pure i { identResolved = Just rn } + +asName :: Maybe ModName -> Ident -> Name +asName mb i = case mb of + Nothing -> Unqual i + Just m -> Qual m i + +inferIdent :: Ident -> ResolveM Ident +inferIdent = inferIdentIn Nothing + + +-- | Lookup something in the current scope. +lkpIdent :: Maybe ModName -> Thing -> Ident -> ResolveM (Maybe OrigName) +lkpIdent loc th i = + do scope <- ResolveM (resInScope <$> ask) + pure $ do defs <- Map.lookup loc scope + nms <- Map.lookup (thingNS th) defs + Map.lookup (identText i) nms + +-- | Resolve a name in a defining position. +lkpDef :: Set OrigName -> Thing -> Ident -> Ident +lkpDef ds th i = case Set.minView (Set.filter matches ds) of + Just (a,_) -> i { identResolved = Just a } + _ -> panic "lkpDef" [ "Missing identifier for defining site" + , "*** Identifier: " ++ showPP i + , "*** Context: " ++ showPP th + ] + where + matches j = rnThing j == th && identText (rnIdent j) == identText i + + + diff --git a/Language/Lustre/Transform/ToCore.hs b/Language/Lustre/Transform/ToCore.hs new file mode 100644 --- /dev/null +++ b/Language/Lustre/Transform/ToCore.hs @@ -0,0 +1,606 @@ +{-# Language FlexibleInstances #-} +{-# Language OverloadedStrings #-} +{-# Language TypeSynonymInstances #-} +-- | Translate siplified Lustre into the Core representation. +module Language.Lustre.Transform.ToCore + ( getEnumInfo, EnumInfo, evalNodeDecl, enumFromVal + ) where + +import Data.Map(Map) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Semigroup ( (<>) ) +import Data.Text (Text) +import qualified Data.Text as Text +import MonadLib hiding (Label) +import AlexTools(SourceRange(..),SourcePos(..)) +import Data.Foldable(toList) +import Data.Graph.SCC(stronglyConnComp) + +import Language.Lustre.Name +import qualified Language.Lustre.AST as P +import qualified Language.Lustre.Core as C +import Language.Lustre.Core (CoreName, coreNameFromOrig) +import Language.Lustre.Monad +import Language.Lustre.Panic +import Language.Lustre.Pretty(showPP) + + +data EnumInfo = EnumInfo + { enumConMap :: !(Map OrigName C.Literal) + -- ^ Maps enum constructor to value + + , enumMax :: !(Map OrigName C.Literal) + -- ^ Maps enum type to largest con + + , enumFromVal :: !(Map (OrigName,Integer) OrigName) + -- ^ Given a type and a number, give back the constructor. + } + +blankEnumInfo :: EnumInfo +blankEnumInfo = EnumInfo { enumConMap = Map.empty + , enumMax = Map.empty + , enumFromVal = Map.empty + } + +-- | Compute info about enums from some top-level declarations. +-- The result maps the original names of enum constructors, to numeric +-- expressions that should represent them. +getEnumInfo :: [ P.TopDecl ] {- ^ Renamed decls -} -> EnumInfo +getEnumInfo tds = foldr addDefs blankEnumInfo enums + where + aliases = Map.fromList + [ (nameOrigName t, identOrigName n) | P.DeclareType + P.TypeDecl { P.typeName = n + , P.typeDef = Just (P.IsType (P.NamedType t)) + } <- tds + ] + + enumAliases n = case Map.lookup n aliases of + Nothing -> [n] + Just s -> s : enumAliases s + + + enums = [ (identOrigName n,is) | P.DeclareType + P.TypeDecl { P.typeName = n + , P.typeDef = Just (P.IsEnum is) } <- tds ] + + -- The constructors of an enum are represented by 0, 1, .. etc + addDefs (n,is) ei = EnumInfo + { enumConMap = foldr addDef (enumConMap ei) (zipWith mkDef is [ 0 .. ]) + , enumMax = Map.insert n (C.Int (fromIntegral (length is) - 1)) + (enumMax ei) + , enumFromVal = Map.union + (Map.fromList (concatMap (mkRevDef n) (zip [0..] is))) + (enumFromVal ei) + + } + + + mkDef i n = (identOrigName i, C.Int n) + mkRevDef n (i,c) = [ ((j,i),identOrigName c) | j <- enumAliases n ] + + addDef (i,n) = Map.insert i n + + +-- | Translate a node to core form, given information about enumerations. +-- We don't return a mapping from original name to core names because +-- for the moment this mapping is very simple: just use 'origNameToCoreName' +evalNodeDecl :: + EnumInfo {- ^ Information about enums -} -> + P.NodeDecl {- ^ Simplified source Lustre -} -> + LustreM C.Node +evalNodeDecl enumCs nd + | null (P.nodeStaticInputs nd) + , Just def <- P.nodeDef nd = + runProcessNode enumCs $ + do let prof = P.nodeProfile nd + ins <- mapM evalInputBinder (P.nodeInputs prof) + outs <- mapM evalBinder (P.nodeOutputs prof) + locs <- mapM evalBinder + $ orderLocals [ b | P.LocalVar b <- P.nodeLocals def ] + + eqnss <- mapM evalEqn (P.nodeEqns def) + let withDef = Set.fromList + [ x | eqns <- eqnss, (x C.::: _) C.:= _ <- eqns ] + + asts <- getAssertNames + props <- getPropertyNames + pure C.Node { C.nName = P.nodeName nd + , C.nInputs = ins + , C.nOutputs = outs + , C.nAbstract = [ l | l@(x C.::: _) <- locs + , not (x `Set.member` withDef) ] + , C.nAssuming = asts + , C.nShows = props + , C.nEqns = C.orderedEqns (concat eqnss) + } + + | otherwise = panic "evalNodeDecl" + [ "Unexpected node declaration" + , "*** Node: " ++ showPP nd + ] + + where + depsOf b = case P.cClock (P.binderType b) of + P.KnownClock (P.WhenClock _ _ c) -> [c] + _ -> [] + + orderLocals bs = concatMap toList + $ stronglyConnComp [ (b,P.binderDefines b,depsOf b) | b <- bs] + + +-- | Rewrite a type, replacing named enumeration types with @int@. +evalType :: P.Type -> C.Type +evalType ty = + case ty of + P.NamedType {} -> C.TInt -- Only enum types should be left by now + P.IntSubrange {} -> C.TInt -- Represented with a number + P.IntType -> C.TInt + P.RealType -> C.TReal + P.BoolType -> C.TBool + P.TypeRange _ t -> evalType t + P.ArrayType {} -> panic "evalType" + [ "Unexpected array type" + , "*** Type: " ++ showPP ty + ] + +-------------------------------------------------------------------------------- +type M = StateT St LustreM + + +runProcessNode :: EnumInfo -> M a -> LustreM a +runProcessNode enumCs m = + do (a,_finS) <- runStateT st m + pure a + where + st = St { stLocalTypes = Map.empty + , stSrcLocalTypes = Map.empty + , stGlobEnumCons = enumCs + , stEqns = [] + , stAssertNames = [] + , stPropertyNames = [] + , stVarMap = Map.empty + } + +data St = St + { stLocalTypes :: Map CoreName C.CType + -- ^ Types of local translated variables. + -- These may change as we generate new equations. + + , stSrcLocalTypes :: Map OrigName C.CType + -- ^ Types of local variables from the source. + -- These shouldn't change. + + , stGlobEnumCons :: EnumInfo + -- ^ Definitions for enum constants. + -- Currently we assume that these would be int constants. + + , stEqns :: [C.Eqn] + -- ^ Generated equations naming subcomponents. + -- Most recently generated first. + -- Since we process things in depth-first fashion, this should be + -- reverse to get proper definition order. + + , stAssertNames :: [(Label,CoreName)] + -- ^ The names of the equations corresponding to asserts. + + , stPropertyNames :: [(Label,CoreName)] + -- ^ The names of the equatiosn corresponding to properties. + + + , stVarMap :: Map OrigName CoreName + {- ^ Remembers what names we used for values in the core. + This is so that when we can parse traces into their original names. -} + } + +-- | Get the collected assert names. +getAssertNames :: M [(Label,CoreName)] +getAssertNames = stAssertNames <$> get + +-- | Get the collected property names. +getPropertyNames :: M [(Label,CoreName)] +getPropertyNames = stPropertyNames <$> get + +-- | Get the map of enumeration constants. +getEnumCons :: M EnumInfo +getEnumCons = stGlobEnumCons <$> get + +-- | Get the collection of local types. +getLocalTypes :: M (Map CoreName C.CType) +getLocalTypes = stLocalTypes <$> get + +-- | Record the type of a local. +addLocal :: CoreName -> C.CType -> M () +addLocal i t = sets_ $ \s -> s { stLocalTypes = Map.insert i t (stLocalTypes s)} + +addBinder :: C.Binder -> M () +addBinder (i C.::: t) = addLocal i t + +-- | Generate a fresh local name with the given stemp +newIdentFrom :: Text -> M CoreName +newIdentFrom stem = + do x <- inBase newInt + let i = Ident { identLabel = toLabel stem + , identResolved = Nothing + } + o = OrigName { rnUID = x + , rnModule = Nothing + , rnIdent = i + , rnThing = AVal + } + pure (coreNameFromOrig o) + + +toLabel :: Text -> Label +toLabel t = Label { labText = t, labRange = noLoc } + +-- XXX: Currently core epxressions have no locations. +noLoc :: SourceRange +noLoc = SourceRange { sourceFrom = noPos, sourceTo = noPos } + where + noPos = SourcePos { sourceIndex = -1, sourceLine = -1 + , sourceColumn = -1, sourceFile = "" } + + +-- | Remember an equation. +addEqn :: C.Eqn -> M () +addEqn eqn@(i C.::: t C.:= _) = + do sets_ $ \s -> s { stEqns = eqn : stEqns s } + addLocal i t + +-- | Return the collected equations, and clear them. +clearEqns :: M [ C.Eqn ] +clearEqns = sets $ \s -> (stEqns s, s { stEqns = [] }) + +-- | Generate a fresh name for this expression, record the equation, +-- and return the name. +nameExpr :: C.Expr -> M C.Atom +nameExpr expr = + do tys <- getLocalTypes + let t = C.typeOf tys expr + i <- newIdentFrom stem + addEqn (i C.::: t C.:= expr) + pure (C.Var i) + + where + stem = case expr of + C.Atom a -> case a of + C.Prim op _ _ -> Text.pack (show op) + _ -> panic "nameExpr" [ "Naming a simple atom?" + , "*** Atom:" ++ showPP a ] + C.Pre a -> namedStem "pre" a + _ C.:-> a -> namedStem "init" a + C.When _ a -> namedStem "when" a + C.Current a -> namedStem "current" a + C.Merge (a, _) _ -> namedStem "merge" (C.Var a) + + namedStem t a = case a of + C.Var i -> t <> "_" <> C.coreNameTextName i + _ -> "$" <> t + +-- | Remember that the given identifier was used for an assert. +addAssertName :: Label -> CoreName -> M () +addAssertName t i = sets_ $ \s -> s { stAssertNames = (t,i) : stAssertNames s } + +-- | Remember that the given identifier was used for a property. +addPropertyName :: Label -> CoreName -> M () +addPropertyName t i = + sets_ $ \s -> s { stPropertyNames = (t,i) : stPropertyNames s } + + +-------------------------------------------------------------------------------- + +evalInputBinder :: P.InputBinder -> M C.Binder +evalInputBinder inp = + case inp of + P.InputBinder b -> do b1 <- evalBinder b + inputTypeAsmps b1 (P.cType (P.binderType b)) + pure b1 + P.InputConst i t -> + panic "evalInputBinder" + [ "Unexpected constant parameter" + , "*** Name: " ++ showPP i + , "*** Type: " ++ showPP t ] + + +-- | Type assumptions for an input. +-- Currently these are assumptions arising from sub-range types and enums. +inputTypeAsmps :: C.Binder -> P.Type -> M () +inputTypeAsmps (v C.::: ct) ty = + + case ty of + P.NamedType i -> + do x <- getEnumCons + case Map.lookup (nameOrigName i) (enumMax x) of + Just s -> inRange (C.Int 0) s + Nothing -> panic "inputTypeAsmps" + [ "Undefined `enum` type", showPP i ] + + P.IntSubrange l u -> + do le <- evalConstExpr l + ue <- evalConstExpr u + inRange le ue + + P.IntType -> pure () + P.RealType -> pure () + P.BoolType -> pure () + P.TypeRange {} -> panic "evalTypeAsmps" [ "Unexpected type range" ] + P.ArrayType {} -> panic "evalTypeAsmps" + [ "Unexpected array type" + , "*** Type: " ++ showPP ty + ] + + + where + lit l = C.Lit l ct + + inRange x y = + do let va = C.Var v + lb = C.Prim C.Leq [ lit x, va ] [boolTy] + ub = C.Prim C.Leq [ va, lit y ] [boolTy] + prop = C.Prim C.And [ lb, ub ] [boolTy] + boolTy = C.TBool `C.On` C.clockOfCType ct + lab = C.coreNameTextName v <> "_bounds" + pn <- newIdentFrom lab + let lhs = pn C.::: C.TBool `C.On` C.clockOfCType ct + eqn = lhs C.:= C.Atom prop + addEqn eqn + addAssertName (toLabel lab) pn + + +-- | Add the type of a binder to the environment. +evalBinder :: P.Binder -> M C.Binder +evalBinder b = + do c <- case P.cClock (P.binderType b) of + P.BaseClock -> pure C.BaseClock + P.KnownClock c -> C.WhenTrue <$> evalClockExpr c + P.ClockVar i -> panic "evalBinder" + [ "Unexpected clock variable", showPP i ] + let t = evalType (P.cType (P.binderType b)) `C.On` c + let xi = evalIdent (P.binderDefines b) + addLocal xi t + let bn = xi C.::: t + addBinder bn + pure bn + +-- | Translate an equation. +-- Invariant: 'stEqns' should be empty before and after this executes. +evalEqn :: P.Equation -> M [C.Eqn] +evalEqn eqn = + case eqn of + P.IsMain _ -> pure [] + P.IVC _ -> pure [] -- XXX: we should do something with these + P.Realizable _ -> pure [] -- XXX: we should do something with these + + P.Property t e -> evalForm "--%PROPERTY" (addPropertyName t) e + P.Assert t _ty e -> evalForm "assert" (addAssertName t) e + -- at the top-level both kinds of assert are treated as assumptions. + + P.Define ls e -> + case ls of + [ P.LVar x ] -> + do tys <- getLocalTypes + let x' = evalIdent x + let t = case Map.lookup x' tys of + Just ty -> ty + Nothing -> + panic "evalEqn" [ "Defining unknown variable:" + , "*** Name: " ++ showPP x ] + e1 <- evalExpr (Just x') e + addEqn (x' C.::: t C.:= e1) + clearEqns + + + _ -> panic "evalExpr" + [ "Unexpected LHS of equation" + , "*** Equation: " ++ showPP eqn + ] + + where + evalForm :: String -> (CoreName -> M ()) -> P.Expression -> M [ C.Eqn ] + evalForm x f e = + do e1 <- evalExprAtom e + case e1 of + C.Var i -> + do f i + clearEqns + C.Lit n _ -> + case n of + C.Bool True -> pure [] + _ -> panic ("Constant in " ++ x) [ "*** Constant: " ++ show n ] + C.Prim {} -> + do ~(C.Var i) <- nameExpr (C.Atom e1) + f i + clearEqns + + + +-- | Evaluate a source expression to an a core atom, naming subexpressions +-- as needed. +evalExprAtom :: P.Expression -> M C.Atom +evalExprAtom expr = + do e1 <- evalExpr Nothing expr + case e1 of + C.Atom a -> pure a + _ -> nameExpr e1 + + +evalIdent :: Ident -> CoreName +evalIdent = coreNameFromOrig . identOrigName + + + +-- | Evaluate a clock-expression to an atom. +evalClockExpr :: P.ClockExpr -> M C.Atom +evalClockExpr (P.WhenClock _ e1 i) = + do a1 <- evalConstExpr e1 + env <- getLocalTypes + let a2 = C.Var (evalIdent i) + ty = C.typeOf env a2 + boolTy = C.TBool `C.On` C.clockOfCType ty + pure $ case a1 of + C.Bool True -> a2 + _ -> C.Prim C.Eq [ C.Lit a1 ty, a2 ] [boolTy] + +evalIClock :: P.IClock -> M C.Clock +evalIClock clo = + case clo of + P.BaseClock -> pure C.BaseClock + P.KnownClock c -> C.WhenTrue <$> evalClockExpr c + P.ClockVar {} -> panic "evalIClockExpr" [ "Unexpectec clock variable." ] + +evalCurrentWith :: Maybe CoreName -> C.Atom -> C.Atom -> M C.Expr +evalCurrentWith xt d e = + do env <- getLocalTypes + let ty = C.typeOf env e + c@(C.WhenTrue ca) = C.clockOfCType ty + Just cc = C.clockParent env c + case xt of + Just x -> desugar x ca ty + Nothing -> + do i <- newIdentFrom "curW" + let thisTy = C.typeOfCType ty `C.On` cc + addLocal i thisTy + e1 <- desugar i ca thisTy + addEqn (i C.::: thisTy C.:= e1) + pure (C.Atom (C.Var i)) + where + desugar x c ty = + do cur <- nameExpr (C.Current e) + pre <- nameExpr (C.Pre (C.Var x)) + hold <- nameExpr ((d, ty) C.:-> pre) + pure (C.Atom (C.Prim C.ITE [c,cur,hold] [ty])) + +evalConstExpr :: P.Expression -> M C.Literal +evalConstExpr expr = + case expr of + P.ERange _ e -> evalConstExpr e + P.Var i -> + do cons <- getEnumCons + case Map.lookup (nameOrigName i) (enumConMap cons) of + Just e -> pure e + Nothing -> bad "undefined constant symbol" + P.Lit l -> pure l + _ -> bad "constant expression" + + where + bad msg = panic "evalConstExpr" [ "Unexpected " ++ msg + , "*** Expression: " ++ showPP expr + ] + +evalCType :: P.CType -> M C.CType +evalCType t = + do c <- evalIClock (P.cClock t) + pure (evalType (P.cType t) `C.On` c) + +-- | Evaluate a source expression to a core expression. +evalExpr :: Maybe CoreName -> P.Expression -> M C.Expr +evalExpr xt expr = + case expr of + P.ERange _ e -> evalExpr xt e + + P.Var i -> pure (C.Atom (C.Var (coreNameFromOrig (nameOrigName i)))) + + P.Const e t -> + do l <- evalConstExpr e + ty <- evalCType t + pure (C.Atom (C.Lit l ty)) + + P.Lit {} -> bad "literal outside `Const`." + + e `P.When` ce -> + do a1 <- evalExprAtom e + a2 <- evalClockExpr ce + pure (C.When a1 a2) + + + P.Merge i alts -> + do let iName = evalIdent i + env <- getLocalTypes + let ty = C.typeOf env (C.Var iName) + + bs <- forM alts $ \(P.MergeCase k e) -> do p <- evalConstExpr k + e' <- evalExprAtom e + pure (p,e') + + pure (C.Merge (iName, ty) bs) + + P.Tuple {} -> bad "tuple" + P.Array {} -> bad "array" + P.Select {} -> bad "selection" + P.Struct {} -> bad "struct" + P.UpdateStruct {} -> bad "update-struct" + P.WithThenElse {} -> bad "with-then-else" + + P.Call ni es _ Nothing -> + panic "ToCore.evalExpr" $ [ "Got a Call with no type", "NodeInst:", show ni, "Arguments:"] ++ (show <$> es) + + P.Call ni es cl (Just tys) -> + do _clv <- evalIClock cl + tys' <- mapM evalCType tys + {- NOTE: we don't really store the clock of the call anywhere, + because for primitives (which is all that should be left) + it can be computed from the clocks of the arguments. -} + + as <- mapM evalExprAtom es + let prim x = pure (C.Atom (C.Prim x as tys')) + case ni of + P.NodeInst (P.CallPrim _ p) [] -> + case p of + + P.Op1 op1 -> + case as of + [v] -> case op1 of + P.Not -> prim C.Not + P.Neg -> prim C.Neg + P.Pre -> pure (C.Pre v) + P.Current -> pure (C.Current v) + P.IntCast -> prim C.IntCast + P.FloorCast-> prim C.FloorCast + P.RealCast -> prim C.RealCast + _ -> bad "unary operator" + + P.Op2 op2 -> + case as of + [v1,v2] -> case op2 of + P.Fby -> do v3 <- nameExpr (C.Pre v2) + pure ((v1, tys' !! 0) C.:-> v3) + P.FbyArr -> pure ((v1, tys' !! 0) C.:-> v2) + P.CurrentWith -> evalCurrentWith xt v1 v2 + P.And -> prim C.And + P.Or -> prim C.Or + P.Xor -> prim C.Xor + P.Implies -> prim C.Implies + P.Eq -> prim C.Eq + P.Neq -> prim C.Neq + P.Lt -> prim C.Lt + P.Leq -> prim C.Leq + P.Gt -> prim C.Gt + P.Geq -> prim C.Geq + P.Mul -> prim C.Mul + P.Mod -> prim C.Mod + P.Div -> prim C.Div + P.Add -> prim C.Add + P.Sub -> prim C.Sub + P.Power -> prim C.Power + P.Replicate -> bad "`^`" + P.Concat -> bad "`|`" + _ -> bad "binary operator" + + P.OpN op -> + case op of + P.AtMostOne -> prim C.AtMostOne + P.Nor -> prim C.Nor + + + P.ITE -> prim C.ITE + + _ -> bad "primitive call" + + _ -> bad "function call" + + where + bad msg = panic "ToCore.evalExpr" [ "Unexpected " ++ msg + , "*** Expression: " ++ showPP expr + ] diff --git a/Language/Lustre/TypeCheck.hs b/Language/Lustre/TypeCheck.hs new file mode 100644 --- /dev/null +++ b/Language/Lustre/TypeCheck.hs @@ -0,0 +1,1090 @@ +{-# Language OverloadedStrings, Rank2Types #-} +module Language.Lustre.TypeCheck where + +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.List (find,transpose) +import Control.Monad(unless,zipWithM_,zipWithM,foldM) +import Text.PrettyPrint as PP +import Data.List(group,sort) +import Data.Traversable(for) +import Data.Foldable(for_) + +import Language.Lustre.Name +import Language.Lustre.AST +import Language.Lustre.Pretty +import Language.Lustre.Panic +import Language.Lustre.Monad(LustreM) +import Language.Lustre.TypeCheck.Monad +import Language.Lustre.TypeCheck.Constraint +import Language.Lustre.TypeCheck.Prims +import Language.Lustre.TypeCheck.Utils + + +type TypeError = Doc +type TypeWarn = Doc + + +-- | Assumes that the declarations are in dependency order. +quickCheckDecls :: [TopDecl] -> LustreM [TopDecl] +quickCheckDecls ds = runTC (go ds) + where + go xs = case xs of + [] -> pure [] + x : more -> do (y,ys) <- checkTopDecl x (go more) + pure (y:ys) + + +checkTopDecl :: TopDecl -> M a -> M (TopDecl,a) +checkTopDecl td m = + case td of + DeclareType tyd -> apFstM DeclareType (checkTypeDecl tyd m) + DeclareConst cd -> apFstM DeclareConst (checkConstDef cd m) + DeclareNode nd -> apFstM DeclareNode (checkNodeDecl nd m) + DeclareNodeInst _nid -> notYetImplemented "node instances" + DeclareContract {} -> notYetImplemented "top-level contract" + + +checkTypeDecl :: TypeDecl -> M a -> M (TypeDecl, a) +checkTypeDecl td m = + case typeDef td of + Nothing -> addFst td $ withNamedType (typeName td) AbstractTy m + Just dec -> + case dec of + + IsEnum is -> + do let nty = NamedType (Unqual ti) + addE i = withConst i nty + ty = EnumTy (Set.fromList (map identOrigName is)) + addFst td (withNamedType ti ty (foldr addE m is)) + + IsStruct fs -> + do fs1 <- mapM checkFieldType fs + mapM_ checkDup $ group $ sort $ map fieldName fs1 + let ty = StructTy fs1 + newTD = td { typeDef = Just (IsStruct fs1) } + addFst newTD (withNamedType ti ty m) + + IsType t -> + do t' <- checkType t + let newTD = td { typeDef = Just (IsType t') } + addFst newTD (withNamedType ti (AliasTy t') m) + where + ti = typeName td + + checkDup xs = + case xs of + [] -> pure () + [_] -> pure () + x : _ -> + reportError $ nestedError + "Multiple fields with the same name." $ + [ "Struct:" <+> pp (typeName td) + , "Field:" <+> pp x + ] ++ [ "Location:" <+> pp (range f) | f <- xs ] + + +checkFieldType :: FieldType -> M FieldType +checkFieldType f = + do let t = fieldType f + t1 <- checkType t + d1 <- case fieldDefault f of + Nothing -> pure Nothing + Just e -> do e' <- checkConstExpr e t + pure (Just e') + pure f { fieldType = t1, fieldDefault = d1 } + +checkNodeDecl :: NodeDecl -> M a -> M (NodeDecl,a) +checkNodeDecl nd k = + do newNd <- check + addFst newNd + $ withNode NodeInfo + { niName = nodeName newNd + , niSafety = nodeSafety newNd + , niType = nodeType newNd + , niStaticParams = nodeStaticInputs newNd + , niProfile = nodeProfile newNd + } + k + where + check :: M NodeDecl + check = + inRange (range (nodeName nd)) $ + inClockScope $ + allowTemporal (nodeType nd == Node) $ + allowUnsafe (nodeSafety nd == Unsafe) $ + do (ps,(prof,ctr,bod)) <- + checkStaticParams (nodeStaticInputs nd) $ + do {-when (nodeExtern nd) $ + case nodeDef nd of + Just _ -> reportError $ nestedError + "Extern node with a definition." + ["Node:" <+> pp (nodeName nd)] + Nothing -> pure ()-} + let prof = nodeProfile nd + (ins,(outs,(ctr,bod))) <- + checkInputBinders (nodeInputs prof) $ + checkOutputBinders (nodeOutputs prof) $ + do c <- traverse checkContract (nodeContract nd) + -- XXX: maybe check that outputs are not mentioned in assume? + + b <- case nodeDef nd of + Nothing -> + do unless (nodeExtern nd) + $ reportError $ nestedError + "Missing node definition" + ["Node:" <+> pp (nodeName nd)] + pure Nothing + Just b -> Just <$> checkNodeBody b + pure (c,b) + + let newProf = NodeProfile { nodeInputs = ins + , nodeOutputs = outs + } + + ctr1 <- traverse zonkContract ctr + bod1 <- traverse zonkBody bod + + pure (newProf, ctr1, bod1) + + pure nd { nodeStaticInputs = ps + , nodeProfile = prof + , nodeContract = ctr + , nodeDef = bod } + +checkStaticParam :: StaticParam -> M a -> M (StaticParam,a) +checkStaticParam sp m = + case sp of + TypeParam t -> + do a <- withNamedType t AbstractTy m + pure (TypeParam t, a) + + ConstParam x t -> + do t1 <- checkType t + a <- withConst x t1 m + pure (ConstParam x t1, a) + + NodeParam safe fun f prof -> + do (is,(os,_)) <- checkInputBinders (nodeInputs prof) $ + checkOutputBinders (nodeOutputs prof) $ + pure () + let prof1 = NodeProfile { nodeInputs = is, nodeOutputs = os } + info = NodeInfo { niName = f + , niSafety = safe + , niType = fun + , niStaticParams = [] + , niProfile = prof1 + } + a <- withNode info m + pure (NodeParam safe fun f prof1, a) + + +checkStaticParams :: [StaticParam] -> M a -> M ([StaticParam],a) +checkStaticParams = checkNested checkStaticParam + +checkStaticArg :: StaticArg -> StaticParam -> M (StaticArg, StaticEnv) +checkStaticArg arg para = + case arg of + ArgRange r a1 -> inRange r (checkStaticArg a1 para) + + TypeArg t -> + case para of + TypeParam i -> + do t1 <- checkType t + pure (TypeArg t1, sType i t1) + _ -> mismatch + + ExprArg e -> + case para of + ConstParam x t -> + do e' <- checkConstExpr e t + pure (ExprArg e', sConst x e') + _ -> mismatch + + NodeArg notationTy ni -> + case para of + NodeParam safe fun _ prof -> + do ni1 <- checkStaticNodeArg ni safe fun prof + pure (NodeArg notationTy ni1, sEmpty) + _ -> mismatch + where + mismatch = reportError $ nestedError + "Invalid static argument." + [ "Expected:" <+> pDoc + , "Got:" <+> aDoc + ] + + aDoc = case arg of + ExprArg {} -> "a constant expression" + TypeArg {} -> "a type" + NodeArg {} -> "a node" + ArgRange {} -> panic "aDoc" ["Unexpected `ArgRange`"] + + pDoc = case para of + TypeParam {} -> "a type" + ConstParam {} -> "a constant expression" + NodeParam {} -> "a node" + + +checkStaticNodeArg :: + NodeInst -> Safety -> NodeType -> NodeProfile -> M NodeInst +checkStaticNodeArg (NodeInst c as) safe fun prof = + case c of + CallUser f -> + do (ni,iprof) <- prepUserNodeInst f as safe fun + checkStaticArgTypes iprof prof + pure ni + + -- The prims are all safe so we don't need to pass the safety + CallPrim _r _op -> + notYetImplemented "Passing primitives as static arguments." + +prepUserNodeInst :: + Name -> [StaticArg] -> Safety -> NodeType -> M (NodeInst, NodeProfile) +prepUserNodeInst f as safe fun = + do fi <- lookupNodeInfo f + inRange (range f) $ + do checkSafetyType fi safe fun + checkEnoughStaticArgs fi as + (as1,envs) <- unzip <$> + zipWithM checkStaticArg as (niStaticParams fi) + let env = sJoin envs + iprof = instantiateProfile env (niProfile fi) + pure (NodeInst (CallUser f) as1, iprof) + + + +checkStaticArgTypes :: NodeProfile -> NodeProfile -> M () +checkStaticArgTypes actual expected = + do unless (haveInNum == needInNum) $ + reportError $ nestedError + "Incorrect number of inputs." + [ "Parameter has" <+> int needInNum <+> "inputs." + , "Given argument has" <+> int haveInNum <+> "inputs." + ] + unless (haveOutNum == needOutNum) $ + reportError $ nestedError + "Incorrect number of outputs." + [ "Parameter has" <+> int needOutNum <+> "outputs." + , "Given argument has" <+> int haveOutNum <+> "outputs." + ] + zipWithM_ checkIn (nodeInputs actual) (nodeInputs expected) + zipWithM_ checkOut (nodeOutputs actual) (nodeOutputs expected) + + where + haveInNum = length (nodeInputs actual) + haveOutNum = length (nodeOutputs actual) + needInNum = length (nodeInputs expected) + needOutNum = length (nodeOutputs expected) + + checkIn arg param = + case (arg,param) of + (InputConst _ t, InputConst _ t1) -> subType t1 t + (InputBinder b, InputBinder b1) -> subCType (binderType b1) (binderType b) + (InputBinder {}, InputConst {}) -> + reportError "Expected a constant input." + (InputConst {}, InputBinder {}) -> + reportError "Unexpected constant input." -- XXX: perhaps this is ok? + + checkOut arg param = subCType (binderType arg) (binderType param) + + subCType x y = + do subType (cType x) (cType y) + sameClock (cClock x) (cClock y) + + + + +-------------------------------------------------------------------------------- +{- Example: + +f <> (x : Array n bool) returns (y : int) +g <> (...) returns (...) + +g << f<<2>> >> + +NOTE: for the moment we assume that node static arguments don't appear in types. +-} + +data StaticEnv = StaticEnv + { sConsts :: Map OrigName Expression + , sTypes :: Map OrigName Type + } + +sEmpty :: StaticEnv +sEmpty = StaticEnv { sConsts = Map.empty, sTypes = Map.empty } + +sType :: Ident -> Type -> StaticEnv +sType x t = sEmpty { sTypes = Map.singleton (identOrigName x) t } + +sConst :: Ident -> Expression -> StaticEnv +sConst x e = sEmpty { sConsts = Map.singleton (identOrigName x) e } + +sJoin :: [StaticEnv] -> StaticEnv +sJoin envs = StaticEnv { sConsts = Map.unions (map sConsts envs) + , sTypes = Map.unions (map sTypes envs) + } + +-------------------------------------------------------------------------------- + +instantiateProfile :: StaticEnv -> NodeProfile -> NodeProfile +instantiateProfile env prof = + NodeProfile + { nodeInputs = map (instantiateInputBinder env) (nodeInputs prof) + , nodeOutputs = map (instantiateBinder env) (nodeOutputs prof) + } + +instantiateInputBinder :: StaticEnv -> InputBinder -> InputBinder +instantiateInputBinder env inp = + case inp of + InputConst x t -> InputConst x (instantiateType env t) + InputBinder b -> InputBinder (instantiateBinder env b) + +instantiateBinder :: StaticEnv -> Binder -> Binder +instantiateBinder env b = + b { binderType = + CType { cType = instantiateType env (cType ct) + , cClock = case cClock ct of + BaseClock -> BaseClock + KnownClock c -> KnownClock (iClock c) + ClockVar i -> ClockVar i + } + } + where + ct = binderType b + iClock (WhenClock r e i) = WhenClock r (instantiateConst env e) i + + +-- | Instantiate a type with the given static parameters. +instantiateType :: StaticEnv -> Type -> Type +instantiateType env ty + | Map.null (sConsts env) && Map.null (sTypes env) = ty -- a very common case + | otherwise = + case ty of + ArrayType t e -> ArrayType (iType t) (iConst e) + NamedType x -> Map.findWithDefault ty (nameOrigName x) (sTypes env) + TypeRange r t -> TypeRange r (iType t) + IntSubrange e1 e2 -> IntSubrange (iConst e1) (iConst e2) + IntType -> ty + RealType -> ty + BoolType -> ty + where + iType = instantiateType env + iConst = instantiateConst env + + +{- | Instantiate a constant with the given static parameters. +These are just constants that can appear in types, so pretty much +an expression denoting an `int`. However, to support selectors and functions +we pretty much do all but the temporal constructs. -} +instantiateConst :: StaticEnv -> Expression -> Expression +instantiateConst env expr + | Map.null (sConsts env) && Map.null (sTypes env) = expr -- a very common case + | otherwise = + case expr of + ERange r e -> ERange r (iConst e) + Var x -> Map.findWithDefault expr (nameOrigName x) (sConsts env) + Lit {} -> expr + + Select e s -> Select (iConst e) (iSelect s) + Tuple es -> Tuple (map iConst es) + Array es -> Array (map iConst es) + Struct s fs -> Struct (iStructTy s) (map iField fs) + UpdateStruct s e fs -> + UpdateStruct (iStructTy <$> s) (iConst e) (map iField fs) + + WithThenElse e1 e2 e3 -> WithThenElse (iConst e1) (iConst e2) (iConst e3) + Call (NodeInst n as) es BaseClock tys -> + Call (NodeInst n (map iArg as)) (map iConst es) BaseClock tys + Call {} -> bad "call with a clock" + + When {} -> bad "WhenClock" + Merge {} -> bad "Merge" + Const {} -> panic "instantiateConst" [ "Unexpected `Const`" ] + + where + bad x = panic "instantiateConst" [ "Unexpected construct: " ++ x ] + + iStructTy x = toNameTy (iType (NamedType x)) + toNameTy ty = case ty of + TypeRange _ t -> toNameTy t + NamedType t -> t + _ -> bad "Struct type was not a named type?" + + iConst = instantiateConst env + iType = instantiateType env + iSelect sel = + case sel of + SelectField {} -> sel + SelectElement e -> SelectElement (iConst e) + SelectSlice s -> SelectSlice (iSlice s) + iSlice sl = ArraySlice { arrayStart = iConst (arrayStart sl) + , arrayEnd = iConst (arrayEnd sl) + , arrayStep = iConst <$> arrayStep sl + } + + iField f = f { fValue = iConst (fValue f) } + iArg arg = case arg of + TypeArg t -> TypeArg (iType t) + ExprArg e -> ExprArg (iConst e) + NodeArg t ni -> NodeArg t (iInst ni) + ArgRange r s -> ArgRange r (iArg s) + iInst (NodeInst f as) = NodeInst f (map iArg as) + + + +checkSafetyType :: NodeInfo -> Safety -> NodeType -> M () +checkSafetyType ni safe fun = + do case (safe, niSafety ni) of + (Safe, Unsafe) -> + reportError ("Invalid unsafe node parameter" <+> fDoc) + _ -> pure () + case (fun, niType ni) of + (Function, Node) -> + reportError ("Expected a function parameter, but" + <+> fDoc <+> "is a node.") + _ -> pure () + where + fDoc = backticks (pp (niName ni)) + + +checkEnoughStaticArgs :: NodeInfo -> [StaticArg] -> M () +checkEnoughStaticArgs ni as = + case compare have need of + EQ -> pure () + LT -> reportError + ("Not enough static arguments in call to" + <+> backticks (pp (niName ni))) + GT -> reportError $ + ("Too many static arguments in call to" + <+> backticks (pp (niName ni))) + where + have = length as + need = length (niStaticParams ni) + + + +checkNodeBody :: NodeBody -> M NodeBody +checkNodeBody nb = addLocals (nodeLocals nb) + where + {- NOTE: there are all kinds of things that one could check here, if + we intentd to run the Lustre program. For example, all variables should + have definitions, and maybe we don't want recursive equations. + However, when using Lustre as a front-end to a model checker, it is sometimes + conveninet to relax such issues. In that case we think of the equations + more in their math form: not so much LHS is defined by RHS, but rather + we'd just like them to be equal. With that mind set it makes sense to + allow partial specifications, and even recursive ones: the result may + be that we transition to multiple next states (i.e., we are no longer + deterministic), or perhaps we get stuck (e.g., if a recursive equation + has no fixed point). + -} + + addLocals ls = + case ls of + [] -> do es <- mapM checkEquation (nodeEqns nb) + pure NodeBody { nodeLocals = [], nodeEqns = es } + l : more -> + do (d,n) <- checkLocalDecl l (addLocals more) + pure n { nodeLocals = d : nodeLocals n } + +checkLocalDecl :: LocalDecl -> M a -> M (LocalDecl,a) +checkLocalDecl ld m = + case ld of + LocalVar b -> apFstM LocalVar (checkBinder b m) + LocalConst c -> apFstM LocalConst (checkConstDef c m) + + +checkConstDef :: ConstDef -> M a -> M (ConstDef, a) +checkConstDef c m = + do (c1,t) <- checkDef + addFst c1 (withConst (constName c) t m) + where + checkDef = + inRange (range (constName c)) $ + case constDef c of + Nothing -> + case constType c of + Nothing -> reportError $ nestedError + "Constant declaration with no type or default." + [ "Name:" <+> pp (constName c) ] + Just t -> do t1 <- checkType t + pure (c { constType = Just t }, t1) + + Just e -> + do (e',t) <- case constType c of + Nothing -> inferConstExpr e + Just t -> do t' <- checkType t + e' <- checkConstExpr e t' + pure (e',t') + pure (c { constType = Just t, constDef = Just e' }, t) + +checkInputBinder :: InputBinder -> M a -> M (InputBinder, a) +checkInputBinder ib m = + case ib of + InputBinder b -> apFstM InputBinder (checkBinder b m) + InputConst i t -> + do t1 <- checkType t + addFst (InputConst i t1) (withConst i t1 m) + +checkBinder :: Binder -> M a -> M (Binder,a) +checkBinder b m = + do c <- case cClock (binderType b) of + BaseClock -> pure BaseClock + KnownClock e -> do (e',_) <- inferClockExpr e + pure (KnownClock e') + ClockVar i -> panic "checkBinder" + [ "Unexpected clock variable: " ++ showPP i ] + t <- checkType (cType (binderType b)) + let ty = CType { cType = t, cClock = c } + newB = b { binderType = ty } + addFst newB $ withLocal (binderDefines b) ty m + +checkInputBinders :: [InputBinder] -> M a -> M ([InputBinder],a) +checkInputBinders = checkNested checkInputBinder + +checkOutputBinders :: [Binder] -> M a -> M ([Binder],a) +checkOutputBinders = checkNested checkBinder + +addFst :: a -> M b -> M (a,b) +addFst a m = + do b <- m + pure (a,b) + +apFstM :: (a -> x) -> M (a,b) -> M (x,b) +apFstM f m = + do (a,b) <- m + pure (f a, b) + +checkNested :: (forall a. t -> M a -> M (t,a)) -> [t] -> M b -> M ([t],b) +checkNested work things m = + case things of + + [] -> + do a <- m + pure ([],a) + + t : ts -> + do (t1,(ts1,a)) <- work t (checkNested work ts m) + pure (t1:ts1,a) + +-------------------------------------------------------------------------------- + + +-- | Validate a type. +checkType :: Type -> M Type +checkType ty = + case ty of + TypeRange _ t -> checkType t + IntType -> pure IntType + BoolType -> pure BoolType + RealType -> pure RealType + IntSubrange x y -> + do a <- checkConstExpr x IntType + b <- checkConstExpr y IntType + leqConsts x y + pure (IntSubrange a b) + NamedType x -> resolveNamed x + ArrayType t n -> + do n1 <- checkConstExpr n IntType + leqConsts (Lit (Int 0)) n1 + t1 <- checkType t + pure (ArrayType t1 n1) + + +-- | Validate an equation. +checkEquation :: Equation -> M Equation +checkEquation eqn = + enterRange $ + case eqn of + Assert l ty e -> + do (e',clk) <- checkExpr1 e BoolType + sameClock BaseClock clk -- do we want to support others? + pure (Assert l ty e') + + Property l e -> + do (e',clk) <- checkExpr1 e BoolType + sameClock BaseClock clk -- do we want to support others? + pure (Property l e') + + IsMain _ -> pure eqn + + IVC _ -> pure eqn -- XXX: what should we check here? + + Realizable _ -> pure eqn -- XXX: what should we check here? + + Define ls e -> + do (ls',lts) <- unzip <$> mapM inferLHS ls + (e',cts) <- inferExpr e + sameLen lts cts + for_ (zip lts cts) $ \(lt,ct) -> + do sameClock (cClock lt) (cClock ct) + subType (cType ct) (cType lt) + pure (Define ls' e') + + where + enterRange = case eqnRangeMaybe eqn of + Nothing -> id + Just r -> inRange r + + +-- | Infer the type of the left-hand-side of a declaration. +inferLHS :: LHS Expression -> M (LHS Expression, CType) +inferLHS lhs = + case lhs of + LVar i -> do t <- lookupLocal i + pure (LVar i, t) + LSelect l s -> + do (l1,t) <- inferLHS l + (s1,t1) <- inferSelector s (cType t) + pure (LSelect l1 s1, t { cType = t1 }) + + + +{- | Infer the type of an expression. +Tuples and function calls may return multiple results, +which is why we provide multiple clocked types. -} +inferExpr :: Expression -> M (Expression, [CType]) +inferExpr expr = + case expr of + ERange r e -> inRange r (inferExpr e) + + Var x -> + inRange (range x) $ + do (e1,ct) <- inferVar x + pure (e1,[ct]) + + Lit l -> + do let ty = inferLit l + c <- newClockVar + let ct = CType { cType = ty, cClock = c } + pure (Const (Lit l) ct, [ct]) + + e `When` c -> + do checkTemporalOk "when" + (c',ct1) <- inferClockExpr c + (e',ct2s) <- inferExpr e + cts <- for ct2s $ \ct -> + do sameClock (cClock ct) (cClock ct1) + pure ct { cClock = KnownClock c' } + pure (e' `When` c', cts) + + Tuple es -> + do (es',cts) <- unzip <$> mapM inferExpr1 es + pure (Tuple es',cts) + + Array es -> + do (es',cts) <- unzip <$> mapM inferExpr1 es + let ne = Lit $ Int $ fromIntegral $ length es + done c t = + do let ct = CType { cClock = c, cType = ArrayType t ne } + pure (Array es', [ct]) + case cts of + [] -> notYetImplemented "Empty arrays" + elT : more -> + do t <- foldM tLUB (cType elT) (map cType more) + mapM_ (sameClock (cClock elT)) (map cClock more) + done (cClock elT) t + + Select e s -> + do (e',recCT) <- inferExpr1 e + (s',ty) <- inferSelector s (cType recCT) + let ct = recCT { cType = ty } + pure (Select e' s', [ct]) + + Struct s fs -> + do (e',ct) <- inferStruct s fs + pure (e',[ct]) + + UpdateStruct s e fs -> + do (e',ct) <- inferStructUpdate s e fs + pure (e',[ct]) + + WithThenElse e1 e2 e3 -> + do e1' <- checkConstExpr e1 BoolType + (e2',ct1) <- inferExpr e2 + (e3',ct2) <- inferExpr e3 + sameLen ct1 ct2 + ct <- zipWithM ctLUB ct1 ct2 + pure (WithThenElse e1' e2' e3', ct) + + Merge i as -> + do ctI <- lookupLocal i + (as',ctss) <- unzip <$> for as (inferMergeCase i (cType ctI)) + case ctss of + [] -> reportError "Empty merge case" + ctAlt : alts -> + do for_ alts (sameLen ctAlt) + let byCol = transpose (map (map cType) ctss) + cts <- for byCol $ \ ~(t:ts) -> + do t1 <- foldM tLUB t ts + pure CType { cClock = cClock ctI, cType = t1 } + pure (Merge i as',cts) + + Call _ _ _ (Just {}) -> + panic "inferExpr" ["Got a call that already has types", show expr] + + Call (NodeInst call as) es cl Nothing -> + case call of + CallUser f -> inferCall f as es cl + CallPrim r prim + | BaseClock <- cl -> inferPrim r prim as es + | otherwise -> reportError "Unexpected clock annotation in call" + + Const {} -> panic "inferExpr" [ "Unexpected `Const` expression." ] + + +-- | Infer the type of an expression that should not return multiple results. +inferExpr1 :: Expression -> M (Expression,CType) +inferExpr1 e = + do (e',cts) <- inferExpr e + ct <- one cts + pure (e',ct) + +{- | Infer the type of a constant expression. +NOTE: the elaborated result will contain `Const` annotations, +which is a little bogus, but they will go away in the `NoStatic pass. -} +inferConstExpr :: Expression -> M (Expression,Type) +inferConstExpr expr = + allowTemporal False $ + allowUnsafe False $ + do (e',ct) <- inferExpr1 expr + sameClock BaseClock (cClock ct) + pure (e',cType ct) + +-- | Infer the type of a constant expression. +checkConstExpr :: Expression -> Type -> M Expression +checkConstExpr expr ty = + do (e',t) <- inferConstExpr expr + subType t ty + pure e' + +checkExpr1 :: Expression -> Type -> M (Expression,IClock) +checkExpr1 e t = + do (e',ct) <- inferExpr1 e + subType (cType ct) t + pure (e', cClock ct) + + + +{- | Ensure that the given named type is a struct. If so, get the real +name of the struct (e.g., if the original was an alias for a struct), +and alsot its fields, in declaration order. -} +checkStructType :: Name -> M (Name, [FieldType]) +checkStructType s = + do ty <- checkType (NamedType s) + let name = case ty of + NamedType nm -> nm + _ -> panic "checkStructType" + [ "Unexpected struct type ellaboration:" + , "*** Struct type: " ++ showPP s + , "*** Result: " ++ showPP ty + ] + fs <- lookupStruct name + pure (name,fs) + + +-- | Infer the type of a struct formaing expression. +inferStruct :: Name -> [Field Expression] -> M (Expression,CType) +inferStruct s fs = + do distinctFields fs + (s',fExpect) <- checkStructType s + let fieldMap = Map.fromList [ (fName f, f) | f <- fs ] + i <- newClockVar + fs' <- for fExpect $ \ft -> + case Map.lookup (fieldName ft) fieldMap of + + Nothing -> -- Field not initialized + case fieldDefault ft of + Nothing -> reportError $ + "Field" <+> backticks (pp (fieldName ft)) <+> + "of" <+> backticks (pp s') <+> + "is not initialized." + Just e1 -> + let ct = CType { cType = fieldType ft, cClock = i } + in pure Field { fName = fieldName ft + , fValue = Const e1 ct + } + + Just f -> -- Field initialized + do (e,clk) <- checkExpr1 (fValue f) (fieldType ft) + sameClock i clk + pure f { fValue = e } + + let ct = CType { cClock = i, cType = NamedType s' } + pure (Struct s' fs', ct) + + +-- | Infer a structure updatating expression. +inferStructUpdate :: + Maybe Name -> Expression -> [Field Expression] -> M (Expression,CType) +inferStructUpdate mbS e fs = + do distinctFields fs + (e',ct) <- inferExpr1 e + (actualName, fieldTs) <- + case mbS of + Just s -> checkStructType s + Nothing -> + case cType ct of + NamedType name -> + do fTs <- lookupStruct name + pure (name,fTs) + _ -> reportError $ nestedError + "Invalid struct update." + [ "Expression is not a struct." ] + + fs' <- for fs $ \f -> + case find ((fName f ==) . fieldName) fieldTs of + + Just ft -> + do (fv,fclk) <- checkExpr1 (fValue f) (fieldType ft) + sameClock fclk (cClock ct) + pure f { fValue = fv } + + Nothing -> reportError $ + "Struct" <+> backticks (pp actualName) <+> + "does not have a field" <+> backticks (pp (fName f)) + + pure (UpdateStruct (Just actualName) e' fs', ct) + + + +-- | Check that all of the fields are different. +distinctFields :: [Field Expression] -> M () +distinctFields = mapM_ check . group . sort . map fName + where + check g = + case g of + [] -> panic "distinctFields" ["`group` returned an empty list?"] + [_] -> pure () + f : _ -> reportError $ nestedError + ("Repeated occurances of field" <+> backticks (pp f)) + (map (pp . range) g) + + + + +-- | Infer the type of a call to a user node. +inferCall :: Name -> + [StaticArg] -> + [Expression] -> + IClock -> + M (Expression, [CType]) +inferCall f as es0 cl0 = + do reqSafety <- getUnsafeLevel + reqTemporal <- getTemporalLevel + cl <- case cl0 of + BaseClock -> pure BaseClock + KnownClock c -> + case reqTemporal of + Node -> KnownClock . fst <$> inferClockExpr c + Function -> reportError $ nestedError + "Invalid clocked call" + [ "Expected to be inside a node." + , "We are inside a function." + ] + ClockVar i -> panic "inferCall" [ "Unexpected clock variable:" + , showPP i ] + + (ni,prof) <- prepUserNodeInst f as reqSafety reqTemporal + (es1,mp) <- checkInputs cl [] Map.empty (nodeInputs prof) es0 + cts <- checkOuts cl mp (nodeOutputs prof) + pure (Call ni es1 cl (Just cts), cts) + where + renBinderClock cl mp b = + case cClock (binderType b) of + BaseClock -> pure cl + + KnownClock (WhenClock r p i) -> + -- We don't consider `cl` for binder that have an explicit clock, + -- as it only affects the "base" clock. Of course, the clocks will + -- probably be inderectly affected anyway as the clock of the clock + -- would change (etc.). + case Map.lookup i mp of + Just (Right j) -> pure (KnownClock (WhenClock r p j)) + Just (Left l) | matches p -> pure BaseClock + where matches v = case v of + ERange _ v1 -> matches v1 + Lit l1 -> l == l1 + _ -> False + _ -> reportError $ + text ("Parameter for clock " ++ show (backticks (pp i)) ++ + " is not an identifier.") + + ClockVar i -> panic "inferCall.renBinderClock" + [ "Unexpected clock variable", showPP i ] + + checkInputs cl done mp is es = + case (is,es) of + ([],[]) -> pure (reverse done,mp) + (b:bs,c:cs) -> do (e,mp1) <- checkIn cl mp b c + checkInputs cl (e:done) mp1 bs cs + _ -> reportError $ nestedError + ("Bad arity in call to" <+> pp f) + [ "Expected:" <+> int (length done + length is) + , "Actual:" <+> int (length done + length es) + ] + + checkIn cl mp ib e = + case ib of + InputBinder b -> + do c <- renBinderClock cl mp b + (e',clk) <- checkExpr1 e (cType (binderType b)) + sameClock c clk + pure ( e' + , case isClock e' of + Just k -> Map.insert (binderDefines b) k mp + Nothing -> mp + ) + InputConst _ t -> + do e' <- checkConstExpr e t + pure (e',mp) + + isClock e = + case e of + ERange _ e1 -> isClock e1 + Var (Unqual i) -> Just (Right i) + Const (Lit l) _ -> Just (Left l) + _ -> Nothing + + checkOuts cl mp bs = mapM (checkOut cl mp) bs + + checkOut cl mp b = + do let t = binderType b + c <- renBinderClock cl mp b + pure t { cClock = c } + + + + + +-- | Infer the type of a variable. +inferVar :: Name -> M (Expression,CType) +inferVar x = + inRange (range x) $ + case x of + Unqual i -> + case rnThing (nameOrigName x) of + AVal -> do ct <- lookupLocal i + pure (Var (Unqual i), ct) + AConst -> do t1 <- lookupConst x + c <- newClockVar + let ct = CType { cType = t1, cClock = c } + pure (Const (Var x) ct, ct) + + t -> panic "inferVar" [ "Identifier is not a value or a constnat:" + , "*** Name: " ++ showPP x + , "*** Thing: " ++ showPP t ] + + Qual {} -> panic "inferVar" [ "Unexpected qualified name" + , "*** Name: " ++ showPP x ] + + +-- | Infer the type of a literal. +inferLit :: Literal -> Type +inferLit lit = + case lit of + Int _ -> IntSubrange (Lit lit) (Lit lit) + Real _ -> RealType + Bool _ -> BoolType + + +-- | Validate a clock expression, and return the type of the clock. +inferClockExpr :: ClockExpr -> M (ClockExpr, CType) +inferClockExpr (WhenClock r v i) = + inRange r $ + do ct <- lookupLocal i + v' <- checkConstExpr v (cType ct) + pure (WhenClock r v' i, ct) + + +-- | Infer the type of a branch in a @merge@. +inferMergeCase :: + Ident {- ^ The clock to merge on -} -> + Type {- ^ The type of the clock -} -> + MergeCase Expression {- ^ The branch to check -} -> + M (MergeCase Expression, [CType]) +inferMergeCase i it (MergeCase p e) = + do p' <- checkConstExpr p it + let clk = KnownClock (WhenClock (range p') p' i) + (e', cts) <- inferExpr e + for_ cts (sameClock clk . cClock) + pure (MergeCase p' e', cts) + + + +-- | Infer the type of a selector. +inferSelector :: Selector Expression -> Type -> M (Selector Expression, Type) +inferSelector sel ty = + case sel of + SelectField f -> + case ty of + NamedType a -> + do fs <- lookupStruct a + case find ((f ==) . fieldName) fs of + Just fi -> pure (sel,fieldType fi) + Nothing -> + reportError $ + nestedError + "Struct has no such field:" + [ "Struct:" <+> pp a + , "Field:" <+> pp f ] + + _ -> reportError $ + nestedError + "Argument to struct selector is not a struct:" + [ "Selector:" <+> pp sel + , "Input:" <+> pp ty + ] + + SelectElement n -> + case ty of + ArrayType t _sz -> + do n1 <- checkConstExpr n IntType + -- XXX: check that 0 <= && n < sz ? + pure (SelectElement n1, t) + + _ -> reportError $ + nestedError + "Argument to array selector is not an array:" + [ "Selector:" <+> pp sel + , "Input:" <+> pp ty + ] + + SelectSlice _s -> + case ty of + ArrayType _t _sz -> notYetImplemented "array slices" + _ -> reportError $ + nestedError + "Arrgument to array slice is not an array:" + [ "Selector:" <+> pp sel + , "Input:" <+> pp ty + ] + + +checkContract :: Contract -> M Contract +checkContract c = + do cis <- mapM checkContractItem (contractItems c) + pure c { contractItems = cis } + +checkContractItem :: ContractItem -> M ContractItem +checkContractItem ci = + case ci of + Assume l e -> + do (e1,clk) <- checkExpr1 e BoolType + sameClock BaseClock clk -- do we want to support others? + pure (Assume l e1) + + Guarantee l e -> + do (e1,clk) <- checkExpr1 e BoolType + sameClock BaseClock clk -- do we want to support others? + pure (Guarantee l e1) + + _ -> notYetImplemented "contract feature" + + + + + + diff --git a/Language/Lustre/TypeCheck.hs-boot b/Language/Lustre/TypeCheck.hs-boot new file mode 100644 --- /dev/null +++ b/Language/Lustre/TypeCheck.hs-boot @@ -0,0 +1,10 @@ +module Language.Lustre.TypeCheck where + +import Language.Lustre.AST(Expression,CType,Type,IClock) +import Language.Lustre.TypeCheck.Monad(M) + +inferExpr :: Expression -> M (Expression,[CType]) +inferExpr1 :: Expression -> M (Expression,CType) +checkConstExpr :: Expression -> Type -> M Expression +checkExpr1 :: Expression -> Type -> M (Expression, IClock) + diff --git a/Language/Lustre/TypeCheck/Constraint.hs b/Language/Lustre/TypeCheck/Constraint.hs new file mode 100644 --- /dev/null +++ b/Language/Lustre/TypeCheck/Constraint.hs @@ -0,0 +1,248 @@ +{-# Language OverloadedStrings #-} +module Language.Lustre.TypeCheck.Constraint where + +import Text.PrettyPrint as PP +import Control.Monad(unless) + +import Language.Lustre.AST +import Language.Lustre.TypeCheck.Monad +import qualified Language.Lustre.Semantics.Const as C +import Language.Lustre.Pretty +import Language.Lustre.Panic + + +opError :: Doc -> [Type] -> Doc +opError op ins = + nestedError "Failed to check that that the types support operation." + (("Operation:" <+> op) : tys "Input" ins) + where + tys lab ts = [ lab <+> integer n PP.<> ":" <+> pp t + | (n,t) <- [ 1 .. ] `zip` ts ] + +-- | Compute the least upper bound of two types. +tLUB :: Type -> Type -> M Type +tLUB t1 t2 = + case t1 of + + BoolType -> + do subType t2 t1 + pure t1 + + RealType -> + do subType t2 t1 + pure t1 + + IntType -> + do subType t2 t1 + pure t1 + + NamedType _ -> + do subType t2 t1 + pure t1 + + ArrayType elT1 sz1 -> + case t2 of + ArrayType elT2 sz2 -> + do sameConsts sz1 sz2 + t <- tLUB elT1 elT2 + pure (ArrayType t sz1) + _ -> err + + IntSubrange l1 h1 -> + case t2 of + IntType -> pure t2 + IntSubrange l2 h2 -> + do (l3,h3) <- intervalUnion (l1,h1) (l2,h2) + pure (IntSubrange l3 h3) + _ -> err + + TypeRange {} -> panic "tLUB" [ "Unexpected `TypeRange`." ] + + where + err = reportError (opError "find common type" [ t1, t2 ]) + + +-- | Computes the type of the result of a unariy arithmetic operator. +tArith1 :: SourceRange -> Op1 -> Type -> M Type +tArith1 r op t = + case t of + IntType -> pure IntType + RealType -> pure RealType + IntSubrange l h -> + do (l1,h1) <- intervalFor1 r op (l,h) + pure (IntSubrange l1 h1) + _ -> reportError (opError (pp op) [t]) + + +-- | Computes the type of the result of a binary arithmetic operator. +tArith2 :: SourceRange -> Op2 -> Type -> Type -> M Type +tArith2 r op t1 t2 = + case t1 of + IntType -> subType t2 t1 >> pure t1 + RealType -> subType t2 RealType >> pure t1 + + IntSubrange l1 h1 -> + case t2 of + IntType -> pure t2 + IntSubrange l2 h2 -> intervalFor2 r op (l1,h1) (l2,h2) + _ -> err + + _ -> err + + where + err = reportError (opError (pp op) [t1,t2]) + + + +-- | Checks that the given types can be compared for equality. +classEq :: Doc -> Type -> Type -> M () +classEq _op s t = + do _ <- tLUB s t -- we can compare values of any comparable type. + -- XXX: Perhaps it is useful to save the common type? + pure () + + +-- | Are these types comparable for ordering +classOrd :: Doc -> Type -> Type -> M () +classOrd op s t = + do r <- tLUB s t + case r of + IntType -> pure () + IntSubrange {} -> pure () + RealType -> pure () + _ -> reportError (opError op [s,t]) + + +-- | Subtype is like "subset" (i.e., we want to make sure that all values +-- of the first type are also good values for the second type). +subType :: Type -> Type -> M () +subType s t = + case (s,t) of + (IntSubrange {}, IntType) -> pure () + (IntSubrange a b, IntSubrange c d) -> leqConsts c a >> leqConsts b d + + (ArrayType elT1 sz1, ArrayType elT2 sz2) -> + do sameConsts sz1 sz2 + subType elT1 elT2 + + (IntType,IntType) -> pure () + (RealType,RealType) -> pure () + (BoolType,BoolType) -> pure () + (NamedType x, NamedType y) | x == y -> pure () + _ -> reportError $ nestedError + "Type mismatch:" + [ "Values of type:" <+> pp s + , "Do not fit into type:" <+> pp t + ] + + + + +-------------------------------------------------------------------------------- + + +-- XXX: This is temporary. Eventually, we should make proper constraints, +-- and either try to solve them statically, or just generate them for the +-- checker to verify on each step. + + +evConstExpr :: Expression -> Maybe C.Value +evConstExpr expr = + case C.evalConst C.emptyEnv expr of + Left _ -> Nothing + Right v -> Just v + +normConstExpr :: Expression -> Expression +normConstExpr expr = + case evConstExpr expr of + Nothing -> expr + Just v -> C.valToExpr v + +intConst :: Expression -> M Integer +intConst e = + case evConstExpr e of + Just (C.VInt a) -> pure a + _ -> reportError $ nestedError + "Constant expression is not a concrete integer." + [ "Expression:" <+> pp e ] + +intInterval :: (Expression,Expression) -> M (Integer,Integer) +intInterval (l,h) = + do i <- intConst l + j <- intConst h + pure (i,j) + +fromIntInterval :: (Integer,Integer) -> M (Expression,Expression) +fromIntInterval (l,h) = pure (Lit (Int l), Lit (Int h)) + + + +sameConsts :: Expression -> Expression -> M () +sameConsts e1 e2 = + case (e1,e2) of + (ERange _ x,_) -> sameConsts x e2 + (_, ERange _ x) -> sameConsts e1 x + (Const x _, _) -> sameConsts x e2 + (_, Const x _) -> sameConsts e1 x + (Var x, Var y) | x == y -> pure () + _ | x <- evConstExpr e1 + , y <- evConstExpr e2 + , x == y -> pure () + + _ -> reportError $ nestedError + "Constants do not match" + [ "Constant 1:" <+> pp e1 + , "Constant 2:" <+> pp e2 + ] + +leqConsts :: Expression -> Expression -> M () +leqConsts e1 e2 = + do x <- intConst e1 + y <- intConst e2 + unless (x <= y) $ reportError + $ pp x <+> "is not less-than, or equal to" <+> pp y + + + +intervalFor1 :: SourceRange -> Op1 -> + (Expression,Expression) -> + M (Expression,Expression) +intervalFor1 _ op i = + do (l,h) <- intInterval i + case op of + Neg -> fromIntInterval (negate h, negate l) + _ -> panic "intervalFor1" [ "Unexpected unary arithmetic operator" + , showPP op ] + + +intervalFor2 :: SourceRange -> Op2 -> + (Expression,Expression) -> + (Expression,Expression) -> + M Type +intervalFor2 _ op i j = + do u@(l1,h1) <- intInterval i + v@(l2,h2) <- intInterval j + case op of + Add -> rng (l1 + l2, h1 + h2) + Sub -> rng (l1 - h2, h1 - l2) + Mul -> byCases u v (*) + Div -> pure IntType -- XXX: more precise? + Mod -> pure IntType -- XXX: more precise + _ -> panic "intervalFor2" [ "Unexpected binary arithmetic operator" + , showPP op ] + where + rng u = do (a,b) <- fromIntInterval u + pure (IntSubrange a b) + + byCases (a,b) (x,y) f = rng (minimum ch, maximum ch) + where ch = [ f u v | u <- [a, b], v <- [x, y] ] + +intervalUnion :: (Expression,Expression) -> + (Expression,Expression) -> + M (Expression,Expression) +intervalUnion i j = + do (l1,h1) <- intInterval i + (l2,h2) <- intInterval j + fromIntInterval (min l1 l2, max h1 h2) + + diff --git a/Language/Lustre/TypeCheck/Monad.hs b/Language/Lustre/TypeCheck/Monad.hs new file mode 100644 --- /dev/null +++ b/Language/Lustre/TypeCheck/Monad.hs @@ -0,0 +1,420 @@ +{-# Language OverloadedStrings, GeneralizedNewtypeDeriving, DataKinds #-} +module Language.Lustre.TypeCheck.Monad where + +import Data.Set(Set) +import qualified Data.Set as Set +import Data.Map(Map) +import qualified Data.Map as Map +import Data.Foldable(for_) +import Text.PrettyPrint as PP +import MonadLib + +import Language.Lustre.Name +import Language.Lustre.AST +import Language.Lustre.Pretty +import Language.Lustre.Monad (LustreM, LustreError(..)) +import qualified Language.Lustre.Monad as L +import Language.Lustre.Panic + +-- | XXX: Parameterize so that we can startin in a non-empty environment. +runTC :: M a -> LustreM a +runTC m = + do (a,_finS) <- runStateT rw0 $ runReaderT ro0 $ unM m + -- L.logMessage "Clock subst:" + -- dumpClockSubstLustre (rwClockVarSubst _finS) + pure a + where + ro0 = RO { roConstants = Map.empty + , roUserNodes = Map.empty + , roIdents = Map.empty + , roCurRange = [] + , roTypeNames = Map.empty + , roTemporal = False + , roUnsafe = False + } + + rw0 = RW { rwClockVarSubst = Map.empty + , rwClockVars = Set.empty + } + + + + +newtype M a = M { unM :: + WithBase LustreM + [ ReaderT RO + , StateT RW + ] a + } deriving (Functor,Applicative,Monad) + +-- | Information about a node that can be called (i.e., is in scope) +data NodeInfo = NodeInfo + { niName :: Ident -- ^ Definition site + , niSafety :: Safety -- ^ Safe/unsafe + , niType :: NodeType -- ^ Function/node + , niStaticParams :: [StaticParam] -- ^ Static parametres + , niProfile :: NodeProfile -- ^ Inputs and ouputs + } + +data RO = RO + { roConstants :: Map OrigName (SourceRange, Type) + -- ^ Constants that are in scope. These include top-level constants, + -- constant (i.e., static) parameters, and local constants. + + , roUserNodes :: Map OrigName NodeInfo + -- ^ User defined nodes in scope, as well as static node parameters. + + , roIdents :: Map OrigName (SourceRange, CType) + -- ^ Locals in scope (i.e., arguments and node locals) + + , roTypeNames :: Map OrigName (SourceRange, NamedType) -- no type vars here + -- ^ Named types in scope (top level declarations plus static parameters) + + , roCurRange :: [SourceRange] + -- ^ The "path" of locations that lead us to where we currently are. + + , roTemporal :: Bool + -- ^ Are temporal constructs OK? + + , roUnsafe :: Bool + -- ^ Are unsafe constucts OK? + } + + +data RW = RW + { rwClockVarSubst :: Map CVar IClock + , rwClockVars :: Set CVar + -- ^ Clock variables in the current node. + -- Ones that don't get bound are defaulted to the base clocks. + } + +data NamedType = StructTy [FieldType] + -- ^ Order of the fields should match declaration + | EnumTy (Set OrigName) + | AliasTy Type + | AbstractTy + + +reportError :: Doc -> M a +reportError msg = + M $ do rs <- roCurRange <$> ask + inBase $ L.reportError $ TCError rs msg + +notYetImplemented :: Doc -> M a +notYetImplemented f = + reportError $ nestedError "XXX: Feature not yet implemented:" + [ "Feature:" <+> f ] + +nestedError :: Doc -> [Doc] -> Doc +nestedError x ys = vcat (x : [ "***" <+> y | y <- ys ]) + +inRange :: SourceRange -> M a -> M a +inRange r (M a) = M (mapReader upd a) + where upd ro = ro { roCurRange = r : roCurRange ro } + +inRangeSet :: SourceRange -> M a -> M a +inRangeSet r (M a) = M (mapReader upd a) + where upd ro = ro { roCurRange = [r] } + +inRangeSetMaybe :: Maybe SourceRange -> M a -> M a +inRangeSetMaybe mb m = case mb of + Nothing -> m + Just r -> inRangeSet r m + +inRangeMaybe :: Maybe SourceRange -> M a -> M a +inRangeMaybe mb m = case mb of + Nothing -> m + Just r -> inRange r m + +lookupLocal :: Ident -> M CType +lookupLocal i = + do ro <- M ask + let orig = identOrigName i + case Map.lookup orig (roIdents ro) of + Nothing -> panic "lookupLocal" + [ "Undefined identifier: " ++ showPP i ] + Just (_,t) -> pure t + + +lookupConst :: Name -> M Type +lookupConst c = + do ro <- M ask + case Map.lookup (nameOrigName c) (roConstants ro) of + Nothing -> panic "lookupConst" [ "Undefined constant: " ++ showPP c ] + Just (_,t) -> pure t + + +resolveNamed :: Name -> M Type +resolveNamed x = + do ro <- M ask + case Map.lookup (nameOrigName x) (roTypeNames ro) of + Nothing -> panic "resolveNamed" [ "Undefined type:" ++ showPP x ] + Just (_,nt) -> pure $ case nt of + AliasTy t -> t + _ -> NamedType x + +lookupStruct :: Name -> M [FieldType] +lookupStruct s = + do ro <- M ask + case Map.lookup (nameOrigName s) (roTypeNames ro) of + Nothing -> panic "lookupStruct" [ "Undefined struct: " ++ showPP s ] + Just (_,nt) -> + case nt of + StructTy fs -> pure fs + EnumTy {} -> reportError $ nestedError + "Enumeration used where a struct was expected." + [ "Type:" <+> pp s ] + AliasTy at -> + case at of + NamedType s' -> lookupStruct s' + _ -> reportError $ nestedError + "Type is not a struct." + [ "Type name:" <+> pp s + , "Type definition:" <+> pp at + ] + + AbstractTy -> reportError $ nestedError + "Abstract type used where a struct was expected." + ["Name:" <+> pp s] + + +lookupNodeInfo :: Name -> M NodeInfo +lookupNodeInfo n = + do ro <- M ask + case Map.lookup (nameOrigName n) (roUserNodes ro) of + Just info -> pure info + Nothing -> panic "lookupNodeProfile" [ "Undefined node: " ++ showPP n ] + +withConst :: Ident -> Type -> M a -> M a +withConst x t (M m) = + do ro <- M ask + let nm = identOrigName x + let cs = roConstants ro + M (local ro { roConstants = Map.insert nm (range x,t) cs } m) + + +withLocal :: Ident -> CType -> M a -> M a +withLocal i t (M m) = + M $ do ro <- ask + let is = roIdents ro + nm = identOrigName i + local ro { roIdents = Map.insert nm (range i, t) is } m + +withNode :: NodeInfo -> M a -> M a +withNode ni (M m) = + M $ do ro <- ask + let nm = identOrigName (niName ni) + local ro { roUserNodes = Map.insert nm ni (roUserNodes ro) } m + +withNamedType :: Ident -> NamedType -> M a -> M a +withNamedType x t (M m) = + M $ do ro <- ask + let nm = identOrigName x + local ro { roTypeNames = Map.insert nm (range x,t) + (roTypeNames ro) } m + + +withLocals :: [(Ident,CType)] -> M a -> M a +withLocals xs k = + case xs of + [] -> k + (x,t) : more -> withLocal x t (withLocals more k) + +allowTemporal :: Bool -> M a -> M a +allowTemporal b (M m) = M (mapReader upd m) + where upd ro = ro { roTemporal = b } + +checkTemporalOk :: Doc -> M () +checkTemporalOk msg = + do ok <- M (roTemporal <$> ask) + unless ok $ + reportError $ nestedError + "Temporal operators are not allowed in a function." + [ "Operator:" <+> msg ] + +getTemporalLevel :: M NodeType +getTemporalLevel = + do ok <- M (roTemporal <$> ask) + pure (if ok then Node else Function) + +allowUnsafe :: Bool -> M a -> M a +allowUnsafe b (M m) = M (mapReader upd m) + where upd ro = ro { roUnsafe = b } + +getUnsafeLevel :: M Safety +getUnsafeLevel = + do ok <- M (roUnsafe <$> ask) + pure (if ok then Unsafe else Safe) + + + +-- | Generate a fresh clock variable. +newClockVar :: M IClock +newClockVar = M $ + do n <- inBase L.newInt + let cv = CVar n + sets_ $ \rw -> rw { rwClockVars = Set.insert cv (rwClockVars rw) } + pure (ClockVar cv) + + +-- | Assumes that the clock is zonked +bindClockVar :: CVar -> IClock -> M () +bindClockVar x c = + case c of + ClockVar y | x == y -> pure () + _ -> do let upd cl = case cl of + ClockVar i | i == x -> c + _ -> cl + M $ sets_ $ \rw -> rw { rwClockVarSubst = Map.insert x c + $ fmap upd + $ rwClockVarSubst rw + , rwClockVars = Set.delete x (rwClockVars rw) + } + +dumpClockSubst :: M () +dumpClockSubst = M $ + do su <- rwClockVarSubst <$> get + lift $ lift $ dumpClockSubstLustre su + +dumpClockSubstLustre :: Map CVar IClock -> LustreM () +dumpClockSubstLustre su = + for_ (Map.toList su) $ \(x,v) -> + L.logMessage (show (pp x <+> ":=" <+> pp v)) + +debugMessage :: String -> M () +debugMessage s = M $ lift $ lift $ L.logMessage s + + +-- | Generate a new scope of clock variables. Variables that are not defined +-- by the parameter computation will be defaulted to "base clock" +inClockScope :: M a -> M a +inClockScope (M m) = M $ + do old <- sets $ \rw -> (rwClockVars rw, rw { rwClockVars = Set.empty }) + a <- m + leftover <- rwClockVars <$> get + let mp = Map.fromList [ (x,BaseClock) | x <- Set.toList leftover ] + sets_ $ \rw -> rw { rwClockVars = old + , rwClockVarSubst = Map.union mp (rwClockVarSubst rw) + } + pure a + + + +zonkClock :: IClock -> M IClock +zonkClock c = + case c of + BaseClock -> pure c + KnownClock (WhenClock r v i) -> + do v' <- zonkExpr v + case isId v' of + Just j | i == j -- clocks that are always true + -> pure BaseClock + _ -> pure (KnownClock (WhenClock r v' i)) + ClockVar v -> M $ do su <- rwClockVarSubst <$> get + pure (Map.findWithDefault c v su) + where + isId e = case e of + ERange _ e1 -> isId e1 + Const e' _ -> isId e' + Var (Unqual x) -> Just x + _ -> Nothing + + + +-- | Apply the substitution to types in the AST. +-- Currently, only the 'Const' construct contains a type. +zonkExpr :: Expression -> M Expression +zonkExpr expr = + case expr of + ERange r e -> ERange r <$> zonkExpr e + Const e ty -> Const <$> zonkExpr e <*> zonkCType ty + Var {} -> pure expr + Lit {} -> pure expr + e `When` c -> When <$> zonkExpr e <*> zonkClockExpr c + + Tuple es -> Tuple <$> traverse zonkExpr es + Array es -> Array <$> traverse zonkExpr es + Select e s -> Select <$> zonkExpr e <*> zonkSelector s + Struct s fs -> Struct s <$> traverse zonkField fs + UpdateStruct s e fs -> UpdateStruct s + <$> zonkExpr e + <*> traverse zonkField fs + WithThenElse e1 e2 e3 -> WithThenElse <$> zonkExpr e1 <*> + zonkExpr e2 <*> zonkExpr e3 + Merge i as -> Merge i <$> traverse zonkMergeCase as + Call f es c mTys -> Call f <$> traverse zonkExpr es <*> zonkClock c <*> + case mTys of + Nothing -> return Nothing + Just tys -> Just <$> mapM zonkCType tys + +zonkCType :: CType -> M CType +zonkCType ct = + do t <- zonkType (cType ct) + c <- zonkClock (cClock ct) + pure CType { cType = t, cClock = c } + +zonkType :: Type -> M Type +zonkType t = + case t of + ArrayType elT sz -> ArrayType <$> zonkType elT <*> zonkExpr sz + IntSubrange e1 e2 -> IntSubrange <$> zonkExpr e1 <*> zonkExpr e2 + NamedType {} -> pure t + RealType -> pure t + IntType -> pure t + BoolType -> pure t + TypeRange r t' -> TypeRange r <$> zonkType t' + +zonkField :: Field Expression -> M (Field Expression) +zonkField f = + do e <- zonkExpr (fValue f) + pure f { fValue = e } + +zonkMergeCase :: MergeCase Expression -> M (MergeCase Expression) +zonkMergeCase (MergeCase k e) = MergeCase <$> zonkExpr k <*> zonkExpr e + +zonkSelector :: Selector Expression -> M (Selector Expression) +zonkSelector sel = + case sel of + SelectField {} -> pure sel + SelectElement e -> SelectElement <$> zonkExpr e + SelectSlice e -> SelectSlice <$> zonkSlice e + +zonkSlice :: ArraySlice Expression -> M (ArraySlice Expression) +zonkSlice a = + do s <- zonkExpr (arrayStart a) + e <- zonkExpr (arrayEnd a) + t <- traverse zonkExpr (arrayStep a) + pure ArraySlice { arrayStart = s, arrayEnd = e, arrayStep = t } + +zonkClockExpr :: ClockExpr -> M ClockExpr +zonkClockExpr (WhenClock r e i) = + do e' <- zonkExpr e + pure (WhenClock r e' i) + +zonkBody :: NodeBody -> M NodeBody +zonkBody b = + do eqs <- traverse zonkEqn (nodeEqns b) + pure b { nodeEqns = eqs } + +zonkEqn :: Equation -> M Equation +zonkEqn eqn = + case eqn of + Assert p ty e -> Assert p ty <$> zonkExpr e + Property p e -> Property p <$> zonkExpr e + IsMain {} -> pure eqn + IVC {} -> pure eqn + Realizable {} -> pure eqn + Define lhs e -> Define lhs <$> zonkExpr e + +zonkContract :: Contract -> M Contract +zonkContract c = + do cis <- mapM zonkContractItem (contractItems c) + pure c { contractItems = cis } + +zonkContractItem :: ContractItem -> M ContractItem +zonkContractItem ci = + case ci of + Assume l e -> Assume l <$> zonkExpr e + Guarantee l e -> Guarantee l <$> zonkExpr e + _ -> panic "zonkContractItem" ["unsupported contract item"] + diff --git a/Language/Lustre/TypeCheck/Prims.hs b/Language/Lustre/TypeCheck/Prims.hs new file mode 100644 --- /dev/null +++ b/Language/Lustre/TypeCheck/Prims.hs @@ -0,0 +1,252 @@ +{-# Language OverloadedStrings #-} +module Language.Lustre.TypeCheck.Prims ( inferPrim ) where + +import Data.Traversable(for) +import Data.Foldable(for_) +import Text.PrettyPrint +import Control.Monad(unless,zipWithM) + +import Language.Lustre.AST +import Language.Lustre.Pretty +import Language.Lustre.TypeCheck.Monad +import Language.Lustre.TypeCheck.Constraint +import {-# SOURCE #-} Language.Lustre.TypeCheck +import Language.Lustre.TypeCheck.Utils + + +-- | Infer the type of a call to a primitive node. +inferPrim :: + SourceRange {- ^ Location of operator -} -> + PrimNode {- ^ Operator -} -> + [StaticArg] {- ^ Static arguments -} -> + [Expression] {- ^ Normal argumetns -} -> + M (Expression,[CType]) +inferPrim r prim as es = + case prim of + + Iter {} -> notYetImplemented "iterators." + + Op1 op -> + case es of + [e] -> noStatic op >> inferOp1 r op e + _ -> reportError (pp op <+> "expects 1 argument.") + + Op2 op -> + case es of + [e1,e2] -> noStatic op >> inferOp2 r op e1 e2 + _ -> reportError (pp op <+> "expects 2 arguments.") + + ITE -> + case es of + [e1,e2,e3] -> noStatic ITE >> inferITE r e1 e2 e3 + _ -> reportError "`if-then-else` expects 3 arguments." + + + OpN op -> noStatic op >> inferOpN r op es + where + noStatic op = + unless (null as) $ + reportError (backticks (pp op) <+> "does not take static arguments") + + +-- | Check an if-then-else expression. +inferITE :: SourceRange -> Expression -> Expression -> Expression -> + M (Expression,[CType]) +inferITE r e1 e2 e3 = + do (e1',c) <- checkExpr1 e1 BoolType + (e2',ctTHEN) <- inferExpr e2 + (e3',ctELSE) <- inferExpr e3 + sameLen ctTHEN ctELSE + for_ ctTHEN (sameClock c . cClock) + for_ ctELSE (sameClock c . cClock) + ts <- zipWithM tLUB (map cType ctTHEN) (map cType ctELSE) + let cts = [ CType { cClock = c, cType = t } | t <- ts ] + pure (eITE r e1' e2' e3' (Just cts), cts) + + + +-- | Check a @current@ expression. +inferCurrent :: Expression -> M (Expression,[CType]) +inferCurrent e = + do checkTemporalOk "current" + (e',ctsIn) <- inferExpr e + cts <- for ctsIn $ \ct -> do c <- clockParent (cClock ct) + pure ct { cClock = c } + pure (e',cts) + + +-- | Check a uniary operator. +inferOp1 :: SourceRange -> Op1 -> Expression -> M (Expression,[CType]) +inferOp1 r op e = + do (a, ct) <- check + pure (eOp1 r op a (Just ct), ct) + + where + check = + case op of + + Pre -> + do checkTemporalOk "pre" + inferExpr e + + Current -> inferCurrent e + + Not -> + do (e', i) <- checkExpr1 e BoolType + let ct = CType { cType = BoolType, cClock = i } + pure (e', [ct]) + + Neg -> + do (e', ct0) <- inferExpr1 e + t <- tArith1 r op (cType ct0) + let ct = CType { cClock = cClock ct0, cType = t } + pure (e', [ct]) + + IntCast -> + do (e', i) <- checkExpr1 e RealType + let ct = CType { cType = IntType, cClock = i } + pure (e', [ct]) + + FloorCast -> + do (e', i) <- checkExpr1 e RealType + let ct = CType { cType = IntType, cClock = i } + pure (e', [ct]) + + RealCast -> + do (e', i) <- checkExpr1 e IntType + let ct = CType { cType = RealType, cClock = i } + pure (e', [ct]) + + +-- | Types of binary operators. +inferOp2 :: + SourceRange -> Op2 -> Expression -> Expression -> M (Expression,[CType]) +inferOp2 r op2 e1 e2 = + do (a, b, cts) <- check + pure (eOp2 r op2 a b (Just cts), cts) + + where + check = + case op2 of + FbyArr -> inferFBY "->" + Fby -> inferFBY "fby" + + CurrentWith -> + do checkTemporalOk "currentWith" + (a,ctDEF) <- inferExpr e1 + (b,ctEXP) <- inferCurrent e2 + sameLen ctDEF ctEXP + cts <- zipWithM ctLUB ctDEF ctEXP + pure (a, b, cts) + + Replicate -> + do (a,ctE) <- inferExpr1 e1 + b <- checkConstExpr e2 IntType + let ct = ctE { cType = ArrayType (cType ctE) b } + pure (a, b, [ct]) + + And -> bool2 + Or -> bool2 + Xor -> bool2 + Implies -> bool2 + + Eq -> eqRel "=" + Neq -> eqRel "<>" + + Lt -> ordRel "<" + Leq -> ordRel "<=" + Gt -> ordRel ">" + Geq -> ordRel ">=" + + Add -> arith Add + Sub -> arith Sub + Mul -> arith Mul + Div -> arith Div + Mod -> arith Mod + + Power -> notYetImplemented "Exponentiation" + Concat -> inferConcat + + + inferFBY x = + do checkTemporalOk x + (a,cts1) <- inferExpr e1 + (b,cts2) <- inferExpr e2 + sameLen cts1 cts2 + ct <- zipWithM ctLUB cts1 cts2 + pure (a, b, ct) + + + infer2 = do (a,t1) <- inferExpr1 e1 + (b,t2) <- inferExpr1 e2 + sameClock (cClock t1) (cClock t2) + pure (cClock t1, cType t1, cType t2, a, b) + + bool2 = do (c,t1,t2,a,b) <- infer2 + _ <- subType t1 BoolType + _ <- subType t2 BoolType + let ct = CType { cType = BoolType, cClock = c } + pure (a, b, [ct]) + + ordRel op = do (c,t1,t2,a,b) <- infer2 + _ <- classOrd op t1 t2 + let ct = CType { cType = BoolType, cClock = c } + pure (a, b, [ct]) + + arith x = do (c,t1,t2,a,b) <- infer2 + ty <- tArith2 r x t1 t2 + let ct = CType { cType = ty, cClock = c } + pure (a, b, [ct]) + + eqRel op = do (a,cts1) <- inferExpr e1 + (b,cts2) <- inferExpr e2 + sameLen cts1 cts2 + for_ (zip cts1 cts2) $ \(ct1,ct2) -> + do sameClock (cClock ct1) (cClock ct2) + classEq op (cType ct1) (cType ct2) + i <- case cts1 of + [] -> newClockVar + ct : _ -> pure (cClock ct) + let ct = CType { cType = BoolType, cClock = i } + pure (a, b, [ct]) + + inferConcat = + do (a, ct1) <- inferExpr1 e1 + (b, ct2) <- inferExpr1 e2 + sameClock (cClock ct1) (cClock ct2) + let t1 = cType ct1 + t2 = cType ct2 + case t1 of + ArrayType elT1 sz1 -> + case t2 of + ArrayType elT2 sz2 -> + do t <- tLUB elT1 elT2 + sz <- addExprs sz1 sz2 + let ct = CType { cType = ArrayType t sz, cClock = cClock ct1 } + pure (a,b,[ct]) + _ -> typeError "right" t2 + _ -> typeError "left" t1 + where + + typeError x t = reportError $ nestedError + ("Incorrect" <+> x <+> "argument to `|`") + [ "Expected:" <+> "array" + , "Actual type:" <+> pp t ] + + +-- | Check a variable arity operator. +inferOpN :: SourceRange -> OpN -> [Expression] -> M (Expression,[CType]) +inferOpN r op es = + case op of + AtMostOne -> boolOp + Nor -> boolOp + where + boolOp = + do (es',cts) <- unzip <$> for es inferExpr1 + i <- newClockVar + for_ cts (sameClock i . cClock) + let ct = CType { cClock = i, cType = BoolType } + pure (eOpN r op es' (Just [ct]),[ct]) + + + diff --git a/Language/Lustre/TypeCheck/Utils.hs b/Language/Lustre/TypeCheck/Utils.hs new file mode 100644 --- /dev/null +++ b/Language/Lustre/TypeCheck/Utils.hs @@ -0,0 +1,114 @@ +{-# Language OverloadedStrings #-} +module Language.Lustre.TypeCheck.Utils where + +import Text.PrettyPrint +import Control.Monad(unless) + +import Language.Lustre.AST +import Language.Lustre.Pretty +import Language.Lustre.TypeCheck.Monad +import Language.Lustre.TypeCheck.Constraint + + +-- | Assert that a given expression has only one type (i.e., is not a tuple) +one :: [a] -> M a +one xs = + case xs of + [x] -> pure x + _ -> arityMismatch (length xs) 1 + +sameLen :: [a] -> [b] -> M () +sameLen xs ys + | a == b = pure () + | otherwise = arityMismatch a b + where + a = length xs + b = length ys + +arityMismatch :: Int -> Int -> M a +arityMismatch x y = + reportError $ + nestedError "Arity mismatch." + [ "Expected arity:" <+> int x + , "Actual arity:" <+> int y + ] + +ctLUB :: CType -> CType -> M CType +ctLUB ct1 ct2 = + do sameClock (cClock ct1) (cClock ct2) + ty <- tLUB (cType ct1 )(cType ct2) + pure CType { cClock = cClock ct1, cType = ty } + + + +-------------------------------------------------------------------------------- +-- Clocks + + +-- | Are these the same clock. If so, return the one that is NOT a 'ConstExpr' +-- (if any). +sameClock :: IClock -> IClock -> M () +sameClock x0 y0 = + do x <- zonkClock x0 + y <- zonkClock y0 + case (x,y) of + (ClockVar a, _) -> bindClockVar a y + (_, ClockVar a) -> bindClockVar a x + (BaseClock,BaseClock) -> pure () + (KnownClock a, KnownClock b) -> sameKnownClock a b + _ -> reportError $ nestedError + "The given clocks are different:" + [ "Clock 1:" <+> pp x + , "Clock 2:" <+> pp y + ] + +-- | Is this the same known clock. +sameKnownClock :: ClockExpr -> ClockExpr -> M () +sameKnownClock c1@(WhenClock _ e1_init i1) c2@(WhenClock _ e2_init i2) = + do unless (i1 == i2) $ + reportError $ + nestedError + "The given clocks are different:" + [ "Clock 1:" <+> pp c1 + , "Clock 2:" <+> pp c2 + ] + sameConsts e1_init e2_init + +-- | Get the clock of a clock, or fail if we are the base clock. +clockParent :: IClock -> M IClock +clockParent ct0 = + do ct <- zonkClock ct0 + case ct of + BaseClock -> reportError "The base clock has no parent." + KnownClock (WhenClock _ _ i) -> cClock <$> lookupLocal i + -- XXX: This can be a constnat? + ClockVar _ -> reportError "Failed to infer the expressions's clock" + + + +-------------------------------------------------------------------------------- +-- Expressions + +binConst :: (Integer -> Integer -> Integer) -> + Expression -> Expression -> M Expression +binConst f e1 e2 = + do x <- intConst e1 + y <- intConst e2 + pure $ Lit $ Int $ f x y + +addExprs :: Expression -> Expression -> M Expression +addExprs = binConst (+) -- XXX: Can make an expression instead + +minExprs :: Expression -> Expression -> M Expression +minExprs = binConst min + +maxConsts :: Expression -> Expression -> M Expression +maxConsts = binConst max + + + + + + + + diff --git a/Language/Lustre/Utils.hs b/Language/Lustre/Utils.hs new file mode 100644 --- /dev/null +++ b/Language/Lustre/Utils.hs @@ -0,0 +1,15 @@ +module Language.Lustre.Utils where + +import Language.Lustre.Panic +import Language.Lustre.Pretty + +-- | Like 'zipWith' except panic if the lists have different lenghts. +zipExact :: (Pretty a, Pretty b) => (a -> b -> c) -> [a] -> [b] -> [c] +zipExact f xs ys + | length xs == length ys = zipWith f xs ys + | otherwise = panic "zipExact" + $ "MISMATCH" + : "--- LHS: ---" + : map showPP xs + ++ ("--- RHS: ---" : map showPP ys) + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/exe/Lustre.hs b/exe/Lustre.hs new file mode 100644 --- /dev/null +++ b/exe/Lustre.hs @@ -0,0 +1,143 @@ +{-# Language OverloadedStrings #-} +module Main(main) where + +import Text.Read(readMaybe) +import Text.PrettyPrint((<+>)) +import Control.Exception(catches,Handler(..),throwIO,catch) +import Control.Monad(when,unless) +import Data.IORef(newIORef,readIORef,writeIORef) +import System.IO(stdin,stdout,stderr,hFlush,hPutStrLn,hPrint + , openFile, IOMode(..), hGetContents ) +import System.IO.Error(isEOFError,mkIOError,eofErrorType) +import System.Exit(exitSuccess) +import qualified Data.Map as Map +import Numeric(readSigned,readFloat) +import SimpleGetOpt +import qualified Data.Set as Set + +import Language.Lustre.AST(Program(..)) +import Language.Lustre.Core +import Language.Lustre.Semantics.Core +import Language.Lustre.Parser(parseProgramFromFileLatin1, ParseError) +import Language.Lustre.Driver +import Language.Lustre.Monad +import Language.Lustre.Pretty(pp) + +import Options + + +computeConf :: Options -> IO LustreConf +computeConf opts = + do logH <- case logFile opts of + Nothing -> pure stdout + Just f -> openFile f WriteMode + pure LustreConf { lustreInitialNameSeed = Nothing + , lustreLogHandle = logH + , lustreDumpAfter = dumpAfter opts + } + + +main :: IO () +main = + do opts <- getOptsX options + when (showHelp opts) $ + do putStrLn (usageString options) + exitSuccess + + a <- case progFile opts of + Nothing -> + throwIO (GetOptException ["No Lustre file was specified."]) + Just f -> parseProgramFromFileLatin1 f + + case a of + ProgramDecls ds -> + do conf <- computeConf opts + (ws,nd) <- runLustre conf $ + do unless (Set.null (lustreDumpAfter conf)) + (setVerbose True) + (_,nd) <- quickNodeToCore Nothing ds + warns <- getWarnings + pure (warns,nd) + mapM_ showWarn ws + sIn <- newIn (inputFile opts) + runNodeIO (dumpState opts) sIn nd + _ -> hPutStrLn stderr "We don't support packages for the moment." + `catches` + [ Handler $ \e -> showErr (e :: ParseError) + , Handler $ \e -> showErr (e :: LustreError) + , Handler $ \(GetOptException es) -> + do mapM_ (hPutStrLn stderr) es + hPutStrLn stderr "" + hPutStrLn stderr (usageString options) + + ] + where + showErr e = hPrint stderr (pp e) + showWarn w = hPrint stderr (pp w) + + +data In = In + { nextToken :: IO String + , echo :: Bool + } + +newIn :: Maybe FilePath -> IO In +newIn mb = + do (h,e) <- case mb of + Nothing -> pure (stdin,False) + Just f -> do h <- openFile f ReadMode + pure (h,True) + ws0 <- words <$> hGetContents h + r <- newIORef ws0 + pure In { nextToken = -- assumes single threaded + do ws <- readIORef r + case ws of + [] -> ioError $ mkIOError eofErrorType + "(EOF)" Nothing Nothing + w : more -> do writeIORef r more + pure w + , echo = e + } + +runNodeIO :: Bool -> In -> Node -> IO () +runNodeIO dumpS sIn node = + go (1::Integer) s0 + `catch` \e -> if isEOFError e then putStrLn "(EOF)" else throwIO e + where + (s0,step) = initNode node Nothing + + go n s = do putStrLn ("--- Step " ++ show n ++ " ---") + when dumpS $ print $ ppState ppinfo s + s1 <- step s <$> getInputs + mapM_ (showOut s1) (nOutputs node) + go (n+1) s1 + + showOut s (x ::: _) = print (pp x <+> "=" <+> ppValue (evalVar s x)) + + getInputs = Map.fromList <$> mapM getInput (nInputs node) + + ppinfo = identVariants node + + getInput b@(x ::: ct) = + do putStr (show (ppBinder ppinfo b <+> " = ")) + hFlush stdout + txt <- nextToken sIn + when (echo sIn) (putStrLn txt) + case parseVal (typeOfCType ct) txt of + Just ok -> pure (x,ok) + Nothing -> do putStrLn ("Invalid " ++ show (ppCType ppinfo ct)) + getInput b + +parseVal :: Type -> String -> Maybe Value +parseVal t s + | ["-"] == words s = Just VNil + | otherwise = + case t of + TBool -> VBool <$> readMaybe s + TInt -> VInt <$> readMaybe s + TReal -> case readSigned readFloat s of + [(n,"")] -> Just (VReal n) + _ -> Nothing + + + diff --git a/exe/Options.hs b/exe/Options.hs new file mode 100644 --- /dev/null +++ b/exe/Options.hs @@ -0,0 +1,79 @@ +module Options where + +import SimpleGetOpt +import Data.Set(Set) +import qualified Data.Set as Set + +import Language.Lustre.Phase + +data Options = Options + { progFile :: Maybe FilePath + , inputFile :: Maybe FilePath + , logFile :: Maybe FilePath + , dumpAfter :: Set LustrePhase + , dumpState :: Bool + , showHelp :: Bool + } + +defaultOptions :: Options +defaultOptions = Options + { progFile = Nothing + , inputFile = Nothing + , logFile = Nothing + , dumpAfter = noPhases + , dumpState = False + , showHelp = False + } + +options :: OptSpec Options +options = OptSpec + { progDefaults = defaultOptions + , progOptions = + + [ Option [] ["input"] + "Read inputs from this file (default `stdin`)." + $ ReqArg "FILE" $ \a s -> + case inputFile s of + Nothing -> Right s { inputFile = Just a } + Just _ -> Left "Multiple input files." + + , Option [] ["logFile"] + "Write messages to his file (default `stdout`)." + $ ReqArg "FILE" $ \a s -> + case logFile s of + Nothing -> Right s { logFile = Just a } + Just _ -> Left "Multiple log file." + + , Option [] ["dump-all"] + "Dump AST after each phase." + $ NoArg $ \s -> Right s { dumpAfter = allPhases } + + , dumpOpt PhaseRename "renamed" "renaming" + , dumpOpt PhaseTypecheck "typechecked" "type checking" + , dumpOpt PhaseNoStatic "no-static" "elimininating constants" + , dumpOpt PhaseNoStruct "no-struct" "elimininating strucutred data" + , dumpOpt PhaseInline "inlined" "inlining nodes" + , dumpOpt PhaseToCore "core" "translating to core" + + , Option [] ["dump-state"] + "Dump state before each step." + $ NoArg $ \s -> Right s { dumpState = True } + + , Option [] ["help"] + "Show this helps message." + $ NoArg $ \s -> Right s { showHelp = True } + + ] + + , progParamDocs = [("FILE", "Lustre file containing model (required).")] + , progParams = \a s -> case progFile s of + Nothing -> Right s { progFile = Just a } + _ -> Left "Multiple program files." + } + + where + dumpOpt ph o msg = + Option [] ["dump-" ++ o] + ("Dump AST after " ++ msg ++ ".") + $ NoArg $ \s -> Right s { dumpAfter = Set.insert ph (dumpAfter s) } + diff --git a/language-lustre.cabal b/language-lustre.cabal new file mode 100644 --- /dev/null +++ b/language-lustre.cabal @@ -0,0 +1,86 @@ +name: language-lustre +version: 1.0.0 +synopsis: A parser and AST for the Lustre language. +description: A parser and AST for the Lustre language (specifically Lustre V6). +license: ISC +license-file: LICENSE +author: Iavor Diatchki +maintainer: iavor.diatchki@gmail.com +category: Development +build-type: Simple +extra-source-files: ChangeLog.md +cabal-version: >=1.10 + +source-repository this + type: git + location: https://github.com/GaloisInc/lustre.git + -- Add a tag for releases + tag: v1.0.0 + +library + exposed-modules: Language.Lustre.AST, + Language.Lustre.Defines, + Language.Lustre.Name, + Language.Lustre.Monad, + Language.Lustre.Error, + Language.Lustre.Panic, + Language.Lustre.Parser.Lexer, + Language.Lustre.Parser, + Language.Lustre.Parser.Monad, + Language.Lustre.Pretty, + Language.Lustre.Core, + Language.Lustre.Utils, + Language.Lustre.ModelState, + Language.Lustre.Driver, + Language.Lustre.Phase, + + Language.Lustre.TypeCheck, + Language.Lustre.TypeCheck.Constraint, + Language.Lustre.TypeCheck.Monad, + Language.Lustre.TypeCheck.Prims, + Language.Lustre.TypeCheck.Utils, + + Language.Lustre.Transform.OrderDecls, + Language.Lustre.Transform.NoStatic, + Language.Lustre.Transform.NoStruct, + Language.Lustre.Transform.Inline, + Language.Lustre.Transform.ToCore, + + Language.Lustre.Semantics.Const, + Language.Lustre.Semantics.Value, + Language.Lustre.Semantics.BuiltIn, + Language.Lustre.Semantics.Core + + + build-depends: base >= 4.7 && < 5, + alex-tools >=0.4, + bytestring, + text, + array, + panic, + containers, + GraphSCC, + pretty, + monadLib >= 3.8 + build-tools: alex, happy + default-language: Haskell2010 + ghc-options: -Wall + +executable lustre + hs-source-dirs: exe + main-is: Lustre.hs + + other-modules: + Options + + build-depends: + base, + containers, + pretty, + simple-get-opt == 0.4.*, + language-lustre + + ghc-options: -Wall + default-language: Haskell2010 + +