From 7ef6620ac6470f2c2b951056870b4882b808f38b Mon Sep 17 00:00:00 2001 From: Robert Krook Date: Fri, 26 Nov 2021 15:11:51 +0100 Subject: [PATCH 01/16] Begun work on parameterising a program over the backend it is intended to run on. --- ssm/SSM/Backend/C/CodeGen.hs | 6 +-- ssm/SSM/Backend/C/Compile.hs | 4 +- ssm/SSM/Backend/C/Peripheral.hs | 57 +++++++++++++++-------------- ssm/SSM/Compile.hs | 11 ++++-- ssm/SSM/Core.hs | 2 + ssm/SSM/Core/Backend.hs | 3 ++ ssm/SSM/Core/Peripheral.hs | 31 +++++++++++----- ssm/SSM/Core/Peripheral/BasicBLE.hs | 42 ++++++++++++--------- ssm/SSM/Core/Peripheral/GPIO.hs | 28 +++++++++----- ssm/SSM/Core/Peripheral/Identity.hs | 18 ++++++--- ssm/SSM/Core/Peripheral/LED.hs | 26 ++++++++----- ssm/SSM/Core/Program.hs | 18 +++++---- ssm/SSM/Frontend/Compile.hs | 7 +++- ssm/SSM/Frontend/Syntax.hs | 3 +- ssm/SSM/Interpret/Internal.hs | 9 ++++- ssm/SSM/Interpret/Interpreter.hs | 12 ++++-- ssm/SSM/Interpret/Types.hs | 6 +-- ssm/SSM/Pretty.hs | 12 +++++- ssm/SSM/Pretty/Syntax.hs | 11 ++++-- 19 files changed, 196 insertions(+), 110 deletions(-) create mode 100644 ssm/SSM/Core/Backend.hs diff --git a/ssm/SSM/Backend/C/CodeGen.hs b/ssm/SSM/Backend/C/CodeGen.hs index f3c3c8bc..a2bcf838 100644 --- a/ssm/SSM/Backend/C/CodeGen.hs +++ b/ssm/SSM/Backend/C/CodeGen.hs @@ -8,7 +8,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE QuasiQuotes #-} - +{-# LANGUAGE DataKinds #-} module SSM.Backend.C.CodeGen ( compile_ ) where @@ -36,7 +36,7 @@ import qualified SSM.Interpret.Trace as T -- | Given a 'Program', returns a tuple containing the compiled program and -- a list of all `include` statements. -compile_ :: Program -> ([C.Definition], [C.Definition]) +compile_ :: Program C -> ([C.Definition], [C.Definition]) compile_ program = (compUnit, includes) where -- | The file to generate, minus include statements @@ -116,7 +116,7 @@ actm :: CIdent actm = "act" -- | Generate the entry point of a program - the first thing to be ran. -genInitProgram :: Program -> [C.Definition] +genInitProgram :: Program C -> [C.Definition] genInitProgram p = [cunit| int $id:initialize_program(void) { $items:(initPeripherals p) diff --git a/ssm/SSM/Backend/C/Compile.hs b/ssm/SSM/Backend/C/Compile.hs index 3ab99532..24bea9e6 100644 --- a/ssm/SSM/Backend/C/Compile.hs +++ b/ssm/SSM/Backend/C/Compile.hs @@ -1,17 +1,19 @@ -- | Interface module to the Backend.C subsystem. +{-# LANGUAGE DataKinds #-} module SSM.Backend.C.Compile ( compile ) where import SSM.Backend.C.CodeGen import SSM.Core.Program +import SSM.Core.Backend import Text.PrettyPrint.Mainland ( pretty ) import Text.PrettyPrint.Mainland.Class ( pprList ) -- | Compile a program from its Core.Syntax representation to a C String. -compile :: Program -> String +compile :: Program C -> String compile p = pretty 120 $ pprList compilationUnit where compilationUnit = includes ++ prg diff --git a/ssm/SSM/Backend/C/Peripheral.hs b/ssm/SSM/Backend/C/Peripheral.hs index a7e263fc..3a16472e 100644 --- a/ssm/SSM/Backend/C/Peripheral.hs +++ b/ssm/SSM/Backend/C/Peripheral.hs @@ -5,6 +5,7 @@ facilitate easier code generation. -} {-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} module SSM.Backend.C.Peripheral where import SSM.Core @@ -17,40 +18,42 @@ import qualified Language.C.Syntax as C {- | Get the global declarations made by a peripheral. Usually this will just be global references. -} -decls :: Peripheral -> [C.Definition] -decls (Peripheral a) = map declSingle $ declaredReferences a - where - declSingle :: Reference -> C.Definition - declSingle r = - [cedecl| $ty:(svt_ $ dereference $ refType r) $id:(refName r);|] +decls :: Peripheral C -> [C.Definition] +decls = undefined +-- decls (Peripheral a) = map declSingle $ declaredReferences a +-- where +-- declSingle :: Reference -> C.Definition +-- declSingle r = +-- [cedecl| $ty:(svt_ $ dereference $ refType r) $id:(refName r);|] {- | Get the statements that initializes this peripheral. These statements should be executed in the program initialization point, before the program actually runs. -} -maininit :: Peripheral -> [C.BlockItem] -maininit (Peripheral a) = concatMap compInitializer $ mainInitializers a - where - compInitializer :: Initializer -> [C.BlockItem] - compInitializer i = case i of - Independent ind -> case ind of - BLEEnable -> [[citem| enable_ble_stack(); |]] - Normal ref -> - let bt = dereference $ refType ref - init = initialize_ bt [cexp|&$id:(refName ref)|] - assign = assign_ bt [cexp|&$id:(refName ref)|] [cexp|0|] [cexp|0|] - in [citems| $exp:init; $exp:assign; |] - StaticInput si ref -> case si of - Switch id -> - [ [citem| $id:initialize_static_input_device((typename ssm_sv_t *) &$id:(refName ref).sv, $int:id);|] - ] - BLEScan -> - [ [citem| $id:initialize_static_input_ble_scan_device(&$id:(refName ref).sv);|] - ] +maininit :: Peripheral C -> [C.BlockItem] +maininit = undefined +-- maininit (Peripheral a) = concatMap compInitializer $ mainInitializers a +-- where +-- compInitializer :: Initializer -> [C.BlockItem] +-- compInitializer i = case i of +-- Independent ind -> case ind of +-- BLEEnable -> [[citem| enable_ble_stack(); |]] +-- Normal ref -> +-- let bt = dereference $ refType ref +-- init = initialize_ bt [cexp|&$id:(refName ref)|] +-- assign = assign_ bt [cexp|&$id:(refName ref)|] [cexp|0|] [cexp|0|] +-- in [citems| $exp:init; $exp:assign; |] +-- StaticInput si ref -> case si of +-- Switch id -> +-- [ [citem| $id:initialize_static_input_device((typename ssm_sv_t *) &$id:(refName ref).sv, $int:id);|] +-- ] +-- BLEScan -> +-- [ [citem| $id:initialize_static_input_ble_scan_device(&$id:(refName ref).sv);|] +-- ] -- | Return all the statements that initialize the peripherals statically -initPeripherals :: Program -> [C.BlockItem] +initPeripherals :: Program C -> [C.BlockItem] initPeripherals p = concatMap maininit $ peripherals p {- | Return all the declarations of static, global variables associated with the peripherals of a program. -} -declarePeripherals :: Program -> [C.Definition] +declarePeripherals :: Program C -> [C.Definition] declarePeripherals p = concatMap decls $ peripherals p diff --git a/ssm/SSM/Compile.hs b/ssm/SSM/Compile.hs index 2d94acc3..33a13ff9 100644 --- a/ssm/SSM/Compile.hs +++ b/ssm/SSM/Compile.hs @@ -1,4 +1,6 @@ -- | SSM EDSL compilation interface, for compiling to C code. +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} module SSM.Compile ( SSMProgram(..) , toC @@ -16,22 +18,23 @@ import System.Exit ( ExitCode(..) import SSM.Backend.C.Compile import SSM.Core.Program +import SSM.Core.Backend -- | Compile a program to a C-file. -- -- TODO: This can fail, so it should return Either CompileError String. -toC :: SSMProgram a => a -> String +toC :: SSMProgram C a => a -> String toC = compile . toProgram -- | Compile a program and write it to the specified path. -compileFile :: SSMProgram a => FilePath -> a -> IO () +compileFile :: SSMProgram C a => FilePath -> a -> IO () compileFile fp = writeFile fp . toC -- | Create command-line compilation interface for specific program. -- -- Includes parameter for specifying a default filepath. If this is not needed, -- use @compileCli_@. -compileCli :: SSMProgram a => Maybe FilePath -> a -> IO () +compileCli :: SSMProgram C a => Maybe FilePath -> a -> IO () compileCli defaultPath program = do args <- getArgs path <- getFilePath args @@ -58,5 +61,5 @@ compileCli defaultPath program = do exitWith $ ExitFailure 1 -- | Create command-line compilation interface for specific program. -compileCli_ :: SSMProgram a => a -> IO () +compileCli_ :: SSMProgram C a => a -> IO () compileCli_ = compileCli Nothing diff --git a/ssm/SSM/Core.hs b/ssm/SSM/Core.hs index 43f645c5..0dfa6428 100644 --- a/ssm/SSM/Core.hs +++ b/ssm/SSM/Core.hs @@ -10,6 +10,7 @@ module SSM.Core , module SSM.Core.Reference , module SSM.Core.Syntax , module SSM.Core.Type + , module SSM.Core.Backend ) where import SSM.Core.Ident @@ -22,3 +23,4 @@ import SSM.Core.Program import SSM.Core.Reference import SSM.Core.Syntax import SSM.Core.Type +import SSM.Core.Backend diff --git a/ssm/SSM/Core/Backend.hs b/ssm/SSM/Core/Backend.hs new file mode 100644 index 00000000..4e240c21 --- /dev/null +++ b/ssm/SSM/Core/Backend.hs @@ -0,0 +1,3 @@ +module SSM.Core.Backend where + +data C diff --git a/ssm/SSM/Core/Peripheral.hs b/ssm/SSM/Core/Peripheral.hs index c5621bc9..46a33719 100644 --- a/ssm/SSM/Core/Peripheral.hs +++ b/ssm/SSM/Core/Peripheral.hs @@ -7,6 +7,9 @@ core representation. An alternative would be to have the core representation use \"C-compileable\" constraint instead, but then we would tie the core representation to the fact that there exists a C backend. -} {-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DataKinds #-} module SSM.Core.Peripheral ( Peripheral(..) , Initializer(..) @@ -22,17 +25,17 @@ import Data.Word ( Word8 ) import SSM.Core.Reference ( Reference ) -- | Type of peripherals -data Peripheral where +data Peripheral backend where -- | A `Peripheral` holds an object that has an instance of `IsPeripheral` - Peripheral ::(IsPeripheral a, Show a, Read a, Eq a) => a -> Peripheral + Peripheral ::(IsPeripheral backend a, Show a, Read a, Eq a) => a -> Peripheral backend -instance Show Peripheral where +instance Show (Peripheral backend) where show (Peripheral p) = show p -instance Read Peripheral where +instance Read (Peripheral backend) where readsPrec = undefined -instance Eq Peripheral where +instance Eq (Peripheral backend) where (==) = undefined {- | Different types of peripherals might require different kinds of initialization. @@ -68,8 +71,16 @@ data BLEHandler | ScanControl deriving (Show, Read, Eq) --- | Class of types that are peripherals -class IsPeripheral a where - declaredReferences :: a -> [Reference] -- ^ Globally declared references - -- | Initialization to perform before program startup - mainInitializers :: a -> [Initializer] +-- -- | Class of types that are peripherals +-- class IsPeripheral a where +-- declaredReferences :: a -> [Reference] -- ^ Globally declared references +-- -- | Initialization to perform before program startup +-- mainInitializers :: a -> [Initializer] + +class IsPeripheral backend a where + type Definition backend + type Initialization backend + + declaredReferences :: proxy backend -> a -> [Reference] + globalDeclarations :: proxy backend -> a -> [Definition backend] + staticInitialization :: proxy backend -> a -> [Initialization backend] diff --git a/ssm/SSM/Core/Peripheral/BasicBLE.hs b/ssm/SSM/Core/Peripheral/BasicBLE.hs index 55624b9c..f528fe02 100644 --- a/ssm/SSM/Core/Peripheral/BasicBLE.hs +++ b/ssm/SSM/Core/Peripheral/BasicBLE.hs @@ -11,11 +11,15 @@ This module is intended to act as a simple example of what we can do. Our ambiti add support for the entire BLE stack. -} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} module SSM.Core.Peripheral.BasicBLE where import SSM.Core.Ident import SSM.Core.Reference import SSM.Core.Type +import SSM.Core.Backend import SSM.Core.Peripheral @@ -28,27 +32,31 @@ data BasicBLE = BasicBLE } deriving (Show, Read, Eq) -instance IsPeripheral BasicBLE where - declaredReferences = basicBLERefs +instance IsPeripheral C BasicBLE where + type Definition C = () + type Initialization C = () - mainInitializers ble = concat [enable, normalInits, specials] - where - (broadcast : broadcastControl : scan : scanControl : _) = - basicBLERefs ble +-- instance IsPeripheral BasicBLE where +-- declaredReferences = basicBLERefs - enable = [ Independent BLEEnable ] +-- mainInitializers ble = concat [enable, normalInits, specials] +-- where +-- (broadcast : broadcastControl : scan : scanControl : _) = +-- basicBLERefs ble - -- initialize the references like you normally initialize them - normalInits = - [ Normal broadcast - , Normal broadcastControl - , Normal scan - , Normal scanControl - ] +-- enable = [ Independent BLEEnable ] - -- perform the BLE input-specific initializations - specials = - [ StaticInput BLEScan scan ] +-- -- initialize the references like you normally initialize them +-- normalInits = +-- [ Normal broadcast +-- , Normal broadcastControl +-- , Normal scan +-- , Normal scanControl +-- ] + +-- -- perform the BLE input-specific initializations +-- specials = +-- [ StaticInput BLEScan scan ] basicBLERefs :: BasicBLE -> [Reference] basicBLERefs ble = map diff --git a/ssm/SSM/Core/Peripheral/GPIO.hs b/ssm/SSM/Core/Peripheral/GPIO.hs index 725ff265..4537d4f9 100644 --- a/ssm/SSM/Core/Peripheral/GPIO.hs +++ b/ssm/SSM/Core/Peripheral/GPIO.hs @@ -12,6 +12,9 @@ code is being generated and the interpreter is ran, this is the datatype that wi describe which pins are being used, what type of pin they are and what names they were assigned. Regardless of how the frontend language lets the programmer interact with GPIO, this describes how the core syntax interacts with GPIO. -} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} module SSM.Core.Peripheral.GPIO ( GPIOPeripheral , switchpins @@ -30,6 +33,7 @@ import SSM.Core.Reference ( makeStaticRef ) import SSM.Core.Type ( Type(TBool) , mkReference ) +import SSM.Core.Backend -- | Datatype that describes which GPIO pins are used. data GPIOPeripheral = GPIOPeripheral @@ -39,17 +43,21 @@ data GPIOPeripheral = GPIOPeripheral } deriving (Show, Read, Eq) --- | IsPeripheral instance for `GPIOPeripheral`, so that we can compile peripherals. -instance IsPeripheral GPIOPeripheral where - declaredReferences gpio = - map (flip makeStaticRef (mkReference TBool) . snd) $ switchpins gpio +instance IsPeripheral C GPIOPeripheral where + type Definition C = () + type Initialization C = () - mainInitializers gpio = concatMap initializeSingle $ switchpins gpio - where - initializeSingle :: (Word8, Ident) -> [Initializer] - initializeSingle (i, id) = - let ref = makeStaticRef id $ mkReference TBool - in [Normal ref, StaticInput (Switch i) ref] +-- -- | IsPeripheral instance for `GPIOPeripheral`, so that we can compile peripherals. +-- instance IsPeripheral GPIOPeripheral where +-- declaredReferences gpio = +-- map (flip makeStaticRef (mkReference TBool) . snd) $ switchpins gpio + +-- mainInitializers gpio = concatMap initializeSingle $ switchpins gpio +-- where +-- initializeSingle :: (Word8, Ident) -> [Initializer] +-- initializeSingle (i, id) = +-- let ref = makeStaticRef id $ mkReference TBool +-- in [Normal ref, StaticInput (Switch i) ref] {- | Create an initial GPIO Peripheral description. In the initial description, no GPIO pins are used. -} diff --git a/ssm/SSM/Core/Peripheral/Identity.hs b/ssm/SSM/Core/Peripheral/Identity.hs index 3cda8e2a..2548845b 100644 --- a/ssm/SSM/Core/Peripheral/Identity.hs +++ b/ssm/SSM/Core/Peripheral/Identity.hs @@ -1,12 +1,16 @@ {- | This module implements an identity peripheral. This is a peripheral that has no side effects. It is suitable for declaring references that should exist in the global scope rather than in the context of an activation record. -} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} module SSM.Core.Peripheral.Identity where import SSM.Core.Ident import SSM.Core.Peripheral import SSM.Core.Reference import SSM.Core.Type +import SSM.Core.Backend import qualified Data.Map as Map @@ -18,11 +22,15 @@ data IdentityPeripheral = IdentityPeripheral } deriving (Show, Read, Eq) -instance IsPeripheral IdentityPeripheral where - declaredReferences ip = - map (uncurry makeStaticRef) $ Map.toList $ identitySVs ip - mainInitializers ip = - map (Normal . uncurry makeStaticRef) $ Map.toList $ identitySVs ip +instance IsPeripheral C IdentityPeripheral where + type Definition C = () + type Initialization C = () + +-- instance IsPeripheral IdentityPeripheral where +-- declaredReferences ip = +-- map (uncurry makeStaticRef) $ Map.toList $ identitySVs ip +-- mainInitializers ip = +-- map (Normal . uncurry makeStaticRef) $ Map.toList $ identitySVs ip emptyIdentityPeripheral :: IdentityPeripheral emptyIdentityPeripheral = IdentityPeripheral Map.empty diff --git a/ssm/SSM/Core/Peripheral/LED.hs b/ssm/SSM/Core/Peripheral/LED.hs index caa4e752..8f469f5e 100644 --- a/ssm/SSM/Core/Peripheral/LED.hs +++ b/ssm/SSM/Core/Peripheral/LED.hs @@ -1,4 +1,7 @@ {- | Core representation of LED peripherals. -} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} module SSM.Core.Peripheral.LED where import SSM.Core.Ident ( Ident ) @@ -9,6 +12,7 @@ import SSM.Core.Reference ( makeStaticRef ) import SSM.Core.Type ( Type(TBool) , mkReference ) +import SSM.Core.Backend import qualified Data.Map as Map import Data.Word ( Word8 ) @@ -20,16 +24,20 @@ data LEDPeripheral = LEDPeripheral } deriving (Eq, Show, Read) --- | `IsPeripheral` instance for `LEDPeripheral`, so that we can compile `LEDPeripheral`s. -instance IsPeripheral LEDPeripheral where - declaredReferences lp = - map (flip makeStaticRef (mkReference TBool) . snd) $ onoffLEDs lp +instance IsPeripheral C LEDPeripheral where + type Definition C = () + type Initialization C = () - mainInitializers lp = concatMap initializeSingle $ onoffLEDs lp - where - initializeSingle :: (Word8, Ident) -> [Initializer] - initializeSingle (_, id) = - let ref = makeStaticRef id $ mkReference TBool in [Normal ref] +-- -- | `IsPeripheral` instance for `LEDPeripheral`, so that we can compile `LEDPeripheral`s. +-- instance IsPeripheral LEDPeripheral where +-- declaredReferences lp = +-- map (flip makeStaticRef (mkReference TBool) . snd) $ onoffLEDs lp + +-- mainInitializers lp = concatMap initializeSingle $ onoffLEDs lp +-- where +-- initializeSingle :: (Word8, Ident) -> [Initializer] +-- initializeSingle (_, id) = +-- let ref = makeStaticRef id $ mkReference TBool in [Normal ref] -- | Create an initial LED peripheral emptyLEDPeripheral :: LEDPeripheral diff --git a/ssm/SSM/Core/Program.hs b/ssm/SSM/Core/Program.hs index 43536190..d57deca4 100644 --- a/ssm/SSM/Core/Program.hs +++ b/ssm/SSM/Core/Program.hs @@ -1,6 +1,10 @@ {- | This module implements the `Procedure` type and the `Program` type, which represents the kind of procedures we can have in an SSM program and how an entire SSM program is represented. -} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} module SSM.Core.Program ( Procedure(..) , QueueContent(..) @@ -42,7 +46,7 @@ data QueueContent {- | Get the identifier of the SSM procedure that is scheduled at the start of a SSM program -} -entry :: Program -> Ident +entry :: Program backend -> Ident entry p = getInitialProcedure' $ initialQueueContent p where getInitialProcedure' :: [QueueContent] -> Ident @@ -55,26 +59,26 @@ entry p = getInitialProcedure' $ initialQueueContent p getInitialProcedure' (_ : xs) = getInitialProcedure' xs -- | Program definition -data Program = Program +data Program backend = Program { -- | The things that should be scheduled when the program starts initialQueueContent :: [QueueContent] -- | Map that associates procedure names with their definitions. , funs :: Map.Map Ident Procedure -- | Name and type of references that exist in the global scope. -- | Any peripherals used by the program - , peripherals :: [Peripheral] + , peripherals :: [Peripheral backend] } deriving (Show, Read) -instance Eq Program where +instance Eq (Program backend) where p1 == p2 = initialQueueContent p1 == initialQueueContent p2 && funs p1 == funs p2 -- | Class of types that can be converted to a `Program`. -class SSMProgram a where +class SSMProgram backend a where -- | This function takes an @a@ and converts it to a `Program` - toProgram :: a -> Program + toProgram :: a -> Program backend -- | Dummy instance for `Program`. Does nothing -- defined to be the identity function. -instance SSMProgram Program where +instance SSMProgram backend (Program backend) where toProgram = id diff --git a/ssm/SSM/Frontend/Compile.hs b/ssm/SSM/Frontend/Compile.hs index 74fe59b9..d82fcf78 100644 --- a/ssm/SSM/Frontend/Compile.hs +++ b/ssm/SSM/Frontend/Compile.hs @@ -4,6 +4,8 @@ should be visible in the entire program, or it could be IO peripherals. -} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} module SSM.Frontend.Compile where import SSM.Core as SC @@ -43,7 +45,10 @@ instance IntState CompileSt where {- | If you have a @Compile (SSM ())@ you have probably set up some global variables using the @Compile@ monad. This instance makes sure that you can compile and interpret something that is a program with such global variables. -} -instance SSMProgram (Compile ()) where +instance ( IsPeripheral backend GPIOPeripheral + , IsPeripheral backend LEDPeripheral + , IsPeripheral backend IdentityPeripheral + , IsPeripheral backend BasicBLE) => SSMProgram backend (Compile ()) where toProgram (Compile p) = let (a, s) = runState p diff --git a/ssm/SSM/Frontend/Syntax.hs b/ssm/SSM/Frontend/Syntax.hs index a0a2450c..affd8234 100644 --- a/ssm/SSM/Frontend/Syntax.hs +++ b/ssm/SSM/Frontend/Syntax.hs @@ -12,6 +12,7 @@ procedure definition (as a monadic computation). -} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} module SSM.Frontend.Syntax ( -- * Types Type(..) @@ -176,7 +177,7 @@ getProcedureName _ = error "not a procedure" {- | Instance of `SSM.Core.Syntax.SSMProgram`, so that the compiler knows how to turn the frontend representation into something that it can generate code for. Just compiling a program does not introduce any global variables. -} -instance SP.SSMProgram (SSM ()) where +instance SP.SSMProgram backend (SSM ()) where toProgram p = let (n, f) = transpile p in SP.Program [SP.SSMProcedure n []] f [] diff --git a/ssm/SSM/Interpret/Internal.hs b/ssm/SSM/Interpret/Internal.hs index dcf266c5..7f9b38b5 100644 --- a/ssm/SSM/Interpret/Internal.hs +++ b/ssm/SSM/Interpret/Internal.hs @@ -1,4 +1,8 @@ -- | Helper functions and auxiliary definitions the interpreter uses. +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} module SSM.Interpret.Internal ( -- * Interpretation monad, re-exported from "SSM.Interpret.Types". Interp @@ -94,6 +98,7 @@ import Data.STRef.Lazy ( STRef import Data.Word ( Word64 , Word8 ) +import Data.Proxy import SSM.Util.HughesList ( toHughes ) import SSM.Util.Operators ( (<#>) ) @@ -105,10 +110,10 @@ import SSM.Interpret.Types {-********** Main interpret function helpers **********-} -- | Create initial global variable storage -globals :: Program -> ST s (Map.Map Ident (Var s)) +globals :: forall backend s . Program backend -> ST s (Map.Map Ident (Var s)) globals p = do vars <- forM (peripherals p) $ \(Peripheral p) -> do - forM (declaredReferences p) $ \ref -> do + forM (declaredReferences (Proxy @backend) p) $ \ref -> do let initval = defaultValue (dereference (refType ref)) v <- newVar' initval 0 return (refIdent ref, v) diff --git a/ssm/SSM/Interpret/Interpreter.hs b/ssm/SSM/Interpret/Interpreter.hs index 03992b7f..106daa77 100644 --- a/ssm/SSM/Interpret/Interpreter.hs +++ b/ssm/SSM/Interpret/Interpreter.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module SSM.Interpret.Interpreter ( interpret , InterpretConfig(..) @@ -23,8 +27,8 @@ import Control.Monad.State.Lazy import Control.Monad.Writer.Lazy -- | Interpret an SSM program with the default configuration. -interpret_ :: SSMProgram p => p -> T.Trace -interpret_ = interpret def +interpret_ :: forall backend p . SSMProgram backend p => p -> T.Trace +interpret_ = interpret @backend def {-| Interpret an SSM program. @@ -36,9 +40,9 @@ issue. What you do to get the output in that case is to ask it for a finite amou of output, such as @take 10000 (interpret program)@. After evaluating enough to give you @10000@ trace items, it will not evaluate more. -} -interpret :: SSMProgram p => InterpretConfig -> p -> T.Trace +interpret :: forall backend p . SSMProgram backend p => InterpretConfig -> p -> T.Trace interpret config program = runST $ do - let p = toProgram program + let p = toProgram @backend program -- Fetch procedure body fun <- case Map.lookup (entry p) (funs p) of Just p' -> return p' diff --git a/ssm/SSM/Interpret/Types.hs b/ssm/SSM/Interpret/Types.hs index a23ff0d0..9587ba9e 100644 --- a/ssm/SSM/Interpret/Types.hs +++ b/ssm/SSM/Interpret/Types.hs @@ -108,7 +108,7 @@ data Proc s = Proc -- | Create the initial process. mkProc :: InterpretConfig -- ^ Configuration - -> Program -- ^ Program + -> Program backend -- ^ Program -> Procedure -- ^ Entry point -> Proc s mkProc conf p fun = Proc { procName = identName $ entry p @@ -176,7 +176,7 @@ data St s = St -- | Create initial state for interpreter. initState :: InterpretConfig -- ^ Configuration - -> Program -- ^ Program + -> Program backend -- ^ Program -> Word64 -- ^ Start time -> Map.Map Ident (Var s) -- ^ Global references -> Proc s -- ^ Entry point @@ -201,7 +201,7 @@ initState conf p startTime glob entryPoint = St @(name, variable)@ pairs that make up the references in the variable storage that appear as input parameters to the program. -} -getReferences :: Program -> Map.Map Ident (Var s) -> [(Ident, Var s)] +getReferences :: Program backend -> Map.Map Ident (Var s) -> [(Ident, Var s)] getReferences p m = case Map.lookup (entry p) (funs p) of Just pr -> let refparams = filter (isReference . snd) $ arguments pr diff --git a/ssm/SSM/Pretty.hs b/ssm/SSM/Pretty.hs index b5dbf085..24e626f7 100644 --- a/ssm/SSM/Pretty.hs +++ b/ssm/SSM/Pretty.hs @@ -56,6 +56,13 @@ fun1(*uint64 ref2, *int ref4, *bool ref5, *int64 ref8, *int64 ref9) { @ which is at least slightly more readable.-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} module SSM.Pretty ( -- * Prettyprint SSM programs prettySSM @@ -66,6 +73,7 @@ module SSM.Pretty --import SSM.Core.Syntax ( SSM ) import SSM.Core.Program import SSM.Pretty.Syntax ( prettyProgram ) +import SSM.Core.Backend -prettySSM :: SSMProgram a => a -> String -prettySSM = prettyProgram . toProgram +prettySSM :: forall backend a . SSMProgram backend a => a -> String +prettySSM = prettyProgram . toProgram @backend diff --git a/ssm/SSM/Pretty/Syntax.hs b/ssm/SSM/Pretty/Syntax.hs index 9d4fe987..f6bdf417 100644 --- a/ssm/SSM/Pretty/Syntax.hs +++ b/ssm/SSM/Pretty/Syntax.hs @@ -1,8 +1,11 @@ {-| This module exposes a pretty printer of programs. -} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} module SSM.Pretty.Syntax ( prettyProgram ) where import qualified Data.Map as Map import Data.List +import Data.Proxy import Control.Monad.Reader ( ReaderT(runReaderT), MonadReader(local, ask) ) @@ -36,12 +39,12 @@ intercalateM ma (x:y:xs) = do {- | Pretty print a program. There is no control of line width currently. If your program contains many nested if's or something, they will be turned into quite wide statements. -} -prettyProgram :: Program -> String +prettyProgram :: Program backend -> String prettyProgram ssm = let wr = runReaderT (prettyProgram' ssm) 0 h = execWriter wr in unlines $ fromHughes h -prettyProgram' :: Program -> PP () +prettyProgram' :: Program backend -> PP () prettyProgram' p = do emit "initial ready-queue content:" mapM_ (indent . emit . prettyQueueContent) (initialQueueContent p) @@ -78,9 +81,9 @@ prettyReferenceDecls :: [Reference] -> PP () prettyReferenceDecls xs = flip mapM_ xs $ \ref -> indent $ emit $ concat [prettyType (refType ref), " ", refName ref] -prettyPeripheralDeclarations :: Peripheral -> PP () +prettyPeripheralDeclarations :: forall backend . Peripheral backend -> PP () prettyPeripheralDeclarations (Peripheral p) = - prettyReferenceDecls $ declaredReferences p + prettyReferenceDecls $ declaredReferences (Proxy @backend) p prettyProcedure :: Procedure -> PP () prettyProcedure p = do From c617454ef2c685f928f3668dd9fb44e67a569330 Mon Sep 17 00:00:00 2001 From: Robert Krook Date: Tue, 30 Nov 2021 15:32:32 +0100 Subject: [PATCH 02/16] testing out LED instances --- ssm.cabal | 1 + ssm/SSM/Core/Peripheral/LED.hs | 15 +++++++++++++-- 2 files changed, 14 insertions(+), 2 deletions(-) diff --git a/ssm.cabal b/ssm.cabal index 5a0f6701..2a57c2ad 100644 --- a/ssm.cabal +++ b/ssm.cabal @@ -32,6 +32,7 @@ library SSM.Backend.C.Types SSM.Compile SSM.Core + SSM.Core.Backend SSM.Core.Ident SSM.Core.Peripheral SSM.Core.Peripheral.BasicBLE diff --git a/ssm/SSM/Core/Peripheral/LED.hs b/ssm/SSM/Core/Peripheral/LED.hs index 8f469f5e..faf50074 100644 --- a/ssm/SSM/Core/Peripheral/LED.hs +++ b/ssm/SSM/Core/Peripheral/LED.hs @@ -17,6 +17,9 @@ import SSM.Core.Backend import qualified Data.Map as Map import Data.Word ( Word8 ) +import Language.C.Quote.GCC +import qualified Language.C.Syntax as C + -- | LED peripherals data LEDPeripheral = LEDPeripheral { -- | Associate LED IDs with reference identifiers @@ -25,8 +28,16 @@ data LEDPeripheral = LEDPeripheral deriving (Eq, Show, Read) instance IsPeripheral C LEDPeripheral where - type Definition C = () - type Initialization C = () + type Definition C = [C.InitGroup] + type Initialization C = [C.BlockItem] + + declaredReferences _ lp = + map (flip makeStaticRef (mkReference TBool) . snd) $ onoffLEDs lp + + globalDeclarations _ _ = [] + + staticInitialization _ lp = flip map (onoffLEDs lp) $ \(_, id) -> + undefined -- -- | `IsPeripheral` instance for `LEDPeripheral`, so that we can compile `LEDPeripheral`s. -- instance IsPeripheral LEDPeripheral where From 1f1d1805cb52a88bd4b8dc4742bcf17b3cb260b3 Mon Sep 17 00:00:00 2001 From: Robert Krook Date: Wed, 8 Dec 2021 15:22:58 +0100 Subject: [PATCH 03/16] Begun a big restructuring project. This might be a very good fit, with the exception of the handers not being of type SSM () now. But let's cross that bridge once this whole refactoring is complete. --- ssm.cabal | 1 + ssm/SSM/Backend/C/CodeGen.hs | 42 +++----- ssm/SSM/Backend/C/Identifiers.hs | 38 +++++++ ssm/SSM/Core/Backend.hs | 12 +++ ssm/SSM/Core/Ident.hs | 2 +- ssm/SSM/Core/Peripheral.hs | 27 +++-- ssm/SSM/Core/Peripheral/BasicBLE.hs | 9 +- ssm/SSM/Core/Peripheral/GPIO.hs | 9 +- ssm/SSM/Core/Peripheral/Identity.hs | 9 +- ssm/SSM/Core/Peripheral/LED.hs | 21 ++-- ssm/SSM/Core/Program.hs | 24 +++-- ssm/SSM/Core/Reference.hs | 2 +- ssm/SSM/Core/Syntax.hs | 12 +-- ssm/SSM/Core/Type.hs | 2 +- ssm/SSM/FreqGen.hs | 2 +- ssm/SSM/Freqmime.hs | 18 ++-- ssm/SSM/FrequencyMime.hs | 4 +- ssm/SSM/Frontend/Compile.hs | 92 +++++++---------- ssm/SSM/Frontend/NewPeripheral/GPIO.hs | 125 ++++++++++++++++++++++++ ssm/SSM/Frontend/Peripheral/BasicBLE.hs | 15 +-- ssm/SSM/Frontend/Peripheral/GPIO.hs | 6 +- ssm/SSM/Frontend/Peripheral/Identity.hs | 6 +- ssm/SSM/Frontend/Peripheral/LED.hs | 10 +- ssm/SSM/Frontend/Syntax.hs | 22 +---- ssm/SSM/Interpret/Trace.hs | 4 +- ssm/SSM/Pretty/Syntax.hs | 41 ++++---- 26 files changed, 354 insertions(+), 201 deletions(-) create mode 100644 ssm/SSM/Frontend/NewPeripheral/GPIO.hs diff --git a/ssm.cabal b/ssm.cabal index 2a57c2ad..4ef7bfbd 100644 --- a/ssm.cabal +++ b/ssm.cabal @@ -50,6 +50,7 @@ library SSM.Frontend.Compile SSM.Frontend.Exp SSM.Frontend.Language + SSM.Frontend.NewPeripheral.GPIO SSM.Frontend.Peripheral.BasicBLE SSM.Frontend.Peripheral.GPIO SSM.Frontend.Peripheral.Identity diff --git a/ssm/SSM/Backend/C/CodeGen.hs b/ssm/SSM/Backend/C/CodeGen.hs index a2bcf838..303ad769 100644 --- a/ssm/SSM/Backend/C/CodeGen.hs +++ b/ssm/SSM/Backend/C/CodeGen.hs @@ -127,18 +127,18 @@ genInitProgram p = [cunit| |] where -- | Create statements for scheduling the initial ready-queue content - initialForks :: [QueueContent] -> [C.BlockItem] + initialForks :: [QueueContent C] -> [C.BlockItem] initialForks ips = zipWith initialFork (pdeps (length ips) - [cexp|SSM_ROOT_PRIORITY|] - [cexp|SSM_ROOT_DEPTH|]) + priority_at_root + depth_at_root) ips where -- | Create the schedule statement for a single schedulable thing - initialFork :: (C.Exp, C.Exp) -> QueueContent -> C.BlockItem + initialFork :: (C.Exp, C.Exp) -> QueueContent C -> C.BlockItem initialFork (priority, depth) (SSMProcedure id args) = [citem| $id:fork($id:(enter_ (identName id))( &$id:top_parent , $exp:priority @@ -146,14 +146,15 @@ genInitProgram p = [cunit| , $args:(map cargs args) ) ); |] - initialFork (priority, depth) (Handler h) = - [citem|$id:fork($id:(resolveNameOfHandler h) - ( &$id:top_parent - , $exp:priority - , $exp:depth - , $args:(argsOfHandler h) - ) - );|] + -- initialFork (priority, depth) (Handler h) = + -- [citem|$id:fork($id:(resolveNameOfHandler h) + -- ( &$id:top_parent + -- , $exp:priority + -- , $exp:depth + -- , $args:(argsOfHandler h) + -- ) + -- );|] + initialFork (priority, depth) (Handler f) = error "fixme" -- | Take a handler and return a list of arguments to it argsOfHandler :: Handler -> [C.Exp] @@ -172,23 +173,6 @@ genInitProgram p = [cunit| cargs (Right r@(Dynamic _)) = error "Why does StaticOutputHandler refer to a non-static var?" x = refName -{- | Create C expressions that represent the new priorities and depths of the -initially scheduled processes. -} -pdeps :: Int -> C.Exp -> C.Exp -> [(C.Exp, C.Exp)] -pdeps cs currentPrio currentDepth = - [ let prio = [cexp|$exp:currentPrio + ($int:(i-1) * (1 << $exp:depth))|] - depth = [cexp|$exp:currentDepth - $exp:(depthSub cs)|] - in (prio, depth) - | i <- [1..cs] - ] - -{- | Calculate the subexpression that should be subtracted from the current depth -in order to achieve the new depth of the processes to fork. - -The argument is the number of new processes that are being forked. -} -depthSub :: Int -> C.Exp -depthSub k = [cexp|$int:(ceiling $ logBase (2 :: Double) $ fromIntegral $ k :: Int) |] - -- | Generate include statements, to be placed at the top of the generated C. genPreamble :: [C.Definition] genPreamble = [cunit| diff --git a/ssm/SSM/Backend/C/Identifiers.hs b/ssm/SSM/Backend/C/Identifiers.hs index 58d04fcb..266a5bc4 100644 --- a/ssm/SSM/Backend/C/Identifiers.hs +++ b/ssm/SSM/Backend/C/Identifiers.hs @@ -29,6 +29,11 @@ module SSM.Backend.C.Identifiers , exhausted_priority , now , never + , pdep + , pdeps + , depthSub + , depth_at_root + , priority_at_root -- * Type names recognized by the the C runtime system. , time_t @@ -175,6 +180,39 @@ throw = "SSM_THROW" exhausted_priority :: C.Exp exhausted_priority = [cexp|SSM_EXHAUSTED_PRIORITY|] +{- | Create C expressions that represent the new priorities and depths of the +initially scheduled processes. -} +-- pdeps :: Int -> C.Exp -> C.Exp -> [(C.Exp, C.Exp)] +-- pdeps cs currentPrio currentDepth = +-- [ let prio = [cexp|$exp:currentPrio + ($int:(i-1) * (1 << $exp:depth))|] +-- depth = [cexp|$exp:currentDepth - $exp:(depthSub cs)|] +-- in (prio, depth) +-- | i <- [1..cs] +-- ] + +pdeps :: Int -> C.Exp -> C.Exp -> [(C.Exp, C.Exp)] +pdeps cs currentPrio currentDepth = + map (\k -> pdep k cs currentPrio currentDepth) [1..cs] + +pdep :: Int -> Int -> C.Exp -> C.Exp -> (C.Exp, C.Exp) +pdep k cs currentPrio currentDepth = + let prio = [cexp|$exp:currentPrio + ($int:(k-1) * (1 << $exp:depth))|] + depth = [cexp|$exp:currentDepth - $exp:(depthSub cs)|] + in (prio, depth) + +{- | Calculate the subexpression that should be subtracted from the current depth +in order to achieve the new depth of the processes to fork. + +The argument is the number of new processes that are being forked. -} +depthSub :: Int -> C.Exp +depthSub k = [cexp|$int:(ceiling $ logBase (2 :: Double) $ fromIntegral $ k :: Int) |] + +depth_at_root :: C.Exp +depth_at_root = [cexp|SSM_ROOT_DEPTH|] + +priority_at_root :: C.Exp +priority_at_root = [cexp|SSM_ROOT_PRIORITY|] + -- | C type that represents model time time_t :: C.Type time_t = [cty|typename ssm_time_t|] diff --git a/ssm/SSM/Core/Backend.hs b/ssm/SSM/Core/Backend.hs index 4e240c21..978533b2 100644 --- a/ssm/SSM/Core/Backend.hs +++ b/ssm/SSM/Core/Backend.hs @@ -1,3 +1,15 @@ +{-# LANGUAGE TypeFamilies #-} module SSM.Core.Backend where +import qualified Language.C.Syntax as C + data C + +type family Definition backend where + Definition C = C.Definition + +type family Initialization backend where + Initialization C = C.BlockItem + +type family Schedule backend where + Schedule C = C.BlockItem diff --git a/ssm/SSM/Core/Ident.hs b/ssm/SSM/Core/Ident.hs index 82ea03cd..587b83ac 100644 --- a/ssm/SSM/Core/Ident.hs +++ b/ssm/SSM/Core/Ident.hs @@ -12,7 +12,7 @@ data Ident = Ident { identName :: String -- ^ Identifiers has a name , identSrcInfo :: Maybe SrcInformation -- ^ And possibly some source information } - deriving (Show, Read) + deriving (Show) makeIdent :: String -> Ident makeIdent str = Ident str Nothing diff --git a/ssm/SSM/Core/Peripheral.hs b/ssm/SSM/Core/Peripheral.hs index 46a33719..71a27902 100644 --- a/ssm/SSM/Core/Peripheral.hs +++ b/ssm/SSM/Core/Peripheral.hs @@ -10,6 +10,8 @@ the fact that there exists a C backend. -} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} module SSM.Core.Peripheral ( Peripheral(..) , Initializer(..) @@ -23,18 +25,18 @@ module SSM.Core.Peripheral import Data.Word ( Word8 ) import SSM.Core.Reference ( Reference ) +import SSM.Core.Type ( Type ) +import SSM.Core.Ident ( Ident ) +import SSM.Core.Backend -- | Type of peripherals data Peripheral backend where -- | A `Peripheral` holds an object that has an instance of `IsPeripheral` - Peripheral ::(IsPeripheral backend a, Show a, Read a, Eq a) => a -> Peripheral backend + Peripheral :: forall backend a . (IsPeripheral backend a, Show a, Eq a) => a -> Peripheral backend instance Show (Peripheral backend) where show (Peripheral p) = show p -instance Read (Peripheral backend) where - readsPrec = undefined - instance Eq (Peripheral backend) where (==) = undefined @@ -58,18 +60,18 @@ data StaticInputVariant = Switch Word8 -- ^ Switch GPIO data Handler -- = StaticOutputHandler Reference Word8 -- ^ Static output handlers (LED? only?) = Output StaticOutputVariant Reference - deriving (Show, Read, Eq) + deriving (Show, Eq) data StaticOutputVariant = LED Word8 | BLE BLEHandler - deriving (Show, Read, Eq) + deriving (Show, Eq) data BLEHandler = Broadcast | BroadcastControl | ScanControl - deriving (Show, Read, Eq) + deriving (Show, Eq) -- -- | Class of types that are peripherals -- class IsPeripheral a where @@ -78,9 +80,14 @@ data BLEHandler -- mainInitializers :: a -> [Initializer] class IsPeripheral backend a where - type Definition backend - type Initialization backend - + declareReference :: proxy backend -> Type -> Ident -> Word8 -> a -> a declaredReferences :: proxy backend -> a -> [Reference] globalDeclarations :: proxy backend -> a -> [Definition backend] staticInitialization :: proxy backend -> a -> [Initialization backend] + +instance IsPeripheral backend (Peripheral backend) where + declareReference proxy t id i (Peripheral p) = + Peripheral $ declareReference proxy t id i p + declaredReferences proxy (Peripheral p) = declaredReferences proxy p + globalDeclarations proxy (Peripheral p) = globalDeclarations proxy p + staticInitialization proxy (Peripheral p) = staticInitialization proxy p diff --git a/ssm/SSM/Core/Peripheral/BasicBLE.hs b/ssm/SSM/Core/Peripheral/BasicBLE.hs index f528fe02..5f327b91 100644 --- a/ssm/SSM/Core/Peripheral/BasicBLE.hs +++ b/ssm/SSM/Core/Peripheral/BasicBLE.hs @@ -23,6 +23,9 @@ import SSM.Core.Backend import SSM.Core.Peripheral +import Language.C.Quote.GCC +import qualified Language.C.Syntax as C + -- | Basic BLE data type data BasicBLE = BasicBLE { broadcast :: (Ident, Type) -- ^ Name and type of broadcast reference @@ -30,11 +33,11 @@ data BasicBLE = BasicBLE , scan :: (Ident, Type) -- ^ Name and type of scan reference , scanControl :: (Ident, Type) -- ^ Name and type of scan control reference } - deriving (Show, Read, Eq) + deriving (Show, Eq) instance IsPeripheral C BasicBLE where - type Definition C = () - type Initialization C = () +-- type Definition C = [C.Definition] +-- type Initialization C = [C.BlockItem] -- instance IsPeripheral BasicBLE where -- declaredReferences = basicBLERefs diff --git a/ssm/SSM/Core/Peripheral/GPIO.hs b/ssm/SSM/Core/Peripheral/GPIO.hs index 4537d4f9..f3d838d7 100644 --- a/ssm/SSM/Core/Peripheral/GPIO.hs +++ b/ssm/SSM/Core/Peripheral/GPIO.hs @@ -35,17 +35,20 @@ import SSM.Core.Type ( Type(TBool) ) import SSM.Core.Backend +import Language.C.Quote.GCC +import qualified Language.C.Syntax as C + -- | Datatype that describes which GPIO pins are used. data GPIOPeripheral = GPIOPeripheral { {- | This map associates a pin number with the name the reference is given in the source code. -} switchpins' :: Map.Map Word8 Ident } - deriving (Show, Read, Eq) + deriving (Show, Eq) instance IsPeripheral C GPIOPeripheral where - type Definition C = () - type Initialization C = () +-- type Definition C = [C.Definition] +-- type Initialization C = [C.BlockItem] -- -- | IsPeripheral instance for `GPIOPeripheral`, so that we can compile peripherals. -- instance IsPeripheral GPIOPeripheral where diff --git a/ssm/SSM/Core/Peripheral/Identity.hs b/ssm/SSM/Core/Peripheral/Identity.hs index 2548845b..f15cc1e9 100644 --- a/ssm/SSM/Core/Peripheral/Identity.hs +++ b/ssm/SSM/Core/Peripheral/Identity.hs @@ -14,17 +14,20 @@ import SSM.Core.Backend import qualified Data.Map as Map +import Language.C.Quote.GCC +import qualified Language.C.Syntax as C + modulename :: String modulename = "SSM.Core.Peripheral.Identity" data IdentityPeripheral = IdentityPeripheral { identitySVs :: (Map.Map Ident Type) } - deriving (Show, Read, Eq) + deriving (Show, Eq) instance IsPeripheral C IdentityPeripheral where - type Definition C = () - type Initialization C = () +-- type Definition C = [C.Definition] +-- type Initialization C = [C.BlockItem] -- instance IsPeripheral IdentityPeripheral where -- declaredReferences ip = diff --git a/ssm/SSM/Core/Peripheral/LED.hs b/ssm/SSM/Core/Peripheral/LED.hs index faf50074..702eb17d 100644 --- a/ssm/SSM/Core/Peripheral/LED.hs +++ b/ssm/SSM/Core/Peripheral/LED.hs @@ -25,19 +25,24 @@ data LEDPeripheral = LEDPeripheral { -- | Associate LED IDs with reference identifiers onoffLEDs' :: Map.Map Word8 Ident } - deriving (Eq, Show, Read) + deriving (Eq, Show) + + +-- instance IsPeripheral C LEDPeripheral where +-- type Definition C = () +-- type Initialization C = () instance IsPeripheral C LEDPeripheral where - type Definition C = [C.InitGroup] - type Initialization C = [C.BlockItem] +-- type Definition C = [C.Definition] +-- type Initialization C = [C.BlockItem] - declaredReferences _ lp = - map (flip makeStaticRef (mkReference TBool) . snd) $ onoffLEDs lp +-- declaredReferences _ lp = +-- map (flip makeStaticRef (mkReference TBool) . snd) $ onoffLEDs lp - globalDeclarations _ _ = [] +-- globalDeclarations _ _ = [] - staticInitialization _ lp = flip map (onoffLEDs lp) $ \(_, id) -> - undefined +-- staticInitialization _ lp = flip map (onoffLEDs lp) $ \(_, id) -> +-- undefined -- -- | `IsPeripheral` instance for `LEDPeripheral`, so that we can compile `LEDPeripheral`s. -- instance IsPeripheral LEDPeripheral where diff --git a/ssm/SSM/Core/Program.hs b/ssm/SSM/Core/Program.hs index d57deca4..377efc14 100644 --- a/ssm/SSM/Core/Program.hs +++ b/ssm/SSM/Core/Program.hs @@ -5,6 +5,7 @@ represented. -} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE GADTs #-} module SSM.Core.Program ( Procedure(..) , QueueContent(..) @@ -14,6 +15,7 @@ module SSM.Core.Program ) where +import SSM.Core.Backend ( Schedule ) import SSM.Core.Ident ( Ident ) import SSM.Core.Peripheral ( Peripheral, Handler ) import SSM.Core.Reference ( Reference ) @@ -32,24 +34,32 @@ data Procedure = Procedure , arguments :: [(Ident, Type)] -- ^ Parameter names and types of the procedure. , body :: [Stm] -- ^ Statements that make up this procedure. } - deriving (Eq, Show, Read) + deriving (Eq, Show) -- | A @QueueContent@ is something that can be scheduled when a program begins executing. -data QueueContent +data QueueContent backend {- | SSM procedures can be scheduled initially. Right now it is assumed that only one SSM procedure will ever be scheduled initiailly, and that it will have no arguments. The constructor looks like this, however, in preparation for any future changes we might want to make. I might remove this second argument... -} = SSMProcedure Ident [Either SSMExp Reference] - | Handler Handler -- ^ Handlers can be scheduled - deriving (Show, Read, Eq) +-- | Handler Handler -- ^ Handlers can be scheduled + | Handler (Int -> Int -> Schedule backend) + +instance Show (QueueContent backend) where + show (SSMProcedure id args) = "SSMProcedure " <> show id <> " " <> show args + show (Handler _) = "" + +instance Eq (QueueContent backend) where + SSMProcedure id1 args1 == SSMProcedure id2 args2 = id1 == id2 && args1 == args2 + Handler _ == Handler _ = undefined -- TODO {- | Get the identifier of the SSM procedure that is scheduled at the start of a SSM program -} entry :: Program backend -> Ident entry p = getInitialProcedure' $ initialQueueContent p where - getInitialProcedure' :: [QueueContent] -> Ident + getInitialProcedure' :: [QueueContent backend] -> Ident getInitialProcedure' [] = error $ concat [ "SSM.Core.Syntax.getInitialProcedure error ---\n" , "no initial SSM procedure set to be scheduled when " @@ -61,14 +71,14 @@ entry p = getInitialProcedure' $ initialQueueContent p -- | Program definition data Program backend = Program { -- | The things that should be scheduled when the program starts - initialQueueContent :: [QueueContent] + initialQueueContent :: [QueueContent backend] -- | Map that associates procedure names with their definitions. , funs :: Map.Map Ident Procedure -- | Name and type of references that exist in the global scope. -- | Any peripherals used by the program , peripherals :: [Peripheral backend] } - deriving (Show, Read) + deriving (Show) instance Eq (Program backend) where p1 == p2 = initialQueueContent p1 == initialQueueContent p2 && diff --git a/ssm/SSM/Core/Reference.hs b/ssm/SSM/Core/Reference.hs index 3e2412aa..af41e90c 100644 --- a/ssm/SSM/Core/Reference.hs +++ b/ssm/SSM/Core/Reference.hs @@ -30,7 +30,7 @@ data Reference reside in an activation record in the generated C-code. It can be referenced from any context. -} | Static Ref - deriving (Eq, Show, Read) + deriving (Eq, Show) -- * Destructing references diff --git a/ssm/SSM/Core/Syntax.hs b/ssm/SSM/Core/Syntax.hs index 451bddb1..e11099f3 100644 --- a/ssm/SSM/Core/Syntax.hs +++ b/ssm/SSM/Core/Syntax.hs @@ -30,7 +30,7 @@ data SSMExp | UOpE Type SSMExp UnaryOpE -- ^ Unary operators on expressions | UOpR Type Reference UnaryOpR -- ^ Unary operators on references | BOp Type SSMExp SSMExp BinOp -- ^ Binary operators - deriving (Eq, Show, Read) + deriving (Eq, Show) -- | Literals take any of these forms data SSMLit @@ -41,19 +41,19 @@ data SSMLit | LInt64 Int64 -- ^ 64bit integer literals | LBool Bool -- ^ Boolean literals | LEvent -- ^ Event literal - deriving (Eq, Show, Read) + deriving (Eq, Show) -- | Expressions of unary operators on expressions data UnaryOpE = Neg -- ^ Numerical negation | Not -- ^ Boolean negation - deriving (Show, Eq, Read) + deriving (Show, Eq) -- | Expressions of unary operators on references data UnaryOpR = Changed -- ^ Expression represents if the reference has been written to | Deref -- ^ Dereference/sample the value of a reference - deriving (Show, Eq, Read) + deriving (Show, Eq) -- | Expressions of binary operators. data BinOp @@ -73,7 +73,7 @@ data BinOp | OBAnd -- ^ bit conjunction | OBOr -- ^ bit disjunction | OBXor -- ^ bit xor - deriving (Eq, Show, Read) + deriving (Eq, Show) -- | Return the type of an expression expType :: SSMExp -> Type @@ -110,4 +110,4 @@ data Stm {-| Fork procedures. The procedures are now identified by their name, and the fork site contains only that name and the arguments to apply the function to. -} | Fork [(Ident, [Either SSMExp Reference])] - deriving (Show, Eq, Read) + deriving (Show, Eq) diff --git a/ssm/SSM/Core/Type.hs b/ssm/SSM/Core/Type.hs index f5dec66c..0a5d36c1 100644 --- a/ssm/SSM/Core/Type.hs +++ b/ssm/SSM/Core/Type.hs @@ -27,7 +27,7 @@ data Type | TBool -- ^ Boolean type | TEvent -- ^ Event type | Ref Type -- ^ A reference to another type - deriving (Eq, Show, Read) + deriving (Eq, Show) -- | Dereference a type. Throws an error if the type is not a reference. dereference :: Type -> Type diff --git a/ssm/SSM/FreqGen.hs b/ssm/SSM/FreqGen.hs index 798481bc..cffa643d 100644 --- a/ssm/SSM/FreqGen.hs +++ b/ssm/SSM/FreqGen.hs @@ -69,7 +69,7 @@ entry = routine $ do period <- var $ time2ns $ secs 1 fork [freqGen period, buttonHandler period] -compiler :: Compile () +compiler :: Compile backend () compiler = do switch0 <- switch 0 switch1 <- switch 1 diff --git a/ssm/SSM/Freqmime.hs b/ssm/SSM/Freqmime.hs index 012a2097..2db6618b 100644 --- a/ssm/SSM/Freqmime.hs +++ b/ssm/SSM/Freqmime.hs @@ -2,6 +2,8 @@ {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE LinearTypes #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} --{-# OPTIONS_GHC -fplugin=SSM.Plugin -fplugin-opt=SSM.Plugin:mode=routine #-} module SSM.Freqmime where @@ -105,7 +107,7 @@ import SSM.Frontend.Peripheral.LED -mmmain :: Compile () +mmmain :: Compile backend () mmmain = do (x, handler) <- onoffLED 0 @@ -122,10 +124,10 @@ mmmain = do after (secs 1) ?led off wait ?led -testGlobal :: Compile () +testGlobal :: forall backend . Compile backend () testGlobal = do - x <- global @Word8 - y <- global @Word64 + x <- global @backend @Word8 + y <- global @backend @Word64 let ?x = x ?y = y @@ -263,7 +265,7 @@ Arguments are 1. ID of this source device 2. ID of the next device -} -source :: Exp Word64 -> Exp Word64 -> Compile () +source :: Exp Word64 -> Exp Word64 -> Compile backend () source this next = do (ble, broadcast, scanning) <- enableBasicBLE let ?ble = ble @@ -290,7 +292,7 @@ Arguments are: 2. ID of previous device 3. ID of next device -} -relay :: Exp Word64 -> Exp Word64 -> Exp Word64 -> Compile () +relay :: Exp Word64 -> Exp Word64 -> Exp Word64 -> Compile backend () relay this previous next = do (ble, broadcast, scanning) <- enableBasicBLE let ?ble = ble @@ -319,7 +321,7 @@ relay this previous next = do {-****** Devie 4 (the sink) ******-} -sink :: Exp Word64 -> Compile () +sink :: Exp Word64 -> Compile backend () sink this = do (ble, broadcast, scanning) <- enableBasicBLE @@ -419,7 +421,7 @@ test2 = boxNullary "test2" $ do -buttonBlinky :: Compile () +buttonBlinky :: Compile backend () buttonBlinky = do button <- switch 0 (led, ledHandler) <- onoffLED 0 diff --git a/ssm/SSM/FrequencyMime.hs b/ssm/SSM/FrequencyMime.hs index a870ede6..3c33e9f7 100644 --- a/ssm/SSM/FrequencyMime.hs +++ b/ssm/SSM/FrequencyMime.hs @@ -49,7 +49,7 @@ entry = routine $ do period <- var $ secs 1 fork [freqGen period, bleHandler period] -generator :: Compile () +generator :: Compile backend () generator = do (led, handler) <- onoffLED 0 (ble, broadcast, scanning) <- enableBasicBLE @@ -106,7 +106,7 @@ counterEntry = routine $ do count <- var $ secs 1 fork [ freqCount2 ?sw count, broadcastCount count ] -counter :: Compile () +counter :: Compile backend () counter = do sw <- switch 0 (ble, broadcast, scanning) <- enableBasicBLE diff --git a/ssm/SSM/Frontend/Compile.hs b/ssm/SSM/Frontend/Compile.hs index d82fcf78..ea976c84 100644 --- a/ssm/SSM/Frontend/Compile.hs +++ b/ssm/SSM/Frontend/Compile.hs @@ -6,6 +6,7 @@ should be visible in the entire program, or it could be IO peripherals. {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} module SSM.Frontend.Compile where import SSM.Core as SC @@ -15,86 +16,63 @@ import SSM.Util.State import Control.Monad.State import Data.Maybe +import qualified Data.Map as Map -- | State maintained by the `Compile` monad -data CompileSt = CompileSt +data CompileSt backend = CompileSt { compileCounter :: Int -- ^ Counter to generate fresh named - , initialQueueContent :: [QueueContent] -- ^ Initial ready-queue content + , initialQueueContent :: [QueueContent backend] -- ^ Initial ready-queue content , entryPoint :: Maybe (SSM ()) -- ^ SSM program to run - -- globals & peripherals - , generatedGlobals :: IdentityPeripheral -- ^ Names and types of global - , gpioperipherals :: GPIOPeripheral -- ^ GPIO peripherals - , ledperipherals :: LEDPeripheral -- ^ LED peripheral - , basicblePeripheral :: Maybe BasicBLE -- ^ Basic BLE peripheral + , peripherals :: Map.Map String (Peripheral backend) } -- | Compile monad -newtype Compile a = Compile (State CompileSt a) - deriving Functor via State CompileSt - deriving Applicative via State CompileSt - deriving Monad via State CompileSt - deriving (MonadState CompileSt) via State CompileSt +newtype Compile backend a = Compile (State (CompileSt backend) a) + deriving Functor via State (CompileSt backend) + deriving Applicative via State (CompileSt backend) + deriving Monad via State (CompileSt backend) + deriving (MonadState (CompileSt backend)) via State (CompileSt backend) {- | @IntState@ instance for `CompileSt` so that the `Compile` monad can generate fresh names with the generic `SSM.Util.State.fresh` function.. -} -instance IntState CompileSt where +instance IntState (CompileSt backend) where getInt = compileCounter setInt i st = st { compileCounter = i } {- | If you have a @Compile (SSM ())@ you have probably set up some global variables using the @Compile@ monad. This instance makes sure that you can compile and interpret something that is a program with such global variables. -} -instance ( IsPeripheral backend GPIOPeripheral - , IsPeripheral backend LEDPeripheral - , IsPeripheral backend IdentityPeripheral - , IsPeripheral backend BasicBLE) => SSMProgram backend (Compile ()) where +instance SSMProgram backend (Compile backend ()) where toProgram (Compile p) = let (a, s) = runState p - (CompileSt 0 - [] - Nothing - emptyIdentityPeripheral - emptyGPIOPeripheral - emptyLEDPeripheral - Nothing - ) + (CompileSt 0 [] Nothing Map.empty) (n, f) = transpile $ fromJust $ entryPoint s in Program (reverse $ SSM.Frontend.Compile.initialQueueContent s) f - $ [ Peripheral $ SSM.Frontend.Compile.gpioperipherals s - , Peripheral $ SSM.Frontend.Compile.ledperipherals s - , Peripheral $ generatedGlobals s - ] - ++ maybe [] (\p -> [Peripheral p]) (basicblePeripheral s) + $ Map.elems (SSM.Frontend.Compile.peripherals s) + +data OutputHandler backend = OutputHandler (Int -> Int -> Schedule backend) -{- | Schedule an SSM procedure for execution upon program start-up. Procedures that are -scheduled will be placed in the ready queue to be executed when the program starts. -Currently, they are executed in the order in which they were scheduled. +class Schedulable backend a where + schedule :: a -> Compile backend () -Note that there are only two valid things that can be scheduled. +instance Schedulable backend (SSM ()) where + schedule = scheduleSSM - 1. Nullary SSM procedures, aka procedures that take no arguments. These procedures must - be created by using the @Box@ machinery. - 2. Handlers that are returned by creating peripherals. +instance Schedulable backend (OutputHandler backend) where + schedule (OutputHandler f) = do + st <- get + let queuecontents = SSM.Frontend.Compile.initialQueueContent st + newcontent = Handler f + combined = newcontent : queuecontents + put $ st { SSM.Frontend.Compile.initialQueueContent = combined } -It is forbidden to schedule stuff like @fork [ ... ]@, @ var 0 >>= \r -> assign r 5@ and -so forth. - --} -schedule :: SSM () -> Compile () -schedule ssm = do - case isHandler ssm of - Just handlers -> modify $ \st -> st - { SSM.Frontend.Compile.initialQueueContent = map SC.Handler handlers - ++ SSM.Frontend.Compile.initialQueueContent st - } - Nothing -> - let id = getProcedureName $ runSSM ssm - in - modify $ \st -> st - { SSM.Frontend.Compile.initialQueueContent = - SSMProcedure id [] - : SSM.Frontend.Compile.initialQueueContent st - , entryPoint = Just ssm - } +scheduleSSM :: SSM () -> Compile backend () +scheduleSSM ssm = + let id = getProcedureName $ runSSM ssm + in modify $ \st -> st + { SSM.Frontend.Compile.initialQueueContent = + SSMProcedure id [] : SSM.Frontend.Compile.initialQueueContent st + , entryPoint = Just ssm + } diff --git a/ssm/SSM/Frontend/NewPeripheral/GPIO.hs b/ssm/SSM/Frontend/NewPeripheral/GPIO.hs new file mode 100644 index 00000000..7c42f627 --- /dev/null +++ b/ssm/SSM/Frontend/NewPeripheral/GPIO.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +module SSM.Frontend.NewPeripheral.GPIO where + +import SSM.Core ( C + , Ident + , dereference + , Type + , makeStaticRef + , refName + , refType + , IsPeripheral(..) + , Peripheral(..) + , makeIdent + ) +import SSM.Core.Backend + +import SSM.Backend.C.Identifiers +import SSM.Backend.C.Types ( svt_ + , initialize_ + , assign_ + ) + +import SSM.Frontend.Ref ( Ref(..) ) +import SSM.Frontend.Compile +import SSM.Frontend.Syntax + +import Data.Proxy ( Proxy(Proxy) ) +import Data.Word ( Word8 ) +import qualified Data.Map as Map + +import Control.Monad.State ( MonadState(put, get) ) + +import Language.C.Quote.GCC ( cedecl, cexp, citem, citems ) +import qualified Language.C.Syntax as C + +-- | The GPIO datatype represents the GPIO pins we have requested from the environment +data GPIOP = GPIOP { pins :: Map.Map Word8 (Ident, Type)} + deriving (Show, Eq) + +-- | Create an empty GPIO peripheral +emptyGPIO :: GPIOP +emptyGPIO = GPIOP { pins = Map.empty } + +instance IsPeripheral C GPIOP where + declareReference _ t id i gpio = gpio { pins = Map.insert i (id,t) (pins gpio) } + + declaredReferences _ gpio = + map (uncurry makeStaticRef) $ Map.elems $ pins gpio + + globalDeclarations p gpio = + flip map (declaredReferences p gpio) $ \ref -> + [cedecl| $ty:(svt_ $ dereference $ refType ref) $id:(refName ref); |] + + staticInitialization p gpio = flip concatMap (declaredReferences p gpio) $ \ref -> + let bt = dereference $ refType ref + init = initialize_ bt [cexp| &$id:(refName ref)|] + assign = assign_ bt [cexp| &$id:(refName ref)|] [cexp|0|] [cexp|0|] + in [citems| $exp:init; $exp:assign; |] + +type GPIO = Bool + +{- | Populates the GPIO pripheral with a new reference. + +Parameters: + + 1. @Word8@ that identifies the GPIO pin on the board + 2. The name of the reference + +Returns: The @Ref LED@ that represents the newly created reference. -} +insertGPIO :: forall backend + . IsPeripheral backend GPIOP + => Word8 -> Ident -> Compile backend (Ref GPIO) +insertGPIO i id = do + st <- get + + -- fetch the GPIO peripheral and populate it with the new reference + let maybegpio = Map.lookup "gpio" (peripherals st) + emptyperi = Peripheral @backend emptyGPIO + m = maybe emptyperi (\x -> x) maybegpio + m' = declareReference (Proxy @backend) typ id i m + + -- modify the @CompileSt@ to contain the updated GPIO peripheral + put $ st { peripherals = Map.insert "gpio" m' (peripherals st)} + + -- create the reference and return it + let ref = makeStaticRef id typ + return $ Ptr ref + where + -- | GPIO pins have a binary state, so treating them like @Bool@s seems reasonable + typ :: Type + typ = Ref TBool + +class GPIOHandler backend where + make_handler :: proxy backend -> Ref GPIO -> Word8 -> OutputHandler backend + +instance GPIOHandler C where + make_handler _ (Ptr r) i = OutputHandler $ \k cs -> + let (prio,dep) = pdep k cs priority_at_root depth_at_root + in [citem| $id:initialize_static_output_device( $id:top_parent + , $exp:prio + , $exp:dep + , &$id:(refName r).sv + , $uint:i); |] + +{- | Ask the GPIO peripheral for a GPIO pin identified by the @Word8@, and +get the reference and handler back. The reference is what is used to interact +with the GPIO, and the handler must be `schedule`d in order to actually +perform the IO output actions. -} +gpio :: forall backend . + (IsPeripheral backend GPIOP, GPIOHandler backend) + => Word8 -> Compile backend (Ref GPIO, OutputHandler backend) +gpio i = do + n <- fresh + let id = makeIdent n + + ref <- insertGPIO i id + + let handler = make_handler (Proxy @backend) ref i + + return (ref, handler) diff --git a/ssm/SSM/Frontend/Peripheral/BasicBLE.hs b/ssm/SSM/Frontend/Peripheral/BasicBLE.hs index c8035d3a..00621f8a 100644 --- a/ssm/SSM/Frontend/Peripheral/BasicBLE.hs +++ b/ssm/SSM/Frontend/Peripheral/BasicBLE.hs @@ -41,10 +41,10 @@ import Control.Monad.State describes the remote devices MAC address as a string of hex octets, separated by colon. E.g "AB:CD:EF:01:23:54" -} -enableBasicBLE :: Compile (BBLE, SSM (), SSM ()) +enableBasicBLE :: Compile backend (BBLE, SSM (), SSM ()) enableBasicBLE = do let basicble = enableBLE broadcast broadcastControl scan scanControl - modify $ \s -> s { basicblePeripheral = Just basicble } + --modify $ \s -> s { basicblePeripheral = Just basicble } let scanref = makeStaticRef' scan broadcastref = makeStaticRef' broadcast @@ -55,11 +55,12 @@ enableBasicBLE = do , scanControl = Ptr $ scanControlref , broadcastControl = Ptr $ broadcastControlref } - broadcastHandler = do - emit $ Handler $ Output (BLE Broadcast) broadcastref - emit $ Handler $ Output (BLE BroadcastControl) broadcastControlref - scanControlHandler = - emit $ Handler $ Output (BLE ScanControl) scanControlref + broadcastHandler = undefined + -- do + -- emit $ Handler $ Output (BLE Broadcast) broadcastref + -- emit $ Handler $ Output (BLE BroadcastControl) broadcastControlref + scanControlHandler = undefined + -- emit $ Handler $ Output (BLE ScanControl) scanControlref return (bble, broadcastHandler, scanControlHandler) where diff --git a/ssm/SSM/Frontend/Peripheral/GPIO.hs b/ssm/SSM/Frontend/Peripheral/GPIO.hs index 66016241..1114defa 100644 --- a/ssm/SSM/Frontend/Peripheral/GPIO.hs +++ b/ssm/SSM/Frontend/Peripheral/GPIO.hs @@ -27,10 +27,10 @@ isLow :: Ref SW -> Exp Bool isLow = not' . isHigh -- | Create a @Ref SW@ by identifying a GPIO pin with a unique ID. E.g GPIO 1. -switch :: Word8 -> Compile (Ref SW) +switch :: Word8 -> Compile backend (Ref SW) switch i = do n <- fresh let id = Ident n Nothing - modify $ \st -> - st { gpioperipherals = addSwitchGPIO i id (gpioperipherals st) } + -- modify $ \st -> + -- st { gpioperipherals = addSwitchGPIO i id (gpioperipherals st) } return $ Ptr $ makeStaticRef id (Ref TBool) diff --git a/ssm/SSM/Frontend/Peripheral/Identity.hs b/ssm/SSM/Frontend/Peripheral/Identity.hs index 415ae40b..719b3e83 100644 --- a/ssm/SSM/Frontend/Peripheral/Identity.hs +++ b/ssm/SSM/Frontend/Peripheral/Identity.hs @@ -19,11 +19,11 @@ import Data.Proxy import Control.Monad.State -- | Generate a global SV -global :: forall a . SSMType a => Compile (Ref a) +global :: forall backend a . SSMType a => Compile backend (Ref a) global = do n <- fresh let id = Ident n Nothing let t = mkReference $ typeOf $ Proxy @a - modify $ \st -> - st { generatedGlobals = addIdentitySV id t $ generatedGlobals st } + -- modify $ \st -> + -- st { generatedGlobals = addIdentitySV id t $ generatedGlobals st } return $ Ptr $ makeStaticRef id t diff --git a/ssm/SSM/Frontend/Peripheral/LED.hs b/ssm/SSM/Frontend/Peripheral/LED.hs index 5069e088..0d3bec23 100644 --- a/ssm/SSM/Frontend/Peripheral/LED.hs +++ b/ssm/SSM/Frontend/Peripheral/LED.hs @@ -27,7 +27,7 @@ import SSM.Core.Type ( Type(TBool) ) import SSM.Frontend.Compile ( Compile - , CompileSt(ledperipherals) +-- , CompileSt(ledperipherals) ) import SSM.Frontend.Exp ( Exp ) import SSM.Frontend.Language ( (==.) @@ -40,7 +40,7 @@ import SSM.Frontend.Language ( (==.) import SSM.Frontend.Ref ( Ref(Ptr) ) import SSM.Frontend.Syntax ( SSM , emit - , SSMStm(Handler) + -- , SSMStm(Handler) ) import SSM.Util.State ( fresh ) @@ -73,20 +73,20 @@ integer. The meaning of this integer is not well defined yet, and it is assumed meaning exists in the runtime. This function also returns a handler that will actually perform the IO side-effects. This must be scheduled to run, or else it will not perform any side effects. -} -onoffLED :: Word8 -> Compile (Ref LED, SSM ()) +onoffLED :: Word8 -> Compile backend (Ref LED, SSM ()) onoffLED i = do -- generate fresh name for reference n <- fresh let id = Ident n Nothing -- modify internal LED object to know about this reference - modify $ \st -> st { ledperipherals = addOnOffLED i id $ ledperipherals st } +-- modify $ \st -> st { ledperipherals = addOnOffLED i id $ ledperipherals st } -- create the reference to return to the developer let ref = makeStaticRef id (mkReference TBool) -- create the SSM handler to return to the developer - let handler = emit $ Handler $ Output (LED i) ref + let handler = undefined --emit $ Handler $ Output (LED i) ref -- return the reference and the SSM () that performs the actual IO return $ (Ptr ref, handler) diff --git a/ssm/SSM/Frontend/Syntax.hs b/ssm/SSM/Frontend/Syntax.hs index affd8234..9d9129a5 100644 --- a/ssm/SSM/Frontend/Syntax.hs +++ b/ssm/SSM/Frontend/Syntax.hs @@ -44,7 +44,6 @@ module SSM.Frontend.Syntax , SSMStm(..) , getProcedureName , renameStmt - , isHandler -- * SSM Monad , SSM(..) @@ -105,7 +104,7 @@ data SSMStm {-| Records the name an argument has and what value the procedure was applied to -} | Argument Ident Ident (Either S.SSMExp Reference) | Result Ident -- ^ Mark the end of a procedure - | Handler Handler +-- | Handler Handler renameStmt :: SSMStm -> (Maybe String, Maybe (String, Int, Int)) -> SSMStm renameStmt s (Nothing, _ ) = s @@ -116,24 +115,6 @@ renameStmt s (Just n, info) = NewRef n e -> NewRef srcinfo e _ -> s -{- | Check if an `SSM` computation represents a call to a single handler. In that case, -return the handler. Otherwise, return Nothing. -} -isHandler :: SSM () -> Maybe [Handler] -isHandler ssm = case fetchHandlers $ runSSM ssm of - [] -> Nothing - handlers -> Just handlers - where - fetchHandlers :: [SSMStm] -> [Handler] - fetchHandlers stmts = map unwrapHandler $ filter isHandler' stmts - - isHandler' :: SSMStm -> Bool - isHandler' (Handler _) = True - isHandler' _ = False - - unwrapHandler :: SSMStm -> Handler - unwrapHandler (Handler h) = h - unwrapHandler _ = error "not a handler, robert did a mistake somewhere" - {- | The state maintained by the SSM monad. A counter for generating fresh names and a list of statements that make up the program. -} data SSMSt = SSMSt @@ -244,7 +225,6 @@ transpileProcedure xs = fmap concat $ forM xs $ \x -> case x of Procedure n _ _ -> return [] Argument n x a -> return [] Result n -> return [] - Handler h -> return [] where {- | Run a recursive SSM computation by using the last known name generating state. The last known name-generating state is updated to reflect if any new names were diff --git a/ssm/SSM/Interpret/Trace.hs b/ssm/SSM/Interpret/Trace.hs index 8ccd168b..6cbcccf0 100644 --- a/ssm/SSM/Interpret/Trace.hs +++ b/ssm/SSM/Interpret/Trace.hs @@ -71,7 +71,7 @@ data Event = | CrashArithmeticError -- | Interpreter crashed for an unforeseen reason (should be unreachable). | CrashUnforeseen String - deriving (Show, Eq, Read) + deriving (Show, Eq) isTerminal :: Event -> Bool isTerminal TerminatedOk = True @@ -100,7 +100,7 @@ type ActIdent = String -- Even if the variable is a reference, VarVal should contain its base type -- (i.e., without the reference) and base value (i.e., dereferenced). data VarVal = VarVal VarIdent Type ConcreteValue - deriving (Show, Eq, Read) + deriving (Show, Eq) -- | An untyped, concrete value. -- diff --git a/ssm/SSM/Pretty/Syntax.hs b/ssm/SSM/Pretty/Syntax.hs index f6bdf417..3229113c 100644 --- a/ssm/SSM/Pretty/Syntax.hs +++ b/ssm/SSM/Pretty/Syntax.hs @@ -55,27 +55,28 @@ prettyProgram' p = do intercalateM (emit "") $ map prettyProcedure (Map.elems (funs p)) return () -prettyQueueContent :: QueueContent -> String +prettyQueueContent :: QueueContent backend -> String prettyQueueContent (SSMProcedure id args) = prettyApp (id, args) -prettyQueueContent (Handler h ) = case h of - Output variant ref -> case variant of - LED id -> prettyApp - ( Ident "led_output_handler" Nothing - , [Right ref, Left $ Lit TUInt8 $ LUInt8 id] - ) - BLE bh -> case bh of - Broadcast -> prettyApp - ( Ident "broadcast_output_handler" Nothing - , [Right ref] - ) - BroadcastControl -> prettyApp - ( Ident "broadcast_control_output_handler" Nothing - , [Right ref] - ) - ScanControl -> prettyApp - ( Ident "scan_control_output_handler" Nothing - , [Right ref] - ) +prettyQueueContent (Handler h ) = "output-handler" +-- case h of +-- Output variant ref -> case variant of +-- LED id -> prettyApp +-- ( Ident "led_output_handler" Nothing +-- , [Right ref, Left $ Lit TUInt8 $ LUInt8 id] +-- ) +-- BLE bh -> case bh of +-- Broadcast -> prettyApp +-- ( Ident "broadcast_output_handler" Nothing +-- , [Right ref] +-- ) +-- BroadcastControl -> prettyApp +-- ( Ident "broadcast_control_output_handler" Nothing +-- , [Right ref] +-- ) +-- ScanControl -> prettyApp +-- ( Ident "scan_control_output_handler" Nothing +-- , [Right ref] +-- ) prettyReferenceDecls :: [Reference] -> PP () prettyReferenceDecls xs = flip mapM_ xs $ \ref -> From 95bde84b2956dcf94e9ab2fae61a2ce74173c9ce Mon Sep 17 00:00:00 2001 From: Robert Krook Date: Thu, 9 Dec 2021 16:04:31 +0100 Subject: [PATCH 04/16] almost done refactoring everything. Then time to evaluat! --- ssm.cabal | 6 - ssm/SSM/Backend/C/CodeGen.hs | 24 +-- ssm/SSM/Backend/C/Identifiers.hs | 11 +- ssm/SSM/Core.hs | 8 - ssm/SSM/Core/Peripheral.hs | 60 +++--- ssm/SSM/Core/Peripheral/BasicBLE.hs | 89 --------- ssm/SSM/Core/Peripheral/GPIO.hs | 82 --------- ssm/SSM/Core/Peripheral/Identity.hs | 53 ------ ssm/SSM/Core/Peripheral/LED.hs | 74 -------- ssm/SSM/Core/Program.hs | 15 +- ssm/SSM/FreqGen.hs | 16 +- ssm/SSM/Freqmime.hs | 148 ++++----------- ssm/SSM/FrequencyMime.hs | 26 +-- ssm/SSM/Frontend/Compile.hs | 6 +- ssm/SSM/Frontend/NewPeripheral/GPIO.hs | 125 ------------- ssm/SSM/Frontend/Peripheral/BasicBLE.hs | 210 +++++++++++++-------- ssm/SSM/Frontend/Peripheral/GPIO.hs | 235 +++++++++++++++++++++--- ssm/SSM/Frontend/Peripheral/Identity.hs | 74 ++++++-- ssm/SSM/Frontend/Peripheral/LED.hs | 92 ---------- ssm/SSM/Pretty/Syntax.hs | 23 +-- 20 files changed, 507 insertions(+), 870 deletions(-) delete mode 100644 ssm/SSM/Core/Peripheral/BasicBLE.hs delete mode 100644 ssm/SSM/Core/Peripheral/GPIO.hs delete mode 100644 ssm/SSM/Core/Peripheral/Identity.hs delete mode 100644 ssm/SSM/Core/Peripheral/LED.hs delete mode 100644 ssm/SSM/Frontend/NewPeripheral/GPIO.hs delete mode 100644 ssm/SSM/Frontend/Peripheral/LED.hs diff --git a/ssm.cabal b/ssm.cabal index 4ef7bfbd..bb6c95e3 100644 --- a/ssm.cabal +++ b/ssm.cabal @@ -35,10 +35,6 @@ library SSM.Core.Backend SSM.Core.Ident SSM.Core.Peripheral - SSM.Core.Peripheral.BasicBLE - SSM.Core.Peripheral.GPIO - SSM.Core.Peripheral.Identity - SSM.Core.Peripheral.LED SSM.Core.Program SSM.Core.Reference SSM.Core.Syntax @@ -50,11 +46,9 @@ library SSM.Frontend.Compile SSM.Frontend.Exp SSM.Frontend.Language - SSM.Frontend.NewPeripheral.GPIO SSM.Frontend.Peripheral.BasicBLE SSM.Frontend.Peripheral.GPIO SSM.Frontend.Peripheral.Identity - SSM.Frontend.Peripheral.LED SSM.Frontend.Ref SSM.Frontend.Syntax SSM.Frontend.Waitable diff --git a/ssm/SSM/Backend/C/CodeGen.hs b/ssm/SSM/Backend/C/CodeGen.hs index 303ad769..160eff1c 100644 --- a/ssm/SSM/Backend/C/CodeGen.hs +++ b/ssm/SSM/Backend/C/CodeGen.hs @@ -154,18 +154,18 @@ genInitProgram p = [cunit| -- , $args:(argsOfHandler h) -- ) -- );|] - initialFork (priority, depth) (Handler f) = error "fixme" - - -- | Take a handler and return a list of arguments to it - argsOfHandler :: Handler -> [C.Exp] - argsOfHandler (Output variant ref) = case variant of - LED id -> [ [cexp| &$id:(refName ref).sv |] - , [cexp| $uint:id |] - ] - BLE bh -> case bh of - Broadcast -> [ [cexp| &$id:(refName ref).sv |] ] - BroadcastControl -> [ [cexp| &$id:(refName ref).sv |] ] - ScanControl -> [ [cexp| &$id:(refName ref).sv |] ] + initialFork (priority, depth) (OutputHandler (Handler f _)) = error "fixme" + + -- -- | Take a handler and return a list of arguments to it + -- argsOfHandler :: Handler -> [C.Exp] + -- argsOfHandler (Output variant ref) = case variant of + -- LED id -> [ [cexp| &$id:(refName ref).sv |] + -- , [cexp| $uint:id |] + -- ] + -- BLE bh -> case bh of + -- Broadcast -> [ [cexp| &$id:(refName ref).sv |] ] + -- BroadcastControl -> [ [cexp| &$id:(refName ref).sv |] ] + -- ScanControl -> [ [cexp| &$id:(refName ref).sv |] ] cargs :: Either SSMExp Reference -> C.Exp cargs (Left e) = genExp [] e diff --git a/ssm/SSM/Backend/C/Identifiers.hs b/ssm/SSM/Backend/C/Identifiers.hs index 266a5bc4..21853cf2 100644 --- a/ssm/SSM/Backend/C/Identifiers.hs +++ b/ssm/SSM/Backend/C/Identifiers.hs @@ -14,7 +14,7 @@ module SSM.Backend.C.Identifiers , initialize_static_output_ble_scan_control_device , initialize_static_output_ble_broadcast_control_device , initialize_static_output_ble_broadcast_device - , resolveNameOfHandler + , enable_ble_stack , top_return , top_parent , fork @@ -116,13 +116,8 @@ initialize_static_output_ble_broadcast_device :: CIdent initialize_static_output_ble_broadcast_device = "bind_static_ble_broadcast_device" -resolveNameOfHandler :: Handler -> CIdent -resolveNameOfHandler (Output variant _) = case variant of - LED _ -> initialize_static_output_device - BLE bh -> case bh of - Broadcast -> initialize_static_output_ble_broadcast_device - BroadcastControl -> initialize_static_output_ble_broadcast_control_device - ScanControl -> initialize_static_output_ble_scan_control_device +enable_ble_stack :: CIdent +enable_ble_stack = "enable_ble_stack" -- | Name of top level return step-function top_return :: CIdent diff --git a/ssm/SSM/Core.hs b/ssm/SSM/Core.hs index 0dfa6428..f50dc6d9 100644 --- a/ssm/SSM/Core.hs +++ b/ssm/SSM/Core.hs @@ -2,10 +2,6 @@ module SSM.Core ( module SSM.Core.Ident , module SSM.Core.Peripheral - , module SSM.Core.Peripheral.Identity - , module SSM.Core.Peripheral.GPIO - , module SSM.Core.Peripheral.LED - , module SSM.Core.Peripheral.BasicBLE , module SSM.Core.Program , module SSM.Core.Reference , module SSM.Core.Syntax @@ -15,10 +11,6 @@ module SSM.Core import SSM.Core.Ident import SSM.Core.Peripheral -import SSM.Core.Peripheral.GPIO -import SSM.Core.Peripheral.Identity -import SSM.Core.Peripheral.LED -import SSM.Core.Peripheral.BasicBLE import SSM.Core.Program import SSM.Core.Reference import SSM.Core.Syntax diff --git a/ssm/SSM/Core/Peripheral.hs b/ssm/SSM/Core/Peripheral.hs index 71a27902..3d4eea27 100644 --- a/ssm/SSM/Core/Peripheral.hs +++ b/ssm/SSM/Core/Peripheral.hs @@ -14,13 +14,7 @@ the fact that there exists a C backend. -} {-# LANGUAGE RankNTypes #-} module SSM.Core.Peripheral ( Peripheral(..) - , Initializer(..) - , StaticInputVariant(..) - , Handler(..) - , StaticOutputVariant(..) - , BLEHandler(..) , IsPeripheral(..) - , IndependentInit(..) ) where import Data.Word ( Word8 ) @@ -40,38 +34,38 @@ instance Show (Peripheral backend) where instance Eq (Peripheral backend) where (==) = undefined -{- | Different types of peripherals might require different kinds of initialization. -This type is meant to enumerate the different types of initialization. -} -data Initializer - = Normal Reference -- ^ Perform regular initialization of the reference - {- | The @StaticInput@ initialization tells us that the reference is an input - reference, and that it needs to be initialized as the kind of static input described - by the `StaticInputVariant` type. -} - | StaticInput StaticInputVariant Reference - | Independent IndependentInit +-- {- | Different types of peripherals might require different kinds of initialization. +-- This type is meant to enumerate the different types of initialization. -} +-- data Initializer +-- = Normal Reference -- ^ Perform regular initialization of the reference +-- {- | The @StaticInput@ initialization tells us that the reference is an input +-- reference, and that it needs to be initialized as the kind of static input described +-- by the `StaticInputVariant` type. -} +-- | StaticInput StaticInputVariant Reference +-- | Independent IndependentInit -data IndependentInit = BLEEnable +-- data IndependentInit = BLEEnable --- | Static input variants. -data StaticInputVariant = Switch Word8 -- ^ Switch GPIO - | BLEScan +-- -- | Static input variants. +-- data StaticInputVariant = Switch Word8 -- ^ Switch GPIO +-- | BLEScan --- | Different variants of handlers that can be scheduled at the beginning of a program -data Handler --- = StaticOutputHandler Reference Word8 -- ^ Static output handlers (LED? only?) - = Output StaticOutputVariant Reference - deriving (Show, Eq) +-- -- | Different variants of handlers that can be scheduled at the beginning of a program +-- data Handler +-- -- = StaticOutputHandler Reference Word8 -- ^ Static output handlers (LED? only?) +-- = Output StaticOutputVariant Reference +-- deriving (Show, Eq) -data StaticOutputVariant - = LED Word8 - | BLE BLEHandler - deriving (Show, Eq) +-- data StaticOutputVariant +-- = LED Word8 +-- | BLE BLEHandler +-- deriving (Show, Eq) -data BLEHandler - = Broadcast - | BroadcastControl - | ScanControl - deriving (Show, Eq) +-- data BLEHandler +-- = Broadcast +-- | BroadcastControl +-- | ScanControl +-- deriving (Show, Eq) -- -- | Class of types that are peripherals -- class IsPeripheral a where diff --git a/ssm/SSM/Core/Peripheral/BasicBLE.hs b/ssm/SSM/Core/Peripheral/BasicBLE.hs deleted file mode 100644 index 5f327b91..00000000 --- a/ssm/SSM/Core/Peripheral/BasicBLE.hs +++ /dev/null @@ -1,89 +0,0 @@ -{- | This module implements the peripheral that describes basic BLE support. The -part that makes it basic is the fact that this module only supports broadcasting & -scanning, in a very limited manner. - - 1. When you scan for messages, you need to specify the MAC-address of the remote board - you are scanning for messages from. - 2. You can only broadcast/scan a single byta at a time, so the size of the payload - is very limited. - -This module is intended to act as a simple example of what we can do. Our ambition is to -add support for the entire BLE stack. - --} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -module SSM.Core.Peripheral.BasicBLE where - -import SSM.Core.Ident -import SSM.Core.Reference -import SSM.Core.Type -import SSM.Core.Backend - -import SSM.Core.Peripheral - -import Language.C.Quote.GCC -import qualified Language.C.Syntax as C - --- | Basic BLE data type -data BasicBLE = BasicBLE - { broadcast :: (Ident, Type) -- ^ Name and type of broadcast reference - , broadcastControl :: (Ident, Type) -- ^ Name and type of broadcast control reference - , scan :: (Ident, Type) -- ^ Name and type of scan reference - , scanControl :: (Ident, Type) -- ^ Name and type of scan control reference - } - deriving (Show, Eq) - -instance IsPeripheral C BasicBLE where --- type Definition C = [C.Definition] --- type Initialization C = [C.BlockItem] - --- instance IsPeripheral BasicBLE where --- declaredReferences = basicBLERefs - --- mainInitializers ble = concat [enable, normalInits, specials] --- where --- (broadcast : broadcastControl : scan : scanControl : _) = --- basicBLERefs ble - --- enable = [ Independent BLEEnable ] - --- -- initialize the references like you normally initialize them --- normalInits = --- [ Normal broadcast --- , Normal broadcastControl --- , Normal scan --- , Normal scanControl --- ] - --- -- perform the BLE input-specific initializations --- specials = --- [ StaticInput BLEScan scan ] - -basicBLERefs :: BasicBLE -> [Reference] -basicBLERefs ble = map - (uncurry makeStaticRef) - [broadcast ble, broadcastControl ble, scan ble, scanControl ble] - -{- | This function returns a peripheral that enables the BLE stack. The arguments are: - - 1. Name and type of the reference used to broadcast messages - 2. Name and type of the reference that is used to control the broadcasting - functionality - 3. Name and type of the reference used to scan for messages - 4. Name and type of the reference that is used to control the scanning functionality - --} -enableBLE - :: (Ident, Type) - -> (Ident, Type) - -> (Ident, Type) - -> (Ident, Type) - -> BasicBLE -enableBLE broadcast broadcastControl scan scanControl = BasicBLE - { broadcast = broadcast - , broadcastControl = broadcastControl - , scan = scan - , scanControl = scanControl - } diff --git a/ssm/SSM/Core/Peripheral/GPIO.hs b/ssm/SSM/Core/Peripheral/GPIO.hs deleted file mode 100644 index f3d838d7..00000000 --- a/ssm/SSM/Core/Peripheral/GPIO.hs +++ /dev/null @@ -1,82 +0,0 @@ -{- | This module implements the data types and functions necessary to specify which GPIO -peripherals a program uses. GPIOs come in three main flavours: - - 1. Switches -- input GPIOs that can be read (either HIGH or LOW) - 2. DACs - 3. ADCs - -but this module only implements support for switches so far. - -The idea is that this will act as the core representation of the GPIO peripherals. When -code is being generated and the interpreter is ran, this is the datatype that will -describe which pins are being used, what type of pin they are and what names they were -assigned. Regardless of how the frontend language lets the programmer interact with GPIO, -this describes how the core syntax interacts with GPIO. -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -module SSM.Core.Peripheral.GPIO - ( GPIOPeripheral - , switchpins - , emptyGPIOPeripheral - , addSwitchGPIO - ) where - -import qualified Data.Map as Map -import Data.Word ( Word8 ) -import SSM.Core.Ident ( Ident ) -import SSM.Core.Peripheral ( Initializer(..) - , IsPeripheral(..) - , StaticInputVariant(Switch) - ) -import SSM.Core.Reference ( makeStaticRef ) -import SSM.Core.Type ( Type(TBool) - , mkReference - ) -import SSM.Core.Backend - -import Language.C.Quote.GCC -import qualified Language.C.Syntax as C - --- | Datatype that describes which GPIO pins are used. -data GPIOPeripheral = GPIOPeripheral - { {- | This map associates a pin number with the name the reference is given in the - source code. -} - switchpins' :: Map.Map Word8 Ident - } - deriving (Show, Eq) - -instance IsPeripheral C GPIOPeripheral where --- type Definition C = [C.Definition] --- type Initialization C = [C.BlockItem] - --- -- | IsPeripheral instance for `GPIOPeripheral`, so that we can compile peripherals. --- instance IsPeripheral GPIOPeripheral where --- declaredReferences gpio = --- map (flip makeStaticRef (mkReference TBool) . snd) $ switchpins gpio - --- mainInitializers gpio = concatMap initializeSingle $ switchpins gpio --- where --- initializeSingle :: (Word8, Ident) -> [Initializer] --- initializeSingle (i, id) = --- let ref = makeStaticRef id $ mkReference TBool --- in [Normal ref, StaticInput (Switch i) ref] - -{- | Create an initial GPIO Peripheral description. In the initial description, no GPIO -pins are used. -} -emptyGPIOPeripheral :: GPIOPeripheral -emptyGPIOPeripheral = GPIOPeripheral Map.empty - --- | Add a switch to a `GPIOPeripheral` and get the new peripheral back. -addSwitchGPIO :: Word8 -> Ident -> GPIOPeripheral -> GPIOPeripheral -addSwitchGPIO i id p = case Map.lookup i (switchpins' p) of - Just _ -> error $ concat - [ "SSM.Core.Peripheral.GPIO error: attempt to add switch " - , show i - , " but that switch has already been initialized" - ] - Nothing -> p { switchpins' = Map.insert i id (switchpins' p) } - --- | Get the switch GPIO pins from a `GPIOPeripheral` -switchpins :: GPIOPeripheral -> [(Word8, Ident)] -switchpins gp = Map.toList $ switchpins' gp diff --git a/ssm/SSM/Core/Peripheral/Identity.hs b/ssm/SSM/Core/Peripheral/Identity.hs deleted file mode 100644 index f15cc1e9..00000000 --- a/ssm/SSM/Core/Peripheral/Identity.hs +++ /dev/null @@ -1,53 +0,0 @@ -{- | This module implements an identity peripheral. This is a peripheral that has no side -effects. It is suitable for declaring references that should exist in the global scope -rather than in the context of an activation record. -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -module SSM.Core.Peripheral.Identity where - -import SSM.Core.Ident -import SSM.Core.Peripheral -import SSM.Core.Reference -import SSM.Core.Type -import SSM.Core.Backend - -import qualified Data.Map as Map - -import Language.C.Quote.GCC -import qualified Language.C.Syntax as C - -modulename :: String -modulename = "SSM.Core.Peripheral.Identity" - -data IdentityPeripheral = IdentityPeripheral - { identitySVs :: (Map.Map Ident Type) - } - deriving (Show, Eq) - -instance IsPeripheral C IdentityPeripheral where --- type Definition C = [C.Definition] --- type Initialization C = [C.BlockItem] - --- instance IsPeripheral IdentityPeripheral where --- declaredReferences ip = --- map (uncurry makeStaticRef) $ Map.toList $ identitySVs ip --- mainInitializers ip = --- map (Normal . uncurry makeStaticRef) $ Map.toList $ identitySVs ip - -emptyIdentityPeripheral :: IdentityPeripheral -emptyIdentityPeripheral = IdentityPeripheral Map.empty - -getIdentitySVs :: IdentityPeripheral -> [(Ident, Type)] -getIdentitySVs = Map.toList . identitySVs - -addIdentitySV :: Ident -> Type -> IdentityPeripheral -> IdentityPeripheral -addIdentitySV id t ip = if Map.member id $ identitySVs ip - then error $ concat - [ modulename - , ".addIdentitySV error ---\n" - , "reference name " - , identName id - , "already registered" - ] - else ip { identitySVs = Map.insert id t $ identitySVs ip } diff --git a/ssm/SSM/Core/Peripheral/LED.hs b/ssm/SSM/Core/Peripheral/LED.hs deleted file mode 100644 index 702eb17d..00000000 --- a/ssm/SSM/Core/Peripheral/LED.hs +++ /dev/null @@ -1,74 +0,0 @@ -{- | Core representation of LED peripherals. -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -module SSM.Core.Peripheral.LED where - -import SSM.Core.Ident ( Ident ) -import SSM.Core.Peripheral ( Initializer(Normal) - , IsPeripheral(..) - ) -import SSM.Core.Reference ( makeStaticRef ) -import SSM.Core.Type ( Type(TBool) - , mkReference - ) -import SSM.Core.Backend - -import qualified Data.Map as Map -import Data.Word ( Word8 ) - -import Language.C.Quote.GCC -import qualified Language.C.Syntax as C - --- | LED peripherals -data LEDPeripheral = LEDPeripheral - { -- | Associate LED IDs with reference identifiers - onoffLEDs' :: Map.Map Word8 Ident - } - deriving (Eq, Show) - - --- instance IsPeripheral C LEDPeripheral where --- type Definition C = () --- type Initialization C = () - -instance IsPeripheral C LEDPeripheral where --- type Definition C = [C.Definition] --- type Initialization C = [C.BlockItem] - --- declaredReferences _ lp = --- map (flip makeStaticRef (mkReference TBool) . snd) $ onoffLEDs lp - --- globalDeclarations _ _ = [] - --- staticInitialization _ lp = flip map (onoffLEDs lp) $ \(_, id) -> --- undefined - --- -- | `IsPeripheral` instance for `LEDPeripheral`, so that we can compile `LEDPeripheral`s. --- instance IsPeripheral LEDPeripheral where --- declaredReferences lp = --- map (flip makeStaticRef (mkReference TBool) . snd) $ onoffLEDs lp - --- mainInitializers lp = concatMap initializeSingle $ onoffLEDs lp --- where --- initializeSingle :: (Word8, Ident) -> [Initializer] --- initializeSingle (_, id) = --- let ref = makeStaticRef id $ mkReference TBool in [Normal ref] - --- | Create an initial LED peripheral -emptyLEDPeripheral :: LEDPeripheral -emptyLEDPeripheral = LEDPeripheral Map.empty - --- | Register a new ON-OFF LED -addOnOffLED :: Word8 -> Ident -> LEDPeripheral -> LEDPeripheral -addOnOffLED i id lp = case Map.lookup i (onoffLEDs' lp) of - Just _ -> error $ concat - [ "SSM.Core.Peripheral.LED error: attempt to initialize LED " - , show i - , "but that LED has already been initialized" - ] - Nothing -> lp { onoffLEDs' = Map.insert i id $ onoffLEDs' lp } - --- | Get all ON-OFF LEDs -onoffLEDs :: LEDPeripheral -> [(Word8, Ident)] -onoffLEDs lp = Map.toList $ onoffLEDs' lp diff --git a/ssm/SSM/Core/Program.hs b/ssm/SSM/Core/Program.hs index 377efc14..f83fb224 100644 --- a/ssm/SSM/Core/Program.hs +++ b/ssm/SSM/Core/Program.hs @@ -12,12 +12,13 @@ module SSM.Core.Program , entry , Program(..) , SSMProgram(..) + , Handler(..) ) where import SSM.Core.Backend ( Schedule ) import SSM.Core.Ident ( Ident ) -import SSM.Core.Peripheral ( Peripheral, Handler ) +import SSM.Core.Peripheral ( Peripheral ) import SSM.Core.Reference ( Reference ) import SSM.Core.Syntax ( SSMExp , Stm @@ -43,16 +44,20 @@ data QueueContent backend arguments. The constructor looks like this, however, in preparation for any future changes we might want to make. I might remove this second argument... -} = SSMProcedure Ident [Either SSMExp Reference] --- | Handler Handler -- ^ Handlers can be scheduled - | Handler (Int -> Int -> Schedule backend) + | OutputHandler (Handler backend) + +data Handler backend = + Handler { gen_handler :: Int -> Int -> [Schedule backend] + , pretty_handler :: String + } instance Show (QueueContent backend) where show (SSMProcedure id args) = "SSMProcedure " <> show id <> " " <> show args - show (Handler _) = "" + show (OutputHandler _) = "" instance Eq (QueueContent backend) where SSMProcedure id1 args1 == SSMProcedure id2 args2 = id1 == id2 && args1 == args2 - Handler _ == Handler _ = undefined -- TODO + OutputHandler _ == OutputHandler _ = undefined -- TODO {- | Get the identifier of the SSM procedure that is scheduled at the start of a SSM program -} diff --git a/ssm/SSM/FreqGen.hs b/ssm/SSM/FreqGen.hs index cffa643d..43784c27 100644 --- a/ssm/SSM/FreqGen.hs +++ b/ssm/SSM/FreqGen.hs @@ -37,6 +37,7 @@ for details. -} import Prelude +import SSM.Core.Backend import SSM.Compile import SSM.Language import SSM.Pretty @@ -45,10 +46,9 @@ import Data.Word import SSM.Frontend.Peripheral.GPIO import SSM.Frontend.Peripheral.Identity -import SSM.Frontend.Peripheral.LED -buttonHandler :: (?sw0::Ref SW, ?sw1::Ref SW) => Ref Word64 -> SSM () +buttonHandler :: (?sw0::Ref Switch, ?sw1::Ref Switch) => Ref Word64 -> SSM () buttonHandler period = routine $ while true $ do wait (?sw0, ?sw1) -- Nit: using parens for each branch is annoying @@ -56,24 +56,24 @@ buttonHandler period = routine $ while true $ do then period <~ deref period * 2 else period <~ max' (deref period /. 2) 1 -freqGen :: (?led0::Ref LED) => Ref Word64 -> SSM () +freqGen :: (?led0::Ref GPIO) => Ref Word64 -> SSM () freqGen period = routine $ while true $ do after (nsecs $ deref period) ?led0 (not' $ deref ?led0) wait ?led0 -- Nit: implicit params aren't transitive, must be declared by caller -entry :: (?sw0::Ref SW, ?sw1::Ref SW, ?led0::Ref LED) => SSM () +entry :: (?sw0::Ref Switch, ?sw1::Ref Switch, ?led0::Ref GPIO) => SSM () entry = routine $ do -- Nit: can't construct Ref SSMTime? Marshalling to/from ns is really annoying -- and seems error-prone. period <- var $ time2ns $ secs 1 fork [freqGen period, buttonHandler period] -compiler :: Compile backend () +compiler :: Compile C () compiler = do - switch0 <- switch 0 - switch1 <- switch 1 - (led, handler) <- onoffLED 0 + switch0 <- input 0 + switch1 <- input 1 + (led, handler) <- output 0 let ?led0 = led ?sw0 = switch0 diff --git a/ssm/SSM/Freqmime.hs b/ssm/SSM/Freqmime.hs index 2db6618b..208faed8 100644 --- a/ssm/SSM/Freqmime.hs +++ b/ssm/SSM/Freqmime.hs @@ -13,121 +13,36 @@ import SSM.Compile import SSM.Language import SSM.Pretty import qualified SSM.Core as C +import SSM.Core.Backend import Data.Word import SSM.Frontend.Peripheral.BasicBLE import SSM.Frontend.Peripheral.GPIO import SSM.Frontend.Peripheral.Identity -import SSM.Frontend.Peripheral.LED --- gate_period :: Exp Time --- gate_period = secs 1 --- blink_time :: Exp Time --- blink_time = msecs 100 - --- type Frequency = Word64 - --- freq_count :: Ref SW -> Ref SW -> Ref Frequency -> SSM () --- freq_count = --- box "freq_count" ["gate", "signal", "freq"] $ \gate signal freq -> do --- wake <- var event' --- count <- var 0 --- while true' $ do --- ifThen (unchanged gate) $ do --- wait gate - --- ifThenElse (changed signal) (count <~ 1) (count <~ 0) --- after gate_period wake event' - --- doWhile --- (do --- wait (signal, wake) --- count <~ (deref count + 1) --- ) --- (unchanged wake) - --- freq <~ (deref count * time2ns (secs 1 /. gate_period)) - --- freq_mime :: Ref Frequency -> Ref LED -> SSM () --- freq_mime = box "freq_mime" ["freq", "led_ctl"] $ \freq led_ctl -> do --- wake <- var event' --- while true' $ do - --- ifThen (deref freq /=. 0) $ do --- led_ctl <~ true' --- after (secs 1 /. (nsecs $ deref freq)) wake event' - --- wait (wake, freq) - --- one_shot :: Ref Frequency -> Ref LED -> SSM () --- one_shot = box "one_shot" ["freq", "led_ctl"] $ \freq led_ctl -> do --- while true' $ do --- wait led_ctl - --- -- try to calculate delay for when it should turn off --- -- delay will be stored in @delay@ as nanoseconds --- delay <- var 0 --- ifThenElse --- (deref freq /=. 0) --- ( delay --- <~ (time2ns $ lift2T min' blink_time (secs 1 // deref freq // 2) --- ) --- ) --- (delay <~ time2ns blink_time) - --- ifThen (deref led_ctl) $ do --- after (nsecs $ deref delay) led_ctl false' - --- mmain :: (?sw0::Ref SW, ?sw1::Ref SW, ?led_ctl::Ref Bool) => SSM () --- mmain = boxNullary "mmain" $ do --- freq <- var $ u64 0 --- fork --- [ freq_count ?sw0 ?sw1 freq --- , freq_mime freq ?led_ctl --- , one_shot freq ?led_ctl --- ] - --- testprogram :: Compile () --- testprogram = do --- x <- switch 0 --- y <- switch 1 --- (z, handler) <- onoffLED 0 - --- let ?sw0 = x --- ?sw1 = y --- ?led_ctl = z - --- schedule mmain --- schedule handler - - - - - - -mmmain :: Compile backend () +mmmain :: Compile C () mmmain = do - (x, handler) <- onoffLED 0 + (x, handler) <- output 0 let ?led = x schedule handler schedule mmain where - mmain :: (?led::Ref LED) => SSM () + mmain :: (?led::Ref GPIO) => SSM () mmain = boxNullary "mmain" $ do while true $ do - after (secs 1) ?led on + after (secs 1) ?led high wait ?led - after (secs 1) ?led off + after (secs 1) ?led low wait ?led -testGlobal :: forall backend . Compile backend () +testGlobal :: Compile C () testGlobal = do - x <- global @backend @Word8 - y <- global @backend @Word64 + x <- global @C @Word8 + y <- global @C @Word64 let ?x = x ?y = y @@ -265,13 +180,14 @@ Arguments are 1. ID of this source device 2. ID of the next device -} -source :: Exp Word64 -> Exp Word64 -> Compile backend () +source :: Exp Word64 -> Exp Word64 -> Compile C () source this next = do - (ble, broadcast, scanning) <- enableBasicBLE + (ble, broadcast, broadcastControl, scanning) <- enableBLE let ?ble = ble schedule sourceCommunication schedule broadcast + schedule broadcastControl schedule scanning where sourceCommunication :: (?ble :: BBLE) => SSM () @@ -292,13 +208,14 @@ Arguments are: 2. ID of previous device 3. ID of next device -} -relay :: Exp Word64 -> Exp Word64 -> Exp Word64 -> Compile backend () +relay :: Exp Word64 -> Exp Word64 -> Exp Word64 -> Compile C () relay this previous next = do - (ble, broadcast, scanning) <- enableBasicBLE + (ble, broadcast, broadcastControl, scanning) <- enableBLE let ?ble = ble schedule relayMessage schedule broadcast + schedule broadcastControl schedule scanning where relayMessage :: (?ble :: BBLE) => SSM () @@ -321,14 +238,14 @@ relay this previous next = do {-****** Devie 4 (the sink) ******-} -sink :: Exp Word64 -> Compile backend () +sink :: Exp Word64 -> Compile C () sink this = do - (ble, broadcast, scanning) <- enableBasicBLE + (ble, broadcast, broadcastControl, scanning) <- enableBLE - (led0, lh0) <- onoffLED 0 - (led1, lh1) <- onoffLED 1 - (led2, lh2) <- onoffLED 2 - (led3, lh3) <- onoffLED 3 + (led0, lh0) <- output 0 + (led1, lh1) <- output 1 + (led2, lh2) <- output 2 + (led3, lh3) <- output 3 let ?ble = ble ?led0 = led0 @@ -342,13 +259,14 @@ sink this = do schedule lh2 schedule lh3 schedule broadcast + schedule broadcastControl schedule scanning where theSink :: ( ?ble :: BBLE - , ?led0 :: Ref LED - , ?led1 :: Ref LED - , ?led2 :: Ref LED - , ?led3 :: Ref LED + , ?led0 :: Ref GPIO + , ?led1 :: Ref GPIO + , ?led2 :: Ref GPIO + , ?led3 :: Ref GPIO ) => SSM () theSink = boxNullary "theSink" $ do while true $ do @@ -375,10 +293,10 @@ sink this = do -- acknowledge message fork [acknowledge this from 0 ab] - ledBlinker :: Ref LED -> SSM () + ledBlinker :: Ref GPIO -> SSM () ledBlinker = box "ledBlinker" ["led"] $ \led -> do - assign led on - after (secs 1) led off + assign led high + after (secs 1) led low wait led switchCase :: SSMType a => Exp a -> [(Exp a, SSM ())] -> SSM () @@ -421,10 +339,10 @@ test2 = boxNullary "test2" $ do -buttonBlinky :: Compile backend () +buttonBlinky :: Compile C () buttonBlinky = do - button <- switch 0 - (led, ledHandler) <- onoffLED 0 + button <- input 0 + (led, ledHandler) <- output 0 let ?led = led ?button = button @@ -434,7 +352,7 @@ buttonBlinky = do where - program :: (?led :: Ref LED, ?button :: Ref SW) => SSM () + program :: (?led :: Ref GPIO, ?button :: Ref Switch) => SSM () program = boxNullary "program" $ do while true $ do wait ?button diff --git a/ssm/SSM/FrequencyMime.hs b/ssm/SSM/FrequencyMime.hs index 3c33e9f7..cc04226f 100644 --- a/ssm/SSM/FrequencyMime.hs +++ b/ssm/SSM/FrequencyMime.hs @@ -5,11 +5,11 @@ module SSM.FrequencyMime where import Prelude +import SSM.Core.Backend import SSM.Language import SSM.Frontend.Peripheral.GPIO import SSM.Frontend.Peripheral.Identity -import SSM.Frontend.Peripheral.LED import SSM.Frontend.Peripheral.BasicBLE import Data.Word @@ -39,20 +39,20 @@ bleHandler period = routine $ do delay (secs 5) -- generate the frequency -freqGen :: (?led0::Ref LED) => Ref Time -> SSM () +freqGen :: (?led0::Ref GPIO) => Ref Time -> SSM () freqGen period = routine $ while true $ do after (deref period) ?led0 (not' $ deref ?led0) wait ?led0 -entry :: (?ble :: BBLE, ?led0::Ref LED) => SSM () +entry :: (?ble :: BBLE, ?led0::Ref GPIO) => SSM () entry = routine $ do period <- var $ secs 1 fork [freqGen period, bleHandler period] -generator :: Compile backend () +generator :: Compile C () generator = do - (led, handler) <- onoffLED 0 - (ble, broadcast, scanning) <- enableBasicBLE + (led, handler) <- output 0 + (ble, broadcast, broadcastControl, scanning) <- enableBLE let ?led0 = led ?ble = ble @@ -60,13 +60,14 @@ generator = do schedule handler schedule entry schedule broadcast + schedule broadcastControl schedule scanning -- frequency counter {- | Count the frequency on the specified gpio and write the measured period to the reference @period@. -} -freqCount :: Ref SW -> Ref Time -> SSM () +freqCount :: Ref Switch -> Ref Time -> SSM () freqCount sw period = routine $ do gate <- var event count <- var $ u64 0 @@ -86,7 +87,7 @@ freqCount sw period = routine $ do else count <~ deref count + 1 wait (gate, sw) -freqCount2 :: Ref SW -> Ref Time -> SSM () +freqCount2 :: Ref Switch -> Ref Time -> SSM () freqCount2 sw period = routine $ while true $ do period <~ (msecs 200) delay (secs 5) @@ -101,19 +102,20 @@ broadcastCount count = routine $ while true $ do disableBroadcast -- | Entry-point for the frequency counter -counterEntry :: (?ble :: BBLE, ?sw :: Ref SW) => SSM () +counterEntry :: (?ble :: BBLE, ?sw :: Ref Switch) => SSM () counterEntry = routine $ do count <- var $ secs 1 fork [ freqCount2 ?sw count, broadcastCount count ] -counter :: Compile backend () +counter :: Compile C () counter = do - sw <- switch 0 - (ble, broadcast, scanning) <- enableBasicBLE + sw <- input 0 + (ble, broadcast, broadcastControl, scanning) <- enableBLE let ?sw = sw ?ble = ble schedule counterEntry schedule broadcast + schedule broadcastControl schedule scanning diff --git a/ssm/SSM/Frontend/Compile.hs b/ssm/SSM/Frontend/Compile.hs index ea976c84..82350207 100644 --- a/ssm/SSM/Frontend/Compile.hs +++ b/ssm/SSM/Frontend/Compile.hs @@ -52,7 +52,7 @@ instance SSMProgram backend (Compile backend ()) where in Program (reverse $ SSM.Frontend.Compile.initialQueueContent s) f $ Map.elems (SSM.Frontend.Compile.peripherals s) -data OutputHandler backend = OutputHandler (Int -> Int -> Schedule backend) +type OutputHandler backend = Handler backend class Schedulable backend a where schedule :: a -> Compile backend () @@ -61,10 +61,10 @@ instance Schedulable backend (SSM ()) where schedule = scheduleSSM instance Schedulable backend (OutputHandler backend) where - schedule (OutputHandler f) = do + schedule h{-(Handler f)-} = do st <- get let queuecontents = SSM.Frontend.Compile.initialQueueContent st - newcontent = Handler f + newcontent = OutputHandler h combined = newcontent : queuecontents put $ st { SSM.Frontend.Compile.initialQueueContent = combined } diff --git a/ssm/SSM/Frontend/NewPeripheral/GPIO.hs b/ssm/SSM/Frontend/NewPeripheral/GPIO.hs deleted file mode 100644 index 7c42f627..00000000 --- a/ssm/SSM/Frontend/NewPeripheral/GPIO.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE FlexibleContexts #-} -module SSM.Frontend.NewPeripheral.GPIO where - -import SSM.Core ( C - , Ident - , dereference - , Type - , makeStaticRef - , refName - , refType - , IsPeripheral(..) - , Peripheral(..) - , makeIdent - ) -import SSM.Core.Backend - -import SSM.Backend.C.Identifiers -import SSM.Backend.C.Types ( svt_ - , initialize_ - , assign_ - ) - -import SSM.Frontend.Ref ( Ref(..) ) -import SSM.Frontend.Compile -import SSM.Frontend.Syntax - -import Data.Proxy ( Proxy(Proxy) ) -import Data.Word ( Word8 ) -import qualified Data.Map as Map - -import Control.Monad.State ( MonadState(put, get) ) - -import Language.C.Quote.GCC ( cedecl, cexp, citem, citems ) -import qualified Language.C.Syntax as C - --- | The GPIO datatype represents the GPIO pins we have requested from the environment -data GPIOP = GPIOP { pins :: Map.Map Word8 (Ident, Type)} - deriving (Show, Eq) - --- | Create an empty GPIO peripheral -emptyGPIO :: GPIOP -emptyGPIO = GPIOP { pins = Map.empty } - -instance IsPeripheral C GPIOP where - declareReference _ t id i gpio = gpio { pins = Map.insert i (id,t) (pins gpio) } - - declaredReferences _ gpio = - map (uncurry makeStaticRef) $ Map.elems $ pins gpio - - globalDeclarations p gpio = - flip map (declaredReferences p gpio) $ \ref -> - [cedecl| $ty:(svt_ $ dereference $ refType ref) $id:(refName ref); |] - - staticInitialization p gpio = flip concatMap (declaredReferences p gpio) $ \ref -> - let bt = dereference $ refType ref - init = initialize_ bt [cexp| &$id:(refName ref)|] - assign = assign_ bt [cexp| &$id:(refName ref)|] [cexp|0|] [cexp|0|] - in [citems| $exp:init; $exp:assign; |] - -type GPIO = Bool - -{- | Populates the GPIO pripheral with a new reference. - -Parameters: - - 1. @Word8@ that identifies the GPIO pin on the board - 2. The name of the reference - -Returns: The @Ref LED@ that represents the newly created reference. -} -insertGPIO :: forall backend - . IsPeripheral backend GPIOP - => Word8 -> Ident -> Compile backend (Ref GPIO) -insertGPIO i id = do - st <- get - - -- fetch the GPIO peripheral and populate it with the new reference - let maybegpio = Map.lookup "gpio" (peripherals st) - emptyperi = Peripheral @backend emptyGPIO - m = maybe emptyperi (\x -> x) maybegpio - m' = declareReference (Proxy @backend) typ id i m - - -- modify the @CompileSt@ to contain the updated GPIO peripheral - put $ st { peripherals = Map.insert "gpio" m' (peripherals st)} - - -- create the reference and return it - let ref = makeStaticRef id typ - return $ Ptr ref - where - -- | GPIO pins have a binary state, so treating them like @Bool@s seems reasonable - typ :: Type - typ = Ref TBool - -class GPIOHandler backend where - make_handler :: proxy backend -> Ref GPIO -> Word8 -> OutputHandler backend - -instance GPIOHandler C where - make_handler _ (Ptr r) i = OutputHandler $ \k cs -> - let (prio,dep) = pdep k cs priority_at_root depth_at_root - in [citem| $id:initialize_static_output_device( $id:top_parent - , $exp:prio - , $exp:dep - , &$id:(refName r).sv - , $uint:i); |] - -{- | Ask the GPIO peripheral for a GPIO pin identified by the @Word8@, and -get the reference and handler back. The reference is what is used to interact -with the GPIO, and the handler must be `schedule`d in order to actually -perform the IO output actions. -} -gpio :: forall backend . - (IsPeripheral backend GPIOP, GPIOHandler backend) - => Word8 -> Compile backend (Ref GPIO, OutputHandler backend) -gpio i = do - n <- fresh - let id = makeIdent n - - ref <- insertGPIO i id - - let handler = make_handler (Proxy @backend) ref i - - return (ref, handler) diff --git a/ssm/SSM/Frontend/Peripheral/BasicBLE.hs b/ssm/SSM/Frontend/Peripheral/BasicBLE.hs index 00621f8a..ffb2e6dc 100644 --- a/ssm/SSM/Frontend/Peripheral/BasicBLE.hs +++ b/ssm/SSM/Frontend/Peripheral/BasicBLE.hs @@ -1,90 +1,122 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} module SSM.Frontend.Peripheral.BasicBLE - ( BBLE - , enableBasicBLE - , enableBroadcast - , disableBroadcast - , enableScan - , disableScan - , scanref - ) where - -import SSM.Core.Ident -import SSM.Core.Peripheral -import SSM.Core.Peripheral.BasicBLE - hiding ( broadcast - , broadcastControl - , scan - , scanControl - ) -import SSM.Core.Reference hiding ( Ref ) -import SSM.Core.Type - -import SSM.Frontend.Compile -import SSM.Frontend.Language -import SSM.Frontend.Ref -import SSM.Frontend.Syntax - -import Data.Word - -import Control.Monad.State - -{- | Enable the basic BLE device. The returned components are - - 1. An object that can be used together with `enableScan`, `disableScan`, - `enableBroadcast`, `disableBroadcast` and `scanref` to interact with the underlying - BLE device. - 2. A hander that has to be scheduled for the `enableBroadcast` & `disableBroadcast` - calls to function. - 3. A handler that must be scheduled for the `enableScan` and `disableScan` calls to - function. The handler can only be acquired by applying this component to a string that - describes the remote devices MAC address as a string of hex octets, separated by colon. - E.g "AB:CD:EF:01:23:54" --} -enableBasicBLE :: Compile backend (BBLE, SSM (), SSM ()) -enableBasicBLE = do - let basicble = enableBLE broadcast broadcastControl scan scanControl - --modify $ \s -> s { basicblePeripheral = Just basicble } - - let scanref = makeStaticRef' scan - broadcastref = makeStaticRef' broadcast - scanControlref = makeStaticRef' scanControl - broadcastControlref = makeStaticRef' broadcastControl - bble = BBLE { scan = Ptr $ scanref - , broadcast = Ptr $ broadcastref - , scanControl = Ptr $ scanControlref - , broadcastControl = Ptr $ broadcastControlref - } - broadcastHandler = undefined - -- do - -- emit $ Handler $ Output (BLE Broadcast) broadcastref - -- emit $ Handler $ Output (BLE BroadcastControl) broadcastControlref - scanControlHandler = undefined - -- emit $ Handler $ Output (BLE ScanControl) scanControlref - - return (bble, broadcastHandler, scanControlHandler) + ( BBLE + , enableBLE + , enableBroadcast + , disableBroadcast + , enableScan + , disableScan + , scanref + ) where - scan :: (Ident, Type) - scan = (Ident "scan" Nothing, Ref TUInt64) - broadcast :: (Ident, Type) - broadcast = (Ident "broadcast" Nothing, Ref TUInt64) - - scanControl :: (Ident, Type) - scanControl = (Ident "scanControl" Nothing, Ref TBool) - - broadcastControl :: (Ident, Type) - broadcastControl = (Ident "broadcastControl" Nothing, Ref TBool) - - makeStaticRef' :: (Ident, Type) -> Reference - makeStaticRef' = uncurry makeStaticRef +import SSM.Core hiding (BasicBLE(..), peripherals, enableBLE) + +import SSM.Backend.C.Identifiers +import SSM.Backend.C.Types + +import SSM.Frontend.Compile +import SSM.Frontend.Ref +import SSM.Language + +import Data.Proxy +import Data.Word +import qualified Data.Map as Map + +import Control.Monad.State + +import Language.C.Quote.GCC ( cedecl, cexp, citem, citems ) +import qualified Language.C.Syntax as C + +data BasicBLE = BasicBLE + { broadcast_ :: (Ident, Type) + , broadcastControl_ :: (Ident, Type) + , scan_ :: (Ident, Type) + , scanControl_ :: (Ident, Type) + } + deriving (Show, Eq) + +initBasicBLE :: BasicBLE +initBasicBLE = BasicBLE + { broadcast_ = (makeIdent "broadcast", Ref TUInt64) + , broadcastControl_ = (makeIdent "broadcastControl", Ref TBool) + , scan_ = (makeIdent "scan", Ref TUInt64) + , scanControl_ = (makeIdent "scanControl", Ref TBool) + } + +instance IsPeripheral C BasicBLE where + declareReference _ _ id _ _ = error "error --- declareReference BasicBLE called" + declaredReferences _ bble = map + (\f -> uncurry makeStaticRef $ f bble) + [broadcast_, broadcastControl_, scan_, scanControl_] + + globalDeclarations p bble = flip map (declaredReferences p bble) $ \ref -> do + [cedecl| $ty:(svt_ $ dereference $ refType ref) $id:(refName ref); |] + + staticInitialization p bble = + let enable = [cexp| $id:enable_ble_stack() |] + scanref = uncurry makeStaticRef (scan_ bble) + scaninit = [cexp| $id:initialize_static_input_ble_scan_device(&$id:(refName scanref).sv) |] + in [citems| $exp:enable; $exp:scaninit; |] + +class BLEHandlers backend where + broadcastHandler :: proxy backend -> BasicBLE -> Handler backend + broadcastControlHandler :: proxy backend -> BasicBLE -> Handler backend + scanControlHandler :: proxy backend -> BasicBLE -> Handler backend + +instance BLEHandlers C where + broadcastHandler _ bble = Handler + (\k cs -> + let (prio,dep) = pdep k cs priority_at_root depth_at_root + proto = initialize_static_output_ble_broadcast_device + refname = identName $ fst $ broadcast_ bble + in [[citem| $id:proto(&$id:(refname).sv); |]]) + (concat [ "bind_static_ble_broadcast_handler_device(" + , identName $ fst $ broadcast_ bble + , ")"]) + + broadcastControlHandler _ bble = Handler + (\k cs -> + let (prio,dep) = pdep k cs priority_at_root depth_at_root + proto = initialize_static_output_ble_broadcast_control_device + refname = identName $ fst $ broadcastControl_ bble + in [[citem| $id:proto(&$id:(refname).sv); |]]) + (concat [ "bind_static_ble_broadcast_control_handler_device(" + , identName $ fst $ broadcastControl_ bble + , ")"]) + + scanControlHandler _ bble = Handler + (\k cs -> + let (prio,dep) = pdep k cs priority_at_root depth_at_root + proto = initialize_static_output_ble_scan_control_device + refname = identName $ fst $ scanControl_ bble + in [[citem| $id:proto(&$id:(refname).sv); |]]) + (concat [ "bind_static_ble_scan_control_handler_device(" + , identName $ fst $ scanControl_ bble + , ")"]) + +-- frontend api of BBLE data BBLE = BBLE - { scan :: Ref Word64 - , broadcast :: Ref Word64 - , scanControl :: Ref Bool - , broadcastControl :: Ref Bool - } + { broadcast :: Ref Word64 + , broadcastControl :: Ref Bool + , scan :: Ref Word64 + , scanControl :: Ref Bool + } + +createBBLE :: BasicBLE -> BBLE +createBBLE bble = BBLE + { broadcast = Ptr $ uncurry makeStaticRef $ broadcast_ bble + , broadcastControl = Ptr $ uncurry makeStaticRef $ broadcastControl_ bble + , scan = Ptr $ uncurry makeStaticRef $ scan_ bble + , scanControl = Ptr $ uncurry makeStaticRef $ scanControl_ bble + } -- | Enable the BLE scanning device enableScan :: (?ble :: BBLE) => SSM () @@ -113,3 +145,19 @@ toggleControl :: Ref Bool -> Exp Bool -> SSM () toggleControl ctrl command = do after (nsecs 1) ctrl command wait ctrl + +bblekey :: String +bblekey = "bblekey" + +enableBLE :: forall backend . (IsPeripheral backend BasicBLE, BLEHandlers backend) => Compile backend (BBLE, OutputHandler backend, OutputHandler backend, OutputHandler backend) +enableBLE = do + modify $ \st -> st { + peripherals = Map.insert bblekey (Peripheral initBasicBLE) (peripherals st) } + + let ble = initBasicBLE + broadcastH = broadcastHandler (Proxy @backend) ble + broadcastControlH = broadcastControlHandler (Proxy @backend) ble + scanControlH = scanControlHandler (Proxy @backend) ble + bble = createBBLE initBasicBLE + + return (bble, broadcastH, broadcastControlH, scanControlH) diff --git a/ssm/SSM/Frontend/Peripheral/GPIO.hs b/ssm/SSM/Frontend/Peripheral/GPIO.hs index 1114defa..900cf716 100644 --- a/ssm/SSM/Frontend/Peripheral/GPIO.hs +++ b/ssm/SSM/Frontend/Peripheral/GPIO.hs @@ -1,36 +1,219 @@ -module SSM.Frontend.Peripheral.GPIO where +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +module SSM.Frontend.Peripheral.GPIO + ( output + , input + , GPIO + , Switch + , high + , low + , GPIOHandler + ) + where -import SSM.Core.Peripheral.GPIO -import SSM.Core.Syntax hiding ( gpioperipherals ) +import SSM.Core ( C + , Ident + , dereference + , Type + , makeStaticRef + , refName + , refType + , IsPeripheral(..) + , Peripheral(..) + , makeIdent + , Handler(..) + ) +import SSM.Core.Backend + +import SSM.Backend.C.Identifiers +import SSM.Backend.C.Types ( svt_ + , initialize_ + , assign_ + ) + +import SSM.Frontend.Ref ( Ref(..) ) import SSM.Frontend.Compile -import SSM.Frontend.Exp -import SSM.Frontend.Language -import SSM.Frontend.Ref import SSM.Frontend.Syntax +import SSM.Frontend.Language + +import Data.Proxy ( Proxy(Proxy) ) +import Data.Word ( Word8 ) +import qualified Data.Map as Map + +import Control.Monad.State ( MonadState(put, get) ) + +import Language.C.Quote.GCC ( cedecl, cexp, citem, citems ) +import qualified Language.C.Syntax as C + +---------- GPIO Output ---------- + +-- | The GPIO datatype represents the GPIO pins we have requested from the environment +data GPIOutput = GPIOutput { output_ :: Map.Map Word8 (Ident, Type)} + deriving (Show, Eq) + +-- | Create an empty GPIO peripheral +emptyGPIOutput :: GPIOutput +emptyGPIOutput = GPIOutput { output_ = Map.empty } -import Control.Monad.State +instance IsPeripheral C GPIOutput where + declareReference _ t id i gpio = gpio { output_ = Map.insert i (id,t) (output_ gpio) } -import Data.Word + declaredReferences _ gpio = + map (uncurry makeStaticRef) $ Map.elems $ output_ gpio + + globalDeclarations p gpio = + flip map (declaredReferences p gpio) $ \ref -> + [cedecl| $ty:(svt_ $ dereference $ refType ref) $id:(refName ref); |] -{- | A switch can provide input that is either high or low, so we use a @Bool@ to model -this binary state. It would perhaps improve readabilty to change this to a dedicated -datatype with states @HIGH@ and @LOW@ later on down the road when we have support for -user defined ADTs. -} -type SW = Bool + staticInitialization p gpio = flip concatMap (declaredReferences p gpio) $ \ref -> + let bt = dereference $ refType ref + init = initialize_ bt [cexp| &$id:(refName ref)|] + assign = assign_ bt [cexp| &$id:(refName ref)|] [cexp|0|] [cexp|0|] + in [citems| $exp:init; $exp:assign; |] --- | Is a @Ref SW@ high? -isHigh :: Ref SW -> Exp Bool -isHigh = deref +gpioutputkey :: String +gpioutputkey = "gpioutput" --- | Is a @Ref SW@ low? -isLow :: Ref SW -> Exp Bool -isLow = not' . isHigh +type GPIO = Bool --- | Create a @Ref SW@ by identifying a GPIO pin with a unique ID. E.g GPIO 1. -switch :: Word8 -> Compile backend (Ref SW) -switch i = do +{- | Populates the GPIO pripheral with a new reference. + +Parameters: + + 1. @Word8@ that identifies the GPIO pin on the board + 2. The name of the reference + +Returns: The @Ref LED@ that represents the newly created reference. -} +insertGPIOutput :: forall backend + . IsPeripheral backend GPIOutput + => Word8 -> Ident -> Compile backend (Ref GPIO) +insertGPIOutput i id = do + st <- get + + -- fetch the GPIO peripheral and populate it with the new reference + let maybegpio = Map.lookup gpioutputkey (peripherals st) + emptyperi = Peripheral @backend emptyGPIOutput + m = maybe emptyperi (\x -> x) maybegpio + m' = declareReference (Proxy @backend) typ id i m + + -- modify the @CompileSt@ to contain the updated GPIO peripheral + put $ st { peripherals = Map.insert gpioutputkey m' (peripherals st)} + + -- create the reference and return it + let ref = makeStaticRef id typ + return $ Ptr ref + where + -- | GPIO pins have a binary state, so treating them like @Bool@s seems reasonable + typ :: Type + typ = Ref TBool + +class GPIOHandler backend where + make_handler :: proxy backend -> Ref GPIO -> Word8 -> OutputHandler backend + +instance GPIOHandler C where + make_handler _ (Ptr r) i = + let sched k cs = let (prio, dep) = pdep k cs priority_at_root depth_at_root + in [[citem| $id:initialize_static_output_device( + $id:top_parent, + $exp:prio, + $exp:dep, + &$id:(refName r).sv, + $uint:i);|]] + pretty = concat ["initialize_static_output_device(", refName r, ", ", show i, ")"] + in Handler sched pretty + +{- | Ask the GPIO peripheral for a GPIO pin identified by the @Word8@, and +get the reference and handler back. The reference is what is used to interact +with the GPIO, and the handler must be `schedule`d in order to actually +perform the IO output actions. -} +output :: forall backend . + (IsPeripheral backend GPIOutput, GPIOHandler backend) + => Word8 -> Compile backend (Ref GPIO, OutputHandler backend) +output i = do n <- fresh - let id = Ident n Nothing - -- modify $ \st -> - -- st { gpioperipherals = addSwitchGPIO i id (gpioperipherals st) } - return $ Ptr $ makeStaticRef id (Ref TBool) + let id = makeIdent n + + ref <- insertGPIOutput i id + + let handler = make_handler (Proxy @backend) ref i + + return (ref, handler) + +----------- GPIO Input ---------- + +data GPInputO = GPInputO { input_ :: Map.Map Word8 (Ident, Type) } + deriving (Show, Eq) + +emptyGPInputO :: GPInputO +emptyGPInputO = GPInputO { input_ = Map.empty } + +instance IsPeripheral C GPInputO where + declareReference _ t id i gpio = gpio { input_ = Map.insert i (id,t) (input_ gpio) } + + declaredReferences _ gpio = + map (uncurry makeStaticRef) $ Map.elems $ input_ gpio + + globalDeclarations p gpio = + flip map (declaredReferences p gpio) $ \ref -> + [cedecl| $ty:(svt_ $ dereference $ refType ref) $id:(refName ref); |] + + staticInitialization p gpio = flip concatMap (Map.toList (input_ gpio)) $ + \(i,(id,t)) -> + let + bt = dereference t + ref = makeStaticRef id t + init = initialize_ bt [cexp| &$id:(refName ref)|] + assign = assign_ bt [cexp| &$id:(refName ref)|] [cexp|0|] [cexp|0|] + bind = [cexp| $id:initialize_static_input_device( + (typename ssm_sv_t *) &$id:(refName ref).sv, + $uint:i) |] + in [citems| $exp:init; $exp:assign; $exp:bind; |] + +type Switch = Bool + +gpinputokey :: String +gpinputokey = "gpinputo" + +insertGPInputO :: forall backend + . IsPeripheral backend GPInputO + => Word8 -> Ident -> Compile backend (Ref Switch) +insertGPInputO i id = do + st <- get + + -- fetch the GPIO peripheral and populate it with the new reference + let maybegpio = Map.lookup gpinputokey (peripherals st) + emptyperi = Peripheral @backend emptyGPInputO + m = maybe emptyperi (\x -> x) maybegpio + m' = declareReference (Proxy @backend) typ id i m + + -- modify the @CompileSt@ to contain the updated GPIO peripheral + put $ st { peripherals = Map.insert gpinputokey m' (peripherals st)} + + -- create the reference and return it + let ref = makeStaticRef id typ + return $ Ptr ref + where + -- | GPIO pins have a binary state, so treating them like @Bool@s seems reasonable + typ :: Type + typ = Ref TBool + +input :: forall backend . + (IsPeripheral backend GPInputO, GPIOHandler backend) + => Word8 -> Compile backend (Ref Switch) +input i = do + n <- fresh + let id = makeIdent n + + ref <- insertGPInputO i id + + return ref + +high :: Exp Bool +high = true + +low :: Exp Bool +low = false diff --git a/ssm/SSM/Frontend/Peripheral/Identity.hs b/ssm/SSM/Frontend/Peripheral/Identity.hs index 719b3e83..b561d42a 100644 --- a/ssm/SSM/Frontend/Peripheral/Identity.hs +++ b/ssm/SSM/Frontend/Peripheral/Identity.hs @@ -1,29 +1,69 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} module SSM.Frontend.Peripheral.Identity where -import SSM.Core.Ident -import SSM.Core.Peripheral.Identity -import SSM.Core.Reference hiding (Ref) -import SSM.Core.Type +import SSM.Core hiding (peripherals) + +import SSM.Util.State + +import SSM.Frontend.Compile +import SSM.Frontend.Ref + +import SSM.Backend.C.Identifiers +import SSM.Backend.C.Types + +import Data.Proxy +import qualified Data.Map as Map -import SSM.Util.State +import Control.Monad.State -import SSM.Frontend.Compile -import SSM.Frontend.Exp -import SSM.Frontend.Ref +import Language.C.Quote.GCC +import qualified Language.C.Syntax as C -import Data.Proxy +data Globals = Globals { references :: Map.Map Ident Type } + deriving (Show, Eq) -import Control.Monad.State +emptyGlobals :: Globals +emptyGlobals = Globals Map.empty --- | Generate a global SV -global :: forall backend a . SSMType a => Compile backend (Ref a) +instance IsPeripheral C Globals where + declareReference _ t id _ global = + let m = references global + in global { references = Map.insert id t m} + + declaredReferences _ globals = + map (uncurry makeStaticRef) $ Map.toList $ references globals + + globalDeclarations p globals = + flip map (declaredReferences p globals) $ \ref -> + [cedecl| $ty:(svt_ $ dereference $ refType ref) $id:(refName ref); |] + + staticInitialization p globals = flip concatMap (declaredReferences p globals) $ \ref -> + let bt = dereference $ refType ref + init = initialize_ bt [cexp| &$id:(refName ref) |] + assign = assign_ bt [cexp| &$id:(refName ref)|] [cexp|0|] [cexp|0|] + in [citems| $exp:init; $exp:assign; |] + +global :: forall backend a . (IsPeripheral backend Globals, SSMType a) => Compile backend (Ref a) global = do n <- fresh let id = Ident n Nothing - let t = mkReference $ typeOf $ Proxy @a - -- modify $ \st -> - -- st { generatedGlobals = addIdentitySV id t $ generatedGlobals st } - return $ Ptr $ makeStaticRef id t + let t = mkReference $ typeOf $ Proxy @a + + st <- get + let maybeg = Map.lookup "globals" (peripherals st) + emptyg = Peripheral @backend emptyGlobals + m = maybe emptyg (\x -> x) maybeg + m' = declareReference (Proxy @backend) typ id 0 m + + put $ st { peripherals = Map.insert "globals" m' (peripherals st) } + + let ref = makeStaticRef id typ + return (Ptr ref) + where + typ :: Type + typ = mkReference $ typeOf $ Proxy @a diff --git a/ssm/SSM/Frontend/Peripheral/LED.hs b/ssm/SSM/Frontend/Peripheral/LED.hs deleted file mode 100644 index 0d3bec23..00000000 --- a/ssm/SSM/Frontend/Peripheral/LED.hs +++ /dev/null @@ -1,92 +0,0 @@ -{- | This module implements support for controlled LEDs from the EDSL. A LED has a binary -state that is either `on` or `off`. As with any normal SSM references, LEDs can e.g be -scheduled to turn on at a specific time - -@ -after (msec 1000) led on -@ - -and they can be waited on - -@ -wait [led] -@ - -Internally the state of a LED is represented with a @Bool@, but it is advisable to talk -about them by using the type synonym `LED` and the two values `on` and `off`, -representing the two different states a LED can have. --} -module SSM.Frontend.Peripheral.LED where - -import SSM.Core.Ident ( Ident(Ident) ) -import SSM.Core.Peripheral.LED ( addOnOffLED ) -import SSM.Core.Peripheral -import SSM.Core.Reference ( makeStaticRef ) -import SSM.Core.Type ( Type(TBool) - , mkReference - ) - -import SSM.Frontend.Compile ( Compile --- , CompileSt(ledperipherals) - ) -import SSM.Frontend.Exp ( Exp ) -import SSM.Frontend.Language ( (==.) - , Ref - , deref - , false - , not' - , true - ) -import SSM.Frontend.Ref ( Ref(Ptr) ) -import SSM.Frontend.Syntax ( SSM - , emit - -- , SSMStm(Handler) - ) - -import SSM.Util.State ( fresh ) - -import Control.Monad.State ( modify ) -import Data.Word ( Word8 ) - -{- | On-off LEDs can be either on or off, so their state is semantically equivalent to -a boolean state. -} -type LED = Bool - --- | A value representing the LED-state on -on :: Exp LED -on = true - --- | A value representing the LED-state off -off :: Exp LED -off = false - --- | Is a LED on? -isON :: Ref LED -> Exp Bool -isON = (==.) on . deref - --- | Is a LED off? -isOFF :: Ref LED -> Exp Bool -isOFF = not' . isON - -{- | Statically create and initialize a binary stated LED, identified by a single -integer. The meaning of this integer is not well defined yet, and it is assumed that a -meaning exists in the runtime. This function also returns a handler that will actually -perform the IO side-effects. This must be scheduled to run, or else it will not -perform any side effects. -} -onoffLED :: Word8 -> Compile backend (Ref LED, SSM ()) -onoffLED i = do - -- generate fresh name for reference - n <- fresh - let id = Ident n Nothing - - -- modify internal LED object to know about this reference --- modify $ \st -> st { ledperipherals = addOnOffLED i id $ ledperipherals st } - - -- create the reference to return to the developer - let ref = makeStaticRef id (mkReference TBool) - - -- create the SSM handler to return to the developer - let handler = undefined --emit $ Handler $ Output (LED i) ref - - -- return the reference and the SSM () that performs the actual IO - return $ (Ptr ref, handler) diff --git a/ssm/SSM/Pretty/Syntax.hs b/ssm/SSM/Pretty/Syntax.hs index 3229113c..c9aab963 100644 --- a/ssm/SSM/Pretty/Syntax.hs +++ b/ssm/SSM/Pretty/Syntax.hs @@ -56,27 +56,8 @@ prettyProgram' p = do return () prettyQueueContent :: QueueContent backend -> String -prettyQueueContent (SSMProcedure id args) = prettyApp (id, args) -prettyQueueContent (Handler h ) = "output-handler" --- case h of --- Output variant ref -> case variant of --- LED id -> prettyApp --- ( Ident "led_output_handler" Nothing --- , [Right ref, Left $ Lit TUInt8 $ LUInt8 id] --- ) --- BLE bh -> case bh of --- Broadcast -> prettyApp --- ( Ident "broadcast_output_handler" Nothing --- , [Right ref] --- ) --- BroadcastControl -> prettyApp --- ( Ident "broadcast_control_output_handler" Nothing --- , [Right ref] --- ) --- ScanControl -> prettyApp --- ( Ident "scan_control_output_handler" Nothing --- , [Right ref] --- ) +prettyQueueContent (SSMProcedure id args) = prettyApp (id, args) +prettyQueueContent (OutputHandler (Handler _ p)) = p prettyReferenceDecls :: [Reference] -> PP () prettyReferenceDecls xs = flip mapM_ xs $ \ref -> From d251f12eab13b23c4c5d511a293e3ce340d8759f Mon Sep 17 00:00:00 2001 From: Robert Krook Date: Thu, 9 Dec 2021 16:51:52 +0100 Subject: [PATCH 05/16] added dank new nice way of exposing constraints without leaking implementation details --- ssm/SSM/FreqGen.hs | 4 ++-- ssm/SSM/FrequencyMime.hs | 5 +++-- ssm/SSM/Frontend/Peripheral/BasicBLE.hs | 6 ++++++ ssm/SSM/Frontend/Peripheral/GPIO.hs | 8 +++++++- 4 files changed, 18 insertions(+), 5 deletions(-) diff --git a/ssm/SSM/FreqGen.hs b/ssm/SSM/FreqGen.hs index 43784c27..24355085 100644 --- a/ssm/SSM/FreqGen.hs +++ b/ssm/SSM/FreqGen.hs @@ -24,7 +24,7 @@ Nits with EDSL noted inline. -} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE RebindableSyntax #-} - +{-# LANGUAGE FlexibleContexts #-} --{-# OPTIONS_GHC -fplugin=SSM.Plugin -fplugin-opt=SSM.Plugin:mode=routine #-} module SSM.FreqGen where @@ -69,7 +69,7 @@ entry = routine $ do period <- var $ time2ns $ secs 1 fork [freqGen period, buttonHandler period] -compiler :: Compile C () +compiler :: SupportGPIO backend => Compile backend () compiler = do switch0 <- input 0 switch1 <- input 1 diff --git a/ssm/SSM/FrequencyMime.hs b/ssm/SSM/FrequencyMime.hs index cc04226f..81725cb7 100644 --- a/ssm/SSM/FrequencyMime.hs +++ b/ssm/SSM/FrequencyMime.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fplugin=SSM.Plugin -fplugin-opt=SSM.Plugin:mode=routine #-} module SSM.FrequencyMime where @@ -49,7 +50,7 @@ entry = routine $ do period <- var $ secs 1 fork [freqGen period, bleHandler period] -generator :: Compile C () +generator :: (SupportGPIO backend, SupportBBLE backend) => Compile backend () generator = do (led, handler) <- output 0 (ble, broadcast, broadcastControl, scanning) <- enableBLE @@ -107,7 +108,7 @@ counterEntry = routine $ do count <- var $ secs 1 fork [ freqCount2 ?sw count, broadcastCount count ] -counter :: Compile C () +counter :: (SupportGPIO backend, SupportBBLE backend) => Compile backend () counter = do sw <- input 0 (ble, broadcast, broadcastControl, scanning) <- enableBLE diff --git a/ssm/SSM/Frontend/Peripheral/BasicBLE.hs b/ssm/SSM/Frontend/Peripheral/BasicBLE.hs index ffb2e6dc..e32e62c4 100644 --- a/ssm/SSM/Frontend/Peripheral/BasicBLE.hs +++ b/ssm/SSM/Frontend/Peripheral/BasicBLE.hs @@ -5,6 +5,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ConstraintKinds #-} module SSM.Frontend.Peripheral.BasicBLE ( BBLE , enableBLE @@ -13,6 +14,7 @@ module SSM.Frontend.Peripheral.BasicBLE , enableScan , disableScan , scanref + , SupportBBLE ) where @@ -161,3 +163,7 @@ enableBLE = do bble = createBBLE initBasicBLE return (bble, broadcastH, broadcastControlH, scanControlH) + +type SupportBBLE backend = ( IsPeripheral backend BasicBLE + , BLEHandlers backend + ) diff --git a/ssm/SSM/Frontend/Peripheral/GPIO.hs b/ssm/SSM/Frontend/Peripheral/GPIO.hs index 900cf716..fc84136a 100644 --- a/ssm/SSM/Frontend/Peripheral/GPIO.hs +++ b/ssm/SSM/Frontend/Peripheral/GPIO.hs @@ -4,6 +4,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} module SSM.Frontend.Peripheral.GPIO ( output , input @@ -11,7 +12,7 @@ module SSM.Frontend.Peripheral.GPIO , Switch , high , low - , GPIOHandler + , SupportGPIO ) where @@ -217,3 +218,8 @@ high = true low :: Exp Bool low = false + +type SupportGPIO backend = ( IsPeripheral backend GPIOutput + , IsPeripheral backend GPInputO + , GPIOHandler backend + ) From 6932c99c71dfe75e689207a80f4ed6c1cd07e3ce Mon Sep 17 00:00:00 2001 From: Robert Krook Date: Fri, 10 Dec 2021 14:05:07 +0100 Subject: [PATCH 06/16] removed some dead code, updated CodeGen --- ssm.cabal | 1 + ssm/SSM/Backend/C/CodeGen.hs | 56 +++++++---------------- ssm/SSM/Backend/C/Identifiers.hs | 4 +- ssm/SSM/Backend/C/Peripheral.hs | 59 ------------------------- ssm/SSM/Core/Peripheral.hs | 39 ---------------- ssm/SSM/Core/Program.hs | 15 +++---- ssm/SSM/Frontend/Compile.hs | 8 ++-- ssm/SSM/Frontend/Language.hs | 2 +- ssm/SSM/Frontend/Peripheral/BasicBLE.hs | 8 ++-- ssm/SSM/Frontend/Peripheral/GPIO.hs | 8 ++-- ssm/SSM/Frontend/Peripheral/Identity.hs | 2 +- ssm/SSM/Frontend/Syntax.hs | 2 +- ssm/SSM/Test.hs | 37 ++++++++++++++++ ssm/SSM/Util/State.hs | 4 +- 14 files changed, 77 insertions(+), 168 deletions(-) delete mode 100644 ssm/SSM/Backend/C/Peripheral.hs create mode 100644 ssm/SSM/Test.hs diff --git a/ssm.cabal b/ssm.cabal index bb6c95e3..fff6b832 100644 --- a/ssm.cabal +++ b/ssm.cabal @@ -62,6 +62,7 @@ library SSM.Plugin SSM.Pretty SSM.Pretty.Syntax + SSM.Test SSM.Util.Default SSM.Util.HughesList SSM.Util.Operators diff --git a/ssm/SSM/Backend/C/CodeGen.hs b/ssm/SSM/Backend/C/CodeGen.hs index 160eff1c..569e5821 100644 --- a/ssm/SSM/Backend/C/CodeGen.hs +++ b/ssm/SSM/Backend/C/CodeGen.hs @@ -9,6 +9,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} module SSM.Backend.C.CodeGen ( compile_ ) where @@ -25,10 +26,10 @@ import qualified Data.Map as Map import Language.C.Quote.GCC import qualified Language.C.Syntax as C +import Data.Proxy import Data.List ( sortOn ) import SSM.Backend.C.Identifiers import SSM.Backend.C.Types -import SSM.Backend.C.Peripheral import SSM.Core @@ -41,7 +42,7 @@ compile_ program = (compUnit, includes) where -- | The file to generate, minus include statements compUnit :: [C.Definition] - compUnit = concat [ declarePeripherals program + compUnit = concat [ concatMap (globalDeclarations (Proxy @C)) (peripherals program) , preamble , decls , defns @@ -119,7 +120,7 @@ actm = "act" genInitProgram :: Program C -> [C.Definition] genInitProgram p = [cunit| int $id:initialize_program(void) { - $items:(initPeripherals p) + $items:(concatMap (staticInitialization (Proxy @C)) (peripherals p)) $items:(initialForks $ initialQueueContent p) return 0; @@ -128,50 +129,23 @@ genInitProgram p = [cunit| where -- | Create statements for scheduling the initial ready-queue content initialForks :: [QueueContent C] -> [C.BlockItem] - initialForks ips = - zipWith - initialFork - (pdeps - (length ips) - priority_at_root - depth_at_root) - ips + initialForks ips = concat $ zipWith3 initialFork [1..length ips] (repeat $ length ips) ips where - -- | Create the schedule statement for a single schedulable thing - initialFork :: (C.Exp, C.Exp) -> QueueContent C -> C.BlockItem - initialFork (priority, depth) (SSMProcedure id args) = - [citem| $id:fork($id:(enter_ (identName id))( &$id:top_parent - , $exp:priority - , $exp:depth - , $args:(map cargs args) - ) - ); |] - -- initialFork (priority, depth) (Handler h) = - -- [citem|$id:fork($id:(resolveNameOfHandler h) - -- ( &$id:top_parent - -- , $exp:priority - -- , $exp:depth - -- , $args:(argsOfHandler h) - -- ) - -- );|] - initialFork (priority, depth) (OutputHandler (Handler f _)) = error "fixme" - - -- -- | Take a handler and return a list of arguments to it - -- argsOfHandler :: Handler -> [C.Exp] - -- argsOfHandler (Output variant ref) = case variant of - -- LED id -> [ [cexp| &$id:(refName ref).sv |] - -- , [cexp| $uint:id |] - -- ] - -- BLE bh -> case bh of - -- Broadcast -> [ [cexp| &$id:(refName ref).sv |] ] - -- BroadcastControl -> [ [cexp| &$id:(refName ref).sv |] ] - -- ScanControl -> [ [cexp| &$id:(refName ref).sv |] ] + initialFork :: Int -> Int -> QueueContent C -> [C.BlockItem] + initialFork k cs (SSMProcedure id args) = + let (prio, depth) = pdep k cs priority_at_root depth_at_root + in [[citem| $id:fork($id:(enter_ (identName id))( &$id:top_parent + , $exp:prio + , $exp:depth + , $args:(map cargs args) + ) + ); |]] + initialFork k cs (OutputHandler (Handler f _)) = f k cs cargs :: Either SSMExp Reference -> C.Exp cargs (Left e) = genExp [] e cargs (Right r@(Static _)) = [cexp| &$id:(refName r).sv|] cargs (Right r@(Dynamic _)) = error "Why does StaticOutputHandler refer to a non-static var?" - x = refName -- | Generate include statements, to be placed at the top of the generated C. genPreamble :: [C.Definition] diff --git a/ssm/SSM/Backend/C/Identifiers.hs b/ssm/SSM/Backend/C/Identifiers.hs index 21853cf2..63549d90 100644 --- a/ssm/SSM/Backend/C/Identifiers.hs +++ b/ssm/SSM/Backend/C/Identifiers.hs @@ -191,8 +191,8 @@ pdeps cs currentPrio currentDepth = pdep :: Int -> Int -> C.Exp -> C.Exp -> (C.Exp, C.Exp) pdep k cs currentPrio currentDepth = - let prio = [cexp|$exp:currentPrio + ($int:(k-1) * (1 << $exp:depth))|] - depth = [cexp|$exp:currentDepth - $exp:(depthSub cs)|] + let prio = [cexp|$exp:currentPrio + ($int:(k-1) * (1 << $exp:depth))|] + depth = [cexp|$exp:currentDepth - $exp:(depthSub cs)|] in (prio, depth) {- | Calculate the subexpression that should be subtracted from the current depth diff --git a/ssm/SSM/Backend/C/Peripheral.hs b/ssm/SSM/Backend/C/Peripheral.hs deleted file mode 100644 index 3a16472e..00000000 --- a/ssm/SSM/Backend/C/Peripheral.hs +++ /dev/null @@ -1,59 +0,0 @@ -{- | This module defines a type class @CPeripheral@ that can be used to generate C code -for a IO peripheral. Every peripheral should be made an instance of this type class to -facilitate easier code generation. -} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE DataKinds #-} -module SSM.Backend.C.Peripheral where - -import SSM.Core - -import SSM.Backend.C.Identifiers -import SSM.Backend.C.Types - -import Language.C.Quote.GCC -import qualified Language.C.Syntax as C - -{- | Get the global declarations made by a peripheral. Usually this will just be global -references. -} -decls :: Peripheral C -> [C.Definition] -decls = undefined --- decls (Peripheral a) = map declSingle $ declaredReferences a --- where --- declSingle :: Reference -> C.Definition --- declSingle r = --- [cedecl| $ty:(svt_ $ dereference $ refType r) $id:(refName r);|] - -{- | Get the statements that initializes this peripheral. These statements should be -executed in the program initialization point, before the program actually runs. -} -maininit :: Peripheral C -> [C.BlockItem] -maininit = undefined --- maininit (Peripheral a) = concatMap compInitializer $ mainInitializers a --- where --- compInitializer :: Initializer -> [C.BlockItem] --- compInitializer i = case i of --- Independent ind -> case ind of --- BLEEnable -> [[citem| enable_ble_stack(); |]] --- Normal ref -> --- let bt = dereference $ refType ref --- init = initialize_ bt [cexp|&$id:(refName ref)|] --- assign = assign_ bt [cexp|&$id:(refName ref)|] [cexp|0|] [cexp|0|] --- in [citems| $exp:init; $exp:assign; |] --- StaticInput si ref -> case si of --- Switch id -> --- [ [citem| $id:initialize_static_input_device((typename ssm_sv_t *) &$id:(refName ref).sv, $int:id);|] --- ] --- BLEScan -> --- [ [citem| $id:initialize_static_input_ble_scan_device(&$id:(refName ref).sv);|] --- ] - --- | Return all the statements that initialize the peripherals statically -initPeripherals :: Program C -> [C.BlockItem] -initPeripherals p = concatMap maininit $ peripherals p - -{- | Return all the declarations of static, global variables associated with the -peripherals of a program. -} -declarePeripherals :: Program C -> [C.Definition] -declarePeripherals p = concatMap decls $ peripherals p diff --git a/ssm/SSM/Core/Peripheral.hs b/ssm/SSM/Core/Peripheral.hs index 3d4eea27..77f5990b 100644 --- a/ssm/SSM/Core/Peripheral.hs +++ b/ssm/SSM/Core/Peripheral.hs @@ -34,45 +34,6 @@ instance Show (Peripheral backend) where instance Eq (Peripheral backend) where (==) = undefined --- {- | Different types of peripherals might require different kinds of initialization. --- This type is meant to enumerate the different types of initialization. -} --- data Initializer --- = Normal Reference -- ^ Perform regular initialization of the reference --- {- | The @StaticInput@ initialization tells us that the reference is an input --- reference, and that it needs to be initialized as the kind of static input described --- by the `StaticInputVariant` type. -} --- | StaticInput StaticInputVariant Reference --- | Independent IndependentInit - --- data IndependentInit = BLEEnable - --- -- | Static input variants. --- data StaticInputVariant = Switch Word8 -- ^ Switch GPIO --- | BLEScan - --- -- | Different variants of handlers that can be scheduled at the beginning of a program --- data Handler --- -- = StaticOutputHandler Reference Word8 -- ^ Static output handlers (LED? only?) --- = Output StaticOutputVariant Reference --- deriving (Show, Eq) - --- data StaticOutputVariant --- = LED Word8 --- | BLE BLEHandler --- deriving (Show, Eq) - --- data BLEHandler --- = Broadcast --- | BroadcastControl --- | ScanControl --- deriving (Show, Eq) - --- -- | Class of types that are peripherals --- class IsPeripheral a where --- declaredReferences :: a -> [Reference] -- ^ Globally declared references --- -- | Initialization to perform before program startup --- mainInitializers :: a -> [Initializer] - class IsPeripheral backend a where declareReference :: proxy backend -> Type -> Ident -> Word8 -> a -> a declaredReferences :: proxy backend -> a -> [Reference] diff --git a/ssm/SSM/Core/Program.hs b/ssm/SSM/Core/Program.hs index f83fb224..aead26f0 100644 --- a/ssm/SSM/Core/Program.hs +++ b/ssm/SSM/Core/Program.hs @@ -39,17 +39,13 @@ data Procedure = Procedure -- | A @QueueContent@ is something that can be scheduled when a program begins executing. data QueueContent backend - {- | SSM procedures can be scheduled initially. Right now it is assumed that only - one SSM procedure will ever be scheduled initiailly, and that it will have no - arguments. The constructor looks like this, however, in preparation for any future - changes we might want to make. I might remove this second argument... -} = SSMProcedure Ident [Either SSMExp Reference] | OutputHandler (Handler backend) -data Handler backend = - Handler { gen_handler :: Int -> Int -> [Schedule backend] - , pretty_handler :: String - } +data Handler backend = Handler + { gen_handler :: Int -> Int -> [Schedule backend] + , pretty_handler :: String + } instance Show (QueueContent backend) where show (SSMProcedure id args) = "SSMProcedure " <> show id <> " " <> show args @@ -79,8 +75,7 @@ data Program backend = Program initialQueueContent :: [QueueContent backend] -- | Map that associates procedure names with their definitions. , funs :: Map.Map Ident Procedure - -- | Name and type of references that exist in the global scope. - -- | Any peripherals used by the program + -- | Peripherals , peripherals :: [Peripheral backend] } deriving (Show) diff --git a/ssm/SSM/Frontend/Compile.hs b/ssm/SSM/Frontend/Compile.hs index 82350207..cab302a2 100644 --- a/ssm/SSM/Frontend/Compile.hs +++ b/ssm/SSM/Frontend/Compile.hs @@ -20,11 +20,11 @@ import qualified Data.Map as Map -- | State maintained by the `Compile` monad data CompileSt backend = CompileSt - { compileCounter :: Int -- ^ Counter to generate fresh named + { compileCounter :: Int -- ^ Counter to generate fresh names , initialQueueContent :: [QueueContent backend] -- ^ Initial ready-queue content - , entryPoint :: Maybe (SSM ()) -- ^ SSM program to run + , entryPoint :: Maybe (SSM ()) -- ^ SSM program to run - , peripherals :: Map.Map String (Peripheral backend) + , peripherals :: Map.Map String (Peripheral backend) -- ^ Peripherals } -- | Compile monad @@ -61,7 +61,7 @@ instance Schedulable backend (SSM ()) where schedule = scheduleSSM instance Schedulable backend (OutputHandler backend) where - schedule h{-(Handler f)-} = do + schedule h = do st <- get let queuecontents = SSM.Frontend.Compile.initialQueueContent st newcontent = OutputHandler h diff --git a/ssm/SSM/Frontend/Language.hs b/ssm/SSM/Frontend/Language.hs index 3fd5c9bc..c77e056c 100644 --- a/ssm/SSM/Frontend/Language.hs +++ b/ssm/SSM/Frontend/Language.hs @@ -327,7 +327,7 @@ it was created in terminates. -} var :: Exp a -> SSM (Ref a) var (Exp e) = do n <- fresh - let id = Ident n Nothing + let id = Ident ("var" <> show n) Nothing emit $ NewRef id e return $ Ptr $ makeDynamicRef id (mkReference $ expType e) diff --git a/ssm/SSM/Frontend/Peripheral/BasicBLE.hs b/ssm/SSM/Frontend/Peripheral/BasicBLE.hs index e32e62c4..13e6f47f 100644 --- a/ssm/SSM/Frontend/Peripheral/BasicBLE.hs +++ b/ssm/SSM/Frontend/Peripheral/BasicBLE.hs @@ -46,10 +46,10 @@ data BasicBLE = BasicBLE initBasicBLE :: BasicBLE initBasicBLE = BasicBLE - { broadcast_ = (makeIdent "broadcast", Ref TUInt64) - , broadcastControl_ = (makeIdent "broadcastControl", Ref TBool) - , scan_ = (makeIdent "scan", Ref TUInt64) - , scanControl_ = (makeIdent "scanControl", Ref TBool) + { broadcast_ = (makeIdent "broadcast", mkReference $ typeOf $ Proxy @Word64) + , broadcastControl_ = (makeIdent "broadcastControl", mkReference $ typeOf $ Proxy @Bool) + , scan_ = (makeIdent "scan", mkReference $ typeOf $ Proxy @Word64) + , scanControl_ = (makeIdent "scanControl", mkReference $ typeOf $ Proxy @Bool) } instance IsPeripheral C BasicBLE where diff --git a/ssm/SSM/Frontend/Peripheral/GPIO.hs b/ssm/SSM/Frontend/Peripheral/GPIO.hs index fc84136a..e87ea9bc 100644 --- a/ssm/SSM/Frontend/Peripheral/GPIO.hs +++ b/ssm/SSM/Frontend/Peripheral/GPIO.hs @@ -110,7 +110,7 @@ insertGPIOutput i id = do where -- | GPIO pins have a binary state, so treating them like @Bool@s seems reasonable typ :: Type - typ = Ref TBool + typ = mkReference $ typeOf $ Proxy @Bool class GPIOHandler backend where make_handler :: proxy backend -> Ref GPIO -> Word8 -> OutputHandler backend @@ -136,7 +136,7 @@ output :: forall backend . => Word8 -> Compile backend (Ref GPIO, OutputHandler backend) output i = do n <- fresh - let id = makeIdent n + let id = makeIdent ("output" <> show n) ref <- insertGPIOutput i id @@ -200,14 +200,14 @@ insertGPInputO i id = do where -- | GPIO pins have a binary state, so treating them like @Bool@s seems reasonable typ :: Type - typ = Ref TBool + typ = mkReference $ typeOf $ Proxy @Bool input :: forall backend . (IsPeripheral backend GPInputO, GPIOHandler backend) => Word8 -> Compile backend (Ref Switch) input i = do n <- fresh - let id = makeIdent n + let id = makeIdent ("input" <> show n) ref <- insertGPInputO i id diff --git a/ssm/SSM/Frontend/Peripheral/Identity.hs b/ssm/SSM/Frontend/Peripheral/Identity.hs index b561d42a..e19dc428 100644 --- a/ssm/SSM/Frontend/Peripheral/Identity.hs +++ b/ssm/SSM/Frontend/Peripheral/Identity.hs @@ -51,7 +51,7 @@ instance IsPeripheral C Globals where global :: forall backend a . (IsPeripheral backend Globals, SSMType a) => Compile backend (Ref a) global = do n <- fresh - let id = Ident n Nothing + let id = Ident ("global" <> show n) Nothing let t = mkReference $ typeOf $ Proxy @a st <- get diff --git a/ssm/SSM/Frontend/Syntax.hs b/ssm/SSM/Frontend/Syntax.hs index 9d9129a5..cad54d2e 100644 --- a/ssm/SSM/Frontend/Syntax.hs +++ b/ssm/SSM/Frontend/Syntax.hs @@ -262,7 +262,7 @@ transpileProcedure xs = fmap concat $ forM xs $ \x -> case x of synthesizeProcedure :: [SSMStm] -> Transpile (Ident, [Either S.SSMExp Reference]) synthesizeProcedure body = do - name <- (makeIdent . (<>) "generated") <$> fresh + name <- (makeIdent . (<>) "generated" . show) <$> fresh stmts <- transpileProcedure body let toapply = L.nub $ freeInStm [] stmts procedure = SP.Procedure name (map (either expInfo refInfo) toapply) stmts diff --git a/ssm/SSM/Test.hs b/ssm/SSM/Test.hs new file mode 100644 index 00000000..ec54ce12 --- /dev/null +++ b/ssm/SSM/Test.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -fplugin=SSM.Plugin -fplugin-opt=SSM.Plugin:mode=routine #-} +module SSM.Test where + +import Prelude + +import SSM.Language +import SSM.Frontend.Peripheral.GPIO + +import SSM.Core.Backend +import SSM.Compile +import SSM.Pretty + +import Data.Word + +program :: (SupportGPIO backend) => Compile backend () +program = do + (led0, handler0) <- output 0 + (led1, handler1) <- output 1 + (led2, handler2) <- output 2 + + let ?led0 = led0 + ?led1 = led1 + ?led2 = led2 + + schedule main + schedule handler0 + schedule handler1 + schedule handler2 + where + main :: (?led0 :: Ref GPIO, ?led1 :: Ref GPIO, ?led2 :: Ref GPIO) => SSM () + main = routine $ do + ?led0 <~ high + ?led1 <~ low + ?led2 <~ high diff --git a/ssm/SSM/Util/State.hs b/ssm/SSM/Util/State.hs index ac5c4d24..d5d76d34 100644 --- a/ssm/SSM/Util/State.hs +++ b/ssm/SSM/Util/State.hs @@ -62,8 +62,8 @@ instance IntState Int where setInt i _ = i -- | Generate fresh names from any monad whose state has an `IntState` instance -fresh :: (IntState s, MonadState s m) => m String +fresh :: (IntState s, MonadState s m) => m Int fresh = do s <- gets getInt modify $ \st -> setInt (s + 1) st - return $ "fresh" ++ show s + return s From c98ef9d6b1d824601ffdbd613eb2b9bfd482be28 Mon Sep 17 00:00:00 2001 From: Robert Krook Date: Fri, 10 Dec 2021 16:07:08 +0100 Subject: [PATCH 07/16] some more documentation, changed the Identity peripheral to work regardless of backend. Moved out the reference initialization of peripherals from the typeclass itself to the specific backend. --- ssm.cabal | 1 - ssm/SSM/Backend/C/CodeGen.hs | 19 +++++++- ssm/SSM/Backend/C/Identifiers.hs | 22 +++++----- ssm/SSM/Core/Backend.hs | 19 +++++--- ssm/SSM/Core/Peripheral.hs | 43 ++++++++++++++---- ssm/SSM/Core/Program.hs | 12 +++-- ssm/SSM/Freqmime.hs | 4 +- ssm/SSM/Frontend/Peripheral/BasicBLE.hs | 47 ++++++++++++++++---- ssm/SSM/Frontend/Peripheral/GPIO.hs | 58 +++++++++++++++---------- ssm/SSM/Frontend/Peripheral/Identity.hs | 37 +++++++++++----- ssm/SSM/Test.hs | 7 ++- 11 files changed, 192 insertions(+), 77 deletions(-) diff --git a/ssm.cabal b/ssm.cabal index fff6b832..7387595e 100644 --- a/ssm.cabal +++ b/ssm.cabal @@ -28,7 +28,6 @@ library SSM.Backend.C.CodeGen SSM.Backend.C.Compile SSM.Backend.C.Identifiers - SSM.Backend.C.Peripheral SSM.Backend.C.Types SSM.Compile SSM.Core diff --git a/ssm/SSM/Backend/C/CodeGen.hs b/ssm/SSM/Backend/C/CodeGen.hs index 569e5821..9166bb23 100644 --- a/ssm/SSM/Backend/C/CodeGen.hs +++ b/ssm/SSM/Backend/C/CodeGen.hs @@ -42,13 +42,18 @@ compile_ program = (compUnit, includes) where -- | The file to generate, minus include statements compUnit :: [C.Definition] - compUnit = concat [ concatMap (globalDeclarations (Proxy @C)) (peripherals program) + compUnit = concat [ peripheralDeclarations , preamble , decls , defns , initProg ] + peripheralDeclarations :: [C.Definition] + peripheralDeclarations = flip concatMap (peripherals program) (\pe -> + flip map (declaredReferences (Proxy @C) pe) (\ref -> + [cedecl| $ty:(svt_ $ dereference $ refType ref) $id:(refName ref);|])) + initProg :: [C.Definition] initProg = genInitProgram program @@ -120,6 +125,7 @@ actm = "act" genInitProgram :: Program C -> [C.Definition] genInitProgram p = [cunit| int $id:initialize_program(void) { + $items:initPeripheralReferences $items:(concatMap (staticInitialization (Proxy @C)) (peripherals p)) $items:(initialForks $ initialQueueContent p) @@ -127,6 +133,17 @@ genInitProgram p = [cunit| } |] where + initPeripheralReferences :: [C.BlockItem] + initPeripheralReferences = + concatMap (concatMap initSingle . declaredReferences (Proxy @C)) (peripherals p) + where + initSingle :: Reference -> [C.BlockItem] + initSingle ref = + let bt = dereference $ refType ref + init = initialize_ bt [cexp| &$id:(refName ref) |] + assign = assign_ bt [cexp| &$id:(refName ref) |] [cexp|0|] [cexp|0|] + in [citems| $exp:init; $exp:assign; |] + -- | Create statements for scheduling the initial ready-queue content initialForks :: [QueueContent C] -> [C.BlockItem] initialForks ips = concat $ zipWith3 initialFork [1..length ips] (repeat $ length ips) ips diff --git a/ssm/SSM/Backend/C/Identifiers.hs b/ssm/SSM/Backend/C/Identifiers.hs index 63549d90..294f9778 100644 --- a/ssm/SSM/Backend/C/Identifiers.hs +++ b/ssm/SSM/Backend/C/Identifiers.hs @@ -175,20 +175,20 @@ throw = "SSM_THROW" exhausted_priority :: C.Exp exhausted_priority = [cexp|SSM_EXHAUSTED_PRIORITY|] -{- | Create C expressions that represent the new priorities and depths of the -initially scheduled processes. -} --- pdeps :: Int -> C.Exp -> C.Exp -> [(C.Exp, C.Exp)] --- pdeps cs currentPrio currentDepth = --- [ let prio = [cexp|$exp:currentPrio + ($int:(i-1) * (1 << $exp:depth))|] --- depth = [cexp|$exp:currentDepth - $exp:(depthSub cs)|] --- in (prio, depth) --- | i <- [1..cs] --- ] - +-- | Generate a list of priority-depth pairs to use when forking new processes. pdeps :: Int -> C.Exp -> C.Exp -> [(C.Exp, C.Exp)] pdeps cs currentPrio currentDepth = map (\k -> pdep k cs currentPrio currentDepth) [1..cs] +{- | Generate a priority-depth pair to use when populating the ready queue. + +Arguments are: + + 1. We want the priority and depth of the k:th procedure + 2. Total number of processes that are being enqueued + 3. Expression that represents priority of parent + 4. Expression that represents depth of parent +-} pdep :: Int -> Int -> C.Exp -> C.Exp -> (C.Exp, C.Exp) pdep k cs currentPrio currentDepth = let prio = [cexp|$exp:currentPrio + ($int:(k-1) * (1 << $exp:depth))|] @@ -202,9 +202,11 @@ The argument is the number of new processes that are being forked. -} depthSub :: Int -> C.Exp depthSub k = [cexp|$int:(ceiling $ logBase (2 :: Double) $ fromIntegral $ k :: Int) |] +-- | Depth at program initialization depth_at_root :: C.Exp depth_at_root = [cexp|SSM_ROOT_DEPTH|] +-- | Priority at program initialization priority_at_root :: C.Exp priority_at_root = [cexp|SSM_ROOT_PRIORITY|] diff --git a/ssm/SSM/Core/Backend.hs b/ssm/SSM/Core/Backend.hs index 978533b2..d643acfe 100644 --- a/ssm/SSM/Core/Backend.hs +++ b/ssm/SSM/Core/Backend.hs @@ -1,15 +1,22 @@ +{- | Programs are parameterized over different backends. This file lists the available +backends and declares some type families that can be used to talk about backend-specific +code in a general way. -} {-# LANGUAGE TypeFamilies #-} -module SSM.Core.Backend where +module SSM.Core.Backend + ( C + , Definition + , Statement + ) where import qualified Language.C.Syntax as C +-- | Programs can be compiled to C data C +-- | Type of top-level declarations type family Definition backend where Definition C = C.Definition -type family Initialization backend where - Initialization C = C.BlockItem - -type family Schedule backend where - Schedule C = C.BlockItem +-- | Type of statements +type family Statement backend where + Statement C = C.BlockItem diff --git a/ssm/SSM/Core/Peripheral.hs b/ssm/SSM/Core/Peripheral.hs index 77f5990b..0844d51b 100644 --- a/ssm/SSM/Core/Peripheral.hs +++ b/ssm/SSM/Core/Peripheral.hs @@ -1,11 +1,11 @@ -{- | This module implements functionality that allows us to talk about peripherals. -A peripheral, rihgt now, is something that might declare some variables in the global -scope, and there might be some initial initialization required upon program startup. - -The purpose of this module is mainly to not let any details about C leak to the -core representation. An alternative would be to have the core representation use a -\"C-compileable\" constraint instead, but then we would tie the core representation to -the fact that there exists a C backend. -} +{- | This module implements functionality related to talking about peripherals. + +All peripherals must implement the @IsPeripheral@ typeclass, once for each backend +that supports the peripheral. + +To get a common interface to talk about peripherals that abstracts away the type of +the actual peripheral, we use a GADT @Peripheral@. @Peripheral@ only talks about the +backend the peripheral supports, not the type of the peripheral itself. -} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -34,12 +34,37 @@ instance Show (Peripheral backend) where instance Eq (Peripheral backend) where (==) = undefined +-- | @IsPeripheral@ describes everything that a peripheral is and what it can do class IsPeripheral backend a where + {- | Declare a peripheral that is declared in the global scope. The peripheral + might need to identify some IO driver that it needs to be connected to, which + is what the @Word8@ parameter is for. -} declareReference :: proxy backend -> Type -> Ident -> Word8 -> a -> a + + {- | Fetch a list of all the references that has been declared in the global scope + by this peripheral. -} declaredReferences :: proxy backend -> a -> [Reference] + + {- | Fetch a list of declarations that needs to be done at the top-level in + the generated program. This could be variable declarations, type declarations, + functions etc. + + NOTE: This list of definitions don't need to declare the references. This should + be handled by each respective backend by calling @declaredReferences@ and using + that alone to generate the reference definitions. -} globalDeclarations :: proxy backend -> a -> [Definition backend] - staticInitialization :: proxy backend -> a -> [Initialization backend] + {- | Fetch the statements that make up the static initialization of this peripheral. + These statements must be inserted in the generated setup procedure. + + NOTE: This list of initialization statements don't need to initialize the references + declared by a peripheral. This should be handled by each respective backend by + calling @declaredReferences@ and using that information to do initialization. + It should be assumed that this initialization has happened before these + statements are executed. -} + staticInitialization :: proxy backend -> a -> [Statement backend] + +-- | Dummy instance to prevent the need for wrapping/unwrapping of @Peripherals@ instance IsPeripheral backend (Peripheral backend) where declareReference proxy t id i (Peripheral p) = Peripheral $ declareReference proxy t id i p diff --git a/ssm/SSM/Core/Program.hs b/ssm/SSM/Core/Program.hs index aead26f0..1ba91303 100644 --- a/ssm/SSM/Core/Program.hs +++ b/ssm/SSM/Core/Program.hs @@ -16,7 +16,7 @@ module SSM.Core.Program ) where -import SSM.Core.Backend ( Schedule ) +import SSM.Core.Backend ( Statement ) import SSM.Core.Ident ( Ident ) import SSM.Core.Peripheral ( Peripheral ) import SSM.Core.Reference ( Reference ) @@ -42,18 +42,22 @@ data QueueContent backend = SSMProcedure Ident [Either SSMExp Reference] | OutputHandler (Handler backend) +{- | A @Handler@ can do two things. If the Handler is given its ordinal in the list +of things that are scheduled and the total number of things that are scheduled, the +handler can return the statements that schedule this handler. +A Handler can also specify a string to use when pretty-printing. -} data Handler backend = Handler - { gen_handler :: Int -> Int -> [Schedule backend] + { gen_handler :: Int -> Int -> [Statement backend] , pretty_handler :: String } instance Show (QueueContent backend) where show (SSMProcedure id args) = "SSMProcedure " <> show id <> " " <> show args - show (OutputHandler _) = "" + show (OutputHandler _) = "" instance Eq (QueueContent backend) where SSMProcedure id1 args1 == SSMProcedure id2 args2 = id1 == id2 && args1 == args2 - OutputHandler _ == OutputHandler _ = undefined -- TODO + OutputHandler _ == OutputHandler _ = undefined -- EE {- | Get the identifier of the SSM procedure that is scheduled at the start of a SSM program -} diff --git a/ssm/SSM/Freqmime.hs b/ssm/SSM/Freqmime.hs index 208faed8..6cdd4e9f 100644 --- a/ssm/SSM/Freqmime.hs +++ b/ssm/SSM/Freqmime.hs @@ -41,8 +41,8 @@ mmmain = do testGlobal :: Compile C () testGlobal = do - x <- global @C @Word8 - y <- global @C @Word64 + x <- global @Word8 + y <- global @Word64 let ?x = x ?y = y diff --git a/ssm/SSM/Frontend/Peripheral/BasicBLE.hs b/ssm/SSM/Frontend/Peripheral/BasicBLE.hs index 13e6f47f..372a1b4f 100644 --- a/ssm/SSM/Frontend/Peripheral/BasicBLE.hs +++ b/ssm/SSM/Frontend/Peripheral/BasicBLE.hs @@ -1,3 +1,9 @@ +{-| This module exposes the "basically BLE" peripheral. This peripheral only +implements very limited broadcasting and scanning. When you run @enableBLE@ you +get a @BBLE@ object and three handlers back. The first two handlers control the +broadcast payload and broadcast control, while the last one controls the scan +functionality. The @BBLE@ object acts as a handle that all BBLE functionality +must happen through. -} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ImplicitParams #-} @@ -7,14 +13,17 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ConstraintKinds #-} module SSM.Frontend.Peripheral.BasicBLE - ( BBLE + ( -- * Accessing the BBLE driver + BBLE + , SupportBBLE , enableBLE + -- * Broadcast management , enableBroadcast , disableBroadcast + -- * Scan management , enableScan , disableScan , scanref - , SupportBBLE ) where @@ -36,14 +45,17 @@ import Control.Monad.State import Language.C.Quote.GCC ( cedecl, cexp, citem, citems ) import qualified Language.C.Syntax as C +{- | Internal representation of BasicBLE. It is just a collection of references to +control different parts of the BLE API. -} data BasicBLE = BasicBLE - { broadcast_ :: (Ident, Type) - , broadcastControl_ :: (Ident, Type) - , scan_ :: (Ident, Type) - , scanControl_ :: (Ident, Type) + { broadcast_ :: (Ident, Type) -- ^ This ref controls broadcast payload + , broadcastControl_ :: (Ident, Type) -- ^ This ref controls broadcast status (on/off) + , scan_ :: (Ident, Type) -- ^ This ref controls scanned messages + , scanControl_ :: (Ident, Type) -- ^ This ref controls scan status (on/off) } deriving (Show, Eq) +-- | Create @BasicBLE@ default value initBasicBLE :: BasicBLE initBasicBLE = BasicBLE { broadcast_ = (makeIdent "broadcast", mkReference $ typeOf $ Proxy @Word64) @@ -52,14 +64,15 @@ initBasicBLE = BasicBLE , scanControl_ = (makeIdent "scanControl", mkReference $ typeOf $ Proxy @Bool) } +-- | @BasicBLE@ can be compiled to C instance IsPeripheral C BasicBLE where declareReference _ _ id _ _ = error "error --- declareReference BasicBLE called" + declaredReferences _ bble = map (\f -> uncurry makeStaticRef $ f bble) [broadcast_, broadcastControl_, scan_, scanControl_] - globalDeclarations p bble = flip map (declaredReferences p bble) $ \ref -> do - [cedecl| $ty:(svt_ $ dereference $ refType ref) $id:(refName ref); |] + globalDeclarations p bble = [] staticInitialization p bble = let enable = [cexp| $id:enable_ble_stack() |] @@ -67,11 +80,13 @@ instance IsPeripheral C BasicBLE where scaninit = [cexp| $id:initialize_static_input_ble_scan_device(&$id:(refName scanref).sv) |] in [citems| $exp:enable; $exp:scaninit; |] +-- | This class abstracts away the action of creating handlers for a specific backend class BLEHandlers backend where broadcastHandler :: proxy backend -> BasicBLE -> Handler backend broadcastControlHandler :: proxy backend -> BasicBLE -> Handler backend scanControlHandler :: proxy backend -> BasicBLE -> Handler backend +-- | The handlers can be compiled to C instance BLEHandlers C where broadcastHandler _ bble = Handler (\k cs -> @@ -103,8 +118,9 @@ instance BLEHandlers C where , identName $ fst $ scanControl_ bble , ")"]) --- frontend api of BBLE +---------- Frontend API of BBLE ---------- +-- | This object can be used to access the BLE driver data BBLE = BBLE { broadcast :: Ref Word64 , broadcastControl :: Ref Bool @@ -112,6 +128,7 @@ data BBLE = BBLE , scanControl :: Ref Bool } + -- | Create a @BBLE@ from a @BasicBLE@ createBBLE :: BasicBLE -> BBLE createBBLE bble = BBLE { broadcast = Ptr $ uncurry makeStaticRef $ broadcast_ bble @@ -148,9 +165,19 @@ toggleControl ctrl command = do after (nsecs 1) ctrl command wait ctrl +-- | Key to use when looking up the @BasicBLE@ peripheral from the @Compile@-monad bblekey :: String bblekey = "bblekey" +{- | Enable the BBLE driver, and get four things bacl. + + 1. @BBLE@ value that can be used to access the BLE driver + 2. Handler that when scheduled make sure that the broadcast payload is + updated + 3. Handler that when scheduled enables the broadcast control functionality + 4. Handler that when scheduled enables the scan control functionality + +-} enableBLE :: forall backend . (IsPeripheral backend BasicBLE, BLEHandlers backend) => Compile backend (BBLE, OutputHandler backend, OutputHandler backend, OutputHandler backend) enableBLE = do modify $ \st -> st { @@ -164,6 +191,8 @@ enableBLE = do return (bble, broadcastH, broadcastControlH, scanControlH) +{- | If a backend satisfies the @SupperBBLE@ constraint, the backend fully supports +the BBLE functionality. -} type SupportBBLE backend = ( IsPeripheral backend BasicBLE , BLEHandlers backend ) diff --git a/ssm/SSM/Frontend/Peripheral/GPIO.hs b/ssm/SSM/Frontend/Peripheral/GPIO.hs index e87ea9bc..2cab5517 100644 --- a/ssm/SSM/Frontend/Peripheral/GPIO.hs +++ b/ssm/SSM/Frontend/Peripheral/GPIO.hs @@ -1,3 +1,5 @@ +{-| This module exposes the GPIO peripheral. The GPIO peripheral enables a developer +to write programs that use GPIO pins either as high/low output or high/low input. -} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE QuasiQuotes #-} @@ -6,13 +8,17 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} module SSM.Frontend.Peripheral.GPIO - ( output - , input + ( -- * SUpporting GPIO + SupportGPIO + -- * Output GPIO , GPIO + , output + -- * Input GPIO + , input , Switch + -- * Controlling GPIO , high , low - , SupportGPIO ) where @@ -66,19 +72,14 @@ instance IsPeripheral C GPIOutput where declaredReferences _ gpio = map (uncurry makeStaticRef) $ Map.elems $ output_ gpio - globalDeclarations p gpio = - flip map (declaredReferences p gpio) $ \ref -> - [cedecl| $ty:(svt_ $ dereference $ refType ref) $id:(refName ref); |] + globalDeclarations p gpio = [] - staticInitialization p gpio = flip concatMap (declaredReferences p gpio) $ \ref -> - let bt = dereference $ refType ref - init = initialize_ bt [cexp| &$id:(refName ref)|] - assign = assign_ bt [cexp| &$id:(refName ref)|] [cexp|0|] [cexp|0|] - in [citems| $exp:init; $exp:assign; |] + staticInitialization p gpio = [] gpioutputkey :: String gpioutputkey = "gpioutput" +-- | GPIO output pins have a binary state type GPIO = Bool {- | Populates the GPIO pripheral with a new reference. @@ -127,10 +128,15 @@ instance GPIOHandler C where pretty = concat ["initialize_static_output_device(", refName r, ", ", show i, ")"] in Handler sched pretty -{- | Ask the GPIO peripheral for a GPIO pin identified by the @Word8@, and -get the reference and handler back. The reference is what is used to interact -with the GPIO, and the handler must be `schedule`d in order to actually -perform the IO output actions. -} +{- | Ask the GPIO peripheral for an output pin that can take the value high or low. +The pin is identified by the @Word8@ parameter. + +The output is + + 1. A reference that controls the pin + 2. A handler than when scheduled will make sure that the IO is actualized + + -} output :: forall backend . (IsPeripheral backend GPIOutput, GPIOHandler backend) => Word8 -> Compile backend (Ref GPIO, OutputHandler backend) @@ -158,22 +164,19 @@ instance IsPeripheral C GPInputO where declaredReferences _ gpio = map (uncurry makeStaticRef) $ Map.elems $ input_ gpio - globalDeclarations p gpio = - flip map (declaredReferences p gpio) $ \ref -> - [cedecl| $ty:(svt_ $ dereference $ refType ref) $id:(refName ref); |] + globalDeclarations p gpio = [] staticInitialization p gpio = flip concatMap (Map.toList (input_ gpio)) $ \(i,(id,t)) -> let bt = dereference t ref = makeStaticRef id t - init = initialize_ bt [cexp| &$id:(refName ref)|] - assign = assign_ bt [cexp| &$id:(refName ref)|] [cexp|0|] [cexp|0|] bind = [cexp| $id:initialize_static_input_device( - (typename ssm_sv_t *) &$id:(refName ref).sv, - $uint:i) |] - in [citems| $exp:init; $exp:assign; $exp:bind; |] + (typename ssm_sv_t *) &$id:(refName ref).sv, + $uint:i) |] + in [citems| $exp:bind; |] +-- | GPIO input pins have a binary state type Switch = Bool gpinputokey :: String @@ -202,6 +205,11 @@ insertGPInputO i id = do typ :: Type typ = mkReference $ typeOf $ Proxy @Bool +{- | Ask the GPIO peripheral for an input pin that can take the value high or low. +The pin is identified by the @Word8@ parameter. + +The output is a reference that is written to by the GPIO driver when an input is received + -} input :: forall backend . (IsPeripheral backend GPInputO, GPIOHandler backend) => Word8 -> Compile backend (Ref Switch) @@ -213,12 +221,16 @@ input i = do return ref +-- | pin state high high :: Exp Bool high = true +-- | pin state low low :: Exp Bool low = false +{- | A backend that satisfies the @SupportGPIO@ constraint fully supports both input and +output GPIO pins. -} type SupportGPIO backend = ( IsPeripheral backend GPIOutput , IsPeripheral backend GPInputO , GPIOHandler backend diff --git a/ssm/SSM/Frontend/Peripheral/Identity.hs b/ssm/SSM/Frontend/Peripheral/Identity.hs index e19dc428..236b63f9 100644 --- a/ssm/SSM/Frontend/Peripheral/Identity.hs +++ b/ssm/SSM/Frontend/Peripheral/Identity.hs @@ -1,10 +1,14 @@ +{- | This module implements an identity peripheral. The identity peripheral has +no IO actions associated with it, and is used solely to create references that +exist in the global scope. -} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE FlexibleContexts #-} -module SSM.Frontend.Peripheral.Identity where +{-# LANGUAGE FlexibleInstances #-} +module SSM.Frontend.Peripheral.Identity ( global ) where import SSM.Core hiding (peripherals) @@ -30,7 +34,8 @@ data Globals = Globals { references :: Map.Map Ident Type } emptyGlobals :: Globals emptyGlobals = Globals Map.empty -instance IsPeripheral C Globals where +-- | The identity peripheral works regardless of backend, since no IO is involved +instance IsPeripheral backend Globals where declareReference _ t id _ global = let m = references global in global { references = Map.insert id t m} @@ -38,17 +43,27 @@ instance IsPeripheral C Globals where declaredReferences _ globals = map (uncurry makeStaticRef) $ Map.toList $ references globals - globalDeclarations p globals = - flip map (declaredReferences p globals) $ \ref -> - [cedecl| $ty:(svt_ $ dereference $ refType ref) $id:(refName ref); |] + globalDeclarations p globals = [] - staticInitialization p globals = flip concatMap (declaredReferences p globals) $ \ref -> - let bt = dereference $ refType ref - init = initialize_ bt [cexp| &$id:(refName ref) |] - assign = assign_ bt [cexp| &$id:(refName ref)|] [cexp|0|] [cexp|0|] - in [citems| $exp:init; $exp:assign; |] + staticInitialization p globals = [] -global :: forall backend a . (IsPeripheral backend Globals, SSMType a) => Compile backend (Ref a) +{- | Create a global reference. The reference is created in the compile monad and +can be shared across the Scoria program with the @ImplicitParams@ extension. + +@ +program :: Compile backend () +program = do + ref <- global @Word8 + let ?ref = ref + + schedule main + +main :: (?ref :: Ref Word8) => SSM () +main = assign ?ref 5 +@ + +-} +global :: forall a backend . SSMType a => Compile backend (Ref a) global = do n <- fresh let id = Ident ("global" <> show n) Nothing diff --git a/ssm/SSM/Test.hs b/ssm/SSM/Test.hs index ec54ce12..b9aeb448 100644 --- a/ssm/SSM/Test.hs +++ b/ssm/SSM/Test.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fplugin=SSM.Plugin -fplugin-opt=SSM.Plugin:mode=routine #-} module SSM.Test where @@ -8,6 +9,7 @@ import Prelude import SSM.Language import SSM.Frontend.Peripheral.GPIO +import SSM.Frontend.Peripheral.Identity import SSM.Core.Backend import SSM.Compile @@ -20,18 +22,21 @@ program = do (led0, handler0) <- output 0 (led1, handler1) <- output 1 (led2, handler2) <- output 2 + glo <- global @Word8 let ?led0 = led0 ?led1 = led1 ?led2 = led2 + ?glo = glo schedule main schedule handler0 schedule handler1 schedule handler2 where - main :: (?led0 :: Ref GPIO, ?led1 :: Ref GPIO, ?led2 :: Ref GPIO) => SSM () + main :: (?led0 :: Ref GPIO, ?led1 :: Ref GPIO, ?led2 :: Ref GPIO, ?glo :: Ref Word8) => SSM () main = routine $ do ?led0 <~ high ?led1 <~ low ?led2 <~ high + ?glo <~ 0 From 1febb62e0db53cd3ef53c4fa8764b13105d8571f Mon Sep 17 00:00:00 2001 From: Robert Krook Date: Mon, 13 Dec 2021 12:32:24 +0100 Subject: [PATCH 08/16] added PrettyPrint backend and the appropriate instances --- ssm/SSM/Backend/C/CodeGen.hs | 2 +- ssm/SSM/Core/Backend.hs | 8 ++- ssm/SSM/Core/Program.hs | 4 +- ssm/SSM/Frontend/Peripheral/BasicBLE.hs | 87 ++++++++++++++++++++----- ssm/SSM/Frontend/Peripheral/GPIO.hs | 78 ++++++++++++++++++---- ssm/SSM/Pretty.hs | 4 +- ssm/SSM/Pretty/Syntax.hs | 67 +++++++++++++++---- ssm/SSM/Test.hs | 23 +++++-- 8 files changed, 218 insertions(+), 55 deletions(-) diff --git a/ssm/SSM/Backend/C/CodeGen.hs b/ssm/SSM/Backend/C/CodeGen.hs index 9166bb23..c12ec232 100644 --- a/ssm/SSM/Backend/C/CodeGen.hs +++ b/ssm/SSM/Backend/C/CodeGen.hs @@ -157,7 +157,7 @@ genInitProgram p = [cunit| , $args:(map cargs args) ) ); |]] - initialFork k cs (OutputHandler (Handler f _)) = f k cs + initialFork k cs (OutputHandler (Handler f)) = f k cs cargs :: Either SSMExp Reference -> C.Exp cargs (Left e) = genExp [] e diff --git a/ssm/SSM/Core/Backend.hs b/ssm/SSM/Core/Backend.hs index d643acfe..a2466c67 100644 --- a/ssm/SSM/Core/Backend.hs +++ b/ssm/SSM/Core/Backend.hs @@ -4,6 +4,7 @@ code in a general way. -} {-# LANGUAGE TypeFamilies #-} module SSM.Core.Backend ( C + , PrettyPrint , Definition , Statement ) where @@ -12,11 +13,14 @@ import qualified Language.C.Syntax as C -- | Programs can be compiled to C data C +data PrettyPrint -- | Type of top-level declarations type family Definition backend where - Definition C = C.Definition + Definition C = C.Definition + Definition PrettyPrint = String -- | Type of statements type family Statement backend where - Statement C = C.BlockItem + Statement C = C.BlockItem + Statement PrettyPrint = String diff --git a/ssm/SSM/Core/Program.hs b/ssm/SSM/Core/Program.hs index 1ba91303..af288b62 100644 --- a/ssm/SSM/Core/Program.hs +++ b/ssm/SSM/Core/Program.hs @@ -47,9 +47,7 @@ of things that are scheduled and the total number of things that are scheduled, handler can return the statements that schedule this handler. A Handler can also specify a string to use when pretty-printing. -} data Handler backend = Handler - { gen_handler :: Int -> Int -> [Statement backend] - , pretty_handler :: String - } + { gen_handler :: Int -> Int -> [Statement backend] } instance Show (QueueContent backend) where show (SSMProcedure id args) = "SSMProcedure " <> show id <> " " <> show args diff --git a/ssm/SSM/Frontend/Peripheral/BasicBLE.hs b/ssm/SSM/Frontend/Peripheral/BasicBLE.hs index 372a1b4f..4729902f 100644 --- a/ssm/SSM/Frontend/Peripheral/BasicBLE.hs +++ b/ssm/SSM/Frontend/Peripheral/BasicBLE.hs @@ -64,14 +64,18 @@ initBasicBLE = BasicBLE , scanControl_ = (makeIdent "scanControl", mkReference $ typeOf $ Proxy @Bool) } --- | @BasicBLE@ can be compiled to C -instance IsPeripheral C BasicBLE where - declareReference _ _ id _ _ = error "error --- declareReference BasicBLE called" +declareReferenceBasicBLE :: proxy backend -> Type -> Ident -> Word8 -> BasicBLE -> BasicBLE +declareReferenceBasicBLE _ _ _ _ _ = error "error --- declareReference BasicBLE called" - declaredReferences _ bble = map - (\f -> uncurry makeStaticRef $ f bble) - [broadcast_, broadcastControl_, scan_, scanControl_] +declaredReferencesBasicBLE :: proxy backend -> BasicBLE -> [Reference] +declaredReferencesBasicBLE _ bble = + map (\f -> uncurry makeStaticRef $ f bble) + [broadcast_, broadcastControl_, scan_, scanControl_] +-- | @BasicBLE@ can be compiled to C +instance IsPeripheral C BasicBLE where + declareReference = declareReferenceBasicBLE + declaredReferences = declaredReferencesBasicBLE globalDeclarations p bble = [] staticInitialization p bble = @@ -80,6 +84,52 @@ instance IsPeripheral C BasicBLE where scaninit = [cexp| $id:initialize_static_input_ble_scan_device(&$id:(refName scanref).sv) |] in [citems| $exp:enable; $exp:scaninit; |] +instance IsPeripheral PrettyPrint BasicBLE where + declareReference = declareReferenceBasicBLE + declaredReferences = declaredReferencesBasicBLE + + globalDeclarations p bble = map init [ + unlines [ "-- BBLE peripheral broadcast handler:" + , "-- initialize_static_output_ble_broadcast(ref) binds the ref to this procedure" + , "broadcast_handler() {" + , " while(true) {" + , concat [" wait ", identName $ fst $ broadcast_ bble] + , " -- reflect value of broadcast ref in BLE broadcast payload" + , " }" + , "}" + ] + , unlines [ "-- BBLE peripheral broadcast control handler:" + , "-- initialize_static_output_ble_broadcast_control(ref) binds the ref to this procedure" + , "broadcast_control_handler() {" + , " while(true) {" + , concat [" wait ", identName $ fst $ broadcastControl_ bble] + , " -- toggle broadcasting on or off depending on broadcastControl value" + , " }" + , "}" + ] + , unlines [ "-- BBLE peripheral scan control handler:" + , "-- initialize_static_output_ble_scan_control(ref) binds the ref to this procedure" + , "scan_control_handler() {" + , " while(true) {" + , concat [" wait ", identName $ fst $ scanControl_ bble] + , " -- toggle scanning on or off depending on scanControl value" + , " }" + , "}" + ] + , unlines [ "-- BBLE peripheral broadcast handler:" + , "-- initialize_static_output_ble_scan(ref) binds the ref to this procedure" + , "scan_handler() {" + , " while(true) {" + , " -- wait to successfully scan for a received BLE packet" + , concat [" -- turn the scanned message into an event on the ", identName $ fst $ scan_ bble, " ref"] + , " }" + , "}" + ] + ] + + staticInitialization p bble = [ "enable_ble()" + , concat ["initialize_static_output_ble_scan(", identName $ fst $ scan_ bble, ")"]] + -- | This class abstracts away the action of creating handlers for a specific backend class BLEHandlers backend where broadcastHandler :: proxy backend -> BasicBLE -> Handler backend @@ -94,9 +144,6 @@ instance BLEHandlers C where proto = initialize_static_output_ble_broadcast_device refname = identName $ fst $ broadcast_ bble in [[citem| $id:proto(&$id:(refname).sv); |]]) - (concat [ "bind_static_ble_broadcast_handler_device(" - , identName $ fst $ broadcast_ bble - , ")"]) broadcastControlHandler _ bble = Handler (\k cs -> @@ -104,9 +151,6 @@ instance BLEHandlers C where proto = initialize_static_output_ble_broadcast_control_device refname = identName $ fst $ broadcastControl_ bble in [[citem| $id:proto(&$id:(refname).sv); |]]) - (concat [ "bind_static_ble_broadcast_control_handler_device(" - , identName $ fst $ broadcastControl_ bble - , ")"]) scanControlHandler _ bble = Handler (\k cs -> @@ -114,9 +158,22 @@ instance BLEHandlers C where proto = initialize_static_output_ble_scan_control_device refname = identName $ fst $ scanControl_ bble in [[citem| $id:proto(&$id:(refname).sv); |]]) - (concat [ "bind_static_ble_scan_control_handler_device(" - , identName $ fst $ scanControl_ bble - , ")"]) + +instance BLEHandlers PrettyPrint where + broadcastHandler _ bble = Handler $ \_ _ -> + [concat [ "initialize_static_output_ble_broadcast(" + , identName $ fst $ broadcast_ bble, ")" + ]] + + broadcastControlHandler _ bble = Handler $ \_ _ -> + [concat [ "initialize_static_output_ble_broadcast_control(" + , identName $ fst $ broadcastControl_ bble, ")" + ]] + + scanControlHandler _ bble = Handler $ \_ _ -> + [concat [ "initialize_static_output_ble_scan_control(" + , identName $ fst $ scan_ bble, ")" + ]] ---------- Frontend API of BBLE ---------- diff --git a/ssm/SSM/Frontend/Peripheral/GPIO.hs b/ssm/SSM/Frontend/Peripheral/GPIO.hs index 2cab5517..96f6c7b7 100644 --- a/ssm/SSM/Frontend/Peripheral/GPIO.hs +++ b/ssm/SSM/Frontend/Peripheral/GPIO.hs @@ -66,16 +66,40 @@ data GPIOutput = GPIOutput { output_ :: Map.Map Word8 (Ident, Type)} emptyGPIOutput :: GPIOutput emptyGPIOutput = GPIOutput { output_ = Map.empty } +declareReferenceGPIOutput :: proxy backend -> Type -> Ident -> Word8 -> GPIOutput -> GPIOutput +declareReferenceGPIOutput _ t id i gpio = gpio { output_ = Map.insert i (id,t) (output_ gpio) } + +declaredReferencesGPIOutput :: proxy backend -> GPIOutput -> [Reference] +declaredReferencesGPIOutput _ gpio = map (uncurry makeStaticRef) $ Map.elems $ output_ gpio + instance IsPeripheral C GPIOutput where - declareReference _ t id i gpio = gpio { output_ = Map.insert i (id,t) (output_ gpio) } + declareReference = declareReferenceGPIOutput + + declaredReferences = declaredReferencesGPIOutput - declaredReferences _ gpio = - map (uncurry makeStaticRef) $ Map.elems $ output_ gpio - globalDeclarations p gpio = [] staticInitialization p gpio = [] +instance IsPeripheral PrettyPrint GPIOutput where + declareReference = declareReferenceGPIOutput + + declaredReferences = declaredReferencesGPIOutput + + globalDeclarations p gpio = [ + unlines [ "-- GPIO peripheral output handler:" + , "-- initialize_static_output_device(ref,id) binds the ref to this procedure" + , "output_handler(ref,id) {" + , " while(true) {" + , " wait ref" + , " -- actualize value of ref to output pin id" + , " }" + , "}" + ] + ] + + staticInitialization p gpio = [] + gpioutputkey :: String gpioutputkey = "gpioutput" @@ -125,9 +149,12 @@ instance GPIOHandler C where $exp:dep, &$id:(refName r).sv, $uint:i);|]] - pretty = concat ["initialize_static_output_device(", refName r, ", ", show i, ")"] - in Handler sched pretty - + in Handler sched + +instance GPIOHandler PrettyPrint where + make_handler _ (Ptr r) i = Handler $ \_ _ -> + [concat ["initialize_static_output_device(", refName r, ", ", show i, ")"]] + {- | Ask the GPIO peripheral for an output pin that can take the value high or low. The pin is identified by the @Word8@ parameter. @@ -158,15 +185,20 @@ data GPInputO = GPInputO { input_ :: Map.Map Word8 (Ident, Type) } emptyGPInputO :: GPInputO emptyGPInputO = GPInputO { input_ = Map.empty } +declareReferenceGPInputO :: proxy backend -> Type -> Ident -> Word8 -> GPInputO -> GPInputO +declareReferenceGPInputO _ t id i gpio = gpio { input_ = Map.insert i (id,t) (input_ gpio) } + +declaredReferencesGPInputO :: proxy backend -> GPInputO -> [Reference] +declaredReferencesGPInputO _ gpio = map (uncurry makeStaticRef) $ Map.elems $ input_ gpio + instance IsPeripheral C GPInputO where - declareReference _ t id i gpio = gpio { input_ = Map.insert i (id,t) (input_ gpio) } + declareReference = declareReferenceGPInputO + + declaredReferences = declaredReferencesGPInputO - declaredReferences _ gpio = - map (uncurry makeStaticRef) $ Map.elems $ input_ gpio - globalDeclarations p gpio = [] - staticInitialization p gpio = flip concatMap (Map.toList (input_ gpio)) $ + staticInitialization p gpio = flip map (Map.toList (input_ gpio)) $ \(i,(id,t)) -> let bt = dereference t @@ -174,7 +206,27 @@ instance IsPeripheral C GPInputO where bind = [cexp| $id:initialize_static_input_device( (typename ssm_sv_t *) &$id:(refName ref).sv, $uint:i) |] - in [citems| $exp:bind; |] + in [citem| $exp:bind; |] + +instance IsPeripheral PrettyPrint GPInputO where + declareReference = declareReferenceGPInputO + + declaredReferences = declaredReferencesGPInputO + + globalDeclarations p gpio = map init [ + unlines [ "-- GPIO peripheral input handler:" + , "-- initialize_static_input_device(ref,id) binds the ref to this procedure" + , "input_handler(ref,id) {" + , " while(true) {" + , " -- wait for input on pin id" + , " -- turn input on pin id to a write to ref" + , " }" + , "}" + ] + ] + + staticInitialization _ gpio = flip map (Map.toList (input_ gpio)) $ + \(i,(id,t)) -> concat ["initialize_static_input_device(", identName id, ", ", show i, ")"] -- | GPIO input pins have a binary state type Switch = Bool diff --git a/ssm/SSM/Pretty.hs b/ssm/SSM/Pretty.hs index 24e626f7..41774b86 100644 --- a/ssm/SSM/Pretty.hs +++ b/ssm/SSM/Pretty.hs @@ -75,5 +75,5 @@ import SSM.Core.Program import SSM.Pretty.Syntax ( prettyProgram ) import SSM.Core.Backend -prettySSM :: forall backend a . SSMProgram backend a => a -> String -prettySSM = prettyProgram . toProgram @backend +prettySSM :: SSMProgram PrettyPrint a => a -> String +prettySSM = prettyProgram . toProgram diff --git a/ssm/SSM/Pretty/Syntax.hs b/ssm/SSM/Pretty/Syntax.hs index c9aab963..95db3aaa 100644 --- a/ssm/SSM/Pretty/Syntax.hs +++ b/ssm/SSM/Pretty/Syntax.hs @@ -8,7 +8,7 @@ import Data.List import Data.Proxy import Control.Monad.Reader - ( ReaderT(runReaderT), MonadReader(local, ask) ) + ( ReaderT(runReaderT), MonadReader(local, ask), forM, forM_ ) import Control.Monad.Writer ( execWriter, MonadWriter(tell), Writer ) @@ -39,33 +39,74 @@ intercalateM ma (x:y:xs) = do {- | Pretty print a program. There is no control of line width currently. If your program contains many nested if's or something, they will be turned into quite wide statements. -} -prettyProgram :: Program backend -> String +prettyProgram :: Program PrettyPrint -> String prettyProgram ssm = let wr = runReaderT (prettyProgram' ssm) 0 h = execWriter wr in unlines $ fromHughes h -prettyProgram' :: Program backend -> PP () +prettyProgram' :: Program PrettyPrint -> PP () prettyProgram' p = do - emit "initial ready-queue content:" - mapM_ (indent . emit . prettyQueueContent) (initialQueueContent p) - emit "" - emit "global variables:" + emit "-- ** global variables **" mapM_ prettyPeripheralDeclarations (peripherals p) emit "" + emit "-- ** global declarations by peripherals **" + globaldecls p + emit "" + emit "-- ** program setup function **" + program_setup p + emit "" + emit "-- ** executable entry point **" + run_program p + emit "" + emit "-- ***** user-written Scoria procedures *****" intercalateM (emit "") $ map prettyProcedure (Map.elems (funs p)) return () -prettyQueueContent :: QueueContent backend -> String -prettyQueueContent (SSMProcedure id args) = prettyApp (id, args) -prettyQueueContent (OutputHandler (Handler _ p)) = p +globaldecls :: Program PrettyPrint -> PP () +globaldecls p = do + intercalateM (emit "") $ concatMap + (\pe -> map emit (globalDeclarations (Proxy @PrettyPrint) pe)) + (peripherals p) + return () + +program_setup :: Program PrettyPrint -> PP () +program_setup p = do + emit "setup() {" + + indent $ emit "-- initialize global references" + forM_ (map (declaredReferences (Proxy @PrettyPrint)) (peripherals p)) $ \refs -> + forM_ refs $ \ref -> indent $ emit $ concat ["initialize_ref(", refName ref, ")"] + + emit "" + indent $ emit "-- initialize output peripherals" + forM_ (map (staticInitialization (Proxy @PrettyPrint)) (peripherals p)) $ \inits -> + mapM_ (indent . emit) inits + + emit "" + indent $ emit "-- schedule initial ready-queue content" + forM_ (initialQueueContent p) $ \qc -> + mapM_ (indent . emit . \x -> concat ["schedule(", x, ")"]) $ prettyQueueContent qc + + emit "}" + +run_program :: Program PrettyPrint -> PP () +run_program p = do + emit "run_program() {" + indent $ emit "setup()" + indent $ emit "run_scheduler()" + emit "}" + +prettyQueueContent :: QueueContent PrettyPrint -> [String] +prettyQueueContent (SSMProcedure id args) = [prettyApp (id, args)] +prettyQueueContent (OutputHandler (Handler p)) = p 0 0 prettyReferenceDecls :: [Reference] -> PP () prettyReferenceDecls xs = flip mapM_ xs $ \ref -> - indent $ emit $ concat [prettyType (refType ref), " ", refName ref] + emit $ concat [prettyType (refType ref), " ", refName ref] -prettyPeripheralDeclarations :: forall backend . Peripheral backend -> PP () +prettyPeripheralDeclarations :: Peripheral PrettyPrint -> PP () prettyPeripheralDeclarations (Peripheral p) = - prettyReferenceDecls $ declaredReferences (Proxy @backend) p + prettyReferenceDecls $ declaredReferences (Proxy @PrettyPrint) p prettyProcedure :: Procedure -> PP () prettyProcedure p = do diff --git a/ssm/SSM/Test.hs b/ssm/SSM/Test.hs index b9aeb448..de29dbd7 100644 --- a/ssm/SSM/Test.hs +++ b/ssm/SSM/Test.hs @@ -10,6 +10,7 @@ import Prelude import SSM.Language import SSM.Frontend.Peripheral.GPIO import SSM.Frontend.Peripheral.Identity +import SSM.Frontend.Peripheral.BasicBLE import SSM.Core.Backend import SSM.Compile @@ -17,26 +18,36 @@ import SSM.Pretty import Data.Word -program :: (SupportGPIO backend) => Compile backend () +program :: (SupportGPIO backend, SupportBBLE backend) => Compile backend () program = do (led0, handler0) <- output 0 (led1, handler1) <- output 1 (led2, handler2) <- output 2 + input0 <- input 0 + input1 <- input 1 glo <- global @Word8 + (_, b, bc, sc) <- enableBLE - let ?led0 = led0 - ?led1 = led1 - ?led2 = led2 - ?glo = glo + let ?led0 = led0 + ?led1 = led1 + ?led2 = led2 + ?input0 = input0 + ?input1 = input1 + ?glo = glo schedule main schedule handler0 schedule handler1 schedule handler2 + schedule b + schedule bc + schedule sc where - main :: (?led0 :: Ref GPIO, ?led1 :: Ref GPIO, ?led2 :: Ref GPIO, ?glo :: Ref Word8) => SSM () + main :: ( ?led0 :: Ref GPIO , ?led1 :: Ref GPIO, ?led2 :: Ref GPIO + , ?glo :: Ref Word8, ?input0 :: Ref Switch, ?input1 :: Ref Switch) => SSM () main = routine $ do ?led0 <~ high ?led1 <~ low ?led2 <~ high + ?input0 <~ deref ?led0 ?glo <~ 0 From e864f5970d02f1b724f5613e86febb5988b27e67 Mon Sep 17 00:00:00 2001 From: Robert Krook Date: Tue, 14 Dec 2021 16:13:40 +0100 Subject: [PATCH 09/16] added interpreter backend and started trying to make tests work. Now I am starting to doubt if this is actually worth it. --- ssm/SSM/Compile.hs | 12 ++++--- ssm/SSM/Core/Backend.hs | 4 +++ ssm/SSM/Core/Program.hs | 3 +- ssm/SSM/Core/Type.hs | 2 +- ssm/SSM/Frontend/Peripheral/BasicBLE.hs | 10 ++++++ ssm/SSM/Frontend/Peripheral/GPIO.hs | 15 +++++++++ ssm/SSM/Frontend/Peripheral/Identity.hs | 5 ++- ssm/SSM/Interpret/Interpreter.hs | 9 ++--- ssm/SSM/Interpret/Trace.hs | 14 +++++--- ssm/SSM/Pretty.hs | 4 +-- ssm/SSM/Test.hs | 4 +-- test/lib/Test/SSM/Build.hs | 4 ++- test/lib/Test/SSM/Prop.hs | 33 ++++++++++++------- test/lib/Test/SSM/QuickCheck/Generator.hs | 9 ++--- test/lib/Test/SSM/QuickCheck/Shrink.hs | 2 +- .../Test/SSM/QuickCheck/Shrink/Expressions.hs | 2 +- test/lib/Test/SSM/QuickCheck/Shrink/Fork.hs | 2 +- test/lib/Test/SSM/QuickCheck/Shrink/If.hs | 2 +- .../SSM/QuickCheck/Shrink/ProcedureArity.hs | 2 +- .../Test/SSM/QuickCheck/Shrink/Procedures.hs | 10 +++--- .../Test/SSM/QuickCheck/Shrink/References.hs | 2 +- .../Test/SSM/QuickCheck/Shrink/Statements.hs | 2 +- test/lib/Test/SSM/QuickCheck/Shrink/Wait.hs | 2 +- test/lib/Test/SSM/QuickCheck/Util.hs | 2 +- test/lib/Test/SSM/Report.hs | 9 +++-- test/lib/Test/SSM/Trace.hs | 6 ++-- .../Regression/CancelBothSpec.hs | 2 +- .../Regression/CancelLaterSpec.hs | 2 +- .../regression-low/Regression/EmptyFunSpec.hs | 2 +- .../Regression/FiveForkerSpec.hs | 2 +- .../Regression/FlipFlopLoopSpec.hs | 2 +- .../Regression/GlobalEventSpec.hs | 2 +- .../Regression/Int32ArithSpec.hs | 2 +- .../Regression/LaterAssignOverwriteSpec.hs | 2 +- .../Regression/LaterWaitSpec.hs | 2 +- .../Regression/ManyContsSpec.hs | 2 +- .../Regression/MultOverflowIndirectSpec.hs | 2 +- .../Regression/MultOverflowSpec.hs | 2 +- .../regression-low/Regression/NewEventSpec.hs | 2 +- .../Regression/RecurseExhaustDepthSpec.hs | 2 +- .../Regression/RecurseForeverSpec.hs | 2 +- .../Regression/CancelBothSpec.hs | 2 +- .../Regression/CancelLaterSpec.hs | 2 +- .../Regression/EmptyFunSpec.hs | 2 +- .../Regression/FlipFlopLoopSpec.hs | 2 +- .../Regression/GlobalEventSpec.hs | 4 +-- .../Regression/Int32ArithSpec.hs | 2 +- .../Regression/LaterAssignOverflowSpec.hs | 2 +- .../Regression/LaterWaitSpec.hs | 2 +- .../Regression/ManyContsSpec.hs | 2 +- .../Regression/MultOverflowIndirectSpec.hs | 2 +- .../Regression/MultOverflowSpec.hs | 2 +- .../Regression/NewEventSpec.hs | 2 +- .../Regression/RecurseExhaustiveSpec.hs | 2 +- .../Regression/RecurseForeverSpec.hs | 2 +- .../Regression/SynthesizeAdditionSpec.hs | 2 +- .../Regression/SynthesizeDelaySpec.hs | 2 +- .../SynthesizeForeverRecurseSpec.hs | 2 +- .../Regression/SynthesizeNamedSpec.hs | 2 +- .../Regression/SynthesizeRecursiveSpec.hs | 2 +- 60 files changed, 148 insertions(+), 93 deletions(-) diff --git a/ssm/SSM/Compile.hs b/ssm/SSM/Compile.hs index 33a13ff9..655e3f97 100644 --- a/ssm/SSM/Compile.hs +++ b/ssm/SSM/Compile.hs @@ -1,6 +1,7 @@ -- | SSM EDSL compilation interface, for compiling to C code. {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} module SSM.Compile ( SSMProgram(..) , toC @@ -23,18 +24,19 @@ import SSM.Core.Backend -- | Compile a program to a C-file. -- -- TODO: This can fail, so it should return Either CompileError String. -toC :: SSMProgram C a => a -> String -toC = compile . toProgram +--toC :: SSMProgram C a => a -> String +toC :: SSMProgram C p => p -> String +toC p = compile $ toProgram p -- | Compile a program and write it to the specified path. -compileFile :: SSMProgram C a => FilePath -> a -> IO () +compileFile :: SSMProgram C p => FilePath -> p -> IO () compileFile fp = writeFile fp . toC -- | Create command-line compilation interface for specific program. -- -- Includes parameter for specifying a default filepath. If this is not needed, -- use @compileCli_@. -compileCli :: SSMProgram C a => Maybe FilePath -> a -> IO () +compileCli :: SSMProgram C p => Maybe FilePath -> p -> IO () compileCli defaultPath program = do args <- getArgs path <- getFilePath args @@ -61,5 +63,5 @@ compileCli defaultPath program = do exitWith $ ExitFailure 1 -- | Create command-line compilation interface for specific program. -compileCli_ :: SSMProgram C a => a -> IO () +compileCli_ :: SSMProgram C p => p -> IO () compileCli_ = compileCli Nothing diff --git a/ssm/SSM/Core/Backend.hs b/ssm/SSM/Core/Backend.hs index a2466c67..959302db 100644 --- a/ssm/SSM/Core/Backend.hs +++ b/ssm/SSM/Core/Backend.hs @@ -5,6 +5,7 @@ code in a general way. -} module SSM.Core.Backend ( C , PrettyPrint + , Interpret , Definition , Statement ) where @@ -14,13 +15,16 @@ import qualified Language.C.Syntax as C -- | Programs can be compiled to C data C data PrettyPrint +data Interpret -- | Type of top-level declarations type family Definition backend where Definition C = C.Definition Definition PrettyPrint = String + Definition Interpret = () -- FIXME add meaning -- | Type of statements type family Statement backend where Statement C = C.BlockItem Statement PrettyPrint = String + Statement Interpret = () -- FIXME add meaning diff --git a/ssm/SSM/Core/Program.hs b/ssm/SSM/Core/Program.hs index af288b62..245a404e 100644 --- a/ssm/SSM/Core/Program.hs +++ b/ssm/SSM/Core/Program.hs @@ -46,8 +46,7 @@ data QueueContent backend of things that are scheduled and the total number of things that are scheduled, the handler can return the statements that schedule this handler. A Handler can also specify a string to use when pretty-printing. -} -data Handler backend = Handler - { gen_handler :: Int -> Int -> [Statement backend] } +data Handler backend = Handler { gen_handler :: Int -> Int -> [Statement backend] } instance Show (QueueContent backend) where show (SSMProcedure id args) = "SSMProcedure " <> show id <> " " <> show args diff --git a/ssm/SSM/Core/Type.hs b/ssm/SSM/Core/Type.hs index 0a5d36c1..f5dec66c 100644 --- a/ssm/SSM/Core/Type.hs +++ b/ssm/SSM/Core/Type.hs @@ -27,7 +27,7 @@ data Type | TBool -- ^ Boolean type | TEvent -- ^ Event type | Ref Type -- ^ A reference to another type - deriving (Eq, Show) + deriving (Eq, Show, Read) -- | Dereference a type. Throws an error if the type is not a reference. dereference :: Type -> Type diff --git a/ssm/SSM/Frontend/Peripheral/BasicBLE.hs b/ssm/SSM/Frontend/Peripheral/BasicBLE.hs index 4729902f..53be60f7 100644 --- a/ssm/SSM/Frontend/Peripheral/BasicBLE.hs +++ b/ssm/SSM/Frontend/Peripheral/BasicBLE.hs @@ -130,6 +130,12 @@ instance IsPeripheral PrettyPrint BasicBLE where staticInitialization p bble = [ "enable_ble()" , concat ["initialize_static_output_ble_scan(", identName $ fst $ scan_ bble, ")"]] +instance IsPeripheral Interpret BasicBLE where + declareReference = declareReferenceBasicBLE + declaredReferences = declaredReferencesBasicBLE + globalDeclarations p bble = [] + staticInitialization p bble = [] + -- | This class abstracts away the action of creating handlers for a specific backend class BLEHandlers backend where broadcastHandler :: proxy backend -> BasicBLE -> Handler backend @@ -175,6 +181,10 @@ instance BLEHandlers PrettyPrint where , identName $ fst $ scan_ bble, ")" ]] +instance BLEHandlers Interpret where + broadcastHandler _ _ = Handler $ \_ _ -> [] + broadcastControlHandler _ _ = Handler $ \_ _ -> [] + scanControlHandler _ _ = Handler $ \_ _ -> [] ---------- Frontend API of BBLE ---------- -- | This object can be used to access the BLE driver diff --git a/ssm/SSM/Frontend/Peripheral/GPIO.hs b/ssm/SSM/Frontend/Peripheral/GPIO.hs index 96f6c7b7..7d0052b7 100644 --- a/ssm/SSM/Frontend/Peripheral/GPIO.hs +++ b/ssm/SSM/Frontend/Peripheral/GPIO.hs @@ -100,6 +100,12 @@ instance IsPeripheral PrettyPrint GPIOutput where staticInitialization p gpio = [] +instance IsPeripheral Interpret GPIOutput where + declareReference = declareReferenceGPIOutput + declaredReferences = declaredReferencesGPIOutput + globalDeclarations p gpio = [] + staticInitialization p gpio = [] + gpioutputkey :: String gpioutputkey = "gpioutput" @@ -155,6 +161,9 @@ instance GPIOHandler PrettyPrint where make_handler _ (Ptr r) i = Handler $ \_ _ -> [concat ["initialize_static_output_device(", refName r, ", ", show i, ")"]] +instance GPIOHandler Interpret where + make_handler _ _ _ = Handler $ \_ _ -> [] + {- | Ask the GPIO peripheral for an output pin that can take the value high or low. The pin is identified by the @Word8@ parameter. @@ -228,6 +237,12 @@ instance IsPeripheral PrettyPrint GPInputO where staticInitialization _ gpio = flip map (Map.toList (input_ gpio)) $ \(i,(id,t)) -> concat ["initialize_static_input_device(", identName id, ", ", show i, ")"] +instance IsPeripheral Interpret GPInputO where + declareReference = declareReferenceGPInputO + declaredReferences = declaredReferencesGPInputO + globalDeclarations p gpio = [] + staticInitialization p gpio = [] + -- | GPIO input pins have a binary state type Switch = Bool diff --git a/ssm/SSM/Frontend/Peripheral/Identity.hs b/ssm/SSM/Frontend/Peripheral/Identity.hs index 236b63f9..a6412a55 100644 --- a/ssm/SSM/Frontend/Peripheral/Identity.hs +++ b/ssm/SSM/Frontend/Peripheral/Identity.hs @@ -8,7 +8,10 @@ exist in the global scope. -} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -module SSM.Frontend.Peripheral.Identity ( global ) where +module SSM.Frontend.Peripheral.Identity + ( global + , Globals(..) -- only exposed for testing, FIXME + ) where import SSM.Core hiding (peripherals) diff --git a/ssm/SSM/Interpret/Interpreter.hs b/ssm/SSM/Interpret/Interpreter.hs index 106daa77..0fceb70a 100644 --- a/ssm/SSM/Interpret/Interpreter.hs +++ b/ssm/SSM/Interpret/Interpreter.hs @@ -2,6 +2,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} module SSM.Interpret.Interpreter ( interpret , InterpretConfig(..) @@ -27,8 +28,8 @@ import Control.Monad.State.Lazy import Control.Monad.Writer.Lazy -- | Interpret an SSM program with the default configuration. -interpret_ :: forall backend p . SSMProgram backend p => p -> T.Trace -interpret_ = interpret @backend def +interpret_ :: forall p . SSMProgram Interpret p => p -> T.Trace +interpret_ = interpret def {-| Interpret an SSM program. @@ -40,9 +41,9 @@ issue. What you do to get the output in that case is to ask it for a finite amou of output, such as @take 10000 (interpret program)@. After evaluating enough to give you @10000@ trace items, it will not evaluate more. -} -interpret :: forall backend p . SSMProgram backend p => InterpretConfig -> p -> T.Trace +interpret :: forall p . SSMProgram Interpret p => InterpretConfig -> p -> T.Trace interpret config program = runST $ do - let p = toProgram @backend program + let p = toProgram @Interpret program -- Fetch procedure body fun <- case Map.lookup (entry p) (funs p) of Just p' -> return p' diff --git a/ssm/SSM/Interpret/Trace.hs b/ssm/SSM/Interpret/Trace.hs index 6cbcccf0..6e97c5a8 100644 --- a/ssm/SSM/Interpret/Trace.hs +++ b/ssm/SSM/Interpret/Trace.hs @@ -11,6 +11,7 @@ and at the beginning of each step function. The running microtick count persists between instants, so that it increases monotonically throughout the execution. -} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DerivingVia #-} module SSM.Interpret.Trace where import qualified Data.Text as T @@ -71,7 +72,7 @@ data Event = | CrashArithmeticError -- | Interpreter crashed for an unforeseen reason (should be unreachable). | CrashUnforeseen String - deriving (Show, Eq) + deriving (Show, Read, Eq) isTerminal :: Event -> Bool isTerminal TerminatedOk = True @@ -100,7 +101,7 @@ type ActIdent = String -- Even if the variable is a reference, VarVal should contain its base type -- (i.e., without the reference) and base value (i.e., dereferenced). data VarVal = VarVal VarIdent Type ConcreteValue - deriving (Show, Eq) + deriving (Show, Read, Eq) -- | An untyped, concrete value. -- @@ -186,8 +187,11 @@ ref = "Ref" {-********** Generate random traces **********-} -instance Arbitrary Type where - arbitrary = elements $ basetypes ++ Prelude.map Ref basetypes +{- Need to newtype this so the test-suites don't complain about duplicate arbitrary +instances for Types -} +newtype TType = TType Type +instance Arbitrary TType where + arbitrary = elements $ map TType $ basetypes ++ Prelude.map Ref basetypes where basetypes = [TUInt8, TUInt64, TInt32, TInt64, TBool, TEvent] instance Arbitrary ConcreteValue where @@ -197,7 +201,7 @@ instance Arbitrary VarVal where arbitrary = do i <- arbitrary :: Gen Word8 let varIdent = "v" ++ show i - t <- arbitrary + TType t <- arbitrary cv <- arbitrary return $ VarVal varIdent t cv diff --git a/ssm/SSM/Pretty.hs b/ssm/SSM/Pretty.hs index 41774b86..7ec35b26 100644 --- a/ssm/SSM/Pretty.hs +++ b/ssm/SSM/Pretty.hs @@ -75,5 +75,5 @@ import SSM.Core.Program import SSM.Pretty.Syntax ( prettyProgram ) import SSM.Core.Backend -prettySSM :: SSMProgram PrettyPrint a => a -> String -prettySSM = prettyProgram . toProgram +prettySSM :: SSMProgram PrettyPrint p => p -> String +prettySSM p = prettyProgram $ toProgram p diff --git a/ssm/SSM/Test.hs b/ssm/SSM/Test.hs index de29dbd7..fae5ab80 100644 --- a/ssm/SSM/Test.hs +++ b/ssm/SSM/Test.hs @@ -25,8 +25,8 @@ program = do (led2, handler2) <- output 2 input0 <- input 0 input1 <- input 1 - glo <- global @Word8 - (_, b, bc, sc) <- enableBLE + glo <- global @Word8 + (_, b, bc, sc) <- enableBLE let ?led0 = led0 ?led1 = led1 diff --git a/test/lib/Test/SSM/Build.hs b/test/lib/Test/SSM/Build.hs index 196c1aaf..d2d42256 100644 --- a/test/lib/Test/SSM/Build.hs +++ b/test/lib/Test/SSM/Build.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} module Test.SSM.Build ( doCompile , doMake @@ -11,6 +12,7 @@ import System.Directory ( createDirectoryIfMissing ) import System.Exit ( ExitCode(..) ) import System.Process ( readProcessWithExitCode ) +import SSM.Core ( Program, C ) import SSM.Compile ( SSMProgram(..) , toC ) @@ -32,7 +34,7 @@ buildPlatform :: String buildPlatform = "trace" -- | Compile an SSM program to a C program's string representation. -doCompile :: (Monad m, SSMProgram p) => Slug -> p -> QC.PropertyM m String +doCompile :: (SSMProgram C p, Monad m) => Slug -> p -> QC.PropertyM m String doCompile slug program = do let cSrc = toC program reportOnFail slug (show slug ++ ".c") cSrc diff --git a/test/lib/Test/SSM/Prop.hs b/test/lib/Test/SSM/Prop.hs index 4f084881..0367c895 100644 --- a/test/lib/Test/SSM/Prop.hs +++ b/test/lib/Test/SSM/Prop.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ConstraintKinds #-} module Test.SSM.Prop ( propCompiles , propValgrind @@ -8,6 +11,11 @@ module Test.SSM.Prop , semanticIncorrectSpec ) where +import SSM.Core ( Program + , C + , Interpret + , PrettyPrint + ) import SSM.Compile ( SSMProgram(..) ) import Test.SSM.QuickCheck.Generator ( ) -- instance Arbitrary Program @@ -32,18 +40,19 @@ import Test.SSM.Trace ( doCompareTraces , doParseOutput ) +type Testable backend p = (SSMProgram C p, SSMProgram Interpret p, SSMProgram PrettyPrint p) + -- | List of act and event queue sizes to test. queueSizes :: [(Int, Int)] queueSizes = [(32, 32), (256, 256), (2048, 2048)] -- | Tests that generated SSM programs compile successfully. -propCompiles :: SSMProgram p => TestName -> p -> QC.Property +propCompiles :: Testable backend p => TestName -> p -> QC.Property propCompiles tn program = QC.monadicIO $ mapM_ (propCompilesWithSize tn program) queueSizes -- | Tests that generated SSM programs compile successfully, given some size. -propCompilesWithSize - :: SSMProgram p => TestName -> p -> (Int, Int) -> QC.PropertyM IO () +propCompilesWithSize :: Testable backend p => TestName -> p -> (Int, Int) -> QC.PropertyM IO () propCompilesWithSize tn program (aQSize, eQSize) = do slug <- QC.run $ getSlug tn reportSlug slug @@ -53,13 +62,12 @@ propCompilesWithSize tn program (aQSize, eQSize) = do return () -- | Tests an SSM program by evaluating it under valgrind. -propValgrind :: SSMProgram p => TestName -> p -> QC.Property +propValgrind :: Testable backend p => TestName -> p -> QC.Property propValgrind tn program = QC.monadicIO $ mapM_ (propValgrindWithSize tn program) queueSizes -- | Tests an SSM program by evaluating it under valgrind, given some size -propValgrindWithSize - :: SSMProgram p => TestName -> p -> (Int, Int) -> QC.PropertyM IO () +propValgrindWithSize :: Testable backend p => TestName -> p -> (Int, Int) -> QC.PropertyM IO () propValgrindWithSize tn program (aQSize, eQSize) = do slug <- QC.run $ getSlug tn reportSlug slug @@ -71,7 +79,7 @@ propValgrindWithSize tn program (aQSize, eQSize) = do -- | Tests an SSM program by evaluating both the interpreter and running the -- compiled C code and comparing the output. -propCorrect :: SSMProgram p => TestName -> p -> QC.Property +propCorrect :: Testable backend p => TestName -> p -> QC.Property propCorrect tn program = QC.monadicIO $ mapM_ (propCorrectWithSize tn program) queueSizes @@ -79,7 +87,8 @@ propCorrect tn program = -- compiled C code and comparing the output. -- Sizes are give as an argument propCorrectWithSize - :: SSMProgram p => TestName -> p -> (Int, Int) -> QC.PropertyM IO () + :: Testable backend p + => TestName -> p -> (Int, Int) -> QC.PropertyM IO () propCorrectWithSize tn program (aQSize, eQSize) = do slug <- QC.run $ getSlug tn reportSlug slug @@ -96,7 +105,7 @@ propCorrectWithSize tn program (aQSize, eQSize) = do -- without memory errors, and behaves the same as the interpreter. -- -- Used to build passing integration tests. -correctSpec :: SSMProgram p => String -> p -> H.Spec +correctSpec :: Testable backend p => String -> p -> H.Spec correctSpec name p = do once $ H.prop "compiles" $ propCompiles tn p once $ H.prop "no memory errors" $ propValgrind tn p @@ -111,7 +120,7 @@ correctSpec name p = do -- Used to note discrepancies with the interpreter in the regression test suite. -- Note that the description is still "matches interpreter" so that we can use -- the same test name match clause (i.e., with HSpec's --match argument). -semanticIncorrectSpec :: SSMProgram p => String -> p -> H.Spec +semanticIncorrectSpec :: Testable backend p => String -> p -> H.Spec semanticIncorrectSpec name p = do once $ H.prop "compiles" $ propCompiles tn p once $ H.prop "no memory errors" $ propValgrind tn p @@ -120,6 +129,6 @@ semanticIncorrectSpec name p = do once = H.modifyMaxSuccess (const 1) tn = NamedTest name -propSyntacticEquality :: (SSMProgram p1, SSMProgram p2) => String -> p1 -> p2 -> H.Spec +propSyntacticEquality :: (Testable backend p1, Testable backend p2) => String -> p1 -> p2 -> H.Spec propSyntacticEquality name p1 p2 = do - H.prop "produces correct syntax" $ toProgram p1 == toProgram p2 + H.prop "produces correct syntax" $ toProgram @C p1 == toProgram @C p2 diff --git a/test/lib/Test/SSM/QuickCheck/Generator.hs b/test/lib/Test/SSM/QuickCheck/Generator.hs index defcdcf8..171ca01a 100644 --- a/test/lib/Test/SSM/QuickCheck/Generator.hs +++ b/test/lib/Test/SSM/QuickCheck/Generator.hs @@ -14,9 +14,10 @@ import SSM.Core.Ident import SSM.Core.Reference import SSM.Core.Program import SSM.Core.Type -import SSM.Core.Peripheral.Identity import SSM.Core.Peripheral +import SSM.Frontend.Peripheral.Identity + import SSM.Util.HughesList hiding ( (++) ) import Test.SSM.QuickCheck.Shrink hiding (Ref, Variable) @@ -47,7 +48,7 @@ genListOfLength :: Gen a -> Int -> Gen [a] genListOfLength ga 0 = return [] genListOfLength ga n = (:) <$> ga <*> genListOfLength ga (n-1) -instance Arbitrary Program where +instance Arbitrary (Program backend) where shrink = shrinkProgram arbitrary = do @@ -88,7 +89,7 @@ instance Arbitrary Program where return $ Program [SSMProcedure entryPoint []] procedures [Peripheral identityperipheral] -genGlobals :: Gen (IdentityPeripheral, [Reference]) +genGlobals :: Gen (Globals, [Reference]) genGlobals = do globaltypes <- genListOfLength (elements (map Ref basetypes)) =<< choose (0,5) @@ -99,7 +100,7 @@ genGlobals = do let globalrefs = map (uncurry makeStaticRef) globals - let idsvs = foldl (\svs (id, t) -> addIdentitySV id t svs) emptyIdentityPeripheral globals + let idsvs = foldl (\(Globals m) (id, t) -> Globals $ Map.insert id t m) (Globals Map.empty) globals return (idsvs, globalrefs) -- | Generate a procedure body. diff --git a/test/lib/Test/SSM/QuickCheck/Shrink.hs b/test/lib/Test/SSM/QuickCheck/Shrink.hs index 9a9bde03..3b269aba 100644 --- a/test/lib/Test/SSM/QuickCheck/Shrink.hs +++ b/test/lib/Test/SSM/QuickCheck/Shrink.hs @@ -17,7 +17,7 @@ import Test.SSM.QuickCheck.Shrink.Expressions ( expressions ) {- | Shrink a program into several sub-programs. Please refer to the separate modules implementing the shrinking strategies for more documentation of what each strategy actually does. -} -shrinkProgram :: Program -> [Program] +shrinkProgram :: Program backend -> [Program backend] shrinkProgram p = let p' = removeUnusedProcedures p in concat $ map ($p') [ shrinkManyProcedures diff --git a/test/lib/Test/SSM/QuickCheck/Shrink/Expressions.hs b/test/lib/Test/SSM/QuickCheck/Shrink/Expressions.hs index df3c6cc8..3007e29a 100644 --- a/test/lib/Test/SSM/QuickCheck/Shrink/Expressions.hs +++ b/test/lib/Test/SSM/QuickCheck/Shrink/Expressions.hs @@ -11,7 +11,7 @@ import Test.SSM.QuickCheck.Util {- | Shrink the expressions in a program. Each program in the output has at most and at least one expression shrunk. -} -expressions :: Program -> [Program] +expressions :: Program backend -> [Program backend] expressions = transformProcedures shrinkExpInProcedure {- | Take a procedure and produce a list of mutated procedures, where each mutation has diff --git a/test/lib/Test/SSM/QuickCheck/Shrink/Fork.hs b/test/lib/Test/SSM/QuickCheck/Shrink/Fork.hs index db0dde3f..e82f7005 100644 --- a/test/lib/Test/SSM/QuickCheck/Shrink/Fork.hs +++ b/test/lib/Test/SSM/QuickCheck/Shrink/Fork.hs @@ -12,7 +12,7 @@ import Data.List {- | Shrink fork statements in a program. Each resulting program contains only one mutation. -} -forks :: Program -> [Program] +forks :: Program backend -> [Program backend] forks = transformProcedures shrinkForksProcedure {- | Shrink all fork statements found in a procedure. Every procedure in the output diff --git a/test/lib/Test/SSM/QuickCheck/Shrink/If.hs b/test/lib/Test/SSM/QuickCheck/Shrink/If.hs index 3e9f152f..01d1fcbd 100644 --- a/test/lib/Test/SSM/QuickCheck/Shrink/If.hs +++ b/test/lib/Test/SSM/QuickCheck/Shrink/If.hs @@ -13,7 +13,7 @@ the program is turned into three mutations. One mutation does not have the If-st at all, one mutation has the then-branch inlined while the third mutation has the else-branch inlined. This is done once for each If-statement, so a program with three If-else-statements will be turned into a total of nine different mutations. -} -ifs :: Program -> [Program] +ifs :: Program backend -> [Program backend] ifs = transformProcedures shrinkIfProcedure -- | Shrink a procedure into several (or none) different mutations. diff --git a/test/lib/Test/SSM/QuickCheck/Shrink/ProcedureArity.hs b/test/lib/Test/SSM/QuickCheck/Shrink/ProcedureArity.hs index 2e703f81..2bcddc50 100644 --- a/test/lib/Test/SSM/QuickCheck/Shrink/ProcedureArity.hs +++ b/test/lib/Test/SSM/QuickCheck/Shrink/ProcedureArity.hs @@ -18,7 +18,7 @@ import qualified Data.Map as Map import Debug.Trace -- | Shrink procedure arities -arities :: Program -> [Program] +arities :: Program backend -> [Program backend] arities p = [ -- delete argument from argument list let newargs = removeNth i (arguments procedure) diff --git a/test/lib/Test/SSM/QuickCheck/Shrink/Procedures.hs b/test/lib/Test/SSM/QuickCheck/Shrink/Procedures.hs index 33f3bd3e..1b103864 100644 --- a/test/lib/Test/SSM/QuickCheck/Shrink/Procedures.hs +++ b/test/lib/Test/SSM/QuickCheck/Shrink/Procedures.hs @@ -17,7 +17,7 @@ import qualified Data.Set as Set -- | Return all mutations where one function were removed from the program. Never -- tries to remove the main function. -shrinkSingleProcedures :: Program -> [Program] +shrinkSingleProcedures :: Program backend -> [Program backend] shrinkSingleProcedures p = -- for each procedure in the program that is not the programs entry point let ps = for (delete (entry p) (Map.keys (funs p))) $ \fun -> @@ -28,7 +28,7 @@ shrinkSingleProcedures p = {- | A more greedy versio pn of program shrinking where one third of the entire program is removed at once. -} -shrinkManyProcedures :: Program -> [Program] +shrinkManyProcedures :: Program backend -> [Program backend] shrinkManyProcedures p = concat $ for [ removeCallsFromProgram h1 p , removeCallsFromProgram h2 p , removeCallsFromProgram h3 p @@ -64,7 +64,7 @@ shrinkManyProcedures p = concat $ for [ removeCallsFromProgram h1 p program but where now no procedure every forks any of the deleted procedures. Returns @Nothing@ if the program was unchanged (in which case no shrinking could have occured). -} -removeCallsFromProgram :: [Ident] -> Program -> Maybe Program +removeCallsFromProgram :: [Ident] -> Program backend -> Maybe (Program backend) removeCallsFromProgram deletedfuns p = let -- delete the procedures from the program funs' = foldl (\m' n -> Map.delete n m') (funs p) deletedfuns @@ -117,7 +117,7 @@ removeCallsFromProcedure funs p = -- | Remove procedures from a program that are not used (dead code) -removeUnusedProcedures :: Program -> Program +removeUnusedProcedures :: Program backend -> Program backend removeUnusedProcedures p = case removeCallsFromProgram (toremove' p) p of Just p -> p Nothing -> p @@ -144,7 +144,7 @@ removeUnusedProcedures p = case removeCallsFromProgram (toremove' p) p of {- | Takes a program and returns a list of names of procedures that are unused can that can be safely removed all together. -} - toremove' :: Program -> [Ident] + toremove' :: Program backend -> [Ident] toremove' p = let -- Set of procedures that exist s1 = Set.fromList $ Map.keys (funs p) -- Set of procedures that are used diff --git a/test/lib/Test/SSM/QuickCheck/Shrink/References.hs b/test/lib/Test/SSM/QuickCheck/Shrink/References.hs index c9f6aa8f..e664699c 100644 --- a/test/lib/Test/SSM/QuickCheck/Shrink/References.hs +++ b/test/lib/Test/SSM/QuickCheck/Shrink/References.hs @@ -10,7 +10,7 @@ import Test.SSM.QuickCheck.Util import Data.Maybe -refs :: Program -> [Program] +refs :: Program backend -> [Program backend] refs = transformProcedures removeAllDeclaredRefs {- | Given a procedure, this function will return all successful transformations of the diff --git a/test/lib/Test/SSM/QuickCheck/Shrink/Statements.hs b/test/lib/Test/SSM/QuickCheck/Shrink/Statements.hs index ef0c2011..1ca20b79 100644 --- a/test/lib/Test/SSM/QuickCheck/Shrink/Statements.hs +++ b/test/lib/Test/SSM/QuickCheck/Shrink/Statements.hs @@ -8,7 +8,7 @@ import SSM.Util.HughesList hiding ( (++) ) import Test.SSM.QuickCheck.Util -statements :: Program -> [Program] +statements :: Program backend -> [Program backend] statements = transformProcedures shrinkAllStmtsProcedure -- | Return a list of new procedures where the procedure is mutated by removing diff --git a/test/lib/Test/SSM/QuickCheck/Shrink/Wait.hs b/test/lib/Test/SSM/QuickCheck/Shrink/Wait.hs index a4202b9f..197100d8 100644 --- a/test/lib/Test/SSM/QuickCheck/Shrink/Wait.hs +++ b/test/lib/Test/SSM/QuickCheck/Shrink/Wait.hs @@ -14,7 +14,7 @@ import Debug.Trace {- | Shrinks a program into several sub programs by making every wait statement one reference smaller, if the wait statement has more than 1 reference. -} -waits :: Program -> [Program] +waits :: Program backend -> [Program backend] waits = transformProcedures shrinkWaitProcedure shrinkWaitProcedure :: Procedure -> [Procedure] diff --git a/test/lib/Test/SSM/QuickCheck/Util.hs b/test/lib/Test/SSM/QuickCheck/Util.hs index 7f123f8c..e474a35d 100644 --- a/test/lib/Test/SSM/QuickCheck/Util.hs +++ b/test/lib/Test/SSM/QuickCheck/Util.hs @@ -27,7 +27,7 @@ new program is produced. In each new `Program`, only one procedure has been muta Example: You have a program with 5 procedures and they can all be shrunk twice each. The result of calling @transformProcedures@ will be a list of 10 new programs. -} -transformProcedures :: (Procedure -> [Procedure]) -> Program -> [Program] +transformProcedures :: (Procedure -> [Procedure]) -> Program backend -> [Program backend] transformProcedures tr prg = [ prg { funs = Map.insert n fun' (funs prg) } | (n,fun) <- Map.toList (funs prg) , fun' <- tr fun diff --git a/test/lib/Test/SSM/Report.hs b/test/lib/Test/SSM/Report.hs index 2262ce6b..83213d8f 100644 --- a/test/lib/Test/SSM/Report.hs +++ b/test/lib/Test/SSM/Report.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} module Test.SSM.Report ( () , reportDir @@ -21,6 +24,7 @@ import System.Directory ( createDirectoryIfMissing , setPermissions ) +import SSM.Core ( Program, PrettyPrint ) import SSM.Compile ( SSMProgram(..) ) import SSM.Pretty ( prettyProgram ) @@ -103,8 +107,7 @@ reportFileOnFail slug src dst = do -- | Leave both pretty-printed and regression-testable stub of program in report -- directory if the test fails. -reportProgramOnFail - :: (Monad m, SSMProgram p) => Slug -> p -> QC.PropertyM m () +reportProgramOnFail :: (SSMProgram PrettyPrint p, Monad m) => Slug -> p -> QC.PropertyM m () reportProgramOnFail slug program = do reportOnFail slug (show slug ++ ".ssm") $ prettyProgram $ toProgram program reportOnFail slug (show slug ++ "Spec.hs") regressionSpec @@ -134,7 +137,7 @@ reportProgramOnFail slug program = do , "spec = T.correctSpec \"" ++ show slug ++ "\" p" , "" , "p :: Program" - , "p = " ++ show (toProgram program) + , "p = " ++ show (toProgram @PrettyPrint program) ] saveSpecScript = unlines diff --git a/test/lib/Test/SSM/Trace.hs b/test/lib/Test/SSM/Trace.hs index 1c1c44c1..45c0d7ef 100644 --- a/test/lib/Test/SSM/Trace.hs +++ b/test/lib/Test/SSM/Trace.hs @@ -1,4 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} module Test.SSM.Trace ( doParseOutput , doInterpret @@ -21,6 +23,7 @@ import Data.List ( isPrefixOf import System.Timeout ( timeout ) import Text.Read ( readMaybe ) +import SSM.Core ( Program, C, Interpret ) import SSM.Interpret ( InterpretConfig(..) , SSMProgram(..) , interpret @@ -79,8 +82,7 @@ doParseOutput slug outs = do -- -- The evaluation is functionally limited to the number of steps specified by -- limit, but also time-limited using the timeout function. -doInterpret - :: SSMProgram a => Slug -> a -> Int -> (Int, Int) -> QC.PropertyM IO Tr.Trace +doInterpret :: SSMProgram Interpret p => Slug -> p -> Int -> (Int, Int) -> QC.PropertyM IO Tr.Trace doInterpret slug program limit (actQueueSize, eventQueueSize) = do iTrace <- QC.run timeoutEval reportOnFail slug "interpreted.out" $ show iTrace diff --git a/test/regression-low/Regression/CancelBothSpec.hs b/test/regression-low/Regression/CancelBothSpec.hs index 2507df74..000f70ed 100644 --- a/test/regression-low/Regression/CancelBothSpec.hs +++ b/test/regression-low/Regression/CancelBothSpec.hs @@ -11,7 +11,7 @@ import qualified Test.SSM.Prop as T import SSM.Compile import SSM.Interpret -p :: Program +p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] , funs = fromList diff --git a/test/regression-low/Regression/CancelLaterSpec.hs b/test/regression-low/Regression/CancelLaterSpec.hs index 4e048576..a2072694 100644 --- a/test/regression-low/Regression/CancelLaterSpec.hs +++ b/test/regression-low/Regression/CancelLaterSpec.hs @@ -7,7 +7,7 @@ import qualified Test.Hspec as H import qualified Test.Hspec.QuickCheck as H import qualified Test.SSM.Prop as T -p :: Program +p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] , funs = fromList diff --git a/test/regression-low/Regression/EmptyFunSpec.hs b/test/regression-low/Regression/EmptyFunSpec.hs index cc788e83..a6a1e118 100644 --- a/test/regression-low/Regression/EmptyFunSpec.hs +++ b/test/regression-low/Regression/EmptyFunSpec.hs @@ -9,7 +9,7 @@ import qualified Test.SSM.Prop as T import qualified Test.Hspec as H import qualified Test.Hspec.QuickCheck as H -p :: Program +p :: Program backend p = Program {initialQueueContent = [SSMProcedure (Ident "fun1" Nothing) []], funs = fromList [(Ident "fun1" Nothing,Procedure {name = Ident "fun1" Nothing, arguments = [], body = []})], peripherals = []} spec :: H.Spec diff --git a/test/regression-low/Regression/FiveForkerSpec.hs b/test/regression-low/Regression/FiveForkerSpec.hs index cc6db009..ab4029f5 100644 --- a/test/regression-low/Regression/FiveForkerSpec.hs +++ b/test/regression-low/Regression/FiveForkerSpec.hs @@ -10,7 +10,7 @@ import qualified Test.Hspec as H import qualified Test.Hspec.QuickCheck as H import qualified Test.SSM.Prop as T -p :: Program +p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] , funs = fromList diff --git a/test/regression-low/Regression/FlipFlopLoopSpec.hs b/test/regression-low/Regression/FlipFlopLoopSpec.hs index 5b395dbe..d17309de 100644 --- a/test/regression-low/Regression/FlipFlopLoopSpec.hs +++ b/test/regression-low/Regression/FlipFlopLoopSpec.hs @@ -11,7 +11,7 @@ import qualified Test.SSM.Prop as T import SSM.Compile -p :: Program +p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] , funs = fromList diff --git a/test/regression-low/Regression/GlobalEventSpec.hs b/test/regression-low/Regression/GlobalEventSpec.hs index 422e4b54..71fb43be 100644 --- a/test/regression-low/Regression/GlobalEventSpec.hs +++ b/test/regression-low/Regression/GlobalEventSpec.hs @@ -17,7 +17,7 @@ import qualified Test.SSM.Prop as T spec :: H.Spec spec = T.correctSpec "GlobalEventSpec" p -p :: Program +p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] , funs = fromList diff --git a/test/regression-low/Regression/Int32ArithSpec.hs b/test/regression-low/Regression/Int32ArithSpec.hs index 24bd0f27..9f6cc6f9 100644 --- a/test/regression-low/Regression/Int32ArithSpec.hs +++ b/test/regression-low/Regression/Int32ArithSpec.hs @@ -18,7 +18,7 @@ import qualified Test.SSM.Prop as T spec :: H.Spec spec = T.correctSpec "Int32Arith" p -p :: Program +p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] , funs = fromList diff --git a/test/regression-low/Regression/LaterAssignOverwriteSpec.hs b/test/regression-low/Regression/LaterAssignOverwriteSpec.hs index 0b61ffa2..f2693013 100644 --- a/test/regression-low/Regression/LaterAssignOverwriteSpec.hs +++ b/test/regression-low/Regression/LaterAssignOverwriteSpec.hs @@ -15,7 +15,7 @@ import qualified Test.Hspec as H import qualified Test.Hspec.QuickCheck as H import qualified Test.SSM.Prop as T -p :: Program +p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] , funs = fromList diff --git a/test/regression-low/Regression/LaterWaitSpec.hs b/test/regression-low/Regression/LaterWaitSpec.hs index d051b34b..ceba3d9e 100644 --- a/test/regression-low/Regression/LaterWaitSpec.hs +++ b/test/regression-low/Regression/LaterWaitSpec.hs @@ -20,7 +20,7 @@ import qualified Test.SSM.Prop as T spec :: H.Spec spec = T.correctSpec "LaterWaitSpec" p -p :: Program +p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] , funs = fromList diff --git a/test/regression-low/Regression/ManyContsSpec.hs b/test/regression-low/Regression/ManyContsSpec.hs index ec2b4848..2cfa3cac 100644 --- a/test/regression-low/Regression/ManyContsSpec.hs +++ b/test/regression-low/Regression/ManyContsSpec.hs @@ -8,7 +8,7 @@ import qualified Test.Hspec as H import qualified Test.Hspec.QuickCheck as H import qualified Test.SSM.Prop as T -p :: Program +p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] , funs = fromList diff --git a/test/regression-low/Regression/MultOverflowIndirectSpec.hs b/test/regression-low/Regression/MultOverflowIndirectSpec.hs index 419342b8..a1c00a05 100644 --- a/test/regression-low/Regression/MultOverflowIndirectSpec.hs +++ b/test/regression-low/Regression/MultOverflowIndirectSpec.hs @@ -10,7 +10,7 @@ import qualified Test.Hspec as H import qualified Test.Hspec.QuickCheck as H import qualified Test.SSM.Prop as T -p :: Program +p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun1" Nothing) []] , funs = fromList diff --git a/test/regression-low/Regression/MultOverflowSpec.hs b/test/regression-low/Regression/MultOverflowSpec.hs index 34b99d69..441369cd 100644 --- a/test/regression-low/Regression/MultOverflowSpec.hs +++ b/test/regression-low/Regression/MultOverflowSpec.hs @@ -10,7 +10,7 @@ import qualified Test.Hspec as H import qualified Test.Hspec.QuickCheck as H import qualified Test.SSM.Prop as T -p :: Program +p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun1" Nothing) []] , funs = fromList diff --git a/test/regression-low/Regression/NewEventSpec.hs b/test/regression-low/Regression/NewEventSpec.hs index 36981ccd..7c09d0f5 100644 --- a/test/regression-low/Regression/NewEventSpec.hs +++ b/test/regression-low/Regression/NewEventSpec.hs @@ -17,7 +17,7 @@ import qualified Test.SSM.Prop as T spec :: H.Spec spec = T.correctSpec "NewEvent" p -p :: Program +p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] , funs = fromList diff --git a/test/regression-low/Regression/RecurseExhaustDepthSpec.hs b/test/regression-low/Regression/RecurseExhaustDepthSpec.hs index 2a582dfc..8eb2a560 100644 --- a/test/regression-low/Regression/RecurseExhaustDepthSpec.hs +++ b/test/regression-low/Regression/RecurseExhaustDepthSpec.hs @@ -7,7 +7,7 @@ import qualified Test.Hspec as H import qualified Test.Hspec.QuickCheck as H import qualified Test.SSM.Prop as T -p :: Program +p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] , funs = fromList diff --git a/test/regression-low/Regression/RecurseForeverSpec.hs b/test/regression-low/Regression/RecurseForeverSpec.hs index e75be78b..d27c3dae 100644 --- a/test/regression-low/Regression/RecurseForeverSpec.hs +++ b/test/regression-low/Regression/RecurseForeverSpec.hs @@ -10,7 +10,7 @@ import qualified Test.Hspec as H import qualified Test.Hspec.QuickCheck as H import qualified Test.SSM.Prop as T -p :: Program +--p :: (SSMProgram C ) => Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] , funs = fromList diff --git a/test/regression-syntax/Regression/CancelBothSpec.hs b/test/regression-syntax/Regression/CancelBothSpec.hs index 75f7de42..9eb040d8 100644 --- a/test/regression-syntax/Regression/CancelBothSpec.hs +++ b/test/regression-syntax/Regression/CancelBothSpec.hs @@ -18,7 +18,7 @@ fun0 = routine $ do v1 <- var $ changed v0 after (nsecs 3872) v1 false' -p :: Program +p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] , funs = fromList diff --git a/test/regression-syntax/Regression/CancelLaterSpec.hs b/test/regression-syntax/Regression/CancelLaterSpec.hs index 2d8de609..d464d8de 100644 --- a/test/regression-syntax/Regression/CancelLaterSpec.hs +++ b/test/regression-syntax/Regression/CancelLaterSpec.hs @@ -16,7 +16,7 @@ fun0 = routine $ do v0 <- var (0 :: Exp Int32) after (nsecs 2) v0 1 -p :: Program +p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] , funs = fromList diff --git a/test/regression-syntax/Regression/EmptyFunSpec.hs b/test/regression-syntax/Regression/EmptyFunSpec.hs index 069a944d..35b71658 100644 --- a/test/regression-syntax/Regression/EmptyFunSpec.hs +++ b/test/regression-syntax/Regression/EmptyFunSpec.hs @@ -14,7 +14,7 @@ import Data.Int fun1 :: SSM () fun1 = routine $ return () -p :: Program +p :: Program backend p = Program {initialQueueContent = [SSMProcedure (Ident "fun1" Nothing) []], funs = fromList [(Ident "fun1" Nothing,Procedure {name = Ident "fun1" Nothing, arguments = [], body = []})], peripherals = []} spec :: H.Spec diff --git a/test/regression-syntax/Regression/FlipFlopLoopSpec.hs b/test/regression-syntax/Regression/FlipFlopLoopSpec.hs index 551b4b09..16c91942 100644 --- a/test/regression-syntax/Regression/FlipFlopLoopSpec.hs +++ b/test/regression-syntax/Regression/FlipFlopLoopSpec.hs @@ -24,7 +24,7 @@ fun1 fresh2 = routine $ do after (nsecs 2) fresh2 true' wait fresh2 -p :: Program +p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] , funs = fromList diff --git a/test/regression-syntax/Regression/GlobalEventSpec.hs b/test/regression-syntax/Regression/GlobalEventSpec.hs index 3f316a90..83bb21bd 100644 --- a/test/regression-syntax/Regression/GlobalEventSpec.hs +++ b/test/regression-syntax/Regression/GlobalEventSpec.hs @@ -14,7 +14,7 @@ import qualified Test.Hspec.QuickCheck as H import qualified Test.SSM.Prop as T import Data.Word -program :: Compile () +program :: Compile backend () program = do glob0 <- global @Word8 let ?glob0 = glob0 @@ -23,7 +23,7 @@ program = do fun0 :: (?glob0 :: Ref Word8) => SSM () fun0 = routine $ return () -p :: Program +p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] , funs = fromList diff --git a/test/regression-syntax/Regression/Int32ArithSpec.hs b/test/regression-syntax/Regression/Int32ArithSpec.hs index 89806f6b..4eb44f78 100644 --- a/test/regression-syntax/Regression/Int32ArithSpec.hs +++ b/test/regression-syntax/Regression/Int32ArithSpec.hs @@ -21,7 +21,7 @@ fun0 = routine $ do fun3 :: Exp Int64 -> SSM () fun3 var3 = routine $ return () -p :: Program +p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] , funs = fromList diff --git a/test/regression-syntax/Regression/LaterAssignOverflowSpec.hs b/test/regression-syntax/Regression/LaterAssignOverflowSpec.hs index 1a2647fe..c0cd68f4 100644 --- a/test/regression-syntax/Regression/LaterAssignOverflowSpec.hs +++ b/test/regression-syntax/Regression/LaterAssignOverflowSpec.hs @@ -28,7 +28,7 @@ fun1 ref1 ref3 = routine $ do wait ref1 wait ref3 -p :: Program +p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] , funs = fromList diff --git a/test/regression-syntax/Regression/LaterWaitSpec.hs b/test/regression-syntax/Regression/LaterWaitSpec.hs index d8bd4e3c..b59297e7 100644 --- a/test/regression-syntax/Regression/LaterWaitSpec.hs +++ b/test/regression-syntax/Regression/LaterWaitSpec.hs @@ -20,7 +20,7 @@ fun0 = routine $ do after (nsecs 2) fresh0 1 wait fresh0 -p :: Program +p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] , funs = fromList diff --git a/test/regression-syntax/Regression/ManyContsSpec.hs b/test/regression-syntax/Regression/ManyContsSpec.hs index 4c1eb0f1..1ee9a83b 100644 --- a/test/regression-syntax/Regression/ManyContsSpec.hs +++ b/test/regression-syntax/Regression/ManyContsSpec.hs @@ -28,7 +28,7 @@ fun1 ref2 = routine $ do , fun1 ref2 ] -p :: Program +p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] , funs = fromList diff --git a/test/regression-syntax/Regression/MultOverflowIndirectSpec.hs b/test/regression-syntax/Regression/MultOverflowIndirectSpec.hs index ba4c5f40..5227dff6 100644 --- a/test/regression-syntax/Regression/MultOverflowIndirectSpec.hs +++ b/test/regression-syntax/Regression/MultOverflowIndirectSpec.hs @@ -23,7 +23,7 @@ fun1 = routine $ do fresh1 <- var (0 :: Exp Int32) wait fresh1 -p :: Program +p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun1" Nothing) []] , funs = fromList diff --git a/test/regression-syntax/Regression/MultOverflowSpec.hs b/test/regression-syntax/Regression/MultOverflowSpec.hs index 1c05f2aa..9907cbed 100644 --- a/test/regression-syntax/Regression/MultOverflowSpec.hs +++ b/test/regression-syntax/Regression/MultOverflowSpec.hs @@ -22,7 +22,7 @@ fun1 = routine $ do (after (nsecs 2) fresh0 1) wait fresh0 -p :: Program +p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun1" Nothing) []] , funs = fromList diff --git a/test/regression-syntax/Regression/NewEventSpec.hs b/test/regression-syntax/Regression/NewEventSpec.hs index 4bea6cd0..322aa34d 100644 --- a/test/regression-syntax/Regression/NewEventSpec.hs +++ b/test/regression-syntax/Regression/NewEventSpec.hs @@ -19,7 +19,7 @@ fun0 = routine $ do var event' return () -p :: Program +p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] , funs = fromList diff --git a/test/regression-syntax/Regression/RecurseExhaustiveSpec.hs b/test/regression-syntax/Regression/RecurseExhaustiveSpec.hs index e3e97824..ce431096 100644 --- a/test/regression-syntax/Regression/RecurseExhaustiveSpec.hs +++ b/test/regression-syntax/Regression/RecurseExhaustiveSpec.hs @@ -20,7 +20,7 @@ fun0 = routine $ fork [fun0, fun1] fun1 :: SSM () fun1 = routine $ return () -p :: Program +p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] , funs = fromList diff --git a/test/regression-syntax/Regression/RecurseForeverSpec.hs b/test/regression-syntax/Regression/RecurseForeverSpec.hs index 9fda795f..7b2b5b52 100644 --- a/test/regression-syntax/Regression/RecurseForeverSpec.hs +++ b/test/regression-syntax/Regression/RecurseForeverSpec.hs @@ -17,7 +17,7 @@ import Data.Int fun0 :: SSM () fun0 = routine $ fork [fun0] -p :: Program +p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] , funs = fromList diff --git a/test/regression-syntax/Regression/SynthesizeAdditionSpec.hs b/test/regression-syntax/Regression/SynthesizeAdditionSpec.hs index c0f217d3..1f30d707 100644 --- a/test/regression-syntax/Regression/SynthesizeAdditionSpec.hs +++ b/test/regression-syntax/Regression/SynthesizeAdditionSpec.hs @@ -21,7 +21,7 @@ fun0 = routine $ do fork [ x <~ deref x + deref y ] -p = Program +p = Program backend { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] , funs = fromList [( Ident "generatedfresh0" Nothing diff --git a/test/regression-syntax/Regression/SynthesizeDelaySpec.hs b/test/regression-syntax/Regression/SynthesizeDelaySpec.hs index d5d73876..37400b3a 100644 --- a/test/regression-syntax/Regression/SynthesizeDelaySpec.hs +++ b/test/regression-syntax/Regression/SynthesizeDelaySpec.hs @@ -21,7 +21,7 @@ fun0 = routine $ do wait wake ] -p = Program +p = Program backend { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] , funs = fromList [( Ident "generatedfresh0" Nothing diff --git a/test/regression-syntax/Regression/SynthesizeForeverRecurseSpec.hs b/test/regression-syntax/Regression/SynthesizeForeverRecurseSpec.hs index f215a84f..1a0e19c1 100644 --- a/test/regression-syntax/Regression/SynthesizeForeverRecurseSpec.hs +++ b/test/regression-syntax/Regression/SynthesizeForeverRecurseSpec.hs @@ -25,7 +25,7 @@ fun0 = routine $ do fun1 :: SSM () fun1 = routine $ fork [fun1] -p = Program +p = Program backend { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] , funs = fromList [( Ident "generatedfresh0" Nothing diff --git a/test/regression-syntax/Regression/SynthesizeNamedSpec.hs b/test/regression-syntax/Regression/SynthesizeNamedSpec.hs index 20bede04..c7c268c4 100644 --- a/test/regression-syntax/Regression/SynthesizeNamedSpec.hs +++ b/test/regression-syntax/Regression/SynthesizeNamedSpec.hs @@ -24,7 +24,7 @@ fun0 :: SSM () fun0 = routine $ do fork [ delay (nsecs 2) ] -p = Program +p = Program backend { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] , funs = fromList [( Ident "generatedfresh0" Nothing diff --git a/test/regression-syntax/Regression/SynthesizeRecursiveSpec.hs b/test/regression-syntax/Regression/SynthesizeRecursiveSpec.hs index e2dd6535..03489a69 100644 --- a/test/regression-syntax/Regression/SynthesizeRecursiveSpec.hs +++ b/test/regression-syntax/Regression/SynthesizeRecursiveSpec.hs @@ -21,7 +21,7 @@ fun0 = routine $ do fork [wait x] ] -p = Program +p = Program backend { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] , funs = fromList [( Ident "fun0" Nothing From ac7d2549ffde401c1158bcc322caf5d4d36244ac Mon Sep 17 00:00:00 2001 From: Robert Krook Date: Wed, 15 Dec 2021 18:00:45 +0100 Subject: [PATCH 10/16] made more progress on the tests, but some more work left to do... --- ssm/SSM/Compile.hs | 17 ++++++----- ssm/SSM/Core/Program.hs | 10 ------- ssm/SSM/Frontend/Compile.hs | 9 ++---- ssm/SSM/Frontend/Syntax.hs | 7 ----- ssm/SSM/Interpret.hs | 23 +++++++++++++-- ssm/SSM/Interpret/Interpreter.hs | 8 ++---- ssm/SSM/Pretty.hs | 3 +- test/arbitrary/Spec.hs | 3 +- test/lib/Test/SSM/Build.hs | 8 ++---- test/lib/Test/SSM/Prop.hs | 28 +++++++++---------- test/lib/Test/SSM/Report.hs | 8 +++--- test/lib/Test/SSM/Trace.hs | 7 ++--- .../Regression/GlobalEventSpec.hs | 3 +- 13 files changed, 66 insertions(+), 68 deletions(-) diff --git a/ssm/SSM/Compile.hs b/ssm/SSM/Compile.hs index 655e3f97..d34fe3f6 100644 --- a/ssm/SSM/Compile.hs +++ b/ssm/SSM/Compile.hs @@ -3,8 +3,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeApplications #-} module SSM.Compile - ( SSMProgram(..) - , toC + ( toC + , toC' , compileFile , compileCli , compileCli_ @@ -20,23 +20,26 @@ import System.Exit ( ExitCode(..) import SSM.Backend.C.Compile import SSM.Core.Program import SSM.Core.Backend +import SSM.Frontend.Compile -- | Compile a program to a C-file. -- -- TODO: This can fail, so it should return Either CompileError String. ---toC :: SSMProgram C a => a -> String -toC :: SSMProgram C p => p -> String +toC :: Compile C () -> String toC p = compile $ toProgram p +toC' :: Program C -> String +toC' = compile + -- | Compile a program and write it to the specified path. -compileFile :: SSMProgram C p => FilePath -> p -> IO () +compileFile :: FilePath -> Compile C () -> IO () compileFile fp = writeFile fp . toC -- | Create command-line compilation interface for specific program. -- -- Includes parameter for specifying a default filepath. If this is not needed, -- use @compileCli_@. -compileCli :: SSMProgram C p => Maybe FilePath -> p -> IO () +compileCli :: Maybe FilePath -> Compile C () -> IO () compileCli defaultPath program = do args <- getArgs path <- getFilePath args @@ -63,5 +66,5 @@ compileCli defaultPath program = do exitWith $ ExitFailure 1 -- | Create command-line compilation interface for specific program. -compileCli_ :: SSMProgram C p => p -> IO () +compileCli_ :: Compile C () -> IO () compileCli_ = compileCli Nothing diff --git a/ssm/SSM/Core/Program.hs b/ssm/SSM/Core/Program.hs index 245a404e..17e0213b 100644 --- a/ssm/SSM/Core/Program.hs +++ b/ssm/SSM/Core/Program.hs @@ -11,7 +11,6 @@ module SSM.Core.Program , QueueContent(..) , entry , Program(..) - , SSMProgram(..) , Handler(..) ) where @@ -84,12 +83,3 @@ data Program backend = Program instance Eq (Program backend) where p1 == p2 = initialQueueContent p1 == initialQueueContent p2 && funs p1 == funs p2 - --- | Class of types that can be converted to a `Program`. -class SSMProgram backend a where - -- | This function takes an @a@ and converts it to a `Program` - toProgram :: a -> Program backend - --- | Dummy instance for `Program`. Does nothing -- defined to be the identity function. -instance SSMProgram backend (Program backend) where - toProgram = id diff --git a/ssm/SSM/Frontend/Compile.hs b/ssm/SSM/Frontend/Compile.hs index cab302a2..3c9112f0 100644 --- a/ssm/SSM/Frontend/Compile.hs +++ b/ssm/SSM/Frontend/Compile.hs @@ -40,18 +40,15 @@ instance IntState (CompileSt backend) where getInt = compileCounter setInt i st = st { compileCounter = i } -{- | If you have a @Compile (SSM ())@ you have probably set up some global variables -using the @Compile@ monad. This instance makes sure that you can compile and interpret -something that is a program with such global variables. -} -instance SSMProgram backend (Compile backend ()) where - toProgram (Compile p) = +toProgram :: Compile backend () -> Program backend +toProgram (Compile p) = let (a, s) = runState p (CompileSt 0 [] Nothing Map.empty) (n, f) = transpile $ fromJust $ entryPoint s in Program (reverse $ SSM.Frontend.Compile.initialQueueContent s) f $ Map.elems (SSM.Frontend.Compile.peripherals s) - + type OutputHandler backend = Handler backend class Schedulable backend a where diff --git a/ssm/SSM/Frontend/Syntax.hs b/ssm/SSM/Frontend/Syntax.hs index cad54d2e..f4c70133 100644 --- a/ssm/SSM/Frontend/Syntax.hs +++ b/ssm/SSM/Frontend/Syntax.hs @@ -155,13 +155,6 @@ getProcedureName :: [SSMStm] -> Ident getProcedureName (Procedure n _ _ : _) = n getProcedureName _ = error "not a procedure" -{- | Instance of `SSM.Core.Syntax.SSMProgram`, so that the compiler knows how to turn -the frontend representation into something that it can generate code for. Just compiling -a program does not introduce any global variables. -} -instance SP.SSMProgram backend (SSM ()) where - toProgram p = - let (n, f) = transpile p in SP.Program [SP.SSMProcedure n []] f [] - {-********** Transpiling to core syntax **********-} -- | Transpilation monad diff --git a/ssm/SSM/Interpret.hs b/ssm/SSM/Interpret.hs index da97d87c..d62adbd5 100644 --- a/ssm/SSM/Interpret.hs +++ b/ssm/SSM/Interpret.hs @@ -1,5 +1,24 @@ module SSM.Interpret - ( module SSM.Interpret.Interpreter + ( interpret + , interpret' + , interpret_ + , I.InterpretConfig(..) + , T.Trace(..) + , T.Event(..) ) where -import SSM.Interpret.Interpreter +import SSM.Frontend.Compile +import SSM.Core +import SSM.Util.Default +import qualified SSM.Interpret.Trace as T + +import qualified SSM.Interpret.Interpreter as I + +interpret :: I.InterpretConfig -> Compile Interpret () -> T.Trace +interpret cf c = I.interpret cf $ toProgram c + +interpret' :: I.InterpretConfig -> Program Interpret -> T.Trace +interpret' cf c = I.interpret cf c + +interpret_ :: Compile Interpret () -> T.Trace +interpret_ = I.interpret def . toProgram diff --git a/ssm/SSM/Interpret/Interpreter.hs b/ssm/SSM/Interpret/Interpreter.hs index 0fceb70a..866a5540 100644 --- a/ssm/SSM/Interpret/Interpreter.hs +++ b/ssm/SSM/Interpret/Interpreter.hs @@ -7,7 +7,6 @@ module SSM.Interpret.Interpreter ( interpret , InterpretConfig(..) , interpret_ - , SSMProgram(..) ) where import SSM.Core @@ -28,7 +27,7 @@ import Control.Monad.State.Lazy import Control.Monad.Writer.Lazy -- | Interpret an SSM program with the default configuration. -interpret_ :: forall p . SSMProgram Interpret p => p -> T.Trace +interpret_ :: Program Interpret -> T.Trace interpret_ = interpret def {-| Interpret an SSM program. @@ -41,9 +40,8 @@ issue. What you do to get the output in that case is to ask it for a finite amou of output, such as @take 10000 (interpret program)@. After evaluating enough to give you @10000@ trace items, it will not evaluate more. -} -interpret :: forall p . SSMProgram Interpret p => InterpretConfig -> p -> T.Trace -interpret config program = runST $ do - let p = toProgram @Interpret program +interpret :: InterpretConfig -> Program Interpret -> T.Trace +interpret config p = runST $ do -- Fetch procedure body fun <- case Map.lookup (entry p) (funs p) of Just p' -> return p' diff --git a/ssm/SSM/Pretty.hs b/ssm/SSM/Pretty.hs index 7ec35b26..6500665a 100644 --- a/ssm/SSM/Pretty.hs +++ b/ssm/SSM/Pretty.hs @@ -74,6 +74,7 @@ module SSM.Pretty import SSM.Core.Program import SSM.Pretty.Syntax ( prettyProgram ) import SSM.Core.Backend +import SSM.Frontend.Compile -prettySSM :: SSMProgram PrettyPrint p => p -> String +prettySSM :: Compile PrettyPrint () -> String prettySSM p = prettyProgram $ toProgram p diff --git a/test/arbitrary/Spec.hs b/test/arbitrary/Spec.hs index 08c0112f..3629f4fc 100644 --- a/test/arbitrary/Spec.hs +++ b/test/arbitrary/Spec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE RankNTypes #-} import SSM.Core.Program import qualified Test.QuickCheck as QC import qualified Test.QuickCheck.Monadic as QC @@ -31,4 +32,4 @@ main = hspec $ do -- $ T.propValgrind T.RandomTest prop "compiles and runs according to interpreter" - (T.propCorrect T.RandomTest :: Program -> QC.Property) + (T.propCorrect T.RandomTest :: (forall backend . Program backend) -> QC.Property) diff --git a/test/lib/Test/SSM/Build.hs b/test/lib/Test/SSM/Build.hs index d2d42256..88f2ad3d 100644 --- a/test/lib/Test/SSM/Build.hs +++ b/test/lib/Test/SSM/Build.hs @@ -13,9 +13,7 @@ import System.Exit ( ExitCode(..) ) import System.Process ( readProcessWithExitCode ) import SSM.Core ( Program, C ) -import SSM.Compile ( SSMProgram(..) - , toC - ) +import SSM.Compile ( toC' ) import qualified Test.QuickCheck as QC import qualified Test.QuickCheck.Monadic as QC @@ -34,9 +32,9 @@ buildPlatform :: String buildPlatform = "trace" -- | Compile an SSM program to a C program's string representation. -doCompile :: (SSMProgram C p, Monad m) => Slug -> p -> QC.PropertyM m String +doCompile :: Monad m => Slug -> Program C -> QC.PropertyM m String doCompile slug program = do - let cSrc = toC program + let cSrc = toC' program reportOnFail slug (show slug ++ ".c") cSrc return cSrc diff --git a/test/lib/Test/SSM/Prop.hs b/test/lib/Test/SSM/Prop.hs index 0367c895..db75ec24 100644 --- a/test/lib/Test/SSM/Prop.hs +++ b/test/lib/Test/SSM/Prop.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE RankNTypes #-} module Test.SSM.Prop ( propCompiles , propValgrind @@ -16,7 +17,7 @@ import SSM.Core ( Program , Interpret , PrettyPrint ) -import SSM.Compile ( SSMProgram(..) ) +import SSM.Compile import Test.SSM.QuickCheck.Generator ( ) -- instance Arbitrary Program import qualified Test.Hspec as H @@ -40,19 +41,17 @@ import Test.SSM.Trace ( doCompareTraces , doParseOutput ) -type Testable backend p = (SSMProgram C p, SSMProgram Interpret p, SSMProgram PrettyPrint p) - -- | List of act and event queue sizes to test. queueSizes :: [(Int, Int)] queueSizes = [(32, 32), (256, 256), (2048, 2048)] -- | Tests that generated SSM programs compile successfully. -propCompiles :: Testable backend p => TestName -> p -> QC.Property +propCompiles :: TestName -> (forall backend . Program backend) -> QC.Property propCompiles tn program = QC.monadicIO $ mapM_ (propCompilesWithSize tn program) queueSizes -- | Tests that generated SSM programs compile successfully, given some size. -propCompilesWithSize :: Testable backend p => TestName -> p -> (Int, Int) -> QC.PropertyM IO () +propCompilesWithSize :: TestName -> (forall backend . Program backend) -> (Int, Int) -> QC.PropertyM IO () propCompilesWithSize tn program (aQSize, eQSize) = do slug <- QC.run $ getSlug tn reportSlug slug @@ -62,12 +61,12 @@ propCompilesWithSize tn program (aQSize, eQSize) = do return () -- | Tests an SSM program by evaluating it under valgrind. -propValgrind :: Testable backend p => TestName -> p -> QC.Property +propValgrind :: TestName -> (forall backend . Program backend) -> QC.Property propValgrind tn program = QC.monadicIO $ mapM_ (propValgrindWithSize tn program) queueSizes -- | Tests an SSM program by evaluating it under valgrind, given some size -propValgrindWithSize :: Testable backend p => TestName -> p -> (Int, Int) -> QC.PropertyM IO () +propValgrindWithSize :: TestName -> (forall backend . Program backend) -> (Int, Int) -> QC.PropertyM IO () propValgrindWithSize tn program (aQSize, eQSize) = do slug <- QC.run $ getSlug tn reportSlug slug @@ -79,16 +78,15 @@ propValgrindWithSize tn program (aQSize, eQSize) = do -- | Tests an SSM program by evaluating both the interpreter and running the -- compiled C code and comparing the output. -propCorrect :: Testable backend p => TestName -> p -> QC.Property +propCorrect :: TestName -> (forall backend . Program backend) -> QC.Property propCorrect tn program = QC.monadicIO $ mapM_ (propCorrectWithSize tn program) queueSizes -- | Tests an SSM program by evaluating both the interpreter and running the -- compiled C code and comparing the output. -- Sizes are give as an argument -propCorrectWithSize - :: Testable backend p - => TestName -> p -> (Int, Int) -> QC.PropertyM IO () +propCorrectWithSize :: + TestName -> (forall backend . Program backend) -> (Int, Int) -> QC.PropertyM IO () propCorrectWithSize tn program (aQSize, eQSize) = do slug <- QC.run $ getSlug tn reportSlug slug @@ -105,7 +103,7 @@ propCorrectWithSize tn program (aQSize, eQSize) = do -- without memory errors, and behaves the same as the interpreter. -- -- Used to build passing integration tests. -correctSpec :: Testable backend p => String -> p -> H.Spec +correctSpec :: String -> (forall backend . Program backend) -> H.Spec correctSpec name p = do once $ H.prop "compiles" $ propCompiles tn p once $ H.prop "no memory errors" $ propValgrind tn p @@ -120,7 +118,7 @@ correctSpec name p = do -- Used to note discrepancies with the interpreter in the regression test suite. -- Note that the description is still "matches interpreter" so that we can use -- the same test name match clause (i.e., with HSpec's --match argument). -semanticIncorrectSpec :: Testable backend p => String -> p -> H.Spec +semanticIncorrectSpec :: String -> (forall backend . Program backend) -> H.Spec semanticIncorrectSpec name p = do once $ H.prop "compiles" $ propCompiles tn p once $ H.prop "no memory errors" $ propValgrind tn p @@ -129,6 +127,6 @@ semanticIncorrectSpec name p = do once = H.modifyMaxSuccess (const 1) tn = NamedTest name -propSyntacticEquality :: (Testable backend p1, Testable backend p2) => String -> p1 -> p2 -> H.Spec +propSyntacticEquality :: String -> (forall backend . Program backend) -> (forall backend . Program backend) -> H.Spec propSyntacticEquality name p1 p2 = do - H.prop "produces correct syntax" $ toProgram @C p1 == toProgram @C p2 + H.prop "produces correct syntax" $ p1 == p2 diff --git a/test/lib/Test/SSM/Report.hs b/test/lib/Test/SSM/Report.hs index 83213d8f..bf37344f 100644 --- a/test/lib/Test/SSM/Report.hs +++ b/test/lib/Test/SSM/Report.hs @@ -25,7 +25,7 @@ import System.Directory ( createDirectoryIfMissing ) import SSM.Core ( Program, PrettyPrint ) -import SSM.Compile ( SSMProgram(..) ) +import SSM.Compile import SSM.Pretty ( prettyProgram ) import Data.Char ( isUpper ) @@ -107,9 +107,9 @@ reportFileOnFail slug src dst = do -- | Leave both pretty-printed and regression-testable stub of program in report -- directory if the test fails. -reportProgramOnFail :: (SSMProgram PrettyPrint p, Monad m) => Slug -> p -> QC.PropertyM m () +reportProgramOnFail :: (Monad m) => Slug -> Program PrettyPrint -> QC.PropertyM m () reportProgramOnFail slug program = do - reportOnFail slug (show slug ++ ".ssm") $ prettyProgram $ toProgram program + reportOnFail slug (show slug ++ ".ssm") $ prettyProgram program reportOnFail slug (show slug ++ "Spec.hs") regressionSpec reportScriptOnFail slug "save-regression" saveSpecScript where @@ -137,7 +137,7 @@ reportProgramOnFail slug program = do , "spec = T.correctSpec \"" ++ show slug ++ "\" p" , "" , "p :: Program" - , "p = " ++ show (toProgram @PrettyPrint program) + , "p = " ++ show program ] saveSpecScript = unlines diff --git a/test/lib/Test/SSM/Trace.hs b/test/lib/Test/SSM/Trace.hs index 45c0d7ef..4cb46606 100644 --- a/test/lib/Test/SSM/Trace.hs +++ b/test/lib/Test/SSM/Trace.hs @@ -25,8 +25,7 @@ import Text.Read ( readMaybe ) import SSM.Core ( Program, C, Interpret ) import SSM.Interpret ( InterpretConfig(..) - , SSMProgram(..) - , interpret + , interpret' ) import qualified SSM.Interpret.Trace as Tr import qualified SSM.Interpret.TraceParser as TrP @@ -82,7 +81,7 @@ doParseOutput slug outs = do -- -- The evaluation is functionally limited to the number of steps specified by -- limit, but also time-limited using the timeout function. -doInterpret :: SSMProgram Interpret p => Slug -> p -> Int -> (Int, Int) -> QC.PropertyM IO Tr.Trace +doInterpret :: Slug -> Program Interpret -> Int -> (Int, Int) -> QC.PropertyM IO Tr.Trace doInterpret slug program limit (actQueueSize, eventQueueSize) = do iTrace <- QC.run timeoutEval reportOnFail slug "interpreted.out" $ show iTrace @@ -103,7 +102,7 @@ doInterpret slug program limit (actQueueSize, eventQueueSize) = do reverse <$> readIORef ref interpreted :: Tr.Trace - interpreted = interpret + interpreted = interpret' def { boundActQueueSize = actQueueSize , boundEventQueueSize = eventQueueSize } diff --git a/test/regression-low/Regression/GlobalEventSpec.hs b/test/regression-low/Regression/GlobalEventSpec.hs index 71fb43be..55b53168 100644 --- a/test/regression-low/Regression/GlobalEventSpec.hs +++ b/test/regression-low/Regression/GlobalEventSpec.hs @@ -10,6 +10,7 @@ module Regression.GlobalEventSpec where import Data.Map ( fromList ) import SSM.Core +import SSM.Frontend.Peripheral.Identity import qualified Test.Hspec as H import qualified Test.Hspec.QuickCheck as H import qualified Test.SSM.Prop as T @@ -29,5 +30,5 @@ p = Program } ) ] - , peripherals = [Peripheral $ IdentityPeripheral (fromList [(Ident "glob0" Nothing, Ref TUInt8)])] + , peripherals = [Peripheral $ Globals (fromList [(Ident "glob0" Nothing, Ref TUInt8)])] } From 7bdb5b3c95cad1a1f05515df37d70d48271906e7 Mon Sep 17 00:00:00 2001 From: Robert Krook Date: Thu, 16 Dec 2021 13:44:00 +0100 Subject: [PATCH 11/16] tests work1 --- test/arbitrary/Spec.hs | 4 +-- test/lib/Test/SSM/Prop.hs | 16 +++++++-- .../Regression/CancelBothSpec.hs | 12 ++++--- .../Regression/FibRoutineSpec.hs | 6 +++- test/regression-high/Regression/FibSpec.hs | 6 +++- .../Regression/RecurseForeverSpec.hs | 6 +++- .../Regression/SenderReceiverSpec.hs | 12 ++++--- .../Regression/CancelBothSpec.hs | 22 ++++++++----- .../Regression/CancelLaterSpec.hs | 10 ++++-- .../Regression/EmptyFunSpec.hs | 6 +++- .../Regression/FlipFlopLoopSpec.hs | 18 ++++++---- .../Regression/GlobalEventSpec.hs | 5 +-- .../Regression/Int32ArithSpec.hs | 6 +++- .../Regression/LaterAssignOverflowSpec.hs | 16 +++++---- .../Regression/LaterWaitSpec.hs | 12 ++++--- .../Regression/ManyContsSpec.hs | 10 ++++-- .../Regression/MultOverflowIndirectSpec.hs | 16 +++++---- .../Regression/MultOverflowSpec.hs | 16 +++++---- .../Regression/NewEventSpec.hs | 10 ++++-- .../Regression/RecurseExhaustiveSpec.hs | 6 +++- .../Regression/RecurseForeverSpec.hs | 6 +++- .../Regression/SynthesizeAdditionSpec.hs | 23 ++++++++----- .../Regression/SynthesizeDelaySpec.hs | 25 ++++++++------ .../SynthesizeForeverRecurseSpec.hs | 23 ++++++++----- .../Regression/SynthesizeNamedSpec.hs | 25 ++++++++------ .../Regression/SynthesizeRecursiveSpec.hs | 33 +++++++++++-------- test/trace-parser/Spec.hs | 8 +++++ 27 files changed, 236 insertions(+), 122 deletions(-) diff --git a/test/arbitrary/Spec.hs b/test/arbitrary/Spec.hs index 3629f4fc..58480577 100644 --- a/test/arbitrary/Spec.hs +++ b/test/arbitrary/Spec.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE RankNTypes #-} import SSM.Core.Program import qualified Test.QuickCheck as QC import qualified Test.QuickCheck.Monadic as QC @@ -10,7 +9,6 @@ import Test.Hspec ( describe import Test.Hspec.QuickCheck ( modifyMaxSuccess , prop ) - -- | Hspec entry point for arbitrary quickcheck test. -- -- To specify the number of random programs to test from the command line, @@ -32,4 +30,4 @@ main = hspec $ do -- $ T.propValgrind T.RandomTest prop "compiles and runs according to interpreter" - (T.propCorrect T.RandomTest :: (forall backend . Program backend) -> QC.Property) + (T.propCorrect T.RandomTest :: Program backend -> QC.Property) diff --git a/test/lib/Test/SSM/Prop.hs b/test/lib/Test/SSM/Prop.hs index db75ec24..4e904600 100644 --- a/test/lib/Test/SSM/Prop.hs +++ b/test/lib/Test/SSM/Prop.hs @@ -12,12 +12,14 @@ module Test.SSM.Prop , semanticIncorrectSpec ) where +import Unsafe.Coerce ( unsafeCoerce ) import SSM.Core ( Program , C , Interpret , PrettyPrint ) import SSM.Compile +import SSM.Pretty import Test.SSM.QuickCheck.Generator ( ) -- instance Arbitrary Program import qualified Test.Hspec as H @@ -78,9 +80,9 @@ propValgrindWithSize tn program (aQSize, eQSize) = do -- | Tests an SSM program by evaluating both the interpreter and running the -- compiled C code and comparing the output. -propCorrect :: TestName -> (forall backend . Program backend) -> QC.Property +propCorrect :: TestName -> Program backend -> QC.Property propCorrect tn program = - QC.monadicIO $ mapM_ (propCorrectWithSize tn program) queueSizes + QC.monadicIO $ mapM_ (propCorrectWithSize tn $ unsafeCoerce program) queueSizes -- | Tests an SSM program by evaluating both the interpreter and running the -- compiled C code and comparing the output. @@ -129,4 +131,12 @@ semanticIncorrectSpec name p = do propSyntacticEquality :: String -> (forall backend . Program backend) -> (forall backend . Program backend) -> H.Spec propSyntacticEquality name p1 p2 = do - H.prop "produces correct syntax" $ p1 == p2 + H.prop "produces correct syntax" $ QC.monadicIO $ do + QC.monitor $ QC.whenFail $ do + putStrLn "Program produce illegal syntax" + putStrLn "program 1:" + putStrLn $ show p1 + putStrLn "" + putStrLn "program 2:" + putStrLn $ show p2 + return $ p1 == p2 diff --git a/test/regression-high/Regression/CancelBothSpec.hs b/test/regression-high/Regression/CancelBothSpec.hs index 6a19c377..df5a5c90 100644 --- a/test/regression-high/Regression/CancelBothSpec.hs +++ b/test/regression-high/Regression/CancelBothSpec.hs @@ -3,6 +3,7 @@ module Regression.CancelBothSpec where import Prelude hiding (sum) +import SSM.Frontend.Compile import Data.Word import SSM.Frontend.Language import SSM.Frontend.Box @@ -14,10 +15,13 @@ import qualified Test.SSM.Prop as T fun0 :: SSM () fun0 = routine $ do - v0 <- var false' - after (nsecs 1) v0 true' + v0 <- var false + after (nsecs 1) v0 true v1 <- var $ changed v0 - after (nsecs 3872) v1 false' + after (nsecs 3872) v1 false + +program :: Compile backend () +program = schedule fun0 spec :: H.Spec -spec = T.correctSpec "CancelBoth" fun0 +spec = T.correctSpec "CancelBoth" (toProgram program) diff --git a/test/regression-high/Regression/FibRoutineSpec.hs b/test/regression-high/Regression/FibRoutineSpec.hs index 8a59b548..93f87242 100644 --- a/test/regression-high/Regression/FibRoutineSpec.hs +++ b/test/regression-high/Regression/FibRoutineSpec.hs @@ -3,6 +3,7 @@ module Regression.FibRoutineSpec where import Prelude hiding (sum) +import SSM.Frontend.Compile import Data.Word import SSM.Frontend.Language import SSM.Frontend.Box @@ -36,5 +37,8 @@ main = routine $ do r <- var 0 fork [ fib 13 r ] +program :: Compile backend () +program = schedule main + spec :: H.Spec -spec = T.correctSpec "FibRoutine" main +spec = T.correctSpec "FibRoutine" (toProgram program) diff --git a/test/regression-high/Regression/FibSpec.hs b/test/regression-high/Regression/FibSpec.hs index 9d833699..7129f70a 100644 --- a/test/regression-high/Regression/FibSpec.hs +++ b/test/regression-high/Regression/FibSpec.hs @@ -3,6 +3,7 @@ module Regression.FibSpec where import Prelude hiding (sum) +import SSM.Frontend.Compile import Data.Word import SSM.Frontend.Language import SSM.Frontend.Box @@ -40,5 +41,8 @@ main = do r <- var 0 fork [ fib 13 r ] +program :: Compile backend () +program = schedule main + spec :: H.Spec -spec = T.correctSpec "Fib" main +spec = T.correctSpec "Fib" (toProgram program) diff --git a/test/regression-high/Regression/RecurseForeverSpec.hs b/test/regression-high/Regression/RecurseForeverSpec.hs index 3b1cd531..1bf47cfa 100644 --- a/test/regression-high/Regression/RecurseForeverSpec.hs +++ b/test/regression-high/Regression/RecurseForeverSpec.hs @@ -6,6 +6,7 @@ -- This is the front-end version of regression-low/Regression/RecurseForeverSpec.hs module Regression.RecurseForeverSpec where +import SSM.Frontend.Compile import SSM.Frontend.Language import SSM.Frontend.Box import SSM.Frontend.Syntax @@ -17,5 +18,8 @@ fun0 :: SSM () fun0 = boxNullary "fun0" $ do fork [ fun0 ] +program :: Compile backend () +program = schedule fun0 + spec :: H.Spec -spec = T.correctSpec "RecurseForever" fun0 +spec = T.correctSpec "RecurseForever" (toProgram program) diff --git a/test/regression-high/Regression/SenderReceiverSpec.hs b/test/regression-high/Regression/SenderReceiverSpec.hs index ecce29f8..6cf87d5e 100644 --- a/test/regression-high/Regression/SenderReceiverSpec.hs +++ b/test/regression-high/Regression/SenderReceiverSpec.hs @@ -2,7 +2,8 @@ module Regression.SenderReceiverSpec where import Data.Int -import SSM.Frontend.Language +import SSM.Frontend.Compile +import SSM.Language import SSM.Frontend.Box import SSM.Frontend.Syntax import SSM.Core.Syntax @@ -12,7 +13,7 @@ import qualified Test.SSM.Prop as T sender :: Ref () -> SSM () sender = box "sender" ["myEvent"] $ \myEvent -> do - after (mins 1 + secs 1) myEvent event' + after (mins 1 + secs 1) myEvent event receiver :: Ref () -> SSM () @@ -21,8 +22,11 @@ receiver = box "receiver" ["myEvent"] $ \myEvent -> do main :: SSM () main = boxNullary "main" $ do - myEvent <- var event' + myEvent <- var event fork [ sender myEvent, receiver myEvent ] +program :: Compile backend () +program = schedule main + spec :: H.Spec -spec = T.correctSpec "SenderReceiver" main +spec = T.correctSpec "SenderReceiver" (toProgram program) diff --git a/test/regression-syntax/Regression/CancelBothSpec.hs b/test/regression-syntax/Regression/CancelBothSpec.hs index 9eb040d8..c7d5a8b8 100644 --- a/test/regression-syntax/Regression/CancelBothSpec.hs +++ b/test/regression-syntax/Regression/CancelBothSpec.hs @@ -3,6 +3,7 @@ module Regression.CancelBothSpec where import Prelude hiding (sum) +import SSM.Frontend.Compile hiding ( initialQueueContent, peripherals ) import SSM.Language import SSM.Core import Data.Map as Map @@ -13,10 +14,13 @@ import qualified Test.SSM.Prop as T fun0 :: SSM () fun0 = routine $ do - v0 <- var false' - after (nsecs 1) v0 true' + v0 <- var false + after (nsecs 1) v0 true v1 <- var $ changed v0 - after (nsecs 3872) v1 false' + after (nsecs 3872) v1 false + +p1 :: Compile backend () +p1 = schedule fun0 p :: Program backend p = Program @@ -27,15 +31,15 @@ p = Program { name = Ident "fun0" Nothing , arguments = [] , body = - [ NewRef (Ident "fresh0" Nothing) TBool (Lit TBool (LBool False)) + [ NewRef (Ident "var0" Nothing) TBool (Lit TBool (LBool False)) , After (Lit TUInt64 (LUInt64 1)) - (Dynamic (Ident "fresh0" Nothing, Ref TBool)) + (Dynamic (Ident "var0" Nothing, Ref TBool)) (Lit TBool (LBool True)) - , NewRef (Ident "fresh1" Nothing) + , NewRef (Ident "var1" Nothing) TBool - (UOpR TBool (Dynamic (Ident "fresh0" Nothing, Ref TBool)) Changed) + (UOpR TBool (Dynamic (Ident "var0" Nothing, Ref TBool)) Changed) , After (Lit TUInt64 (LUInt64 3872)) - (Dynamic (Ident "fresh1" Nothing, Ref TBool)) + (Dynamic (Ident "var1" Nothing, Ref TBool)) (Lit TBool (LBool False)) ] } @@ -44,4 +48,4 @@ p = Program , peripherals = []} spec :: H.Spec -spec = T.propSyntacticEquality "CancelBoth" fun0 p +spec = T.propSyntacticEquality "CancelBoth" (toProgram p1) p diff --git a/test/regression-syntax/Regression/CancelLaterSpec.hs b/test/regression-syntax/Regression/CancelLaterSpec.hs index d464d8de..07b83e46 100644 --- a/test/regression-syntax/Regression/CancelLaterSpec.hs +++ b/test/regression-syntax/Regression/CancelLaterSpec.hs @@ -3,6 +3,7 @@ module Regression.CancelLaterSpec where import Prelude hiding (sum) +import SSM.Frontend.Compile hiding ( initialQueueContent, peripherals ) import SSM.Language import SSM.Core import Data.Map as Map @@ -16,6 +17,9 @@ fun0 = routine $ do v0 <- var (0 :: Exp Int32) after (nsecs 2) v0 1 +p1 :: Compile backend () +p1 = schedule fun0 + p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] @@ -24,11 +28,11 @@ p = Program , Procedure { name = Ident "fun0" Nothing , arguments = [] - , body = [ NewRef (Ident "fresh0" Nothing) + , body = [ NewRef (Ident "var0" Nothing) TInt32 (Lit TInt32 (LInt32 0)) , After (Lit TUInt64 (LUInt64 2)) - (Dynamic (Ident "fresh0" Nothing, Ref TInt32)) + (Dynamic (Ident "var0" Nothing, Ref TInt32)) (Lit TInt32 (LInt32 1)) ] } @@ -37,4 +41,4 @@ p = Program , peripherals = []} spec :: H.Spec -spec = T.propSyntacticEquality "CancelLater" fun0 p +spec = T.propSyntacticEquality "CancelLater" (toProgram p1) p diff --git a/test/regression-syntax/Regression/EmptyFunSpec.hs b/test/regression-syntax/Regression/EmptyFunSpec.hs index 35b71658..bb7ca9e0 100644 --- a/test/regression-syntax/Regression/EmptyFunSpec.hs +++ b/test/regression-syntax/Regression/EmptyFunSpec.hs @@ -3,6 +3,7 @@ module Regression.EmptyFunSpec where import Prelude hiding (sum) +import SSM.Frontend.Compile hiding ( initialQueueContent, peripherals ) import SSM.Language import SSM.Core import Data.Map as Map @@ -14,8 +15,11 @@ import Data.Int fun1 :: SSM () fun1 = routine $ return () +p1 :: Compile backend () +p1 = schedule fun1 + p :: Program backend p = Program {initialQueueContent = [SSMProcedure (Ident "fun1" Nothing) []], funs = fromList [(Ident "fun1" Nothing,Procedure {name = Ident "fun1" Nothing, arguments = [], body = []})], peripherals = []} spec :: H.Spec -spec = T.propSyntacticEquality "EmptyFun" fun1 p +spec = T.propSyntacticEquality "EmptyFun" (toProgram p1) p diff --git a/test/regression-syntax/Regression/FlipFlopLoopSpec.hs b/test/regression-syntax/Regression/FlipFlopLoopSpec.hs index 16c91942..05d3b11e 100644 --- a/test/regression-syntax/Regression/FlipFlopLoopSpec.hs +++ b/test/regression-syntax/Regression/FlipFlopLoopSpec.hs @@ -3,6 +3,7 @@ module Regression.FlipFlopLoopSpec where import Prelude hiding (sum) +import SSM.Frontend.Compile hiding ( initialQueueContent, peripherals ) import SSM.Language import SSM.Core import Data.Map as Map @@ -13,17 +14,20 @@ import Data.Int fun0 :: SSM () fun0 = routine $ do - ref2 <- var true' + ref2 <- var true fork [fun1 ref2] fun1 :: Ref Bool -> SSM () fun1 fresh2 = routine $ do - while true' $ do - after (nsecs 2) fresh2 false' + while true $ do + after (nsecs 2) fresh2 false wait fresh2 - after (nsecs 2) fresh2 true' + after (nsecs 2) fresh2 true wait fresh2 +p1 :: Compile backend () +p1 = schedule fun0 + p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] @@ -32,8 +36,8 @@ p = Program , Procedure { name = Ident "fun0" Nothing , arguments = [] - , body = [ NewRef (Ident "fresh0" Nothing) TBool (Lit TBool (LBool True)) - , Fork [(Ident "fun1" Nothing, [Right (Dynamic (Ident "fresh0" Nothing, Ref TBool))])] + , body = [ NewRef (Ident "var0" Nothing) TBool (Lit TBool (LBool True)) + , Fork [(Ident "fun1" Nothing, [Right (Dynamic (Ident "var0" Nothing, Ref TBool))])] ] } ) @@ -60,4 +64,4 @@ p = Program } spec :: H.Spec -spec = T.propSyntacticEquality "FlipFlopLoop" fun0 p +spec = T.propSyntacticEquality "FlipFlopLoop" (toProgram p1) p diff --git a/test/regression-syntax/Regression/GlobalEventSpec.hs b/test/regression-syntax/Regression/GlobalEventSpec.hs index 83bb21bd..ebb987c4 100644 --- a/test/regression-syntax/Regression/GlobalEventSpec.hs +++ b/test/regression-syntax/Regression/GlobalEventSpec.hs @@ -7,6 +7,7 @@ import Prelude hiding (sum) import SSM.Language import SSM.Frontend.Peripheral.Identity +import SSM.Frontend.Compile hiding ( initialQueueContent, peripherals ) import SSM.Core import Data.Map as Map import qualified Test.Hspec as H @@ -35,8 +36,8 @@ p = Program } ) ] - , peripherals = [Peripheral $ IdentityPeripheral (fromList [(Ident "glob0" Nothing, Ref TUInt8)])] + , peripherals = [Peripheral $ Globals (fromList [(Ident "glob0" Nothing, Ref TUInt8)])] } spec :: H.Spec -spec = T.propSyntacticEquality "GlobalEvent" program p +spec = T.propSyntacticEquality "GlobalEvent" (toProgram program) p diff --git a/test/regression-syntax/Regression/Int32ArithSpec.hs b/test/regression-syntax/Regression/Int32ArithSpec.hs index 4eb44f78..82c0b416 100644 --- a/test/regression-syntax/Regression/Int32ArithSpec.hs +++ b/test/regression-syntax/Regression/Int32ArithSpec.hs @@ -7,6 +7,7 @@ import Prelude hiding (sum) import SSM.Language import SSM.Frontend.Peripheral.Identity +import SSM.Frontend.Compile hiding ( initialQueueContent, peripherals ) import SSM.Core import Data.Map as Map import qualified Test.Hspec as H @@ -21,6 +22,9 @@ fun0 = routine $ do fun3 :: Exp Int64 -> SSM () fun3 var3 = routine $ return () +p1 :: Compile backend () +p1 = schedule fun0 + p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] @@ -67,4 +71,4 @@ p = Program } spec :: H.Spec -spec = T.propSyntacticEquality "Int32Arith" fun0 p +spec = T.propSyntacticEquality "Int32Arith" (toProgram p1) p diff --git a/test/regression-syntax/Regression/LaterAssignOverflowSpec.hs b/test/regression-syntax/Regression/LaterAssignOverflowSpec.hs index c0cd68f4..864557d7 100644 --- a/test/regression-syntax/Regression/LaterAssignOverflowSpec.hs +++ b/test/regression-syntax/Regression/LaterAssignOverflowSpec.hs @@ -7,6 +7,7 @@ import Prelude hiding (sum) import SSM.Language import SSM.Frontend.Peripheral.Identity +import SSM.Frontend.Compile hiding ( initialQueueContent, peripherals ) import SSM.Core import Data.Map as Map import qualified Test.Hspec as H @@ -16,18 +17,21 @@ import Data.Int fun0 :: SSM () fun0 = routine $ do - fresh0 <- var true' + fresh0 <- var true fresh1 <- var (0 :: Exp Int32) fork [fun1 fresh0 fresh1] fun1 :: Ref Bool -> Ref Int32 -> SSM () fun1 ref1 ref3 = routine $ do - after (nsecs 2) ref1 true' + after (nsecs 2) ref1 true after (nsecs 1) ref3 3 ref3 <~ 4 wait ref1 wait ref3 +p1 :: Compile backend () +p1 = schedule fun0 + p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] @@ -37,10 +41,10 @@ p = Program { name = Ident "fun0" Nothing , arguments = [] , body = - [ NewRef (Ident "fresh0" Nothing) TBool (Lit TBool (LBool True)) - , NewRef (Ident "fresh1" Nothing) TInt32 (Lit TInt32 (LInt32 0)) + [ NewRef (Ident "var0" Nothing) TBool (Lit TBool (LBool True)) + , NewRef (Ident "var1" Nothing) TInt32 (Lit TInt32 (LInt32 0)) , Fork - [(Ident "fun1" Nothing, [Right (Dynamic (Ident "fresh0" Nothing, Ref TBool)), Right (Dynamic (Ident "fresh1" Nothing, Ref TInt32))])] + [(Ident "fun1" Nothing, [Right (Dynamic (Ident "var0" Nothing, Ref TBool)), Right (Dynamic (Ident "var1" Nothing, Ref TInt32))])] ] } ) @@ -65,4 +69,4 @@ p = Program } spec :: H.Spec -spec = T.propSyntacticEquality "LaterAssign" fun0 p +spec = T.propSyntacticEquality "LaterAssign" (toProgram p1) p diff --git a/test/regression-syntax/Regression/LaterWaitSpec.hs b/test/regression-syntax/Regression/LaterWaitSpec.hs index b59297e7..3f820856 100644 --- a/test/regression-syntax/Regression/LaterWaitSpec.hs +++ b/test/regression-syntax/Regression/LaterWaitSpec.hs @@ -7,6 +7,7 @@ import Prelude hiding (sum) import SSM.Language import SSM.Frontend.Peripheral.Identity +import SSM.Frontend.Compile hiding ( initialQueueContent, peripherals ) import SSM.Core import Data.Map as Map import qualified Test.Hspec as H @@ -20,6 +21,9 @@ fun0 = routine $ do after (nsecs 2) fresh0 1 wait fresh0 +p1 :: Compile backend () +p1 = schedule fun0 + p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] @@ -28,11 +32,11 @@ p = Program , Procedure { name = Ident "fun0" Nothing , arguments = [] - , body = [ NewRef (Ident "fresh0" Nothing) TInt32 (Lit TInt32 (LInt32 0)) + , body = [ NewRef (Ident "var0" Nothing) TInt32 (Lit TInt32 (LInt32 0)) , After (Lit TUInt64 (LUInt64 2)) - (Dynamic (Ident "fresh0" Nothing, Ref TInt32)) + (Dynamic (Ident "var0" Nothing, Ref TInt32)) (Lit TInt32 (LInt32 1)) - , Wait [Dynamic (Ident "fresh0" Nothing, Ref TInt32)] + , Wait [Dynamic (Ident "var0" Nothing, Ref TInt32)] ] } ) @@ -40,4 +44,4 @@ p = Program , peripherals = []} spec :: H.Spec -spec = T.propSyntacticEquality "LaterWait" fun0 p +spec = T.propSyntacticEquality "LaterWait" (toProgram p1) p diff --git a/test/regression-syntax/Regression/ManyContsSpec.hs b/test/regression-syntax/Regression/ManyContsSpec.hs index 1ee9a83b..afbef83e 100644 --- a/test/regression-syntax/Regression/ManyContsSpec.hs +++ b/test/regression-syntax/Regression/ManyContsSpec.hs @@ -7,6 +7,7 @@ import Prelude hiding (sum) import SSM.Language import SSM.Frontend.Peripheral.Identity +import SSM.Frontend.Compile hiding ( initialQueueContent, peripherals ) import SSM.Core import Data.Map as Map import qualified Test.Hspec as H @@ -28,6 +29,9 @@ fun1 ref2 = routine $ do , fun1 ref2 ] +p1 :: Compile backend () +p1 = schedule fun0 + p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] @@ -36,10 +40,10 @@ p = Program , Procedure { name = Ident "fun0" Nothing , arguments = [] - , body = [ NewRef (Ident "fresh0" Nothing) + , body = [ NewRef (Ident "var0" Nothing) TUInt64 (Lit TUInt64 (LUInt64 0)) - , Fork [(Ident "fun1" Nothing, [Right $ Dynamic (Ident "fresh0" Nothing, Ref TUInt64)])] + , Fork [(Ident "fun1" Nothing, [Right $ Dynamic (Ident "var0" Nothing, Ref TUInt64)])] ] } ) @@ -76,4 +80,4 @@ p = Program } spec :: H.Spec -spec = T.propSyntacticEquality "ManyConts" fun0 p +spec = T.propSyntacticEquality "ManyConts" (toProgram p1) p diff --git a/test/regression-syntax/Regression/MultOverflowIndirectSpec.hs b/test/regression-syntax/Regression/MultOverflowIndirectSpec.hs index 5227dff6..111575fd 100644 --- a/test/regression-syntax/Regression/MultOverflowIndirectSpec.hs +++ b/test/regression-syntax/Regression/MultOverflowIndirectSpec.hs @@ -7,6 +7,7 @@ import Prelude hiding (sum) import SSM.Language import SSM.Frontend.Peripheral.Identity +import SSM.Frontend.Compile hiding ( initialQueueContent, peripherals ) import SSM.Core import Data.Map as Map import qualified Test.Hspec as H @@ -23,6 +24,9 @@ fun1 = routine $ do fresh1 <- var (0 :: Exp Int32) wait fresh1 +p1 :: Compile backend () +p1 = schedule fun1 + p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun1" Nothing) []] @@ -32,23 +36,23 @@ p = Program { name = Ident "fun1" Nothing , arguments = [] , body = - [ NewRef ((Ident "fresh0" Nothing)) + [ NewRef ((Ident "var0" Nothing)) TInt32 (Lit TInt32 (LInt32 999999)) , If (BOp TBool (Lit TInt32 (LInt32 0)) - (BOp TInt32 (UOpR TInt32 (Dynamic (Ident "fresh0" Nothing, Ref TInt32)) Deref) (UOpR TInt32 (Dynamic (Ident "fresh0" Nothing, Ref TInt32)) Deref) OTimes) + (BOp TInt32 (UOpR TInt32 (Dynamic (Ident "var0" Nothing, Ref TInt32)) Deref) (UOpR TInt32 (Dynamic (Ident "var0" Nothing, Ref TInt32)) Deref) OTimes) OLT ) [ After (Lit TUInt64 (LUInt64 2)) - (Dynamic ((Ident "fresh0" Nothing), Ref TInt32)) + (Dynamic ((Ident "var0" Nothing), Ref TInt32)) (Lit TInt32 (LInt32 0)) ] [] - , NewRef (Ident "fresh1" Nothing) TInt32 (Lit TInt32 (LInt32 0)) - , Wait [Dynamic (Ident "fresh1" Nothing, Ref TInt32)] + , NewRef (Ident "var1" Nothing) TInt32 (Lit TInt32 (LInt32 0)) + , Wait [Dynamic (Ident "var1" Nothing, Ref TInt32)] ] } ) @@ -57,4 +61,4 @@ p = Program } spec :: H.Spec -spec = T.propSyntacticEquality "MultOverflowIndirectSpec" fun1 p +spec = T.propSyntacticEquality "MultOverflowIndirectSpec" (toProgram p1) p diff --git a/test/regression-syntax/Regression/MultOverflowSpec.hs b/test/regression-syntax/Regression/MultOverflowSpec.hs index 9907cbed..7820cc6b 100644 --- a/test/regression-syntax/Regression/MultOverflowSpec.hs +++ b/test/regression-syntax/Regression/MultOverflowSpec.hs @@ -7,6 +7,7 @@ import Prelude hiding (sum) import SSM.Language import SSM.Frontend.Peripheral.Identity +import SSM.Frontend.Compile hiding ( initialQueueContent, peripherals ) import SSM.Core import Data.Map as Map import qualified Test.Hspec as H @@ -22,6 +23,9 @@ fun1 = routine $ do (after (nsecs 2) fresh0 1) wait fresh0 +p1 :: Compile backend () +p1 = schedule fun1 + p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun1" Nothing) []] @@ -31,22 +35,22 @@ p = Program { name = Ident "fun1" Nothing , arguments = [] , body = - [ NewRef ((Ident "fresh0" Nothing)) TInt32 (Lit TInt32 (LInt32 999999)) + [ NewRef ((Ident "var0" Nothing)) TInt32 (Lit TInt32 (LInt32 999999)) , If (BOp TBool (Lit TInt32 (LInt32 0)) - (BOp TInt32 (UOpR TInt32 (Dynamic (Ident "fresh0" Nothing, Ref TInt32)) Deref) (UOpR TInt32 (Dynamic (Ident "fresh0" Nothing, Ref TInt32)) Deref) OTimes) + (BOp TInt32 (UOpR TInt32 (Dynamic (Ident "var0" Nothing, Ref TInt32)) Deref) (UOpR TInt32 (Dynamic (Ident "var0" Nothing, Ref TInt32)) Deref) OTimes) OLT ) [ After (Lit TUInt64 (LUInt64 2)) - (Dynamic ((Ident "fresh0" Nothing), Ref TInt32)) + (Dynamic ((Ident "var0" Nothing), Ref TInt32)) (Lit TInt32 (LInt32 0)) ] [ After (Lit TUInt64 (LUInt64 2)) - (Dynamic ((Ident "fresh0" Nothing), Ref TInt32)) + (Dynamic ((Ident "var0" Nothing), Ref TInt32)) (Lit TInt32 (LInt32 1)) ] - , Wait [Dynamic ((Ident "fresh0" Nothing), Ref TInt32)] + , Wait [Dynamic ((Ident "var0" Nothing), Ref TInt32)] ] } ) @@ -54,4 +58,4 @@ p = Program , peripherals = []} spec :: H.Spec -spec = T.propSyntacticEquality "MultOverflow" fun1 p +spec = T.propSyntacticEquality "MultOverflow" (toProgram p1) p diff --git a/test/regression-syntax/Regression/NewEventSpec.hs b/test/regression-syntax/Regression/NewEventSpec.hs index 322aa34d..c2f1c8be 100644 --- a/test/regression-syntax/Regression/NewEventSpec.hs +++ b/test/regression-syntax/Regression/NewEventSpec.hs @@ -7,6 +7,7 @@ import Prelude hiding (sum) import SSM.Language import SSM.Frontend.Peripheral.Identity +import SSM.Frontend.Compile hiding ( initialQueueContent, peripherals ) import SSM.Core import Data.Map as Map import qualified Test.Hspec as H @@ -16,9 +17,12 @@ import Data.Int fun0 :: SSM () fun0 = routine $ do - var event' + var event return () +p1 :: Compile backend () +p1 = schedule fun0 + p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] @@ -28,7 +32,7 @@ p = Program { name = Ident { identName = "fun0", identSrcInfo = Nothing } , arguments = [] , body = [ NewRef - (Ident { identName = "fresh0" + (Ident { identName = "var0" , identSrcInfo = Nothing } ) @@ -42,4 +46,4 @@ p = Program } spec :: H.Spec -spec = T.propSyntacticEquality "NewEvent" fun0 p +spec = T.propSyntacticEquality "NewEvent" (toProgram p1) p diff --git a/test/regression-syntax/Regression/RecurseExhaustiveSpec.hs b/test/regression-syntax/Regression/RecurseExhaustiveSpec.hs index ce431096..8737be9a 100644 --- a/test/regression-syntax/Regression/RecurseExhaustiveSpec.hs +++ b/test/regression-syntax/Regression/RecurseExhaustiveSpec.hs @@ -7,6 +7,7 @@ import Prelude hiding (sum) import SSM.Language import SSM.Frontend.Peripheral.Identity +import SSM.Frontend.Compile hiding ( initialQueueContent, peripherals ) import SSM.Core import Data.Map as Map import qualified Test.Hspec as H @@ -20,6 +21,9 @@ fun0 = routine $ fork [fun0, fun1] fun1 :: SSM () fun1 = routine $ return () +p1 :: Compile backend () +p1 = schedule fun0 + p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] @@ -35,4 +39,4 @@ p = Program , peripherals = []} spec :: H.Spec -spec = T.propSyntacticEquality "RecurseExhaustive" fun0 p +spec = T.propSyntacticEquality "RecurseExhaustive" (toProgram p1) p diff --git a/test/regression-syntax/Regression/RecurseForeverSpec.hs b/test/regression-syntax/Regression/RecurseForeverSpec.hs index 7b2b5b52..2943390c 100644 --- a/test/regression-syntax/Regression/RecurseForeverSpec.hs +++ b/test/regression-syntax/Regression/RecurseForeverSpec.hs @@ -7,6 +7,7 @@ import Prelude hiding (sum) import SSM.Language import SSM.Frontend.Peripheral.Identity +import SSM.Frontend.Compile hiding ( initialQueueContent, peripherals ) import SSM.Core import Data.Map as Map import qualified Test.Hspec as H @@ -17,6 +18,9 @@ import Data.Int fun0 :: SSM () fun0 = routine $ fork [fun0] +p1 :: Compile backend () +p1 = schedule fun0 + p :: Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] @@ -32,4 +36,4 @@ p = Program , peripherals = []} spec :: H.Spec -spec = T.propSyntacticEquality "RecurseForever" fun0 p +spec = T.propSyntacticEquality "RecurseForever" (toProgram p1) p diff --git a/test/regression-syntax/Regression/SynthesizeAdditionSpec.hs b/test/regression-syntax/Regression/SynthesizeAdditionSpec.hs index 1f30d707..7a80c007 100644 --- a/test/regression-syntax/Regression/SynthesizeAdditionSpec.hs +++ b/test/regression-syntax/Regression/SynthesizeAdditionSpec.hs @@ -7,6 +7,7 @@ import Prelude hiding (sum) import SSM.Language import SSM.Frontend.Peripheral.Identity +import SSM.Frontend.Compile hiding ( initialQueueContent, peripherals ) import SSM.Core import Data.Map as Map import qualified Test.Hspec as H @@ -21,22 +22,26 @@ fun0 = routine $ do fork [ x <~ deref x + deref y ] -p = Program backend +p1 :: Compile backend () +p1 = schedule fun0 + +p :: Program backend +p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] - , funs = fromList [( Ident "generatedfresh0" Nothing - , Procedure { name = Ident "generatedfresh0" Nothing - , arguments = [(Ident "fresh0" Nothing, Ref TInt64), (Ident "fresh1" Nothing, Ref TInt64)] - , body = [ SetRef (Dynamic (Ident "fresh0" Nothing, Ref TInt64)) (BOp TInt64 (UOpR TInt64 (Dynamic (Ident "fresh0" Nothing, Ref TInt64)) Deref) (UOpR TInt64 (Dynamic (Ident "fresh1" Nothing, Ref TInt64)) Deref) OPlus)]}) + , funs = fromList [( Ident "generated0" Nothing + , Procedure { name = Ident "generated0" Nothing + , arguments = [(Ident "var0" Nothing, Ref TInt64), (Ident "var1" Nothing, Ref TInt64)] + , body = [ SetRef (Dynamic (Ident "var0" Nothing, Ref TInt64)) (BOp TInt64 (UOpR TInt64 (Dynamic (Ident "var0" Nothing, Ref TInt64)) Deref) (UOpR TInt64 (Dynamic (Ident "var1" Nothing, Ref TInt64)) Deref) OPlus)]}) ,( Ident "fun0" Nothing , Procedure (Ident "fun0" Nothing) [] - [ NewRef (Ident "fresh0" Nothing) TInt64 (Lit TInt64 (LInt64 0)) - , NewRef (Ident "fresh1" Nothing) TInt64 (Lit TInt64 (LInt64 1)) - , Fork [(Ident "generatedfresh0" Nothing,[Right $ Dynamic (Ident "fresh0" Nothing, Ref TInt64), Right $ Dynamic (Ident "fresh1" Nothing, Ref TInt64)])]] + [ NewRef (Ident "var0" Nothing) TInt64 (Lit TInt64 (LInt64 0)) + , NewRef (Ident "var1" Nothing) TInt64 (Lit TInt64 (LInt64 1)) + , Fork [(Ident "generated0" Nothing,[Right $ Dynamic (Ident "var0" Nothing, Ref TInt64), Right $ Dynamic (Ident "var1" Nothing, Ref TInt64)])]] ) ] , peripherals = []} spec :: H.Spec -spec = T.propSyntacticEquality "SynthesizeAddition" fun0 p +spec = T.propSyntacticEquality "SynthesizeAddition" (toProgram p1) p diff --git a/test/regression-syntax/Regression/SynthesizeDelaySpec.hs b/test/regression-syntax/Regression/SynthesizeDelaySpec.hs index 37400b3a..b77786c0 100644 --- a/test/regression-syntax/Regression/SynthesizeDelaySpec.hs +++ b/test/regression-syntax/Regression/SynthesizeDelaySpec.hs @@ -7,6 +7,7 @@ import Prelude hiding (sum) import SSM.Language import SSM.Frontend.Peripheral.Identity +import SSM.Frontend.Compile hiding ( initialQueueContent, peripherals ) import SSM.Core import Data.Map as Map import qualified Test.Hspec as H @@ -16,26 +17,30 @@ import Data.Int fun0 :: SSM () fun0 = routine $ do - fork [ do wake <- var event' - after (secs 1) wake event' + fork [ do wake <- var event + after (secs 1) wake event wait wake ] -p = Program backend +p1 :: Compile backend () +p1 = schedule fun0 + +p :: Program backend +p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] - , funs = fromList [( Ident "generatedfresh0" Nothing - , Procedure { name = Ident "generatedfresh0" Nothing + , funs = fromList [( Ident "generated0" Nothing + , Procedure { name = Ident "generated0" Nothing , arguments = [] - , body = [ NewRef (Ident "fresh0" Nothing) TEvent (Lit TEvent LEvent) - , After (BOp TUInt64 (Lit TUInt64 (LUInt64 1)) (Lit TUInt64 (LUInt64 1000000000)) OTimes) (Dynamic (Ident "fresh0" Nothing,Ref TEvent)) (Lit TEvent LEvent) - , Wait [Dynamic (Ident "fresh0" Nothing,Ref TEvent)]]}) + , body = [ NewRef (Ident "var0" Nothing) TEvent (Lit TEvent LEvent) + , After (BOp TUInt64 (Lit TUInt64 (LUInt64 1)) (Lit TUInt64 (LUInt64 1000000000)) OTimes) (Dynamic (Ident "var0" Nothing,Ref TEvent)) (Lit TEvent LEvent) + , Wait [Dynamic (Ident "var0" Nothing,Ref TEvent)]]}) ,( Ident "fun0" Nothing - , Procedure (Ident "fun0" Nothing) [] [Fork [(Ident "generatedfresh0" Nothing,[])]] + , Procedure (Ident "fun0" Nothing) [] [Fork [(Ident "generated0" Nothing,[])]] ) ] , peripherals = []} spec :: H.Spec -spec = T.propSyntacticEquality "SynthesizeDelay" fun0 p +spec = T.propSyntacticEquality "SynthesizeDelay" (toProgram p1) p diff --git a/test/regression-syntax/Regression/SynthesizeForeverRecurseSpec.hs b/test/regression-syntax/Regression/SynthesizeForeverRecurseSpec.hs index 1a0e19c1..f2e45069 100644 --- a/test/regression-syntax/Regression/SynthesizeForeverRecurseSpec.hs +++ b/test/regression-syntax/Regression/SynthesizeForeverRecurseSpec.hs @@ -7,6 +7,7 @@ import Prelude hiding (sum) import SSM.Language import SSM.Frontend.Peripheral.Identity +import SSM.Frontend.Compile hiding ( initialQueueContent, peripherals ) import SSM.Core import Data.Map as Map import qualified Test.Hspec as H @@ -25,20 +26,24 @@ fun0 = routine $ do fun1 :: SSM () fun1 = routine $ fork [fun1] -p = Program backend +p1 :: Compile backend () +p1 = schedule fun0 + +p :: Program backend +p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] - , funs = fromList [( Ident "generatedfresh0" Nothing - , Procedure { name = Ident "generatedfresh0" Nothing - , arguments = [(Ident "fresh0" Nothing, Ref TInt64), (Ident "fresh1" Nothing, Ref TInt64)] - , body = [ SetRef (Dynamic (Ident "fresh0" Nothing, Ref TInt64)) (BOp TInt64 (UOpR TInt64 (Dynamic (Ident "fresh0" Nothing, Ref TInt64)) Deref) (UOpR TInt64 (Dynamic (Ident "fresh1" Nothing, Ref TInt64)) Deref) OPlus) + , funs = fromList [( Ident "generated0" Nothing + , Procedure { name = Ident "generated0" Nothing + , arguments = [(Ident "var0" Nothing, Ref TInt64), (Ident "var1" Nothing, Ref TInt64)] + , body = [ SetRef (Dynamic (Ident "var0" Nothing, Ref TInt64)) (BOp TInt64 (UOpR TInt64 (Dynamic (Ident "var0" Nothing, Ref TInt64)) Deref) (UOpR TInt64 (Dynamic (Ident "var1" Nothing, Ref TInt64)) Deref) OPlus) , Fork [(Ident "fun1" Nothing, [])] ]}) ,( Ident "fun0" Nothing , Procedure (Ident "fun0" Nothing) [] - [ NewRef (Ident "fresh0" Nothing) TInt64 (Lit TInt64 (LInt64 0)) - , NewRef (Ident "fresh1" Nothing) TInt64 (Lit TInt64 (LInt64 1)) - , Fork [(Ident "generatedfresh0" Nothing,[Right $ Dynamic (Ident "fresh0" Nothing, Ref TInt64), Right $ Dynamic (Ident "fresh1" Nothing, Ref TInt64)])]] + [ NewRef (Ident "var0" Nothing) TInt64 (Lit TInt64 (LInt64 0)) + , NewRef (Ident "var1" Nothing) TInt64 (Lit TInt64 (LInt64 1)) + , Fork [(Ident "generated0" Nothing,[Right $ Dynamic (Ident "var0" Nothing, Ref TInt64), Right $ Dynamic (Ident "var1" Nothing, Ref TInt64)])]] ) , ( Ident "fun1" Nothing , Procedure (Ident "fun1" Nothing) [] @@ -48,4 +53,4 @@ p = Program backend spec :: H.Spec -spec = T.propSyntacticEquality "SynthesizeForeverRecurse" fun0 p +spec = T.propSyntacticEquality "SynthesizeForeverRecurse" (toProgram p1) p diff --git a/test/regression-syntax/Regression/SynthesizeNamedSpec.hs b/test/regression-syntax/Regression/SynthesizeNamedSpec.hs index c7c268c4..25d5d369 100644 --- a/test/regression-syntax/Regression/SynthesizeNamedSpec.hs +++ b/test/regression-syntax/Regression/SynthesizeNamedSpec.hs @@ -7,6 +7,7 @@ import Prelude hiding (sum) import SSM.Language import SSM.Frontend.Peripheral.Identity +import SSM.Frontend.Compile hiding ( initialQueueContent, peripherals ) import SSM.Core import Data.Map as Map import qualified Test.Hspec as H @@ -16,29 +17,33 @@ import Data.Int delay :: Exp Time -> SSM () delay time = do - wake <- var event' - after time wake event' + wake <- var event + after time wake event wait wake fun0 :: SSM () fun0 = routine $ do fork [ delay (nsecs 2) ] -p = Program backend +p1 :: Compile backend () +p1 = schedule fun0 + +p :: Program backend +p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] - , funs = fromList [( Ident "generatedfresh0" Nothing - , Procedure { name = Ident "generatedfresh0" Nothing + , funs = fromList [( Ident "generated0" Nothing + , Procedure { name = Ident "generated0" Nothing , arguments = [] - , body = [ NewRef (Ident "fresh0" Nothing) TEvent (Lit TEvent LEvent) - , After (Lit TUInt64 (LUInt64 2)) (Dynamic (Ident "fresh0" Nothing,Ref TEvent)) (Lit TEvent LEvent) - , Wait [Dynamic (Ident "fresh0" Nothing,Ref TEvent)]]}) + , body = [ NewRef (Ident "var0" Nothing) TEvent (Lit TEvent LEvent) + , After (Lit TUInt64 (LUInt64 2)) (Dynamic (Ident "var0" Nothing,Ref TEvent)) (Lit TEvent LEvent) + , Wait [Dynamic (Ident "var0" Nothing,Ref TEvent)]]}) ,( Ident "fun0" Nothing - , Procedure (Ident "fun0" Nothing) [] [Fork [(Ident "generatedfresh0" Nothing,[])]] + , Procedure (Ident "fun0" Nothing) [] [Fork [(Ident "generated0" Nothing,[])]] ) ] , peripherals = []} spec :: H.Spec -spec = T.propSyntacticEquality "SynthesizeNamed" fun0 p +spec = T.propSyntacticEquality "SynthesizeNamed" (toProgram p1) p diff --git a/test/regression-syntax/Regression/SynthesizeRecursiveSpec.hs b/test/regression-syntax/Regression/SynthesizeRecursiveSpec.hs index 03489a69..a19b26c3 100644 --- a/test/regression-syntax/Regression/SynthesizeRecursiveSpec.hs +++ b/test/regression-syntax/Regression/SynthesizeRecursiveSpec.hs @@ -7,6 +7,7 @@ import Prelude hiding (sum) import SSM.Language import SSM.Frontend.Peripheral.Identity +import SSM.Frontend.Compile hiding ( initialQueueContent, peripherals ) import SSM.Core import Data.Map as Map import qualified Test.Hspec as H @@ -14,36 +15,40 @@ import qualified Test.Hspec.QuickCheck as H import qualified Test.SSM.Prop as T import Data.Int +p1 :: Compile backend () +p1 = schedule fun0 + fun0 :: SSM () fun0 = routine $ do - x <- var event' + x <- var event fork [ do wait x fork [wait x] ] -p = Program backend +p :: Program backend +p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] , funs = fromList [( Ident "fun0" Nothing , Procedure (Ident "fun0" Nothing) [] - [ NewRef (Ident "fresh0" Nothing) TEvent (Lit TEvent LEvent) - , Fork [(Ident "generatedfresh0" Nothing,[Right $ Dynamic (Ident "fresh0" Nothing, Ref TEvent)])]] + [ NewRef (Ident "var0" Nothing) TEvent (Lit TEvent LEvent) + , Fork [(Ident "generated0" Nothing,[Right $ Dynamic (Ident "var0" Nothing, Ref TEvent)])]] ) - , ( Ident "generatedfresh0" Nothing - , Procedure (Ident "generatedfresh0" Nothing) - [(Ident "fresh0" Nothing, Ref TEvent)] - [ Wait [Dynamic (Ident "fresh0" Nothing, Ref TEvent)] - , Fork [(Ident "generatedfresh1" Nothing, [Right $ Dynamic (Ident "fresh0" Nothing, Ref TEvent)])] + , ( Ident "generated0" Nothing + , Procedure (Ident "generated0" Nothing) + [(Ident "var0" Nothing, Ref TEvent)] + [ Wait [Dynamic (Ident "var0" Nothing, Ref TEvent)] + , Fork [(Ident "generated1" Nothing, [Right $ Dynamic (Ident "var0" Nothing, Ref TEvent)])] ] ) - , ( Ident "generatedfresh1" Nothing - , Procedure (Ident "generatedfresh1" Nothing) - [(Ident "fresh0" Nothing, Ref TEvent)] - [Wait [Dynamic (Ident "fresh0" Nothing, Ref TEvent)]] + , ( Ident "generated1" Nothing + , Procedure (Ident "generated1" Nothing) + [(Ident "var0" Nothing, Ref TEvent)] + [Wait [Dynamic (Ident "var0" Nothing, Ref TEvent)]] ) ] , peripherals = []} spec :: H.Spec -spec = T.propSyntacticEquality "SynthesizeRecursive" fun0 p +spec = T.propSyntacticEquality "SynthesizeRecursive" (toProgram p1) p diff --git a/test/trace-parser/Spec.hs b/test/trace-parser/Spec.hs index 4c17c5f1..ae53e25d 100644 --- a/test/trace-parser/Spec.hs +++ b/test/trace-parser/Spec.hs @@ -3,6 +3,8 @@ import SSM.Core.Type import SSM.Interpret.Trace import SSM.Interpret.TraceParser +import Test.QuickCheck + import qualified Test.Hspec as H import qualified Test.Hspec.QuickCheck as H @@ -11,6 +13,12 @@ import qualified Data.Text as T import Text.Megaparsec +instance Arbitrary Type where + arbitrary = elements $ basetypes ++ map Ref basetypes + where + basetypes :: [Type] + basetypes = [TBool, TUInt8, TUInt32, TUInt64, TInt32, TInt64] + main :: IO () main = H.hspec $ do H.describe "Trace parser" $ do From 6bb217c6669578016b3ee94fdda4a00e8f6d5492 Mon Sep 17 00:00:00 2001 From: Robert Krook Date: Thu, 16 Dec 2021 14:12:50 +0100 Subject: [PATCH 12/16] Put the trace datatype in its own directory to make the dependency graph nicer --- ssm.cabal | 4 ++-- ssm/SSM/Backend/C/CodeGen.hs | 2 +- ssm/SSM/Backend/C/Types.hs | 2 +- ssm/SSM/Interpret.hs | 2 +- ssm/SSM/Interpret/Internal.hs | 2 +- ssm/SSM/Interpret/Interpreter.hs | 2 +- ssm/SSM/Interpret/Types.hs | 2 +- ssm/SSM/{Interpret => Trace}/Trace.hs | 2 +- ssm/SSM/{Interpret => Trace}/TraceParser.hs | 4 ++-- test/lib/Test/SSM/Trace.hs | 4 ++-- test/trace-parser/Spec.hs | 4 ++-- 11 files changed, 15 insertions(+), 15 deletions(-) rename ssm/SSM/{Interpret => Trace}/Trace.hs (99%) rename ssm/SSM/{Interpret => Trace}/TraceParser.hs (98%) diff --git a/ssm.cabal b/ssm.cabal index 7387595e..53fe22fc 100644 --- a/ssm.cabal +++ b/ssm.cabal @@ -54,14 +54,14 @@ library SSM.Interpret SSM.Interpret.Internal SSM.Interpret.Interpreter - SSM.Interpret.Trace - SSM.Interpret.TraceParser SSM.Interpret.Types SSM.Language SSM.Plugin SSM.Pretty SSM.Pretty.Syntax SSM.Test + SSM.Trace.Trace + SSM.Trace.TraceParser SSM.Util.Default SSM.Util.HughesList SSM.Util.Operators diff --git a/ssm/SSM/Backend/C/CodeGen.hs b/ssm/SSM/Backend/C/CodeGen.hs index c12ec232..c7d46ba1 100644 --- a/ssm/SSM/Backend/C/CodeGen.hs +++ b/ssm/SSM/Backend/C/CodeGen.hs @@ -33,7 +33,7 @@ import SSM.Backend.C.Types import SSM.Core -import qualified SSM.Interpret.Trace as T +import qualified SSM.Trace.Trace as T -- | Given a 'Program', returns a tuple containing the compiled program and -- a list of all `include` statements. diff --git a/ssm/SSM/Backend/C/Types.hs b/ssm/SSM/Backend/C/Types.hs index 5b532058..b1b60139 100644 --- a/ssm/SSM/Backend/C/Types.hs +++ b/ssm/SSM/Backend/C/Types.hs @@ -7,7 +7,7 @@ import SSM.Core.Ident import SSM.Backend.C.Identifiers -import qualified SSM.Interpret.Trace as T +import qualified SSM.Trace.Trace as T import Language.C.Quote.GCC ( cexp , cstm diff --git a/ssm/SSM/Interpret.hs b/ssm/SSM/Interpret.hs index d62adbd5..7ce2349a 100644 --- a/ssm/SSM/Interpret.hs +++ b/ssm/SSM/Interpret.hs @@ -10,7 +10,7 @@ module SSM.Interpret import SSM.Frontend.Compile import SSM.Core import SSM.Util.Default -import qualified SSM.Interpret.Trace as T +import qualified SSM.Trace.Trace as T import qualified SSM.Interpret.Interpreter as I diff --git a/ssm/SSM/Interpret/Internal.hs b/ssm/SSM/Interpret/Internal.hs index 7f9b38b5..56d71f99 100644 --- a/ssm/SSM/Interpret/Internal.hs +++ b/ssm/SSM/Interpret/Internal.hs @@ -104,7 +104,7 @@ import SSM.Util.Operators ( (<#>) ) import SSM.Core -import qualified SSM.Interpret.Trace as T +import qualified SSM.Trace.Trace as T import SSM.Interpret.Types {-********** Main interpret function helpers **********-} diff --git a/ssm/SSM/Interpret/Interpreter.hs b/ssm/SSM/Interpret/Interpreter.hs index 866a5540..c4d61b11 100644 --- a/ssm/SSM/Interpret/Interpreter.hs +++ b/ssm/SSM/Interpret/Interpreter.hs @@ -12,7 +12,7 @@ module SSM.Interpret.Interpreter import SSM.Core import SSM.Interpret.Internal -import qualified SSM.Interpret.Trace as T +import qualified SSM.Trace.Trace as T import SSM.Util.Default ( Default(def) ) import SSM.Util.HughesList hiding ( (++) ) diff --git a/ssm/SSM/Interpret/Types.hs b/ssm/SSM/Interpret/Types.hs index 9587ba9e..1cab0878 100644 --- a/ssm/SSM/Interpret/Types.hs +++ b/ssm/SSM/Interpret/Types.hs @@ -57,7 +57,7 @@ import Control.Monad.Writer.Lazy import qualified Data.IntMap as IntMap import qualified Data.Map as Map -import qualified SSM.Interpret.Trace as T +import qualified SSM.Trace.Trace as T {- | SSM interpreter variables. A variable is a reference to a 5-tuple. The components are diff --git a/ssm/SSM/Interpret/Trace.hs b/ssm/SSM/Trace/Trace.hs similarity index 99% rename from ssm/SSM/Interpret/Trace.hs rename to ssm/SSM/Trace/Trace.hs index 6e97c5a8..16ad5e89 100644 --- a/ssm/SSM/Interpret/Trace.hs +++ b/ssm/SSM/Trace/Trace.hs @@ -12,7 +12,7 @@ between instants, so that it increases monotonically throughout the execution. -} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DerivingVia #-} -module SSM.Interpret.Trace where +module SSM.Trace.Trace where import qualified Data.Text as T import Data.Word diff --git a/ssm/SSM/Interpret/TraceParser.hs b/ssm/SSM/Trace/TraceParser.hs similarity index 98% rename from ssm/SSM/Interpret/TraceParser.hs rename to ssm/SSM/Trace/TraceParser.hs index 3e5755bd..b123b7fd 100644 --- a/ssm/SSM/Interpret/TraceParser.hs +++ b/ssm/SSM/Trace/TraceParser.hs @@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} -module SSM.Interpret.TraceParser where +module SSM.Trace.TraceParser where import SSM.Core.Type -import SSM.Interpret.Trace +import SSM.Trace.Trace import Data.List.NonEmpty import Data.Maybe diff --git a/test/lib/Test/SSM/Trace.hs b/test/lib/Test/SSM/Trace.hs index 4cb46606..ce6cb6ea 100644 --- a/test/lib/Test/SSM/Trace.hs +++ b/test/lib/Test/SSM/Trace.hs @@ -27,8 +27,8 @@ import SSM.Core ( Program, C, Interpret ) import SSM.Interpret ( InterpretConfig(..) , interpret' ) -import qualified SSM.Interpret.Trace as Tr -import qualified SSM.Interpret.TraceParser as TrP +import qualified SSM.Trace.Trace as Tr +import qualified SSM.Trace.TraceParser as TrP import SSM.Util.Default ( Default(..) ) diff --git a/test/trace-parser/Spec.hs b/test/trace-parser/Spec.hs index ae53e25d..efddd0c0 100644 --- a/test/trace-parser/Spec.hs +++ b/test/trace-parser/Spec.hs @@ -1,7 +1,7 @@ import SSM.Core.Syntax import SSM.Core.Type -import SSM.Interpret.Trace -import SSM.Interpret.TraceParser +import SSM.Trace.Trace +import SSM.Trace.TraceParser import Test.QuickCheck From 114acb7dc75cdd6ccfb59cd85f55a47bba5cef13 Mon Sep 17 00:00:00 2001 From: Robert Krook Date: Wed, 22 Dec 2021 11:00:47 +0100 Subject: [PATCH 13/16] fixed spelling error --- ssm/SSM/Core/Peripheral.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ssm/SSM/Core/Peripheral.hs b/ssm/SSM/Core/Peripheral.hs index 0844d51b..04323a48 100644 --- a/ssm/SSM/Core/Peripheral.hs +++ b/ssm/SSM/Core/Peripheral.hs @@ -36,7 +36,7 @@ instance Eq (Peripheral backend) where -- | @IsPeripheral@ describes everything that a peripheral is and what it can do class IsPeripheral backend a where - {- | Declare a peripheral that is declared in the global scope. The peripheral + {- | Declare a reference that is declared in the global scope. The peripheral might need to identify some IO driver that it needs to be connected to, which is what the @Word8@ parameter is for. -} declareReference :: proxy backend -> Type -> Ident -> Word8 -> a -> a From 2e2300da6b615b84fc08764ece973896f09afd5c Mon Sep 17 00:00:00 2001 From: Robert Krook Date: Mon, 3 Jan 2022 11:10:44 +0100 Subject: [PATCH 14/16] removed type family in favour of class with associated type. We can sprinkle these instances throughout the compiler if we want to. --- ssm/SSM/Core/Backend.hs | 46 +++++++++++++------ ssm/SSM/Core/Peripheral.hs | 8 ++-- ssm/SSM/Frontend/Peripheral/Identity.hs | 4 +- test/arbitrary/Spec.hs | 5 +- test/lib/Test/SSM/Prop.hs | 27 +++++------ test/lib/Test/SSM/QuickCheck/Generator.hs | 3 +- .../Regression/GlobalEventSpec.hs | 2 +- .../Regression/GlobalEventSpec.hs | 4 +- 8 files changed, 60 insertions(+), 39 deletions(-) diff --git a/ssm/SSM/Core/Backend.hs b/ssm/SSM/Core/Backend.hs index 959302db..cf4ed261 100644 --- a/ssm/SSM/Core/Backend.hs +++ b/ssm/SSM/Core/Backend.hs @@ -1,30 +1,46 @@ {- | Programs are parameterized over different backends. This file lists the available -backends and declares some type families that can be used to talk about backend-specific -code in a general way. -} +backends and declares a typeclass with two associated types that are needed to generate +code in a backend-specific way. -} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} module SSM.Core.Backend - ( C + ( -- * Backend typeclass + Backend(..) + -- * Compiler-supported backends + , C , PrettyPrint , Interpret - , Definition - , Statement ) where import qualified Language.C.Syntax as C + -- | Programs can be compiled to C data C +-- | Programs can be pretty-printed data PrettyPrint +-- | Programs can be interpreted data Interpret --- | Type of top-level declarations -type family Definition backend where - Definition C = C.Definition - Definition PrettyPrint = String - Definition Interpret = () -- FIXME add meaning +{- | Any type that implements the backend typeclass is available as a backend. The +associated types @Definition@ and @Statement@ mainly refers to how peripheral +initialization is handled. -} +class Backend backend where + type Definition backend + type Statement backend + +{- | For C, the definitions are of type @Definition@ from mainland-c, and the statements +are @BlockItem@s. -} +instance Backend C where + type Definition C = C.Definition + type Statement C = C.BlockItem + +-- | The pretty-printing backend deals solely with strings +instance Backend PrettyPrint where + type Definition PrettyPrint = String + type Statement PrettyPrint = String --- | Type of statements -type family Statement backend where - Statement C = C.BlockItem - Statement PrettyPrint = String - Statement Interpret = () -- FIXME add meaning +-- FIXME add meaning +instance Backend Interpret where + type Definition Interpret = () + type Statement Interpret = () diff --git a/ssm/SSM/Core/Peripheral.hs b/ssm/SSM/Core/Peripheral.hs index 04323a48..927b87b9 100644 --- a/ssm/SSM/Core/Peripheral.hs +++ b/ssm/SSM/Core/Peripheral.hs @@ -21,12 +21,12 @@ import Data.Word ( Word8 ) import SSM.Core.Reference ( Reference ) import SSM.Core.Type ( Type ) import SSM.Core.Ident ( Ident ) -import SSM.Core.Backend +import SSM.Core.Backend ( Backend(..) ) -- | Type of peripherals data Peripheral backend where -- | A `Peripheral` holds an object that has an instance of `IsPeripheral` - Peripheral :: forall backend a . (IsPeripheral backend a, Show a, Eq a) => a -> Peripheral backend + Peripheral :: forall backend a . (Backend backend, IsPeripheral backend a, Show a, Eq a) => a -> Peripheral backend instance Show (Peripheral backend) where show (Peripheral p) = show p @@ -35,7 +35,7 @@ instance Eq (Peripheral backend) where (==) = undefined -- | @IsPeripheral@ describes everything that a peripheral is and what it can do -class IsPeripheral backend a where +class Backend backend => IsPeripheral backend a where {- | Declare a reference that is declared in the global scope. The peripheral might need to identify some IO driver that it needs to be connected to, which is what the @Word8@ parameter is for. -} @@ -65,7 +65,7 @@ class IsPeripheral backend a where staticInitialization :: proxy backend -> a -> [Statement backend] -- | Dummy instance to prevent the need for wrapping/unwrapping of @Peripherals@ -instance IsPeripheral backend (Peripheral backend) where +instance Backend backend => IsPeripheral backend (Peripheral backend) where declareReference proxy t id i (Peripheral p) = Peripheral $ declareReference proxy t id i p declaredReferences proxy (Peripheral p) = declaredReferences proxy p diff --git a/ssm/SSM/Frontend/Peripheral/Identity.hs b/ssm/SSM/Frontend/Peripheral/Identity.hs index a6412a55..036b2e77 100644 --- a/ssm/SSM/Frontend/Peripheral/Identity.hs +++ b/ssm/SSM/Frontend/Peripheral/Identity.hs @@ -38,7 +38,7 @@ emptyGlobals :: Globals emptyGlobals = Globals Map.empty -- | The identity peripheral works regardless of backend, since no IO is involved -instance IsPeripheral backend Globals where +instance Backend backend => IsPeripheral backend Globals where declareReference _ t id _ global = let m = references global in global { references = Map.insert id t m} @@ -66,7 +66,7 @@ main = assign ?ref 5 @ -} -global :: forall a backend . SSMType a => Compile backend (Ref a) +global :: forall a backend . (Backend backend, SSMType a) => Compile backend (Ref a) global = do n <- fresh let id = Ident ("global" <> show n) Nothing diff --git a/test/arbitrary/Spec.hs b/test/arbitrary/Spec.hs index 58480577..d2f3d964 100644 --- a/test/arbitrary/Spec.hs +++ b/test/arbitrary/Spec.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE TypeApplications #-} import SSM.Core.Program +import SSM.Core.Backend import qualified Test.QuickCheck as QC import qualified Test.QuickCheck.Monadic as QC import qualified Test.SSM.Prop as T @@ -17,6 +19,7 @@ import Test.Hspec.QuickCheck ( modifyMaxSuccess -- -- > stack test --test-arguments='-a 420' -- + main :: IO () main = hspec $ do describe "Random program" $ do @@ -30,4 +33,4 @@ main = hspec $ do -- $ T.propValgrind T.RandomTest prop "compiles and runs according to interpreter" - (T.propCorrect T.RandomTest :: Program backend -> QC.Property) + (T.propCorrect T.RandomTest :: Program C -> QC.Property) -- FIXME diff --git a/test/lib/Test/SSM/Prop.hs b/test/lib/Test/SSM/Prop.hs index 4e904600..e2749f9a 100644 --- a/test/lib/Test/SSM/Prop.hs +++ b/test/lib/Test/SSM/Prop.hs @@ -17,6 +17,7 @@ import SSM.Core ( Program , C , Interpret , PrettyPrint + , Backend(..) ) import SSM.Compile import SSM.Pretty @@ -48,12 +49,12 @@ queueSizes :: [(Int, Int)] queueSizes = [(32, 32), (256, 256), (2048, 2048)] -- | Tests that generated SSM programs compile successfully. -propCompiles :: TestName -> (forall backend . Program backend) -> QC.Property +propCompiles :: TestName -> (forall backend . Backend backend => Program backend) -> QC.Property propCompiles tn program = QC.monadicIO $ mapM_ (propCompilesWithSize tn program) queueSizes -- | Tests that generated SSM programs compile successfully, given some size. -propCompilesWithSize :: TestName -> (forall backend . Program backend) -> (Int, Int) -> QC.PropertyM IO () +propCompilesWithSize :: TestName -> (forall backend . Backend backend => Program backend) -> (Int, Int) -> QC.PropertyM IO () propCompilesWithSize tn program (aQSize, eQSize) = do slug <- QC.run $ getSlug tn reportSlug slug @@ -63,12 +64,12 @@ propCompilesWithSize tn program (aQSize, eQSize) = do return () -- | Tests an SSM program by evaluating it under valgrind. -propValgrind :: TestName -> (forall backend . Program backend) -> QC.Property +propValgrind :: TestName -> (forall backend . Backend backend => Program backend) -> QC.Property propValgrind tn program = QC.monadicIO $ mapM_ (propValgrindWithSize tn program) queueSizes -- | Tests an SSM program by evaluating it under valgrind, given some size -propValgrindWithSize :: TestName -> (forall backend . Program backend) -> (Int, Int) -> QC.PropertyM IO () +propValgrindWithSize :: TestName -> (forall backend . Backend backend => Program backend) -> (Int, Int) -> QC.PropertyM IO () propValgrindWithSize tn program (aQSize, eQSize) = do slug <- QC.run $ getSlug tn reportSlug slug @@ -80,7 +81,7 @@ propValgrindWithSize tn program (aQSize, eQSize) = do -- | Tests an SSM program by evaluating both the interpreter and running the -- compiled C code and comparing the output. -propCorrect :: TestName -> Program backend -> QC.Property +propCorrect :: Backend backend => TestName -> Program backend -> QC.Property propCorrect tn program = QC.monadicIO $ mapM_ (propCorrectWithSize tn $ unsafeCoerce program) queueSizes @@ -105,11 +106,11 @@ propCorrectWithSize tn program (aQSize, eQSize) = do -- without memory errors, and behaves the same as the interpreter. -- -- Used to build passing integration tests. -correctSpec :: String -> (forall backend . Program backend) -> H.Spec +correctSpec :: String -> (forall backend . Backend backend => Program backend) -> H.Spec correctSpec name p = do once $ H.prop "compiles" $ propCompiles tn p once $ H.prop "no memory errors" $ propValgrind tn p - once $ H.prop "matches interpreter" $ propCorrect tn p + once $ H.prop "matches interpreter" $ propCorrect tn (p @C) -- FIXME where once = H.modifyMaxSuccess (const 1) tn = NamedTest name @@ -120,23 +121,23 @@ correctSpec name p = do -- Used to note discrepancies with the interpreter in the regression test suite. -- Note that the description is still "matches interpreter" so that we can use -- the same test name match clause (i.e., with HSpec's --match argument). -semanticIncorrectSpec :: String -> (forall backend . Program backend) -> H.Spec +semanticIncorrectSpec :: String -> (forall backend . Backend backend => Program backend) -> H.Spec semanticIncorrectSpec name p = do once $ H.prop "compiles" $ propCompiles tn p once $ H.prop "no memory errors" $ propValgrind tn p - once $ H.prop "matches interpreter" $ QC.expectFailure $ propCorrect tn p + once $ H.prop "matches interpreter" $ QC.expectFailure $ propCorrect tn (p @C) -- FIXME where once = H.modifyMaxSuccess (const 1) tn = NamedTest name -propSyntacticEquality :: String -> (forall backend . Program backend) -> (forall backend . Program backend) -> H.Spec +propSyntacticEquality :: String -> (forall backend . Backend backend => Program backend) -> (forall backend . Backend backend => Program backend) -> H.Spec propSyntacticEquality name p1 p2 = do H.prop "produces correct syntax" $ QC.monadicIO $ do QC.monitor $ QC.whenFail $ do putStrLn "Program produce illegal syntax" putStrLn "program 1:" - putStrLn $ show p1 + putStrLn $ show $ p1 @PrettyPrint putStrLn "" putStrLn "program 2:" - putStrLn $ show p2 - return $ p1 == p2 + putStrLn $ show $ p2 @PrettyPrint + return $ p1 @PrettyPrint == p2 diff --git a/test/lib/Test/SSM/QuickCheck/Generator.hs b/test/lib/Test/SSM/QuickCheck/Generator.hs index 171ca01a..3247d8b2 100644 --- a/test/lib/Test/SSM/QuickCheck/Generator.hs +++ b/test/lib/Test/SSM/QuickCheck/Generator.hs @@ -15,6 +15,7 @@ import SSM.Core.Reference import SSM.Core.Program import SSM.Core.Type import SSM.Core.Peripheral +import SSM.Core.Backend import SSM.Frontend.Peripheral.Identity @@ -48,7 +49,7 @@ genListOfLength :: Gen a -> Int -> Gen [a] genListOfLength ga 0 = return [] genListOfLength ga n = (:) <$> ga <*> genListOfLength ga (n-1) -instance Arbitrary (Program backend) where +instance Backend backend => Arbitrary (Program backend) where shrink = shrinkProgram arbitrary = do diff --git a/test/regression-low/Regression/GlobalEventSpec.hs b/test/regression-low/Regression/GlobalEventSpec.hs index 55b53168..7a94565c 100644 --- a/test/regression-low/Regression/GlobalEventSpec.hs +++ b/test/regression-low/Regression/GlobalEventSpec.hs @@ -18,7 +18,7 @@ import qualified Test.SSM.Prop as T spec :: H.Spec spec = T.correctSpec "GlobalEventSpec" p -p :: Program backend +p :: Backend backend => Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] , funs = fromList diff --git a/test/regression-syntax/Regression/GlobalEventSpec.hs b/test/regression-syntax/Regression/GlobalEventSpec.hs index ebb987c4..9c7a1acc 100644 --- a/test/regression-syntax/Regression/GlobalEventSpec.hs +++ b/test/regression-syntax/Regression/GlobalEventSpec.hs @@ -15,7 +15,7 @@ import qualified Test.Hspec.QuickCheck as H import qualified Test.SSM.Prop as T import Data.Word -program :: Compile backend () +program :: Backend backend => Compile backend () program = do glob0 <- global @Word8 let ?glob0 = glob0 @@ -24,7 +24,7 @@ program = do fun0 :: (?glob0 :: Ref Word8) => SSM () fun0 = routine $ return () -p :: Program backend +p :: Backend backend => Program backend p = Program { initialQueueContent = [SSMProcedure (Ident "fun0" Nothing) []] , funs = fromList From 40947bd5476e936338e2bcf4a884b3db5e53141c Mon Sep 17 00:00:00 2001 From: Robert Krook Date: Mon, 3 Jan 2022 15:13:52 +0100 Subject: [PATCH 15/16] restructured the peripheral codes so that the instances are placed in the correct subdirectories --- .../SSM => scratch/cc2022examples}/FreqGen.hs | 0 .../cc2022examples}/Freqmime.hs | 0 .../cc2022examples}/FrequencyMime.hs | 0 ssm.cabal | 9 +- ssm/SSM/Backend/C/Peripherals.hs | 87 +++++++++ ssm/SSM/Compile.hs | 1 + ssm/SSM/Core/Peripheral/BasicBLE.hs | 57 ++++++ ssm/SSM/Core/Peripheral/GPIO.hs | 72 ++++++++ ssm/SSM/Core/Peripheral/Identity.hs | 42 +++++ ssm/SSM/Frontend/Peripheral/BasicBLE.hs | 149 +-------------- ssm/SSM/Frontend/Peripheral/GPIO.hs | 171 ++---------------- ssm/SSM/Frontend/Peripheral/Identity.hs | 26 +-- ssm/SSM/Interpret.hs | 1 + ssm/SSM/Interpret/Peripherals.hs | 34 ++++ ssm/SSM/Pretty.hs | 1 + ssm/SSM/Pretty/Peripherals.hs | 115 ++++++++++++ ssm/SSM/Test.hs | 1 + 17 files changed, 433 insertions(+), 333 deletions(-) rename {ssm/SSM => scratch/cc2022examples}/FreqGen.hs (100%) rename {ssm/SSM => scratch/cc2022examples}/Freqmime.hs (100%) rename {ssm/SSM => scratch/cc2022examples}/FrequencyMime.hs (100%) create mode 100644 ssm/SSM/Backend/C/Peripherals.hs create mode 100644 ssm/SSM/Core/Peripheral/BasicBLE.hs create mode 100644 ssm/SSM/Core/Peripheral/GPIO.hs create mode 100644 ssm/SSM/Core/Peripheral/Identity.hs create mode 100644 ssm/SSM/Interpret/Peripherals.hs create mode 100644 ssm/SSM/Pretty/Peripherals.hs diff --git a/ssm/SSM/FreqGen.hs b/scratch/cc2022examples/FreqGen.hs similarity index 100% rename from ssm/SSM/FreqGen.hs rename to scratch/cc2022examples/FreqGen.hs diff --git a/ssm/SSM/Freqmime.hs b/scratch/cc2022examples/Freqmime.hs similarity index 100% rename from ssm/SSM/Freqmime.hs rename to scratch/cc2022examples/Freqmime.hs diff --git a/ssm/SSM/FrequencyMime.hs b/scratch/cc2022examples/FrequencyMime.hs similarity index 100% rename from ssm/SSM/FrequencyMime.hs rename to scratch/cc2022examples/FrequencyMime.hs diff --git a/ssm.cabal b/ssm.cabal index 53fe22fc..c2bd5e29 100644 --- a/ssm.cabal +++ b/ssm.cabal @@ -28,19 +28,20 @@ library SSM.Backend.C.CodeGen SSM.Backend.C.Compile SSM.Backend.C.Identifiers + SSM.Backend.C.Peripherals SSM.Backend.C.Types SSM.Compile SSM.Core SSM.Core.Backend SSM.Core.Ident SSM.Core.Peripheral + SSM.Core.Peripheral.BasicBLE + SSM.Core.Peripheral.GPIO + SSM.Core.Peripheral.Identity SSM.Core.Program SSM.Core.Reference SSM.Core.Syntax SSM.Core.Type - SSM.FreqGen - SSM.Freqmime - SSM.FrequencyMime SSM.Frontend.Box SSM.Frontend.Compile SSM.Frontend.Exp @@ -54,10 +55,12 @@ library SSM.Interpret SSM.Interpret.Internal SSM.Interpret.Interpreter + SSM.Interpret.Peripherals SSM.Interpret.Types SSM.Language SSM.Plugin SSM.Pretty + SSM.Pretty.Peripherals SSM.Pretty.Syntax SSM.Test SSM.Trace.Trace diff --git a/ssm/SSM/Backend/C/Peripherals.hs b/ssm/SSM/Backend/C/Peripherals.hs new file mode 100644 index 00000000..594e8d7b --- /dev/null +++ b/ssm/SSM/Backend/C/Peripherals.hs @@ -0,0 +1,87 @@ +{- | This module implements the various backend specific typeclasses that are used to +compile peripherals. -} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +module SSM.Backend.C.Peripherals where + +import SSM.Core + +import SSM.Core.Peripheral.GPIO +import SSM.Core.Peripheral.BasicBLE + +import SSM.Backend.C.Types +import SSM.Backend.C.Identifiers + +import qualified Data.Map as Map + +import Language.C.Quote.GCC ( cedecl, cexp, citem, citems ) +import qualified Language.C.Syntax as C + +instance IsPeripheral C GPIOOutput where + declareReference = declareReferenceGPIOutput + declaredReferences = declaredReferencesGPIOutput + globalDeclarations p gpio = [] + staticInitialization p gpio = [] + +instance GPIOHandler C where + make_handler _ r i = + let sched k cs = let (prio, dep) = pdep k cs priority_at_root depth_at_root + in [[citem| $id:initialize_static_output_device( + $id:top_parent, + $exp:prio, + $exp:dep, + &$id:(refName r).sv, + $uint:i);|]] + in Handler sched + +instance IsPeripheral C GPIOInput where + declareReference = declareReferenceGPInputO + + declaredReferences = declaredReferencesGPInputO + + globalDeclarations p gpio = [] + + staticInitialization p gpio = flip map (Map.toList (input_ gpio)) $ + \(i,(id,t)) -> + let + bt = dereference t + ref = makeStaticRef id t + bind = [cexp| $id:initialize_static_input_device( + (typename ssm_sv_t *) &$id:(refName ref).sv, + $uint:i) |] + in [citem| $exp:bind; |] + +-- | @BasicBLE@ can be compiled to C +instance IsPeripheral C BasicBLE where + declareReference = declareReferenceBasicBLE + declaredReferences = declaredReferencesBasicBLE + globalDeclarations p bble = [] + + staticInitialization p bble = + let enable = [cexp| $id:enable_ble_stack() |] + scanref = uncurry makeStaticRef (scan_ bble) + scaninit = [cexp| $id:initialize_static_input_ble_scan_device(&$id:(refName scanref).sv) |] + in [citems| $exp:enable; $exp:scaninit; |] + +-- | The handlers can be compiled to C +instance BLEHandlers C where + broadcastHandler _ bble = Handler + (\k cs -> + let (prio,dep) = pdep k cs priority_at_root depth_at_root + proto = initialize_static_output_ble_broadcast_device + refname = identName $ fst $ broadcast_ bble + in [[citem| $id:proto(&$id:(refname).sv); |]]) + + broadcastControlHandler _ bble = Handler + (\k cs -> + let (prio,dep) = pdep k cs priority_at_root depth_at_root + proto = initialize_static_output_ble_broadcast_control_device + refname = identName $ fst $ broadcastControl_ bble + in [[citem| $id:proto(&$id:(refname).sv); |]]) + + scanControlHandler _ bble = Handler + (\k cs -> + let (prio,dep) = pdep k cs priority_at_root depth_at_root + proto = initialize_static_output_ble_scan_control_device + refname = identName $ fst $ scanControl_ bble + in [[citem| $id:proto(&$id:(refname).sv); |]]) diff --git a/ssm/SSM/Compile.hs b/ssm/SSM/Compile.hs index d34fe3f6..6fb616f5 100644 --- a/ssm/SSM/Compile.hs +++ b/ssm/SSM/Compile.hs @@ -18,6 +18,7 @@ import System.Exit ( ExitCode(..) ) import SSM.Backend.C.Compile +import SSM.Backend.C.Peripherals -- import this for the instances import SSM.Core.Program import SSM.Core.Backend import SSM.Frontend.Compile diff --git a/ssm/SSM/Core/Peripheral/BasicBLE.hs b/ssm/SSM/Core/Peripheral/BasicBLE.hs new file mode 100644 index 00000000..68a1c77b --- /dev/null +++ b/ssm/SSM/Core/Peripheral/BasicBLE.hs @@ -0,0 +1,57 @@ +{- | This module implements core support for describing the BasicBLE peripheral, +Basically BLE. It supports very limited broadcasting and scanning (of 64 bits). -} +{-# LANGUAGE TypeApplications #-} +module SSM.Core.Peripheral.BasicBLE + ( BasicBLE + , broadcast_ + , broadcastControl_ + , scan_ + , scanControl_ + , initBasicBLE + , declareReferenceBasicBLE + , declaredReferencesBasicBLE + , BLEHandlers(..) + ) where + +import SSM.Core.Type +import SSM.Core.Ident +import SSM.Core.Reference +import SSM.Core.Program + +import Data.Word +import Data.Proxy + +{- | Internal representation of BasicBLE. It is just a collection of references to +control different parts of the BLE API. -} +data BasicBLE = BasicBLE + { broadcast_ :: (Ident, Type) -- ^ This ref controls broadcast payload + , broadcastControl_ :: (Ident, Type) -- ^ This ref controls broadcast status (on/off) + , scan_ :: (Ident, Type) -- ^ This ref controls scanned messages + , scanControl_ :: (Ident, Type) -- ^ This ref controls scan status (on/off) + } + deriving (Show, Eq) + +-- | Create @BasicBLE@ default value +initBasicBLE :: BasicBLE +initBasicBLE = BasicBLE + { broadcast_ = (makeIdent "broadcast", mkReference $ typeOf $ Proxy @Word64) + , broadcastControl_ = (makeIdent "broadcastControl", mkReference $ typeOf $ Proxy @Bool) + , scan_ = (makeIdent "scan", mkReference $ typeOf $ Proxy @Word64) + , scanControl_ = (makeIdent "scanControl", mkReference $ typeOf $ Proxy @Bool) + } + +-- | Populate the BLE object with a reference +declareReferenceBasicBLE :: proxy backend -> Type -> Ident -> Word8 -> BasicBLE -> BasicBLE +declareReferenceBasicBLE _ _ _ _ _ = error "error --- declareReference BasicBLE called" + +-- | Retrieve the declared references from the BLE object +declaredReferencesBasicBLE :: proxy backend -> BasicBLE -> [Reference] +declaredReferencesBasicBLE _ bble = + map (\f -> uncurry makeStaticRef $ f bble) + [broadcast_, broadcastControl_, scan_, scanControl_] + +-- | This class abstracts away the action of creating handlers for a specific backend +class BLEHandlers backend where + broadcastHandler :: proxy backend -> BasicBLE -> Handler backend + broadcastControlHandler :: proxy backend -> BasicBLE -> Handler backend + scanControlHandler :: proxy backend -> BasicBLE -> Handler backend diff --git a/ssm/SSM/Core/Peripheral/GPIO.hs b/ssm/SSM/Core/Peripheral/GPIO.hs new file mode 100644 index 00000000..06db9051 --- /dev/null +++ b/ssm/SSM/Core/Peripheral/GPIO.hs @@ -0,0 +1,72 @@ +{- | This module implements the core support for working with GPIO peripherals. +It exposes two types @GPIOOutput@ and @GPIOInput@ that represent the GPIO pins that +have been requested by a program.-} +module SSM.Core.Peripheral.GPIO + ( -- * Output + GPIOOutput + , output_ + , emptyGPIOutput + , declareReferenceGPIOutput + , declaredReferencesGPIOutput + , GPIOHandler(..) + -- * Input + , GPIOInput + , input_ + , emptyGPInputO + , declareReferenceGPInputO + , declaredReferencesGPInputO + ) where + +import SSM.Core.Type +import SSM.Core.Ident +import SSM.Core.Reference +import SSM.Core.Program + +import qualified Data.Map as Map + +import Data.Word + +-- Output + +{- | The GPIOOutput datatype represents the GPIO output pins we have requested from the +environment -} +data GPIOOutput = GPIOOutput { output_ :: Map.Map Word8 (Ident, Type)} + deriving (Show, Eq) + +-- | Create an empty GPIOOutput peripheral +emptyGPIOutput :: GPIOOutput +emptyGPIOutput = GPIOOutput { output_ = Map.empty } + +{- | Add a reference to the GPIOOutput peripheral. The added reference will be used to +control an output pin, identified by the 4th argument. -} +declareReferenceGPIOutput :: proxy backend -> Type -> Ident -> Word8 -> GPIOOutput -> GPIOOutput +declareReferenceGPIOutput _ t id i gpio = gpio { output_ = Map.insert i (id,t) (output_ gpio) } + +-- | Retrieve the declared output references from the GPIOOutput peripheral +declaredReferencesGPIOutput :: proxy backend -> GPIOOutput -> [Reference] +declaredReferencesGPIOutput _ gpio = map (uncurry makeStaticRef) $ Map.elems $ output_ gpio + +{- | The @GPIOHandler@ typeclass is parameterised over a backend, and returns a handler +that when scheduled, actually performs the output action. -} +class GPIOHandler backend where + make_handler :: proxy backend -> Reference -> Word8 -> Handler backend + +-- Input + +{- | The GPIOInput datatype represents the GPIO input pins we have requested from the +environment -} +data GPIOInput = GPIOInput { input_ :: Map.Map Word8 (Ident, Type) } + deriving (Show, Eq) + +-- | Create an empty GPIOInput peripheral +emptyGPInputO :: GPIOInput +emptyGPInputO = GPIOInput { input_ = Map.empty } + +{- | Add a reference to the GPIOInput peripheral. The added reference will be used to +control an input pin, identified by the 4th argument. -} +declareReferenceGPInputO :: proxy backend -> Type -> Ident -> Word8 -> GPIOInput -> GPIOInput +declareReferenceGPInputO _ t id i gpio = gpio { input_ = Map.insert i (id,t) (input_ gpio) } + +-- | Retrieve the declared output references from the GPIOOutput peripheral +declaredReferencesGPInputO :: proxy backend -> GPIOInput -> [Reference] +declaredReferencesGPInputO _ gpio = map (uncurry makeStaticRef) $ Map.elems $ input_ gpio diff --git a/ssm/SSM/Core/Peripheral/Identity.hs b/ssm/SSM/Core/Peripheral/Identity.hs new file mode 100644 index 00000000..04ce15dc --- /dev/null +++ b/ssm/SSM/Core/Peripheral/Identity.hs @@ -0,0 +1,42 @@ +{- | This module implements the core support for the identity peripheral, which is used +only to create references that can be used globally, outside the context of a process. -} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module SSM.Core.Peripheral.Identity + ( Globals + , references + , emptyGlobals + ) where + +import SSM.Core.Type +import SSM.Core.Ident +import SSM.Core.Reference +import SSM.Core.Backend +import SSM.Core.Peripheral + +import qualified Data.Map as Map + +-- | The @Globals@ datatype associates reference names with reference types +data Globals = Globals + { + references :: Map.Map Ident Type + } + deriving (Show, Eq) + +-- | Empty @Globals@, containing no references +emptyGlobals :: Globals +emptyGlobals = Globals Map.empty + +{- | A @Globals@ can be used regardless of the backend, since there is no associated +IO with a global reference. -} +instance Backend backend => IsPeripheral backend Globals where + declareReference _ t id _ global = + let m = references global + in global { references = Map.insert id t m} + + declaredReferences _ globals = + map (uncurry makeStaticRef) $ Map.toList $ references globals + + globalDeclarations p globals = [] + + staticInitialization p globals = [] diff --git a/ssm/SSM/Frontend/Peripheral/BasicBLE.hs b/ssm/SSM/Frontend/Peripheral/BasicBLE.hs index 53be60f7..76837316 100644 --- a/ssm/SSM/Frontend/Peripheral/BasicBLE.hs +++ b/ssm/SSM/Frontend/Peripheral/BasicBLE.hs @@ -28,9 +28,7 @@ module SSM.Frontend.Peripheral.BasicBLE where import SSM.Core hiding (BasicBLE(..), peripherals, enableBLE) - -import SSM.Backend.C.Identifiers -import SSM.Backend.C.Types +import SSM.Core.Peripheral.BasicBLE import SSM.Frontend.Compile import SSM.Frontend.Ref @@ -42,151 +40,6 @@ import qualified Data.Map as Map import Control.Monad.State -import Language.C.Quote.GCC ( cedecl, cexp, citem, citems ) -import qualified Language.C.Syntax as C - -{- | Internal representation of BasicBLE. It is just a collection of references to -control different parts of the BLE API. -} -data BasicBLE = BasicBLE - { broadcast_ :: (Ident, Type) -- ^ This ref controls broadcast payload - , broadcastControl_ :: (Ident, Type) -- ^ This ref controls broadcast status (on/off) - , scan_ :: (Ident, Type) -- ^ This ref controls scanned messages - , scanControl_ :: (Ident, Type) -- ^ This ref controls scan status (on/off) - } - deriving (Show, Eq) - --- | Create @BasicBLE@ default value -initBasicBLE :: BasicBLE -initBasicBLE = BasicBLE - { broadcast_ = (makeIdent "broadcast", mkReference $ typeOf $ Proxy @Word64) - , broadcastControl_ = (makeIdent "broadcastControl", mkReference $ typeOf $ Proxy @Bool) - , scan_ = (makeIdent "scan", mkReference $ typeOf $ Proxy @Word64) - , scanControl_ = (makeIdent "scanControl", mkReference $ typeOf $ Proxy @Bool) - } - -declareReferenceBasicBLE :: proxy backend -> Type -> Ident -> Word8 -> BasicBLE -> BasicBLE -declareReferenceBasicBLE _ _ _ _ _ = error "error --- declareReference BasicBLE called" - -declaredReferencesBasicBLE :: proxy backend -> BasicBLE -> [Reference] -declaredReferencesBasicBLE _ bble = - map (\f -> uncurry makeStaticRef $ f bble) - [broadcast_, broadcastControl_, scan_, scanControl_] - --- | @BasicBLE@ can be compiled to C -instance IsPeripheral C BasicBLE where - declareReference = declareReferenceBasicBLE - declaredReferences = declaredReferencesBasicBLE - globalDeclarations p bble = [] - - staticInitialization p bble = - let enable = [cexp| $id:enable_ble_stack() |] - scanref = uncurry makeStaticRef (scan_ bble) - scaninit = [cexp| $id:initialize_static_input_ble_scan_device(&$id:(refName scanref).sv) |] - in [citems| $exp:enable; $exp:scaninit; |] - -instance IsPeripheral PrettyPrint BasicBLE where - declareReference = declareReferenceBasicBLE - declaredReferences = declaredReferencesBasicBLE - - globalDeclarations p bble = map init [ - unlines [ "-- BBLE peripheral broadcast handler:" - , "-- initialize_static_output_ble_broadcast(ref) binds the ref to this procedure" - , "broadcast_handler() {" - , " while(true) {" - , concat [" wait ", identName $ fst $ broadcast_ bble] - , " -- reflect value of broadcast ref in BLE broadcast payload" - , " }" - , "}" - ] - , unlines [ "-- BBLE peripheral broadcast control handler:" - , "-- initialize_static_output_ble_broadcast_control(ref) binds the ref to this procedure" - , "broadcast_control_handler() {" - , " while(true) {" - , concat [" wait ", identName $ fst $ broadcastControl_ bble] - , " -- toggle broadcasting on or off depending on broadcastControl value" - , " }" - , "}" - ] - , unlines [ "-- BBLE peripheral scan control handler:" - , "-- initialize_static_output_ble_scan_control(ref) binds the ref to this procedure" - , "scan_control_handler() {" - , " while(true) {" - , concat [" wait ", identName $ fst $ scanControl_ bble] - , " -- toggle scanning on or off depending on scanControl value" - , " }" - , "}" - ] - , unlines [ "-- BBLE peripheral broadcast handler:" - , "-- initialize_static_output_ble_scan(ref) binds the ref to this procedure" - , "scan_handler() {" - , " while(true) {" - , " -- wait to successfully scan for a received BLE packet" - , concat [" -- turn the scanned message into an event on the ", identName $ fst $ scan_ bble, " ref"] - , " }" - , "}" - ] - ] - - staticInitialization p bble = [ "enable_ble()" - , concat ["initialize_static_output_ble_scan(", identName $ fst $ scan_ bble, ")"]] - -instance IsPeripheral Interpret BasicBLE where - declareReference = declareReferenceBasicBLE - declaredReferences = declaredReferencesBasicBLE - globalDeclarations p bble = [] - staticInitialization p bble = [] - --- | This class abstracts away the action of creating handlers for a specific backend -class BLEHandlers backend where - broadcastHandler :: proxy backend -> BasicBLE -> Handler backend - broadcastControlHandler :: proxy backend -> BasicBLE -> Handler backend - scanControlHandler :: proxy backend -> BasicBLE -> Handler backend - --- | The handlers can be compiled to C -instance BLEHandlers C where - broadcastHandler _ bble = Handler - (\k cs -> - let (prio,dep) = pdep k cs priority_at_root depth_at_root - proto = initialize_static_output_ble_broadcast_device - refname = identName $ fst $ broadcast_ bble - in [[citem| $id:proto(&$id:(refname).sv); |]]) - - broadcastControlHandler _ bble = Handler - (\k cs -> - let (prio,dep) = pdep k cs priority_at_root depth_at_root - proto = initialize_static_output_ble_broadcast_control_device - refname = identName $ fst $ broadcastControl_ bble - in [[citem| $id:proto(&$id:(refname).sv); |]]) - - scanControlHandler _ bble = Handler - (\k cs -> - let (prio,dep) = pdep k cs priority_at_root depth_at_root - proto = initialize_static_output_ble_scan_control_device - refname = identName $ fst $ scanControl_ bble - in [[citem| $id:proto(&$id:(refname).sv); |]]) - -instance BLEHandlers PrettyPrint where - broadcastHandler _ bble = Handler $ \_ _ -> - [concat [ "initialize_static_output_ble_broadcast(" - , identName $ fst $ broadcast_ bble, ")" - ]] - - broadcastControlHandler _ bble = Handler $ \_ _ -> - [concat [ "initialize_static_output_ble_broadcast_control(" - , identName $ fst $ broadcastControl_ bble, ")" - ]] - - scanControlHandler _ bble = Handler $ \_ _ -> - [concat [ "initialize_static_output_ble_scan_control(" - , identName $ fst $ scan_ bble, ")" - ]] - -instance BLEHandlers Interpret where - broadcastHandler _ _ = Handler $ \_ _ -> [] - broadcastControlHandler _ _ = Handler $ \_ _ -> [] - scanControlHandler _ _ = Handler $ \_ _ -> [] ----------- Frontend API of BBLE ---------- - -- | This object can be used to access the BLE driver data BBLE = BBLE { broadcast :: Ref Word64 diff --git a/ssm/SSM/Frontend/Peripheral/GPIO.hs b/ssm/SSM/Frontend/Peripheral/GPIO.hs index 7d0052b7..7f516cc0 100644 --- a/ssm/SSM/Frontend/Peripheral/GPIO.hs +++ b/ssm/SSM/Frontend/Peripheral/GPIO.hs @@ -22,25 +22,11 @@ module SSM.Frontend.Peripheral.GPIO ) where -import SSM.Core ( C - , Ident - , dereference - , Type - , makeStaticRef - , refName - , refType - , IsPeripheral(..) +import SSM.Core ( IsPeripheral(..) , Peripheral(..) , makeIdent - , Handler(..) - ) -import SSM.Core.Backend - -import SSM.Backend.C.Identifiers -import SSM.Backend.C.Types ( svt_ - , initialize_ - , assign_ ) +import SSM.Core.Peripheral.GPIO import SSM.Frontend.Ref ( Ref(..) ) import SSM.Frontend.Compile @@ -53,59 +39,8 @@ import qualified Data.Map as Map import Control.Monad.State ( MonadState(put, get) ) -import Language.C.Quote.GCC ( cedecl, cexp, citem, citems ) -import qualified Language.C.Syntax as C - ---------- GPIO Output ---------- --- | The GPIO datatype represents the GPIO pins we have requested from the environment -data GPIOutput = GPIOutput { output_ :: Map.Map Word8 (Ident, Type)} - deriving (Show, Eq) - --- | Create an empty GPIO peripheral -emptyGPIOutput :: GPIOutput -emptyGPIOutput = GPIOutput { output_ = Map.empty } - -declareReferenceGPIOutput :: proxy backend -> Type -> Ident -> Word8 -> GPIOutput -> GPIOutput -declareReferenceGPIOutput _ t id i gpio = gpio { output_ = Map.insert i (id,t) (output_ gpio) } - -declaredReferencesGPIOutput :: proxy backend -> GPIOutput -> [Reference] -declaredReferencesGPIOutput _ gpio = map (uncurry makeStaticRef) $ Map.elems $ output_ gpio - -instance IsPeripheral C GPIOutput where - declareReference = declareReferenceGPIOutput - - declaredReferences = declaredReferencesGPIOutput - - globalDeclarations p gpio = [] - - staticInitialization p gpio = [] - -instance IsPeripheral PrettyPrint GPIOutput where - declareReference = declareReferenceGPIOutput - - declaredReferences = declaredReferencesGPIOutput - - globalDeclarations p gpio = [ - unlines [ "-- GPIO peripheral output handler:" - , "-- initialize_static_output_device(ref,id) binds the ref to this procedure" - , "output_handler(ref,id) {" - , " while(true) {" - , " wait ref" - , " -- actualize value of ref to output pin id" - , " }" - , "}" - ] - ] - - staticInitialization p gpio = [] - -instance IsPeripheral Interpret GPIOutput where - declareReference = declareReferenceGPIOutput - declaredReferences = declaredReferencesGPIOutput - globalDeclarations p gpio = [] - staticInitialization p gpio = [] - gpioutputkey :: String gpioutputkey = "gpioutput" @@ -121,8 +56,8 @@ Parameters: Returns: The @Ref LED@ that represents the newly created reference. -} insertGPIOutput :: forall backend - . IsPeripheral backend GPIOutput - => Word8 -> Ident -> Compile backend (Ref GPIO) + . IsPeripheral backend GPIOOutput + => Word8 -> Ident -> Compile backend Reference insertGPIOutput i id = do st <- get @@ -136,34 +71,12 @@ insertGPIOutput i id = do put $ st { peripherals = Map.insert gpioutputkey m' (peripherals st)} -- create the reference and return it - let ref = makeStaticRef id typ - return $ Ptr ref + return $ makeStaticRef id typ where -- | GPIO pins have a binary state, so treating them like @Bool@s seems reasonable typ :: Type typ = mkReference $ typeOf $ Proxy @Bool -class GPIOHandler backend where - make_handler :: proxy backend -> Ref GPIO -> Word8 -> OutputHandler backend - -instance GPIOHandler C where - make_handler _ (Ptr r) i = - let sched k cs = let (prio, dep) = pdep k cs priority_at_root depth_at_root - in [[citem| $id:initialize_static_output_device( - $id:top_parent, - $exp:prio, - $exp:dep, - &$id:(refName r).sv, - $uint:i);|]] - in Handler sched - -instance GPIOHandler PrettyPrint where - make_handler _ (Ptr r) i = Handler $ \_ _ -> - [concat ["initialize_static_output_device(", refName r, ", ", show i, ")"]] - -instance GPIOHandler Interpret where - make_handler _ _ _ = Handler $ \_ _ -> [] - {- | Ask the GPIO peripheral for an output pin that can take the value high or low. The pin is identified by the @Word8@ parameter. @@ -174,7 +87,7 @@ The output is -} output :: forall backend . - (IsPeripheral backend GPIOutput, GPIOHandler backend) + (IsPeripheral backend GPIOOutput, GPIOHandler backend) => Word8 -> Compile backend (Ref GPIO, OutputHandler backend) output i = do n <- fresh @@ -184,65 +97,10 @@ output i = do let handler = make_handler (Proxy @backend) ref i - return (ref, handler) + return (Ptr ref, handler) ----------- GPIO Input ---------- -data GPInputO = GPInputO { input_ :: Map.Map Word8 (Ident, Type) } - deriving (Show, Eq) - -emptyGPInputO :: GPInputO -emptyGPInputO = GPInputO { input_ = Map.empty } - -declareReferenceGPInputO :: proxy backend -> Type -> Ident -> Word8 -> GPInputO -> GPInputO -declareReferenceGPInputO _ t id i gpio = gpio { input_ = Map.insert i (id,t) (input_ gpio) } - -declaredReferencesGPInputO :: proxy backend -> GPInputO -> [Reference] -declaredReferencesGPInputO _ gpio = map (uncurry makeStaticRef) $ Map.elems $ input_ gpio - -instance IsPeripheral C GPInputO where - declareReference = declareReferenceGPInputO - - declaredReferences = declaredReferencesGPInputO - - globalDeclarations p gpio = [] - - staticInitialization p gpio = flip map (Map.toList (input_ gpio)) $ - \(i,(id,t)) -> - let - bt = dereference t - ref = makeStaticRef id t - bind = [cexp| $id:initialize_static_input_device( - (typename ssm_sv_t *) &$id:(refName ref).sv, - $uint:i) |] - in [citem| $exp:bind; |] - -instance IsPeripheral PrettyPrint GPInputO where - declareReference = declareReferenceGPInputO - - declaredReferences = declaredReferencesGPInputO - - globalDeclarations p gpio = map init [ - unlines [ "-- GPIO peripheral input handler:" - , "-- initialize_static_input_device(ref,id) binds the ref to this procedure" - , "input_handler(ref,id) {" - , " while(true) {" - , " -- wait for input on pin id" - , " -- turn input on pin id to a write to ref" - , " }" - , "}" - ] - ] - - staticInitialization _ gpio = flip map (Map.toList (input_ gpio)) $ - \(i,(id,t)) -> concat ["initialize_static_input_device(", identName id, ", ", show i, ")"] - -instance IsPeripheral Interpret GPInputO where - declareReference = declareReferenceGPInputO - declaredReferences = declaredReferencesGPInputO - globalDeclarations p gpio = [] - staticInitialization p gpio = [] - -- | GPIO input pins have a binary state type Switch = Bool @@ -250,8 +108,8 @@ gpinputokey :: String gpinputokey = "gpinputo" insertGPInputO :: forall backend - . IsPeripheral backend GPInputO - => Word8 -> Ident -> Compile backend (Ref Switch) + . IsPeripheral backend GPIOInput + => Word8 -> Ident -> Compile backend Reference insertGPInputO i id = do st <- get @@ -265,8 +123,7 @@ insertGPInputO i id = do put $ st { peripherals = Map.insert gpinputokey m' (peripherals st)} -- create the reference and return it - let ref = makeStaticRef id typ - return $ Ptr ref + return $ makeStaticRef id typ where -- | GPIO pins have a binary state, so treating them like @Bool@s seems reasonable typ :: Type @@ -278,7 +135,7 @@ The pin is identified by the @Word8@ parameter. The output is a reference that is written to by the GPIO driver when an input is received -} input :: forall backend . - (IsPeripheral backend GPInputO, GPIOHandler backend) + (IsPeripheral backend GPIOInput, GPIOHandler backend) => Word8 -> Compile backend (Ref Switch) input i = do n <- fresh @@ -286,7 +143,7 @@ input i = do ref <- insertGPInputO i id - return ref + return $ Ptr ref -- | pin state high high :: Exp Bool @@ -298,7 +155,7 @@ low = false {- | A backend that satisfies the @SupportGPIO@ constraint fully supports both input and output GPIO pins. -} -type SupportGPIO backend = ( IsPeripheral backend GPIOutput - , IsPeripheral backend GPInputO +type SupportGPIO backend = ( IsPeripheral backend GPIOOutput + , IsPeripheral backend GPIOInput , GPIOHandler backend ) diff --git a/ssm/SSM/Frontend/Peripheral/Identity.hs b/ssm/SSM/Frontend/Peripheral/Identity.hs index 036b2e77..9bcfd184 100644 --- a/ssm/SSM/Frontend/Peripheral/Identity.hs +++ b/ssm/SSM/Frontend/Peripheral/Identity.hs @@ -14,42 +14,18 @@ module SSM.Frontend.Peripheral.Identity ) where import SSM.Core hiding (peripherals) +import SSM.Core.Peripheral.Identity import SSM.Util.State import SSM.Frontend.Compile import SSM.Frontend.Ref -import SSM.Backend.C.Identifiers -import SSM.Backend.C.Types - import Data.Proxy import qualified Data.Map as Map import Control.Monad.State -import Language.C.Quote.GCC -import qualified Language.C.Syntax as C - -data Globals = Globals { references :: Map.Map Ident Type } - deriving (Show, Eq) - -emptyGlobals :: Globals -emptyGlobals = Globals Map.empty - --- | The identity peripheral works regardless of backend, since no IO is involved -instance Backend backend => IsPeripheral backend Globals where - declareReference _ t id _ global = - let m = references global - in global { references = Map.insert id t m} - - declaredReferences _ globals = - map (uncurry makeStaticRef) $ Map.toList $ references globals - - globalDeclarations p globals = [] - - staticInitialization p globals = [] - {- | Create a global reference. The reference is created in the compile monad and can be shared across the Scoria program with the @ImplicitParams@ extension. diff --git a/ssm/SSM/Interpret.hs b/ssm/SSM/Interpret.hs index 7ce2349a..97c3f55a 100644 --- a/ssm/SSM/Interpret.hs +++ b/ssm/SSM/Interpret.hs @@ -13,6 +13,7 @@ import SSM.Util.Default import qualified SSM.Trace.Trace as T import qualified SSM.Interpret.Interpreter as I +import SSM.Interpret.Peripherals -- make sure the instances are in scope interpret :: I.InterpretConfig -> Compile Interpret () -> T.Trace interpret cf c = I.interpret cf $ toProgram c diff --git a/ssm/SSM/Interpret/Peripherals.hs b/ssm/SSM/Interpret/Peripherals.hs new file mode 100644 index 00000000..2c547080 --- /dev/null +++ b/ssm/SSM/Interpret/Peripherals.hs @@ -0,0 +1,34 @@ +{- | This module gives instances for various typeclasses that are used to interpret +programs that make use of peripherals. -} +{-# LANGUAGE MultiParamTypeClasses #-} +module SSM.Interpret.Peripherals where + +import SSM.Core +import SSM.Core.Peripheral.GPIO +import SSM.Core.Peripheral.BasicBLE + +instance IsPeripheral Interpret GPIOOutput where + declareReference = declareReferenceGPIOutput + declaredReferences = declaredReferencesGPIOutput + globalDeclarations p gpio = [] + staticInitialization p gpio = [] + +instance GPIOHandler Interpret where + make_handler _ _ _ = Handler $ \_ _ -> [] + +instance IsPeripheral Interpret GPIOInput where + declareReference = declareReferenceGPInputO + declaredReferences = declaredReferencesGPInputO + globalDeclarations p gpio = [] + staticInitialization p gpio = [] + +instance IsPeripheral Interpret BasicBLE where + declareReference = declareReferenceBasicBLE + declaredReferences = declaredReferencesBasicBLE + globalDeclarations p bble = [] + staticInitialization p bble = [] + +instance BLEHandlers Interpret where + broadcastHandler _ _ = Handler $ \_ _ -> [] + broadcastControlHandler _ _ = Handler $ \_ _ -> [] + scanControlHandler _ _ = Handler $ \_ _ -> [] diff --git a/ssm/SSM/Pretty.hs b/ssm/SSM/Pretty.hs index 6500665a..174a114a 100644 --- a/ssm/SSM/Pretty.hs +++ b/ssm/SSM/Pretty.hs @@ -73,6 +73,7 @@ module SSM.Pretty --import SSM.Core.Syntax ( SSM ) import SSM.Core.Program import SSM.Pretty.Syntax ( prettyProgram ) +import SSM.Pretty.Peripherals -- make sure the instances are in scope import SSM.Core.Backend import SSM.Frontend.Compile diff --git a/ssm/SSM/Pretty/Peripherals.hs b/ssm/SSM/Pretty/Peripherals.hs new file mode 100644 index 00000000..a4588a29 --- /dev/null +++ b/ssm/SSM/Pretty/Peripherals.hs @@ -0,0 +1,115 @@ +{- | This module gives instances for various typeclasses that are used in order +to pretty-print programs that make use of peripherals. -} +{-# LANGUAGE MultiParamTypeClasses #-} +module SSM.Pretty.Peripherals where + +import SSM.Core +import SSM.Core.Peripheral.GPIO +import SSM.Core.Peripheral.BasicBLE + +import qualified Data.Map as Map + +instance IsPeripheral PrettyPrint GPIOOutput where + declareReference = declareReferenceGPIOutput + + declaredReferences = declaredReferencesGPIOutput + + globalDeclarations p gpio = [ + unlines [ "-- GPIO peripheral output handler:" + , "-- initialize_static_output_device(ref,id) binds the ref to this procedure" + , "output_handler(ref,id) {" + , " while(true) {" + , " wait ref" + , " -- actualize value of ref to output pin id" + , " }" + , "}" + ] + ] + + staticInitialization p gpio = [] + +instance GPIOHandler PrettyPrint where + make_handler _ r i = Handler $ \_ _ -> + [concat ["initialize_static_output_device(", refName r, ", ", show i, ")"]] + +instance IsPeripheral PrettyPrint GPIOInput where + declareReference = declareReferenceGPInputO + + declaredReferences = declaredReferencesGPInputO + + globalDeclarations p gpio = map init [ + unlines [ "-- GPIO peripheral input handler:" + , "-- initialize_static_input_device(ref,id) binds the ref to this procedure" + , "input_handler(ref,id) {" + , " while(true) {" + , " -- wait for input on pin id" + , " -- turn input on pin id to a write to ref" + , " }" + , "}" + ] + ] + + staticInitialization _ gpio = flip map (Map.toList (input_ gpio)) $ + \(i,(id,t)) -> concat ["initialize_static_input_device(", identName id, ", ", show i, ")"] + +instance IsPeripheral PrettyPrint BasicBLE where + declareReference = declareReferenceBasicBLE + declaredReferences = declaredReferencesBasicBLE + + globalDeclarations p bble = map init [ + unlines [ "-- BBLE peripheral broadcast handler:" + , "-- initialize_static_output_ble_broadcast(ref) binds the ref to this procedure" + , "broadcast_handler() {" + , " while(true) {" + , concat [" wait ", identName $ fst $ broadcast_ bble] + , " -- reflect value of broadcast ref in BLE broadcast payload" + , " }" + , "}" + ] + , unlines [ "-- BBLE peripheral broadcast control handler:" + , "-- initialize_static_output_ble_broadcast_control(ref) binds the ref to this procedure" + , "broadcast_control_handler() {" + , " while(true) {" + , concat [" wait ", identName $ fst $ broadcastControl_ bble] + , " -- toggle broadcasting on or off depending on broadcastControl value" + , " }" + , "}" + ] + , unlines [ "-- BBLE peripheral scan control handler:" + , "-- initialize_static_output_ble_scan_control(ref) binds the ref to this procedure" + , "scan_control_handler() {" + , " while(true) {" + , concat [" wait ", identName $ fst $ scanControl_ bble] + , " -- toggle scanning on or off depending on scanControl value" + , " }" + , "}" + ] + , unlines [ "-- BBLE peripheral broadcast handler:" + , "-- initialize_static_output_ble_scan(ref) binds the ref to this procedure" + , "scan_handler() {" + , " while(true) {" + , " -- wait to successfully scan for a received BLE packet" + , concat [" -- turn the scanned message into an event on the ", identName $ fst $ scan_ bble, " ref"] + , " }" + , "}" + ] + ] + + staticInitialization p bble = [ "enable_ble()" + , concat ["initialize_static_output_ble_scan(", identName $ fst $ scan_ bble, ")"]] + +instance BLEHandlers PrettyPrint where + broadcastHandler _ bble = Handler $ \_ _ -> + [concat [ "initialize_static_output_ble_broadcast(" + , identName $ fst $ broadcast_ bble, ")" + ]] + + broadcastControlHandler _ bble = Handler $ \_ _ -> + [concat [ "initialize_static_output_ble_broadcast_control(" + , identName $ fst $ broadcastControl_ bble, ")" + ]] + + scanControlHandler _ bble = Handler $ \_ _ -> + [concat [ "initialize_static_output_ble_scan_control(" + , identName $ fst $ scan_ bble, ")" + ]] diff --git a/ssm/SSM/Test.hs b/ssm/SSM/Test.hs index fae5ab80..848f2987 100644 --- a/ssm/SSM/Test.hs +++ b/ssm/SSM/Test.hs @@ -15,6 +15,7 @@ import SSM.Frontend.Peripheral.BasicBLE import SSM.Core.Backend import SSM.Compile import SSM.Pretty +import SSM.Interpret import Data.Word From 9a39764301b6bfa8dbc8d715864174f05b9e150d Mon Sep 17 00:00:00 2001 From: Robert Krook Date: Mon, 3 Jan 2022 16:00:14 +0100 Subject: [PATCH 16/16] update testing framework to pass all tests --- ssm/SSM/Core/Peripheral/Identity.hs | 3 +-- test/lib/Test/SSM/QuickCheck/Generator.hs | 1 + 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/ssm/SSM/Core/Peripheral/Identity.hs b/ssm/SSM/Core/Peripheral/Identity.hs index 04ce15dc..90345f1d 100644 --- a/ssm/SSM/Core/Peripheral/Identity.hs +++ b/ssm/SSM/Core/Peripheral/Identity.hs @@ -3,8 +3,7 @@ only to create references that can be used globally, outside the context of a pr {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} module SSM.Core.Peripheral.Identity - ( Globals - , references + ( Globals(..) , emptyGlobals ) where diff --git a/test/lib/Test/SSM/QuickCheck/Generator.hs b/test/lib/Test/SSM/QuickCheck/Generator.hs index 3247d8b2..061e6db4 100644 --- a/test/lib/Test/SSM/QuickCheck/Generator.hs +++ b/test/lib/Test/SSM/QuickCheck/Generator.hs @@ -15,6 +15,7 @@ import SSM.Core.Reference import SSM.Core.Program import SSM.Core.Type import SSM.Core.Peripheral +import SSM.Core.Peripheral.Identity import SSM.Core.Backend import SSM.Frontend.Peripheral.Identity