├── .gitignore ├── .gitmodules ├── .travis.yml ├── README.md ├── build.sh ├── cabal.project ├── case-studies ├── OM1 │ ├── .gitignore │ ├── Main.hs │ ├── OM1.hs │ ├── README.md │ ├── Setup.hs │ ├── build.sh │ ├── cabal.project │ └── lima-om1.cabal ├── WBS │ ├── .gitignore │ ├── Main.hs │ ├── Setup.hs │ ├── WBS.hs │ ├── build.sh │ ├── cabal.project │ └── lima-wbs.cabal ├── periodic │ ├── .gitignore │ ├── Main.hs │ ├── Periodic.hs │ ├── README.md │ ├── Setup.hs │ ├── build.sh │ ├── cabal.project │ ├── clean.sh │ ├── lima-periodic.cabal │ └── run └── smp │ ├── .gitignore │ ├── Main.hs │ ├── README.md │ ├── SMP.hs │ ├── Setup.hs │ ├── build.sh │ ├── cabal.project │ ├── clean.sh │ ├── lima-smp.cabal │ └── run ├── cleanup.sh ├── lima-c ├── ChangeLog.md ├── LICENSE ├── Setup.hs ├── cabal.sandbox.config ├── lima-c.cabal └── src │ └── Language │ └── LIMA │ ├── C.hs │ └── C │ ├── Code.hs │ ├── Compile.hs │ ├── Example │ ├── Channel.hs │ ├── ChannelCond.hs │ ├── External.hs │ ├── Gcd.hs │ ├── Periodic.hs │ └── Probes.hs │ ├── Scheduling.hs │ └── Util.hs ├── lima-sally ├── .gitignore ├── .travis.yml ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── build.sh ├── lima-sally.cabal ├── src │ └── Language │ │ ├── Sally.hs │ │ └── Sally │ │ ├── Config.hs │ │ ├── FaultModel.hs │ │ └── Translation.hs └── test │ ├── .gitignore │ └── Spec.hs ├── lima.svg ├── lima ├── LICENSE ├── README.md ├── lima.cabal └── src │ └── Language │ ├── LIMA.hs │ └── LIMA │ ├── Analysis.hs │ ├── Channel.hs │ ├── Channel │ └── Types.hs │ ├── Common.hs │ ├── Common │ ├── Fader.hs │ ├── Threshold.hs │ └── ValidData.hs │ ├── Elaboration.hs │ ├── Expressions.hs │ ├── Graph.hs │ ├── Inspect.hs │ ├── Language.hs │ ├── Types.hs │ └── UeMap.hs └── scripts └── renamer.sh /.gitignore: -------------------------------------------------------------------------------- 1 | tags 2 | dist 3 | dist-newstyle 4 | cabal.project.local 5 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "dependencies/language-sally"] 2 | path = dependencies/language-sally 3 | url = https://github.com/galoisinc/language-sally 4 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This file has been modified from the original generated version -- see 2 | # https://github.com/hvr/multi-ghc-travis 3 | language: c 4 | sudo: false 5 | 6 | matrix: 7 | include: 8 | - env: CABALVER=1.24 GHCVER=7.10.3 9 | compiler: ": #GHC 7.10.3" 10 | addons: {apt: {packages: [cabal-install-1.24,ghc-7.10.3,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}} 11 | - env: CABALVER=1.24 GHCVER=8.0.2 12 | compiler: ": #GHC 8.0.2" 13 | addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}} 14 | 15 | before_install: 16 | - unset CC 17 | - export HAPPYVER=1.19.5 18 | - export ALEXVER=3.1.7 19 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:/opt/happy/$HAPPYVER/bin:/opt/alex/$ALEXVER/bin:$PATH 20 | 21 | install: 22 | - cabal --version 23 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 24 | - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ]; 25 | then 26 | zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz > 27 | $HOME/.cabal/packages/hackage.haskell.org/00-index.tar; 28 | fi 29 | - travis_retry cabal update -v 30 | - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config 31 | 32 | # Here starts the actual work to be performed for the package under test; 33 | # any command which exits with a non-zero exit code causes the build to fail. 34 | script: 35 | - bash build.sh 36 | 37 | # EOF 38 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ![LIMA logo](https://cdn.rawgit.com/GaloisInc/LIMA/4ad3bf21/lima.svg) 2 | 3 | LIMA 4 | ==== 5 | 6 | [![Build Status](https://travis-ci.org/GaloisInc/LIMA.svg?branch=master)](https://travis-ci.org/GaloisInc/LIMA) 7 | 8 | (L)anguage for (I)ntegrated (M)odeling and (A)nalysis 9 | 10 | 11 | Overview 12 | -------- 13 | 14 | LIMA is a domain specific language developed under NASA contract NNL14AA08. It 15 | is designed as a language for generating implementations, formal models, and 16 | architectural models from a common specification. In the area of 17 | fault-tolerant distributed systems, formal models are often produces from a 18 | specification using ad-hoc abstractions. These abstracts tend to cause 19 | implementations, and formals models to diverge. Having a common specification 20 | source from which we automatically generate implementation and formal model 21 | alleviates this. 22 | 23 | 24 | Contents 25 | -------- 26 | 27 | * `lima`: Core LIMA language library 28 | * `lima-c`: C code generator for LIMA 29 | * `lima-sally`: Sally model generator for LIMA 30 | * `case-studies`: Case study systems expressed in LIMA 31 | 32 | The `lima` and `lima-c` packages are direct forks of `Atom`, originally due to 33 | Tom Hawkins and Lee Pike. 34 | 35 | 36 | Quick Start 37 | ----------- 38 | 39 | To generate code and models from the case studies, first make sure you have 40 | installed the Haskell compiler `GHC`, version 7.10 or above and `cabal-install` 41 | version 1.24 or above. Using your system's package manager is the best way to 42 | achieve this. 43 | 44 | Then change to the case study's directory and use `cabal-install` to build 45 | LIMA and the example: 46 | 47 | ``` 48 | $ cd case-studies/OM1 49 | $ cabal new-configure 50 | $ cabal new-build 51 | ``` 52 | 53 | The executable which generates code and models is given on the last line of 54 | output, e.g. 55 | 56 | ``` 57 | Linking /Users/alice/lima/case-studies/OM1/dist-newstyle/build/lima-om1-0.2.0.0/build/lima-om1/lima-om1 58 | ``` 59 | 60 | Thanks 61 | ------ 62 | 63 | Much of the original code base for this project is due to 64 | [Tom Hawkins](https://github.com/tomahawkins/atom) and 65 | [Lee Pike](https://www.cs.indiana.edu/~lepike/). 66 | The LIMA logo was generously designed by 67 | [Getty Ritter](https://github.com/aisamanra). 68 | -------------------------------------------------------------------------------- /build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | CASE_STUDIES="OM1 WBS periodic" 4 | 5 | git submodule update --init 6 | 7 | for c in $CASE_STUDIES; do 8 | pushd "case-studies/$c" 9 | cabal new-configure 10 | cabal new-build 11 | popd 12 | done 13 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: lima/ 2 | lima-c/ 3 | lima-sally/ 4 | dependencies/language-sally/ 5 | -------------------------------------------------------------------------------- /case-studies/OM1/.gitignore: -------------------------------------------------------------------------------- 1 | om1 2 | om1.c 3 | om1.h 4 | om1.mcmt 5 | cabal.project.local 6 | .cabal-sandbox 7 | cabal.sandbox.config 8 | -------------------------------------------------------------------------------- /case-studies/OM1/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.List 4 | 5 | import Language.LIMA 6 | import Language.LIMA.C 7 | import Language.Sally 8 | 9 | import OM1 (om1) 10 | 11 | main :: IO () 12 | main = do 13 | putStrLn "Compiling OM1 to C... (om1.{c,h})" 14 | compileOM1ToC 15 | 16 | putStrLn "Compiling OM1 to Sally... (om1.mcmt)" 17 | let sallyCfg = defaultCfg { cfgMFA = hybridMFA } 18 | compileToSally "om1" sallyCfg "om1.mcmt" om1 Nothing 19 | 20 | putStrLn "Done." 21 | 22 | 23 | -- C Code Generator ------------------------------------------------------ 24 | 25 | -- | Invoke the atom compiler, generating 'om1.{c,h}' 26 | -- Also print out info on the generated schedule. 27 | compileOM1ToC :: IO () 28 | compileOM1ToC = do 29 | res <- compile "om1" cfg om1 30 | putStrLn $ reportSchedule (compSchedule res) 31 | where 32 | cfg = defaults { cCode = prePostCode } 33 | 34 | -- | Custom pre-post code for generated C 35 | prePostCode :: [Name] -> [Name] -> [(Name, Type)] -> (String, String) 36 | prePostCode assertNames _covNames _probeNames = 37 | ( unlines [ "#include " 38 | , "#include " 39 | , "" 40 | , "static char* assert_names[" ++ show (length assertNames) ++ "] = " 41 | ++ "{" ++ intercalate "," (map (\n -> "\"" ++ n ++ "\"") assertNames) ++ "};" 42 | , "" 43 | , "void assert(int id, bool c, int64_t clk) {" 44 | , " if (!c) {" 45 | , " printf(\"assertion %s failed at time %lld\\n\", assert_names[id], clk);" 46 | , " }" 47 | , "}" 48 | , "" 49 | , "// ---- BEGIN of source automatically generated by LIMA ----" 50 | ] 51 | , unlines [ "// ---- END of source automatically generated by LIMA ----" 52 | , "" 53 | , "int main(int argc, char **argv) {" 54 | , " while(1) { om1(); usleep(500); }" 55 | , "}" 56 | ] 57 | ) 58 | 59 | -- | Custom pre-post header for generated C 60 | prePostH :: [Name] -> [Name] -> [(Name, Type)] -> (String, String) 61 | prePostH assertNames _covNames _probeNames = 62 | ( "void assert(int, bool, int64_t);" 63 | , "" 64 | ) 65 | -------------------------------------------------------------------------------- /case-studies/OM1/OM1.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : OM1 3 | -- Copyright : Benjamin Jones 2016 4 | -- License : BSD3 5 | -- 6 | -- Maintainer : bjones@galois.com 7 | -- Stability : experimental 8 | -- Portability : unknown 9 | -- 10 | -- A specification for the distributed, fault tolerant system OM(1) written 11 | -- using LIMA 12 | -- 13 | module OM1 14 | ( om1 15 | ) 16 | where 17 | 18 | import Control.Monad (forM, forM_) 19 | import Data.Int 20 | 21 | import Language.LIMA 22 | import Language.LIMA.C (printProbe) 23 | import Language.Sally 24 | 25 | 26 | -- Parameters ---------------------------------------------------------- 27 | 28 | numRelays = 3 29 | numRecvs = 3 30 | 31 | relaySet = [0..numRelays-1] 32 | recvSet = [0..numRecvs-1] 33 | 34 | 35 | -- OM(1) Spec ------------------------------------------------------------ 36 | 37 | -- | Top level rule 38 | om1 :: Atom () 39 | om1 = do 40 | -- setup channels for communication between source, relays, and receivers 41 | s2rs <- mapM newChannel [ tg "s2r" i | i <- relaySet ] 42 | r2rs <- mapM (mapM newChannel) [ [ tg2 "r2r" i j | j <- recvSet ] 43 | | i <- relaySet ] 44 | votes <- mapM msgVar [ tg "vote" j | j <- recvSet ] 45 | 46 | -- declare source node 47 | source (map fst s2rs) 48 | 49 | -- declare relay nodes 50 | forM_ relaySet $ \ident -> 51 | relay ident (snd (s2rs !! ident)) 52 | (map fst (r2rs !! ident)) 53 | 54 | -- declare receiver nodes 55 | dones <- forM recvSet $ \ident -> 56 | recv ident [ snd ((r2rs !! i) !! ident) | i <- relaySet ] (votes !! ident) 57 | 58 | assert "agreement" $ imply (and_ (map value dones)) (all_ (\(v,w) -> value v ==. value w) 59 | [ (v,w) | v <- votes, w <- votes ]) 60 | assert "validity" $ imply (and_ (map value dones)) (all_ (\v -> value v ==. goodMsg) votes) 61 | 62 | observer 63 | 64 | -- Source -------------------------------------------------------------- 65 | 66 | -- | Source node, a.k.a. "The General" 67 | source :: [ChanInput] -- ^ output channels to broadcast on 68 | -> Atom () 69 | source cs = atom "source" $ do 70 | done <- bool "done" False 71 | 72 | -- activation condition 73 | cond $ not_ (value done) 74 | 75 | -- behavior 76 | done <== Const True 77 | forM_ cs $ \c -> writeChannel c goodMsg 78 | 79 | 80 | -- Relays -------------------------------------------------------------- 81 | 82 | -- | Relay node, a.k.a. a generic 0th round "Lieutenant" 83 | relay :: Int -- ^ relay id 84 | -> ChanOutput -- ^ channel from source 85 | -> [ChanInput] -- ^ channels to receivers 86 | -> Atom () 87 | relay ident inC outCs = atom (tg "relay" ident) $ do 88 | done <- bool "done" False 89 | msg <- msgVar (tg "relay_msg" ident) 90 | 91 | -- activation condition: 92 | -- we haven't stored a value yet and there is a message waiting 93 | -- on the channel 'inC' 94 | cond $ isMissing msg &&. fullChannel inC 95 | 96 | -- behavior 97 | m <- readChannel inC :: Atom (E MsgType) 98 | msg <== m 99 | done <== Const True 100 | forM_ outCs $ \c -> writeChannel c m 101 | 102 | 103 | -- Receivers ----------------------------------------------------------- 104 | 105 | -- | Receiver node, a.k.a. a generic 1st round "Lieutenant" 106 | recv :: Int -- ^ receiver id 107 | -> [ChanOutput] -- ^ channels from relays 108 | -> V MsgType 109 | -> Atom (V Bool) 110 | recv ident inCs vote = atom (tg "recv" ident) $ do 111 | done <- bool "done" False 112 | buffer <- mapM msgVar [ tg (tg "buffer" ident) i | i <- relaySet ] 113 | 114 | -- declare multiple "pollers", one for each buffer location 115 | forM_ relaySet $ \i -> 116 | atom (tg2 "recv_poll" ident i) $ do 117 | cond $ isMissing (buffer !! i) &&. fullChannel (inCs !! i) 118 | b' <- readChannel (inCs !! i) 119 | (buffer !! i) <== b' 120 | 121 | -- declare a voter 122 | atom (tg "recv_vote" ident) $ do 123 | cond $ all_ (not_ . isMissing) buffer 124 | vote <== computeVote (value <$> buffer) 125 | done <== Const True 126 | 127 | return done 128 | 129 | 130 | -- | Boyer-Moore Fast Majority Vote 131 | computeVote :: [E MsgType] -> E MsgType 132 | computeVote = fst . foldr iter (missingMsgValueE, Const 0) 133 | where 134 | iter x (y, c) = ( mux (x ==. y) onTrue1 onFalse1 135 | , mux (x ==. y) onTrue2 onFalse2) 136 | where 137 | -- rules: 138 | -- if x ==. y, then (y, c+1) 139 | -- else if c == 0, then (x, 1) 140 | -- else (y, c-1) 141 | onTrue1 = y 142 | onTrue2 = c + Const 1 143 | onFalse1 = mux (c ==. Const 0) x y 144 | onFalse2 = mux (c ==. Const 0) (Const 1) (c - Const 1) 145 | _ = c :: E Int64 146 | 147 | -- | Synchronous observer node; current prints probe values to console at 148 | -- phase 0. This node has no activation or behavior so its part in the model 149 | -- is trivial. 150 | observer :: Atom () 151 | observer = atom "observer" $ do 152 | ps <- probes 153 | mapM_ printProbe ps 154 | 155 | 156 | -- Helper functions and definitions for Channels and Messages ---------- 157 | 158 | type MsgType = Int64 159 | msgType = Int64 160 | 161 | -- | Specially designated intended message to be send in the absense of faults 162 | goodMsg :: E MsgType 163 | goodMsg = Const 0 164 | 165 | -- | Special message type value indicating "no message present" 166 | missingMsgValue :: MsgType 167 | missingMsgValue = 0 168 | 169 | missingMsgValueE :: E MsgType 170 | missingMsgValueE = Const 0 171 | 172 | isMissing :: V MsgType -> E Bool 173 | isMissing = (==. missingMsgValueE) . value 174 | 175 | -- | Declare a new channel with 'missingMsgValue' as its initial value 176 | newChannel :: String -> Atom (ChanInput, ChanOutput) 177 | newChannel = flip channel msgType 178 | 179 | -- | Declare a variable of message type and add a probe for it to the 180 | -- environment 181 | msgVar :: Name -> Atom (V MsgType) 182 | msgVar nm = do 183 | v <- msgVar' nm 184 | probe nm (value v) 185 | return v 186 | 187 | -- | Declare a message variable w/o adding a probe 188 | msgVar' :: Name -> Atom (V MsgType) 189 | msgVar' nm = int64 nm missingMsgValue 190 | 191 | -- | Tag a name with an ID 192 | tg :: Name -> Int -> Name 193 | tg nm i = nm ++ "_" ++ show i 194 | 195 | -- | Tag a name with a pair of IDs 196 | tg2 :: Name -> Int -> Int -> Name 197 | tg2 nm i j = nm ++ "_" ++ show i ++ "_" ++ show j 198 | -------------------------------------------------------------------------------- /case-studies/OM1/README.md: -------------------------------------------------------------------------------- 1 | # atom-om1 2 | 3 | [Atom](https://github.com/tomahawkins/atom) (Haskell eDSL) specification for a 4 | concurrent [OM1](link) running on a shared memory distributed system. 5 | 6 | # Usage 7 | 8 | Compilation requires GHC, cabal, and a C99 compatible C compiler, and copies 9 | of the GaloisInc `atom` and `atom-sally` repositories in a common directory. 10 | Once the dependencies are met you can install and run the translators using 11 | the `install.sh` script like so: 12 | 13 | ``` 14 | $ mkdir deps 15 | $ cd deps 16 | $ git clone https://github.com/GaloisInc/atom 17 | $ git clone https://github.com/GaloisInc/atom-sally 18 | $ cd .. 19 | 20 | $ ATOMDIR=deps ./install.sh 21 | ``` 22 | 23 | This will build the C and Sally translators and translate the 'om1' 24 | specification to code `om1.{c,h}` and model `om1.mcmt`, respectively. 25 | 26 | 27 | # Simplified View of the specification 28 | 29 | Here is a simplified view of the spec, without the probes and compiler 30 | details. The `om1` declaration knits the source, relays, and receivers 31 | together using a system of typed channels. The relays and receivers are 32 | parameterized over an ID and set of input/output channels. Finally, the 33 | `computeVote` function produces a completely unrolled expression for the 34 | Boyer-Moore fast majority vote algorithm. 35 | 36 | ```haskell 37 | -- Parameters ---------------------------------------------------------- 38 | 39 | -- Node clock periods (in ticks) 40 | initPeriod = 100 41 | sourcePeriod = 20 42 | relayPeriod = 7 43 | recvPeriod = 13 44 | observerPeriod = 1 45 | 46 | numRelays = 3 47 | numRecvs = 3 48 | 49 | relaySet = [0..numRelays-1] 50 | recvSet = [0..numRecvs-1] 51 | 52 | 53 | -- OM(1) Spec ------------------------------------------------------------ 54 | 55 | om1 :: Atom () 56 | om1 = do 57 | -- setup channels for communication between source, relays, and receivers 58 | s2rs <- mapM newChannel [ tg "s2r" i | i <- relaySet ] 59 | r2rs <- mapM (mapM newChannel) [ [ tg2 "r2r" i j | j <- recvSet ] 60 | | i <- relaySet ] 61 | votes <- mapM msgVar [ tg "vote" j | j <- recvSet ] 62 | 63 | -- declare source node 64 | source (map fst s2rs) 65 | 66 | -- declare relay nodes 67 | forM_ relaySet $ \ident -> 68 | relay ident (snd (s2rs !! ident)) 69 | (map fst (r2rs !! ident)) 70 | 71 | -- declare receiver nodes 72 | forM_ recvSet $ \ident -> 73 | recv ident [ snd ((r2rs !! i) !! ident) | i <- relaySet ] 74 | (votes !! ident) 75 | 76 | -- declare the observer 77 | observer 78 | 79 | 80 | -- Source -------------------------------------------------------------- 81 | 82 | -- | Source node, a.k.a. "The General" 83 | source :: [ChanInput] -- ^ output channels to broadcast on 84 | -> Atom () 85 | source cs = period sourcePeriod 86 | . atom "source" $ do 87 | done <- bool "done" False 88 | 89 | -- activation condition 90 | cond $ not_ (value done) 91 | 92 | -- behavior 93 | done <== Const True 94 | forM_ cs $ \c -> do 95 | writeChannel c goodMsg 96 | 97 | 98 | -- Relays -------------------------------------------------------------- 99 | 100 | -- | Relay node, a.k.a. a generic 0th round "Lieutenant" 101 | relay :: Int -- ^ relay id 102 | -> ChanOutput -- ^ channel from source 103 | -> [ChanInput] -- ^ channels to receivers 104 | -> Atom () 105 | relay ident inC outCs = period relayPeriod 106 | . atom (tg "relay" ident) $ do 107 | done <- bool "done" False 108 | msg <- msgVar (tg "relay_msg" ident) 109 | 110 | -- activation condition 111 | cond $ isMissing msg -- we haven't stored a value yet 112 | condChannel inC -- there is a value available 113 | 114 | -- behavior 115 | msg <== readChannel inC 116 | done <== Const True 117 | forM_ outCs $ \c -> do 118 | let m = readChannel inC :: E MsgType 119 | writeChannel c m 120 | 121 | 122 | -- Receivers ----------------------------------------------------------- 123 | 124 | -- | Receiver node, a.k.a. a generic 1st round "Lieutenant" 125 | recv :: Int -- ^ receiver id 126 | -> [ChanOutput] -- ^ channels from relays 127 | -> V MsgType 128 | -> Atom () 129 | recv ident inCs vote = period recvPeriod 130 | . atom (tg "recv" ident) $ do 131 | done <- bool "done" False 132 | buffer <- mapM msgVar [ tg (tg "buffer" ident) i | i <- relaySet ] 133 | 134 | -- declare multiple "pollers", one for each buffer location 135 | forM_ relaySet $ \i -> do 136 | atom (tg2 "recv_poll" ident i) $ do 137 | cond $ isMissing (buffer !! i) 138 | condChannel (inCs !! i) 139 | (buffer !! i) <== readChannel (inCs !! i) 140 | 141 | -- declare a voter 142 | atom (tg "recv_vote" ident) $ do 143 | cond $ all_ (not_ . isMissing) buffer 144 | vote <== computeVote (value <$> buffer) 145 | done <== Const True 146 | 147 | -- | Boyer-Moore Fast Majority Vote 148 | computeVote :: [E MsgType] -> E MsgType 149 | computeVote = fst . foldr iter (missingMsgValueE, Const 0) 150 | where 151 | iter x (y, c) = ( mux (x ==. y) onTrue1 onFalse1 152 | , mux (x ==. y) onTrue2 onFalse2) 153 | where 154 | -- rules: 155 | -- if x ==. y, then (y, c+1) 156 | -- else if c == 0, then (x, 1) 157 | -- else (y, c-1) 158 | onTrue1 = y 159 | onTrue2 = c + (Const 1) 160 | onFalse1 = mux (c ==. Const 0) x y 161 | onFalse2 = mux (c ==. Const 0) (Const 1) (c - (Const 1)) 162 | _ = c :: E Int64 163 | 164 | -- | Synchronous observer node; current prints probe values to console at 165 | -- phase 0. This node has no activation or behavior so its part in the model 166 | -- is trivial. 167 | observer :: Atom () 168 | observer = period observerPeriod 169 | . exactPhase 0 170 | . atom "observer" $ do 171 | ps <- probes 172 | mapM_ printProbe ps 173 | ``` 174 | -------------------------------------------------------------------------------- /case-studies/OM1/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /case-studies/OM1/build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | git submodule update 4 | 5 | if [ -d .cabal-sandbox ]; then 6 | echo "Skipping sandbox build..." 7 | else 8 | cabal sandbox init 9 | cabal sandbox add-source ../../lima/ 10 | cabal sandbox add-source ../../lima-c/ 11 | cabal sandbox add-source ../../lima-sally/ 12 | cabal sandbox add-source ../../dependencies/language-sally 13 | cabal install --only-dependencies 14 | fi 15 | 16 | cabal configure 17 | cabal build 18 | cabal install 19 | -------------------------------------------------------------------------------- /case-studies/OM1/cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | ../../lima/ 3 | ../../lima-c/ 4 | ../../lima-sally/ 5 | ../../dependencies/language-sally 6 | -------------------------------------------------------------------------------- /case-studies/OM1/lima-om1.cabal: -------------------------------------------------------------------------------- 1 | name: lima-om1 2 | version: 0.2.0.0 3 | synopsis: OM1 in LIMA 4 | author: Benjamin Jones 5 | maintainer: bjones@galois.com 6 | category: Language 7 | build-type: Simple 8 | cabal-version: >=1.10 9 | 10 | extra-source-files: om1.h 11 | , om1.c 12 | , om1.mcmt 13 | 14 | executable lima-om1 15 | default-language: Haskell2010 16 | main-is: Main.hs 17 | other-modules: OM1 18 | build-depends: base >= 4.8 && < 5 19 | , lima >= 0.1.0.0 && < 0.2 20 | , lima-c >= 0.1.0.0 && < 0.2 21 | , lima-sally >= 0.1.0.0 && < 0.2 22 | -------------------------------------------------------------------------------- /case-studies/WBS/.gitignore: -------------------------------------------------------------------------------- 1 | wbs.c 2 | wbs.h 3 | wbs.mcmt 4 | cabal.project.local 5 | dist-newstyle 6 | .cabal-sandbox 7 | cabal.sandbox.config 8 | wbs 9 | -------------------------------------------------------------------------------- /case-studies/WBS/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.List 4 | 5 | import Language.LIMA 6 | import Language.LIMA.C 7 | import Language.Sally 8 | 9 | import WBS (wbs) 10 | 11 | main :: IO () 12 | main = do 13 | putStrLn "Compiling WBS to C... (wbs.{c,h})" 14 | compileWBSToC 15 | 16 | putStrLn "Compiling WBS to Sally... (wbs.mcmt)" 17 | -- TODO: specifying 'hybridMFA' below leads to an explosion in model 18 | -- generation 19 | let sallyCfg = defaultCfg { cfgMFA = NoFaults } 20 | compileToSally "wbs" sallyCfg "wbs.mcmt" wbs Nothing 21 | 22 | putStrLn "Done." 23 | 24 | 25 | -- C Code Generator ------------------------------------------------------ 26 | 27 | -- | Invoke the LIMA compiler, generating 'wbs.{c,h}' 28 | -- Also print out info on the generated schedule. 29 | compileWBSToC :: IO () 30 | compileWBSToC = do 31 | res <- compile "wbs" cfg wbs 32 | putStrLn $ reportSchedule (compSchedule res) 33 | where 34 | cfg = defaults { cCode = prePostCode 35 | , hCode = prePostH 36 | } 37 | 38 | -- | Custom pre-post code for generated C 39 | prePostCode :: [Name] -> [Name] -> [(Name, Type)] -> (String, String) 40 | prePostCode assertNames _covNames _probeNames = 41 | ( unlines [ "#include " 42 | , "#include " 43 | , "" 44 | , "static char* assert_names[" ++ show (length assertNames) ++ "] = " 45 | ++ "{" ++ intercalate "," (map (\n -> "\"" ++ n ++ "\"") assertNames) ++ "};" 46 | , "" 47 | , "void assert(int id, bool c, int64_t clk) {" 48 | , " if (!c) {" 49 | , " printf(\"assertion %s failed at time %lld\\n\", assert_names[id], clk);" 50 | , " }" 51 | , "}" 52 | , "" 53 | , "// ---- BEGIN of source automatically generated by LIMA ----" 54 | ] 55 | , unlines [ "// ---- END of source automatically generated by LIMA ----" 56 | , "" 57 | , "int main(int argc, char **argv) {" 58 | , " while(1) { wbs(); usleep(500); }" 59 | , "}" 60 | ] 61 | ) 62 | 63 | -- | Custom pre-post header for generated C 64 | prePostH :: [Name] -> [Name] -> [(Name, Type)] -> (String, String) 65 | prePostH assertNames _covNames _probeNames = 66 | ( "void assert(int, bool, int64_t);" 67 | , "" 68 | ) 69 | -------------------------------------------------------------------------------- /case-studies/WBS/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /case-studies/WBS/WBS.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module WBS (wbs) where 4 | 5 | import Data.Int 6 | import Data.Word 7 | import qualified Data.Map.Strict as Map 8 | import System.FilePath.Posix 9 | 10 | import Language.LIMA 11 | import Language.LIMA.C 12 | import Language.Sally 13 | 14 | 15 | -- Constants ------------------------------------------------------------------- 16 | 17 | testDir :: FilePath 18 | testDir = "test" 19 | 20 | type MsgType = Int64 21 | 22 | msgType :: Type 23 | msgType = Int64 -- Atom 'Type' value 24 | 25 | -- Button press processes period 26 | buttonPeriod :: Word64 27 | buttonPeriod = 10 28 | buttonPhase :: Word64 29 | buttonPhase = 0 30 | 31 | -- COM and MON period 32 | procPeriod :: Word64 33 | procPeriod = 2 34 | procPhase :: Word64 35 | procPhase = 0 36 | 37 | 38 | -- Single Channel Wheel Brake Example ------------------------------------------ 39 | 40 | wbs :: Atom () 41 | wbs = atom "wbs" $ do 42 | 43 | -- cross channel comms 44 | (mhtomlIn, mhtomlOut) <- channel "mon_high_to_low" Bool 45 | (mltomhIn, mltomhOut) <- channel "mon_low_to_high" Bool 46 | 47 | -- Declare two lanes 48 | laneIns <- mapM mkLane [ (True, mhtomlIn, mltomhOut) 49 | , (False, mltomhIn, mhtomlOut) 50 | ] -- high/low priority 51 | 52 | clocked buttonPeriod buttonPhase . atom "button" $ do 53 | count <- var "count" zero -- button's frame count 54 | bs <- bool "bs" False -- button state 55 | 56 | probe "boolbutton.count" (value count) 57 | bs <== mux (value bs ==. Const True) (Const False) (Const True) 58 | 59 | mapM_ (\(a, b, c) -> do 60 | writeChannel a (value bs) -- channel for command button input 61 | writeChannel b (value bs) -- channel for monitor button input 62 | writeChannel c (value count)) -- send 'count' to observer 63 | laneIns 64 | 65 | incr count 66 | 67 | printAllProbes 68 | 69 | 70 | -- Command / Monitor "Lane" -------------------------------------------- 71 | 72 | -- | A lane consists of a command node, a monitor node, and an observer. 73 | -- 74 | -- Input is a triple of: flag to indicate "high" lane or "low" lane, chan 75 | -- input to write control messages on for the other mon, and chan output to 76 | -- listen for control messaages on from the other mon. 77 | -- 78 | -- Return includes (in order) a chan input that goes to the COM (Bool), 79 | -- one that goes to the MON (Bool), and one that goes to the observer 80 | -- (Int64). 81 | mkLane :: (Bool, ChanInput, ChanOutput) 82 | -> Atom (ChanInput, ChanInput, ChanInput) 83 | mkLane (pp, mtmIn, mtmOut) = atom (pName pp "lane") $ do 84 | 85 | let probeP nm = probe (pName pp nm) 86 | 87 | (btcIn, btcOut) <- channel (pName pp "btc") Bool -- button to COM 88 | (btmIn, btmOut) <- channel (pName pp "btm") Bool -- button to MON 89 | (btoIn, btoOut) <- channel (pName pp "bto") Int64 -- button to OBS 90 | 91 | -- com to mon and observer state exchange 92 | (ctmIn, ctmOut) <- channel (pName pp "ctm") Bool -- send state 93 | (ctoIn, ctoOut) <- channel (pName pp "cto") Int64 -- send frame count 94 | (mtoIn, mtoOut) <- channel (pName pp "mto") Int64 -- send frame count 95 | 96 | -- COM node 97 | clocked procPeriod procPhase . atom (pName pp "command") $ do 98 | bs <- var "bs" False -- observered button value 99 | prevbs <- var "prevbs" False -- previous button value 100 | framecount <- var "framecount" zero 101 | cautoMode <- var "cautoMode" False 102 | 103 | incr framecount 104 | prevbs <== value bs 105 | -- detect a rising edge in 'bs' 106 | cautoMode <== mux ((value bs ==. Const True) &&. 107 | (value prevbs ==. Const False)) 108 | (not_ (value cautoMode)) 109 | (value cautoMode) 110 | writeChannel ctoIn (value framecount) -- send 'framecount' to observer 111 | writeChannel ctmIn (value cautoMode) -- send 'cautoMode' to MON 112 | 113 | probeP "command.autoMode" (value cautoMode) 114 | 115 | atom "wait_for_button_press" $ do 116 | cond $ fullChannel btcOut 117 | v <- readChannel btcOut 118 | bs <== v 119 | probeP "command.button_pressed" (value bs) 120 | 121 | -- MON node 122 | clocked procPeriod procPhase . atom (pName pp "monitor") $ do 123 | framecount <- var "count" zero 124 | bs <- var "bs" False 125 | prevbs <- var "prevbs" False 126 | mautoMode <- var "mautoMode" False 127 | xSideAutoMode <- var "autoMode" False 128 | agreementFailureCount <- var "agreementFailureCount" zero 129 | agreementFailure <- var "agreementFailure" False 130 | control <- var "control" pp 131 | otherControl <- var "otherControl" False 132 | 133 | incr framecount 134 | prevbs <== value bs 135 | -- detect rising edge 136 | mautoMode <== mux ((value bs ==. Const True) &&. 137 | (value prevbs ==. Const False)) 138 | (not_ (value mautoMode)) 139 | (value mautoMode) 140 | writeChannel mtoIn (value framecount) -- send 'framecount' to observer 141 | probeP "monitor.autoMode" (value mautoMode) 142 | probeP "monitor.agreementFailureCount" (value agreementFailureCount) 143 | probeP "monitor.agreementFailure" (value agreementFailure) 144 | 145 | atom "wait_for_button_press" $ do 146 | cond $ fullChannel btmOut 147 | v <- readChannel btmOut 148 | bs <== v 149 | probeP "monitor.button_pressed" (value bs) 150 | 151 | atom "wait_x_side_autoMode" $ do 152 | cond $ fullChannel ctmOut 153 | v <- readChannel ctmOut 154 | xSideAutoMode <== v 155 | probeP "monitor.XsideAutoMode" (value xSideAutoMode) 156 | 157 | atom "mon_agreement" $ do 158 | agreementFailureCount <== 159 | mux (value mautoMode /=. value xSideAutoMode) 160 | (Const one + value agreementFailureCount) 161 | (Const zero) 162 | assert (pName pp "my assert") (value agreementFailureCount <=. Const three) 163 | 164 | atom "mon_agreement_count" $ do 165 | cond $ value agreementFailureCount ==. Const three 166 | agreementFailure <== Const True 167 | control <== false 168 | writeChannel mtmIn (value control) 169 | 170 | -- read values of "control" from the other mon, indicating whether that 171 | -- mon thinks it is in control or not 172 | atom "mon_other_control" $ do 173 | cond $ fullChannel mtmOut 174 | v <- readChannel mtmOut 175 | otherControl <== v 176 | 177 | -- | Internal Observer Node - run every tick and read values from the 178 | -- observer channels 179 | atom (pName pp "observer") $ do 180 | bcount <- var "bcount" zero 181 | ccount <- var "ccount" zero 182 | mcount <- var "mcount" zero 183 | probeP "observer.bcount" (value bcount) 184 | probeP "observer.com_framecount" (value ccount) 185 | probeP "observer.mon_framecount" (value mcount) 186 | 187 | atom "wait_for_button_frame" $ do 188 | cond $ fullChannel btoOut 189 | _ <- readChannel btoOut 190 | incr bcount 191 | 192 | atom "wait_for_com_frame" $ do 193 | cond $ fullChannel ctoOut 194 | _ <- readChannel ctoOut 195 | incr ccount 196 | 197 | atom "wait_for_mon_frame" $ do 198 | cond $ fullChannel mtoOut 199 | _ <- readChannel mtoOut 200 | incr mcount 201 | 202 | -- return input channels for use by the button 203 | return (btcIn, btmIn, btoIn) 204 | 205 | 206 | -- Utility Stuff ------------------------------------------------------- 207 | 208 | zero, one, three :: Int64 209 | zero = 0 210 | one = 1 211 | three = 3 212 | 213 | printAllProbes :: Atom () 214 | printAllProbes = mapM_ printProbe =<< probes 215 | 216 | -- | Helper function to append "high" or "low" to names of various components 217 | pName :: Bool -> String -> String 218 | pName b nm = nm ++ if b then "_high" else "_low" 219 | -------------------------------------------------------------------------------- /case-studies/WBS/build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | git submodule update 4 | 5 | if [ -d .cabal-sandbox ]; then 6 | echo "Skipping sandbox build..." 7 | else 8 | cabal sandbox init 9 | cabal sandbox add-source ../../lima/ 10 | cabal sandbox add-source ../../lima-c/ 11 | cabal sandbox add-source ../../lima-sally/ 12 | cabal sandbox add-source ../../dependencies/language-sally 13 | cabal install --only-dependencies 14 | fi 15 | 16 | cabal configure 17 | cabal build 18 | cabal install 19 | -------------------------------------------------------------------------------- /case-studies/WBS/cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | ../../lima/ 3 | ../../lima-c/ 4 | ../../lima-sally/ 5 | ../../dependencies/language-sally 6 | -------------------------------------------------------------------------------- /case-studies/WBS/lima-wbs.cabal: -------------------------------------------------------------------------------- 1 | name: lima-wbs 2 | version: 0.1.0.0 3 | synopsis: WBS in LIMA 4 | author: Brenden Hall , 5 | Srivatsan Varadarajan 6 | , 7 | Benjamin Jones 8 | maintainer: bjones@galois.com 9 | category: Language 10 | build-type: Simple 11 | cabal-version: >=1.10 12 | 13 | extra-source-files: wbs.h 14 | , wbs.c 15 | , wbs.mcmt 16 | 17 | executable lima-wbs 18 | default-language: Haskell2010 19 | main-is: Main.hs 20 | other-modules: WBS 21 | build-depends: base >= 4.8 && < 5 22 | , containers 23 | , filepath 24 | , lima >= 0.1.0.0 && < 0.2 25 | , lima-c >= 0.1.0.0 && < 0.2 26 | , lima-sally >= 0.1.0.0 && < 0.2 27 | -------------------------------------------------------------------------------- /case-studies/periodic/.gitignore: -------------------------------------------------------------------------------- 1 | periodic 2 | *.c 3 | *.h 4 | *.mcmt 5 | *.png 6 | .cabal-sandbox 7 | cabal.sandbox.config 8 | ex1 9 | ex2 10 | ex3 11 | ex4 12 | -------------------------------------------------------------------------------- /case-studies/periodic/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (module Main) where 2 | 3 | import Control.Monad (forM_) 4 | import Data.List 5 | 6 | import Language.LIMA 7 | import Language.LIMA.Graph 8 | import Language.LIMA.C 9 | import Language.Sally 10 | 11 | import Periodic 12 | 13 | -- | Atoms to compile 14 | as :: [Atom ()] 15 | as = [ex1, ex2, ex3, ex4, ex5] 16 | 17 | main :: IO () 18 | main = do 19 | let nm i = "ex" ++ show i 20 | forM_ (zip [1..] as) $ \(i,a) -> do 21 | compileToC (nm i) a 22 | let prefix = "periodic_" ++ nm i 23 | compileToSally prefix defaultCfg (prefix ++ ".mcmt") a Nothing 24 | graphAtom prefix a 25 | 26 | 27 | -- C Code Generator Utilities -------------------------------------------- 28 | 29 | -- | Invoke the atom compiler, generating 'om1.{c,h}' 30 | -- Also print out info on the generated schedule. 31 | compileToC :: Name -> Atom () -> IO () 32 | compileToC nm atm = do 33 | res <- compile nm cfg atm 34 | putStrLn $ reportSchedule (compSchedule res) 35 | where 36 | cfg = defaults { cCode = prePostCode nm 37 | , hCode = prePostH 38 | } 39 | 40 | -- | Custom pre-post code for generated C 41 | prePostCode :: Name -> [Name] -> [Name] -> [(Name, Type)] -> (String, String) 42 | prePostCode nm assertNames _covNames _probeNames = 43 | ( unlines [ "#include " 44 | , "#include " 45 | , "" 46 | , "static char* assert_names[" ++ show (length assertNames) ++ "] = " 47 | ++ "{" ++ intercalate "," (map (\n -> "\"" ++ n ++ "\"") assertNames) ++ "};" 48 | , "" 49 | , "void assert(int id, bool c, int64_t clk) {" 50 | , " if (!c) {" 51 | , " printf(\"assertion %s failed at time %lld\\n\", assert_names[id], clk);" 52 | , " }" 53 | , "}" 54 | , "" 55 | , "// ---- BEGIN of source automatically generated by LIMA ----" 56 | ] 57 | , unlines [ "// ---- END of source automatically generated by LIMA ----" 58 | , "" 59 | , "int main(int argc, char **argv) {" 60 | , " while(1) { " ++ nm ++ "(); usleep(500); }" 61 | , "}" 62 | ] 63 | ) 64 | 65 | -- | Custom pre-post header for generated C 66 | prePostH :: [Name] -> [Name] -> [(Name, Type)] -> (String, String) 67 | prePostH assertNames _covNames _probeNames = 68 | ( "void assert(int, bool, int64_t);" 69 | , "" 70 | ) 71 | -------------------------------------------------------------------------------- /case-studies/periodic/Periodic.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Periodic 3 | -- Copyright : Benjamin Jones 2017 4 | -- License : ISC 5 | -- 6 | -- Maintainer : bjones@galois.com 7 | -- Stability : experimental 8 | -- Portability : unknown 9 | -- 10 | -- Some example specifications of systems with different periodic behavior. 11 | -- 12 | module Periodic (module Periodic) where 13 | 14 | import Control.Monad (mapM_) 15 | import Data.Int 16 | 17 | import Language.LIMA 18 | import Language.LIMA.C.Util (printProbe) 19 | import Language.Sally 20 | 21 | 22 | -- Example 1 ------------------------------------------------------------------- 23 | 24 | -- | Simple periodic atom. 25 | ex1 :: Atom () 26 | ex1 = atom "ex1" $ do 27 | x <- int64 "x" 0 28 | incr x 29 | assert "x is bounded" (value x <. 3) -- obviously untrue 30 | 31 | -- | Clocked version of ex1 32 | ex2 :: Atom () 33 | ex2 = atom "ex2" $ clocked 5 3 $ \res -> do 34 | x <- int64 "x" 0 35 | incr x 36 | mapM_ readChannel res -- reset clock channel(s) 37 | assert "x is bounded" (value x <. 3) -- obviously untrue 38 | 39 | -- | Example with two subatoms that communicate. Each time that each of the 40 | -- nodes executes, it decrements a counter and sends a message to the other 41 | -- node. If it receives a message from the other node, it also increments the 42 | -- same counter. 43 | -- 44 | -- This system should satisfy the property that if the periods of the two 45 | -- nodes are the same, then the counters cannot get large in absolute value. 46 | ex3 :: Atom () 47 | ex3 = atom "ex3" $ do 48 | (acin, acout) <- channel "ach" Bool 49 | (bcin, bcout) <- channel "bch" Bool 50 | 51 | atom "alice" $ clocked 2 1 $ \res -> do 52 | x <- int8 "x" 0 53 | writeChannel acin true 54 | mapM_ readChannel res -- reset clock channel(s) 55 | decr x 56 | 57 | atom "alice_rx" $ do 58 | cond $ fullChannel bcout 59 | _ <- readChannel bcout 60 | incr x 61 | 62 | assert "alice's x bounded" ((value x <=. 3) &&. (value x >=. (-3))) 63 | 64 | atom "bob" $ clocked 2 0 $ \res -> do 65 | x <- int8 "x" 0 66 | writeChannel bcin true 67 | mapM_ readChannel res -- reset clock channel(s) 68 | decr x 69 | 70 | atom "bob_rx" $ do 71 | cond $ fullChannel acout 72 | _ <- readChannel acout 73 | incr x 74 | 75 | assert "bob's x bounded" ((value x <=. 3) &&. (value x >=. (-3))) 76 | 77 | 78 | -- | Two periodic nodes modify a shared state variable. 79 | ex4 :: Atom () 80 | ex4 = atom "ex4" $ do 81 | x <- int64 "x" 0 82 | probe "x" (value x) 83 | 84 | clocked 2 0 $ \res -> atom "atom_incr" $ do 85 | incr x 86 | mapM_ readChannel res -- reset clock channel(s) 87 | 88 | clocked 5 3 $ \res -> atom "atom_decr" $ do 89 | decr x 90 | mapM_ readChannel res 91 | 92 | assert "x >= 0" (value x >=. 0) -- valid 93 | mapM_ printProbe =<< probes 94 | 95 | 96 | 97 | -- | Example illustrating "kickstart" mechanism for period execution. The 98 | -- library function 'clocked' in "Language.LIMA.Common" generalizes this 99 | -- pattern. 100 | ex5 :: Atom () 101 | ex5 = atom "ex5" $ do 102 | 103 | let ex5Phase = 3 104 | let ex5Period = 5 105 | 106 | (ii, io) <- channel "init_channel" Bool 107 | (ki, ko) <- channel "kick_channel" Bool 108 | (ni, no) <- channel "node_channel" Bool 109 | 110 | atom "kicker" $ do 111 | t <- var "test" (0 :: Int64) 112 | initChannel ii (CBool True) (DelayTicks ex5Phase) 113 | 114 | cond $ fullChannel io ||. fullChannel ko 115 | _ <- readChannel io 116 | writeChannelWithDelay (DelayTicks ex5Period) ki true 117 | writeChannelWithDelay (DelayTicks 0) ni true 118 | incr t 119 | 120 | atom "node" $ do 121 | x <- var "x" (0 :: Int64) 122 | cond $ fullChannel no 123 | _ <- readChannel no 124 | _ <- readChannel io 125 | incr x 126 | assert "x bounded" $ value x <. 5 -- smoke test 127 | 128 | -------------------------------------------------------------------------------- /case-studies/periodic/README.md: -------------------------------------------------------------------------------- 1 | # atom-om1 2 | 3 | [Atom](https://github.com/tomahawkins/atom) (Haskell eDSL) specification for a 4 | concurrent [OM1](link) running on a shared memory distributed system. 5 | 6 | # Usage 7 | 8 | Compilation requires GHC, cabal, and a C99 compatible C compiler, and copies 9 | of the GaloisInc `atom` and `atom-sally` repositories in a common directory. 10 | Once the dependencies are met you can install and run the translators using 11 | the `install.sh` script like so: 12 | 13 | ``` 14 | $ mkdir deps 15 | $ cd deps 16 | $ git clone https://github.com/GaloisInc/atom 17 | $ git clone https://github.com/GaloisInc/atom-sally 18 | $ cd .. 19 | 20 | $ ATOMDIR=deps ./install.sh 21 | ``` 22 | 23 | This will build the C and Sally translators and translate the 'om1' 24 | specification to code `om1.{c,h}` and model `om1.mcmt`, respectively. 25 | 26 | 27 | # Simplified View of the specification 28 | 29 | Here is a simplified view of the spec, without the probes and compiler 30 | details. The `om1` declaration knits the source, relays, and receivers 31 | together using a system of typed channels. The relays and receivers are 32 | parameterized over an ID and set of input/output channels. Finally, the 33 | `computeVote` function produces a completely unrolled expression for the 34 | Boyer-Moore fast majority vote algorithm. 35 | 36 | ```haskell 37 | -- Parameters ---------------------------------------------------------- 38 | 39 | -- Node clock periods (in ticks) 40 | initPeriod = 100 41 | sourcePeriod = 20 42 | relayPeriod = 7 43 | recvPeriod = 13 44 | observerPeriod = 1 45 | 46 | numRelays = 3 47 | numRecvs = 3 48 | 49 | relaySet = [0..numRelays-1] 50 | recvSet = [0..numRecvs-1] 51 | 52 | 53 | -- OM(1) Spec ------------------------------------------------------------ 54 | 55 | om1 :: Atom () 56 | om1 = do 57 | -- setup channels for communication between source, relays, and receivers 58 | s2rs <- mapM newChannel [ tg "s2r" i | i <- relaySet ] 59 | r2rs <- mapM (mapM newChannel) [ [ tg2 "r2r" i j | j <- recvSet ] 60 | | i <- relaySet ] 61 | votes <- mapM msgVar [ tg "vote" j | j <- recvSet ] 62 | 63 | -- declare source node 64 | source (map fst s2rs) 65 | 66 | -- declare relay nodes 67 | forM_ relaySet $ \ident -> 68 | relay ident (snd (s2rs !! ident)) 69 | (map fst (r2rs !! ident)) 70 | 71 | -- declare receiver nodes 72 | forM_ recvSet $ \ident -> 73 | recv ident [ snd ((r2rs !! i) !! ident) | i <- relaySet ] 74 | (votes !! ident) 75 | 76 | -- declare the observer 77 | observer 78 | 79 | 80 | -- Source -------------------------------------------------------------- 81 | 82 | -- | Source node, a.k.a. "The General" 83 | source :: [ChanInput] -- ^ output channels to broadcast on 84 | -> Atom () 85 | source cs = period sourcePeriod 86 | . atom "source" $ do 87 | done <- bool "done" False 88 | 89 | -- activation condition 90 | cond $ not_ (value done) 91 | 92 | -- behavior 93 | done <== Const True 94 | forM_ cs $ \c -> do 95 | writeChannel c goodMsg 96 | 97 | 98 | -- Relays -------------------------------------------------------------- 99 | 100 | -- | Relay node, a.k.a. a generic 0th round "Lieutenant" 101 | relay :: Int -- ^ relay id 102 | -> ChanOutput -- ^ channel from source 103 | -> [ChanInput] -- ^ channels to receivers 104 | -> Atom () 105 | relay ident inC outCs = period relayPeriod 106 | . atom (tg "relay" ident) $ do 107 | done <- bool "done" False 108 | msg <- msgVar (tg "relay_msg" ident) 109 | 110 | -- activation condition 111 | cond $ isMissing msg -- we haven't stored a value yet 112 | condChannel inC -- there is a value available 113 | 114 | -- behavior 115 | msg <== readChannel inC 116 | done <== Const True 117 | forM_ outCs $ \c -> do 118 | let m = readChannel inC :: E MsgType 119 | writeChannel c m 120 | 121 | 122 | -- Receivers ----------------------------------------------------------- 123 | 124 | -- | Receiver node, a.k.a. a generic 1st round "Lieutenant" 125 | recv :: Int -- ^ receiver id 126 | -> [ChanOutput] -- ^ channels from relays 127 | -> V MsgType 128 | -> Atom () 129 | recv ident inCs vote = period recvPeriod 130 | . atom (tg "recv" ident) $ do 131 | done <- bool "done" False 132 | buffer <- mapM msgVar [ tg (tg "buffer" ident) i | i <- relaySet ] 133 | 134 | -- declare multiple "pollers", one for each buffer location 135 | forM_ relaySet $ \i -> do 136 | atom (tg2 "recv_poll" ident i) $ do 137 | cond $ isMissing (buffer !! i) 138 | condChannel (inCs !! i) 139 | (buffer !! i) <== readChannel (inCs !! i) 140 | 141 | -- declare a voter 142 | atom (tg "recv_vote" ident) $ do 143 | cond $ all_ (not_ . isMissing) buffer 144 | vote <== computeVote (value <$> buffer) 145 | done <== Const True 146 | 147 | -- | Boyer-Moore Fast Majority Vote 148 | computeVote :: [E MsgType] -> E MsgType 149 | computeVote = fst . foldr iter (missingMsgValueE, Const 0) 150 | where 151 | iter x (y, c) = ( mux (x ==. y) onTrue1 onFalse1 152 | , mux (x ==. y) onTrue2 onFalse2) 153 | where 154 | -- rules: 155 | -- if x ==. y, then (y, c+1) 156 | -- else if c == 0, then (x, 1) 157 | -- else (y, c-1) 158 | onTrue1 = y 159 | onTrue2 = c + (Const 1) 160 | onFalse1 = mux (c ==. Const 0) x y 161 | onFalse2 = mux (c ==. Const 0) (Const 1) (c - (Const 1)) 162 | _ = c :: E Int64 163 | 164 | -- | Synchronous observer node; current prints probe values to console at 165 | -- phase 0. This node has no activation or behavior so its part in the model 166 | -- is trivial. 167 | observer :: Atom () 168 | observer = period observerPeriod 169 | . exactPhase 0 170 | . atom "observer" $ do 171 | ps <- probes 172 | mapM_ printProbe ps 173 | ``` 174 | -------------------------------------------------------------------------------- /case-studies/periodic/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /case-studies/periodic/build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | git submodule update 4 | 5 | if [ -d .cabal-sandbox ]; then 6 | echo "Skipping sandbox build..." 7 | else 8 | cabal sandbox init 9 | cabal sandbox add-source ../../lima/ 10 | cabal sandbox add-source ../../lima-c/ 11 | cabal sandbox add-source ../../lima-sally/ 12 | cabal sandbox add-source ../../dependencies/language-sally 13 | cabal install --only-dependencies 14 | fi 15 | 16 | cabal configure 17 | cabal build 18 | cabal install 19 | -------------------------------------------------------------------------------- /case-studies/periodic/cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | ../../lima/ 3 | ../../lima-c/ 4 | ../../lima-sally/ 5 | ../../dependencies/language-sally 6 | -------------------------------------------------------------------------------- /case-studies/periodic/clean.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | rm *.mcmt *.c *.h *.png 3 | -------------------------------------------------------------------------------- /case-studies/periodic/lima-periodic.cabal: -------------------------------------------------------------------------------- 1 | name: lima-periodic 2 | version: 0.1.0.0 3 | synopsis: Periodic examples in LIMA 4 | author: Benjamin Jones 5 | maintainer: bjones@galois.com 6 | category: Language 7 | build-type: Simple 8 | cabal-version: >=1.10 9 | 10 | executable lima-periodic 11 | default-language: Haskell2010 12 | main-is: Main.hs 13 | other-modules: Periodic 14 | build-depends: base >= 4.8 && < 5 15 | , lima >= 0.1.0.0 && < 0.2 16 | , lima-c >= 0.1.0.0 && < 0.2 17 | , lima-sally >= 0.1.0.0 && < 0.2 18 | -------------------------------------------------------------------------------- /case-studies/periodic/run: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | go=$(find . -name lima-periodic | tail -1) 3 | exec "$go" 4 | -------------------------------------------------------------------------------- /case-studies/smp/.gitignore: -------------------------------------------------------------------------------- 1 | periodic 2 | *.c 3 | *.h 4 | *.mcmt 5 | *.png 6 | .cabal-sandbox 7 | cabal.sandbox.config 8 | smp 9 | -------------------------------------------------------------------------------- /case-studies/smp/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (module Main) where 2 | 3 | import Data.List (intercalate) 4 | 5 | import Language.LIMA 6 | import Language.LIMA.Graph 7 | import Language.LIMA.C 8 | import Language.Sally 9 | 10 | import SMP 11 | 12 | main :: IO () 13 | main = do 14 | compileToC "smp" smp 15 | compileToSally "smp" defaultCfg "smp.mcmt" smp Nothing 16 | graphAtom "smp" smp 17 | 18 | 19 | -- C Code Generator Utilities -------------------------------------------- 20 | 21 | -- | Invoke the atom compiler, generating 'om1.{c,h}' 22 | -- Also print out info on the generated schedule. 23 | compileToC :: Name -> Atom () -> IO () 24 | compileToC nm atm = do 25 | res <- compile nm cfg atm 26 | putStrLn $ reportSchedule (compSchedule res) 27 | where 28 | cfg = defaults { cCode = prePostCode 29 | , hCode = prePostH } 30 | 31 | -- | Custom pre-post code for generated C 32 | prePostCode :: [Name] -> [Name] -> [(Name, Type)] -> (String, String) 33 | prePostCode assertNames _covNames _probeNames = 34 | ( unlines [ "#include " 35 | , "#include " 36 | , "" 37 | , "static char* assert_names[" ++ show (length assertNames) ++ "] = " 38 | ++ "{" ++ intercalate "," (map (\n -> "\"" ++ n ++ "\"") assertNames) ++ "};" 39 | , "" 40 | , "void assert(int id, bool c, int64_t clk) {" 41 | , " if (!c) {" 42 | , " printf(\"assertion %s failed at time %lld\\n\", assert_names[id], clk);" 43 | , " }" 44 | , "}" 45 | , "" 46 | , "// ---- BEGIN of source automatically generated by LIMA ----" 47 | ] 48 | , unlines [ "// ---- END of source automatically generated by LIMA ----" 49 | , "" 50 | , "int main(int argc, char **argv) {" 51 | , " while(1) { smp(); usleep(500); }" 52 | , "}" 53 | ] 54 | ) 55 | 56 | -- | Custom pre-post header for generated C 57 | prePostH :: [Name] -> [Name] -> [(Name, Type)] -> (String, String) 58 | prePostH assertNames _covNames _probeNames = 59 | ( "void assert(int, bool, int64_t);" 60 | , "" 61 | ) 62 | -------------------------------------------------------------------------------- /case-studies/smp/README.md: -------------------------------------------------------------------------------- 1 | # atom-om1 2 | 3 | [Atom](https://github.com/tomahawkins/atom) (Haskell eDSL) specification for a 4 | concurrent [OM1](link) running on a shared memory distributed system. 5 | 6 | # Usage 7 | 8 | Compilation requires GHC, cabal, and a C99 compatible C compiler, and copies 9 | of the GaloisInc `atom` and `atom-sally` repositories in a common directory. 10 | Once the dependencies are met you can install and run the translators using 11 | the `install.sh` script like so: 12 | 13 | ``` 14 | $ mkdir deps 15 | $ cd deps 16 | $ git clone https://github.com/GaloisInc/atom 17 | $ git clone https://github.com/GaloisInc/atom-sally 18 | $ cd .. 19 | 20 | $ ATOMDIR=deps ./install.sh 21 | ``` 22 | 23 | This will build the C and Sally translators and translate the 'om1' 24 | specification to code `om1.{c,h}` and model `om1.mcmt`, respectively. 25 | 26 | 27 | # Simplified View of the specification 28 | 29 | Here is a simplified view of the spec, without the probes and compiler 30 | details. The `om1` declaration knits the source, relays, and receivers 31 | together using a system of typed channels. The relays and receivers are 32 | parameterized over an ID and set of input/output channels. Finally, the 33 | `computeVote` function produces a completely unrolled expression for the 34 | Boyer-Moore fast majority vote algorithm. 35 | 36 | ```haskell 37 | -- Parameters ---------------------------------------------------------- 38 | 39 | -- Node clock periods (in ticks) 40 | initPeriod = 100 41 | sourcePeriod = 20 42 | relayPeriod = 7 43 | recvPeriod = 13 44 | observerPeriod = 1 45 | 46 | numRelays = 3 47 | numRecvs = 3 48 | 49 | relaySet = [0..numRelays-1] 50 | recvSet = [0..numRecvs-1] 51 | 52 | 53 | -- OM(1) Spec ------------------------------------------------------------ 54 | 55 | om1 :: Atom () 56 | om1 = do 57 | -- setup channels for communication between source, relays, and receivers 58 | s2rs <- mapM newChannel [ tg "s2r" i | i <- relaySet ] 59 | r2rs <- mapM (mapM newChannel) [ [ tg2 "r2r" i j | j <- recvSet ] 60 | | i <- relaySet ] 61 | votes <- mapM msgVar [ tg "vote" j | j <- recvSet ] 62 | 63 | -- declare source node 64 | source (map fst s2rs) 65 | 66 | -- declare relay nodes 67 | forM_ relaySet $ \ident -> 68 | relay ident (snd (s2rs !! ident)) 69 | (map fst (r2rs !! ident)) 70 | 71 | -- declare receiver nodes 72 | forM_ recvSet $ \ident -> 73 | recv ident [ snd ((r2rs !! i) !! ident) | i <- relaySet ] 74 | (votes !! ident) 75 | 76 | -- declare the observer 77 | observer 78 | 79 | 80 | -- Source -------------------------------------------------------------- 81 | 82 | -- | Source node, a.k.a. "The General" 83 | source :: [ChanInput] -- ^ output channels to broadcast on 84 | -> Atom () 85 | source cs = period sourcePeriod 86 | . atom "source" $ do 87 | done <- bool "done" False 88 | 89 | -- activation condition 90 | cond $ not_ (value done) 91 | 92 | -- behavior 93 | done <== Const True 94 | forM_ cs $ \c -> do 95 | writeChannel c goodMsg 96 | 97 | 98 | -- Relays -------------------------------------------------------------- 99 | 100 | -- | Relay node, a.k.a. a generic 0th round "Lieutenant" 101 | relay :: Int -- ^ relay id 102 | -> ChanOutput -- ^ channel from source 103 | -> [ChanInput] -- ^ channels to receivers 104 | -> Atom () 105 | relay ident inC outCs = period relayPeriod 106 | . atom (tg "relay" ident) $ do 107 | done <- bool "done" False 108 | msg <- msgVar (tg "relay_msg" ident) 109 | 110 | -- activation condition 111 | cond $ isMissing msg -- we haven't stored a value yet 112 | condChannel inC -- there is a value available 113 | 114 | -- behavior 115 | msg <== readChannel inC 116 | done <== Const True 117 | forM_ outCs $ \c -> do 118 | let m = readChannel inC :: E MsgType 119 | writeChannel c m 120 | 121 | 122 | -- Receivers ----------------------------------------------------------- 123 | 124 | -- | Receiver node, a.k.a. a generic 1st round "Lieutenant" 125 | recv :: Int -- ^ receiver id 126 | -> [ChanOutput] -- ^ channels from relays 127 | -> V MsgType 128 | -> Atom () 129 | recv ident inCs vote = period recvPeriod 130 | . atom (tg "recv" ident) $ do 131 | done <- bool "done" False 132 | buffer <- mapM msgVar [ tg (tg "buffer" ident) i | i <- relaySet ] 133 | 134 | -- declare multiple "pollers", one for each buffer location 135 | forM_ relaySet $ \i -> do 136 | atom (tg2 "recv_poll" ident i) $ do 137 | cond $ isMissing (buffer !! i) 138 | condChannel (inCs !! i) 139 | (buffer !! i) <== readChannel (inCs !! i) 140 | 141 | -- declare a voter 142 | atom (tg "recv_vote" ident) $ do 143 | cond $ all_ (not_ . isMissing) buffer 144 | vote <== computeVote (value <$> buffer) 145 | done <== Const True 146 | 147 | -- | Boyer-Moore Fast Majority Vote 148 | computeVote :: [E MsgType] -> E MsgType 149 | computeVote = fst . foldr iter (missingMsgValueE, Const 0) 150 | where 151 | iter x (y, c) = ( mux (x ==. y) onTrue1 onFalse1 152 | , mux (x ==. y) onTrue2 onFalse2) 153 | where 154 | -- rules: 155 | -- if x ==. y, then (y, c+1) 156 | -- else if c == 0, then (x, 1) 157 | -- else (y, c-1) 158 | onTrue1 = y 159 | onTrue2 = c + (Const 1) 160 | onFalse1 = mux (c ==. Const 0) x y 161 | onFalse2 = mux (c ==. Const 0) (Const 1) (c - (Const 1)) 162 | _ = c :: E Int64 163 | 164 | -- | Synchronous observer node; current prints probe values to console at 165 | -- phase 0. This node has no activation or behavior so its part in the model 166 | -- is trivial. 167 | observer :: Atom () 168 | observer = period observerPeriod 169 | . exactPhase 0 170 | . atom "observer" $ do 171 | ps <- probes 172 | mapM_ printProbe ps 173 | ``` 174 | -------------------------------------------------------------------------------- /case-studies/smp/SMP.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : SMP 3 | -- Copyright : Benjamin Jones 2017 4 | -- License : ISC 5 | -- 6 | -- Maintainer : bjones@galois.com 7 | -- Stability : experimental 8 | -- Portability : unknown 9 | -- 10 | -- Simple Message Passing example in LIMA. In this system, node A sends a 11 | -- message to node B. Node B stores the received message and passes it on to 12 | -- node C. 13 | -- 14 | module SMP (module SMP) where 15 | 16 | import Data.Int 17 | 18 | import Language.LIMA 19 | import Language.Sally 20 | 21 | zero :: E Int64 22 | zero = Const 0 23 | zero' :: Int64 24 | zero' = 0 25 | 26 | ans :: E Int64 27 | ans = Const 42 28 | 29 | smp :: Atom () 30 | smp = atom "smp" $ do 31 | 32 | (tx0, rx0) <- channel "atob" Int64 33 | (tx1, rx1) <- channel "btoc" Int64 34 | 35 | atom "nodeA" $ do 36 | done <- var "done" False 37 | -- no cond 38 | done <== true 39 | writeChannel tx0 ans 40 | -- an intentional counterexample 41 | assert "nodeA not done" (not_ (value done)) 42 | 43 | atom "nodeB" $ do 44 | done <- var "done" False 45 | store <- var "store" zero' 46 | cond $ fullChannel rx0 47 | v <- readChannel rx0 48 | store <== v 49 | done <== true 50 | writeChannel tx1 v 51 | -- an intentional counterexample 52 | assert "nodeB not done" (not_ (value done)) 53 | 54 | atom "nodeC" $ do 55 | done <- var "done" False 56 | store <- var "store" zero' 57 | cond $ fullChannel rx1 58 | v <- readChannel rx1 59 | store <== v 60 | done <== true 61 | 62 | -- this property holds 63 | assert "nodeC done" (imply (value done) (value store ==. ans)) 64 | 65 | -------------------------------------------------------------------------------- /case-studies/smp/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /case-studies/smp/build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | git submodule update 4 | 5 | if [ -d .cabal-sandbox ]; then 6 | echo "Skipping sandbox build..." 7 | else 8 | cabal sandbox init 9 | cabal sandbox add-source ../../lima/ 10 | cabal sandbox add-source ../../lima-c/ 11 | cabal sandbox add-source ../../lima-sally/ 12 | cabal sandbox add-source ../../dependencies/language-sally 13 | cabal install --only-dependencies 14 | fi 15 | 16 | cabal configure 17 | cabal build 18 | cabal install 19 | -------------------------------------------------------------------------------- /case-studies/smp/cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | ../../lima/ 3 | ../../lima-c/ 4 | ../../lima-sally/ 5 | ../../dependencies/language-sally 6 | -------------------------------------------------------------------------------- /case-studies/smp/clean.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | rm *.mcmt *.c *.h *.png 3 | -------------------------------------------------------------------------------- /case-studies/smp/lima-smp.cabal: -------------------------------------------------------------------------------- 1 | name: lima-smp 2 | version: 0.1.0.0 3 | synopsis: SMP example in LIMA 4 | author: Benjamin Jones 5 | maintainer: bjones@galois.com 6 | category: Language 7 | build-type: Simple 8 | cabal-version: >=1.10 9 | 10 | executable lima-smp 11 | default-language: Haskell2010 12 | main-is: Main.hs 13 | other-modules: SMP 14 | build-depends: base >= 4.8 && < 5 15 | , lima >= 0.1.0.0 && < 0.2 16 | , lima-c >= 0.1.0.0 && < 0.2 17 | , lima-sally >= 0.1.0.0 && < 0.2 18 | -------------------------------------------------------------------------------- /case-studies/smp/run: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | go=$(find . -name lima-smp | tail -1) 3 | exec "$go" 4 | -------------------------------------------------------------------------------- /cleanup.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | for f in $(find -E . -regex '.*dist-newstyle|.*dist|.*cabal\.project\.local'); 3 | do 4 | echo "Removing $f" 5 | rm -rf "$f" 6 | done 7 | -------------------------------------------------------------------------------- /lima-c/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for lima-c 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /lima-c/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017 Benjamin Jones 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any purpose 4 | with or without fee is hereby granted, provided that the above copyright notice 5 | and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH 8 | REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND 9 | FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, 10 | INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS 11 | OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER 12 | TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF 13 | THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /lima-c/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /lima-c/cabal.sandbox.config: -------------------------------------------------------------------------------- 1 | -- This is a Cabal package environment file. 2 | -- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY. 3 | -- Please create a 'cabal.config' file in the same directory 4 | -- if you want to change the default settings for this sandbox. 5 | 6 | 7 | local-repo: /Users/bjones/galois/affirm-adsl/lima-c/.cabal-sandbox/packages 8 | logs-dir: /Users/bjones/galois/affirm-adsl/lima-c/.cabal-sandbox/logs 9 | world-file: /Users/bjones/galois/affirm-adsl/lima-c/.cabal-sandbox/world 10 | user-install: False 11 | package-db: /Users/bjones/galois/affirm-adsl/lima-c/.cabal-sandbox/x86_64-osx-ghc-8.0.2-packages.conf.d 12 | build-summary: /Users/bjones/galois/affirm-adsl/lima-c/.cabal-sandbox/logs/build.log 13 | 14 | install-dirs 15 | prefix: /Users/bjones/galois/affirm-adsl/lima-c/.cabal-sandbox 16 | bindir: $prefix/bin 17 | libdir: $prefix/lib 18 | libsubdir: $abi/$libname 19 | dynlibdir: $libdir/$abi 20 | libexecdir: $prefix/libexec 21 | datadir: $prefix/share 22 | datasubdir: $abi/$pkgid 23 | docdir: $datadir/doc/$abi/$pkgid 24 | htmldir: $docdir/html 25 | haddockdir: $htmldir 26 | sysconfdir: $prefix/etc 27 | -------------------------------------------------------------------------------- /lima-c/lima-c.cabal: -------------------------------------------------------------------------------- 1 | name: lima-c 2 | version: 0.1.0.0 3 | synopsis: C code generator for LIMA 4 | -- description: 5 | license: ISC 6 | license-file: LICENSE 7 | author: Benjamin Jones 8 | maintainer: bjones@galois.com 9 | copyright: (c) Benjamin Jones 2017 10 | category: Language 11 | build-type: Simple 12 | extra-source-files: ChangeLog.md 13 | cabal-version: >=1.10 14 | 15 | library 16 | default-language: Haskell2010 17 | hs-source-dirs: src 18 | build-depends: base >= 4.8 && < 5 19 | , lima >= 0.1.0.0 20 | , bimap 21 | 22 | exposed-modules: 23 | Language.LIMA.C 24 | Language.LIMA.C.Code 25 | Language.LIMA.C.Compile 26 | Language.LIMA.C.Scheduling 27 | Language.LIMA.C.Example.Channel 28 | Language.LIMA.C.Example.ChannelCond 29 | Language.LIMA.C.Example.External 30 | Language.LIMA.C.Example.Gcd 31 | Language.LIMA.C.Example.Probes 32 | Language.LIMA.C.Example.Periodic 33 | Language.LIMA.C.Util 34 | -------------------------------------------------------------------------------- /lima-c/src/Language/LIMA/C.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Language.LIMA.C 3 | -- Copyright : Tom Hawkins & Lee Pike 2013 and Benjamin Jones 2017 4 | -- License : ISC 5 | -- 6 | -- Maintainer : bjones@galois.com 7 | -- Stability : experimental 8 | -- Portability : unknown 9 | -- 10 | -- Re-export definitions from Language.LIMA.C.* 11 | -- 12 | 13 | module Language.LIMA.C 14 | ( -- * Code 15 | -- | Module: "Language.LIMA.C.Code" 16 | Config (..), defaults, Clock (..), defaultClock, writeC, cType, 17 | RuleCoverage, 18 | -- * Compilation 19 | -- | Module: "Language.LIMA.C.Compile" 20 | compile, CompileResult(..), reportSchedule, Schedule, 21 | -- * Utilities 22 | -- | Module: "Language.LIMA.C.Util" 23 | printString, printE, printProbe 24 | ) where 25 | 26 | import Language.LIMA.C.Code 27 | import Language.LIMA.C.Compile 28 | import Language.LIMA.C.Util 29 | -------------------------------------------------------------------------------- /lima-c/src/Language/LIMA/C/Compile.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Language.LIMA.C.Compile 3 | -- Description: Compilation functions 4 | -- Copyright: (c) 2013 Tom Hawkins & Lee Pike 5 | -- Copyright: (c) 2017 Benjamin Jones 6 | -- 7 | -- LIMA compilation functions 8 | 9 | module Language.LIMA.C.Compile 10 | ( compile 11 | , CompileResult(..) 12 | , reportSchedule 13 | , Schedule 14 | ) where 15 | 16 | import System.Exit 17 | import Control.Monad (when) 18 | import Data.Maybe (isJust) 19 | 20 | import Language.LIMA.Elaboration 21 | import Language.LIMA.UeMap (emptyMap) 22 | import Language.LIMA.Language hiding (Atom) 23 | 24 | import Language.LIMA.C.Code 25 | import Language.LIMA.C.Scheduling 26 | 27 | 28 | -- | Package of all the compilation results 29 | data CompileResult = CompileResult 30 | { compSchedule :: Schedule -- ^ schedule computed by the compiler 31 | , compCoverage :: RuleCoverage -- ^ rule coverage 32 | , compChans :: [ChanInfo] -- ^ channels used in the system 33 | , compAssertNames :: [Name] -- ^ assertion statement names 34 | , compCoverNames :: [Name] -- ^ coverage statement names 35 | , compProbes :: [(Name, Type)] -- ^ declared probe names and types 36 | } 37 | 38 | -- | Compiles an atom description to C. 39 | compile :: Name 40 | -> Config 41 | -> Atom () 42 | -> IO CompileResult 43 | compile name config atom' = do 44 | -- TODO an Atom () -> Atom () rewriting step could be inserted here before 45 | -- elaboration 46 | res <- elaborate defCCtx emptyMap name atom' 47 | case res of 48 | Nothing -> putStrLn "ERROR: Design rule checks failed." >> 49 | exitWith (ExitFailure 1) 50 | Just (umap, (state, rules, chanIns, assertionNames, coverageNames, probeNames)) -> do 51 | -- main code generation step 52 | let sch = schedule rules umap 53 | ruleCoverage <- writeC name config state rules sch assertionNames 54 | coverageNames probeNames 55 | 56 | when (isJust $ hardwareClock config) (putStrLn hwClockWarning) 57 | return $ CompileResult sch ruleCoverage chanIns assertionNames 58 | coverageNames probeNames 59 | 60 | hwClockWarning :: String 61 | hwClockWarning = unlines 62 | [ "" 63 | , "*** LIMA WARNING: you are configuring to use a hardware clock. Please remember" 64 | , " to set the \"__phase_start_time\" variable to the time at which the first" 65 | , " phase should be run before you enter the main LIMA-generated function the" 66 | , " first time." 67 | ] 68 | -------------------------------------------------------------------------------- /lima-c/src/Language/LIMA/C/Example/Channel.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Channel 3 | -- Description: Example design which shows off channels 4 | -- Copyright: (c) 2016 Benjamin Jones 5 | -- 6 | 7 | module Language.LIMA.C.Example.Channel 8 | ( compileExample 9 | , example 10 | ) where 11 | 12 | import Language.LIMA 13 | import Language.LIMA.C 14 | 15 | -- | Invoke the LIMA compiler 16 | compileExample :: IO () 17 | compileExample = do 18 | res <- compile "example" defaults { cCode = prePostCode } example 19 | putStrLn $ reportSchedule (compSchedule res) 20 | 21 | prePostCode :: [Name] -> [Name] -> [(Name, Type)] -> (String, String) 22 | prePostCode _ _ _ = 23 | ( unlines 24 | [ "#include " 25 | , "#include " 26 | , "unsigned long int a = 13;" 27 | , "unsigned long int b = -1;" 28 | , "unsigned char running = 1;" 29 | ] 30 | , unlines 31 | [ "int main(int argc, char* argv[]) {" 32 | , " printf(\"Sending value a = %lu\\n\", a);" 33 | , " while(running) {" 34 | , " example();" 35 | , " printf(\"iteration: a = %lu b = %lu\\n\", a, b);" 36 | , " }" 37 | , " printf(\"Receiver's result: %lu\\n\", b);" 38 | , " return 0;" 39 | , "}" 40 | ] 41 | ) 42 | 43 | -- | An example design that computes the greatest common divisor. 44 | example :: Atom () 45 | example = do 46 | 47 | -- External reference to value A. 48 | let a = word32' "a" 49 | 50 | -- External reference to value B. 51 | let b = word32' "b" 52 | 53 | -- The external running flag. 54 | let running = bool' "running" 55 | 56 | -- Setup channel from node A to node B 57 | (cin, cout) <- channel "A_to_B" Word32 58 | 59 | -- A rule to send value of 'a' 60 | atom "node_A" $ do 61 | cond $ value a >. Const 0 62 | writeChannel cin (value a) 63 | 64 | -- A rule to receive a value from the channel 65 | atom "node_B" $ do 66 | cond $ fullChannel cout 67 | b' <- readChannel cout 68 | b <== b' 69 | 70 | -- A rule to clear the running flag. 71 | atom "stop" $ do 72 | cond $ value a ==. value b 73 | running <== false 74 | 75 | -------------------------------------------------------------------------------- /lima-c/src/Language/LIMA/C/Example/ChannelCond.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: ChannelCond 3 | -- Description: Example design which shows off the two different channel 4 | -- 'cond' primitives 5 | -- Copyright: (c) 2017 Benjamin Jones 6 | -- 7 | 8 | module Language.LIMA.C.Example.ChannelCond 9 | ( compileExample 10 | , example 11 | ) where 12 | 13 | import Language.LIMA 14 | import Language.LIMA.C 15 | 16 | -- | Invoke the LIMA compiler 17 | compileExample :: IO () 18 | compileExample = do 19 | res <- compile "example" defaults { cCode = prePostCode } example 20 | putStrLn $ reportSchedule (compSchedule res) 21 | 22 | prePostCode :: [Name] -> [Name] -> [(Name, Type)] -> (String, String) 23 | prePostCode _ _ _ = 24 | ( unlines 25 | [ "#include " 26 | , "#include " 27 | , "unsigned long int a = 13;" 28 | , "unsigned long int b = -1;" 29 | , "unsigned char running = 1;" 30 | ] 31 | , unlines 32 | [ "int main(int argc, char* argv[]) {" 33 | , " printf(\"Sending value a = %lu\\n\", a);" 34 | , " while(running) {" 35 | , " example();" 36 | , " printf(\"iteration: a = %lu b = %lu\\n\", a, b);" 37 | , " }" 38 | , " printf(\"Receiver's result: %lu\\n\", b);" 39 | , " return 0;" 40 | , "}" 41 | ] 42 | ) 43 | 44 | -- | An example design 45 | example :: Atom () 46 | example = do 47 | 48 | -- External reference to value A. 49 | let a = word32' "a" 50 | 51 | -- External reference to value B. 52 | let b = word32' "b" 53 | 54 | -- The external running flag. 55 | let running = bool' "running" 56 | 57 | subCounter <- int64 "subCounter" 0 58 | probe "subCounter" (value subCounter) 59 | 60 | -- Setup channel from node A to node B 61 | (cin, cout) <- channel "A_to_B" Word32 62 | 63 | -- A rule to send value of 'a' 64 | atom "node_A" $ do 65 | cond $ value running 66 | writeChannel cin (value a) 67 | 68 | -- A rule to receive a value from the channel 69 | atom "node_B" $ do 70 | cond' $ fullChannel cout 71 | b' <- readChannel cout 72 | b <== b' 73 | 74 | -- Sub-atom of node B 75 | atom "sub_node_B" $ do 76 | cond $ value running 77 | incr subCounter 78 | 79 | -- A rule to clear the running flag. 80 | atom "stop" $ do 81 | cond $ value a ==. value b 82 | running <== false 83 | 84 | mapM_ printProbe =<< probes 85 | -------------------------------------------------------------------------------- /lima-c/src/Language/LIMA/C/Example/External.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module: External 3 | Description: Example of referencing external variables and functions in LIMA 4 | Copyright: (c) 2015 Chris Hodapp 5 | 6 | This demonstrates the use of 'word16'' to reference an external variable, and 7 | the use of 'call' to call an external function. 8 | 9 | -} 10 | module Language.LIMA.C.Example.External 11 | (module Language.LIMA.C.Example.External) 12 | where 13 | 14 | import Language.LIMA 15 | import Language.LIMA.C 16 | 17 | -- | Invoke the LIMA compiler 18 | main :: IO () 19 | main = do 20 | let atomCfg = defaults { cCode = prePostCode , cRuleCoverage = False } 21 | r <- compile "extern_example" atomCfg extern 22 | putStrLn $ reportSchedule (compSchedule r) 23 | 24 | -- | Top-level rule 25 | extern :: Atom () 26 | extern = do 27 | 28 | -- External reference to a variable 'g_random' which is a uint16: 29 | let rng = word16' "g_random" 30 | 31 | atom "update" $ do 32 | -- Call external function 'new_random' which updates g_random: 33 | call "new_random" 34 | printE "PRId16" "g_random" $ value rng 35 | 36 | prePostCode :: [Name] -> [Name] -> [(Name, Type)] -> (String, String) 37 | prePostCode _ _ _ = 38 | ( unlines [ "// ---- This source is automatically generated by LIMA ----" 39 | , "#include " 40 | , "#include " 41 | , "#include " 42 | , "" 43 | -- Declarations of what we reference above: 44 | , "static uint16_t g_random = 0;" 45 | , "void new_random(void);" 46 | ] 47 | , unlines [ "int main(void) {" 48 | , " while (true) {" 49 | , " extern_example();" 50 | , " usleep(1000);" 51 | , " }" 52 | , " return 0;" 53 | , "}" 54 | , "" 55 | -- And the function definition: 56 | , "void new_random(void) {" 57 | , " g_random = rand();" 58 | , "}" 59 | , "// ---- End automatically-generated source ----" 60 | ]) 61 | -------------------------------------------------------------------------------- /lima-c/src/Language/LIMA/C/Example/Gcd.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Gcd 3 | -- Description: Example design which computes GCD (greatest-common divisor) 4 | -- Copyright: (c) 2013 Tom Hawkins & Lee Pike 5 | -- 6 | 7 | module Language.LIMA.C.Example.Gcd 8 | ( compileExample 9 | , example 10 | ) where 11 | 12 | import Language.LIMA 13 | import Language.LIMA.C 14 | 15 | -- | Invoke the LIMA compiler 16 | compileExample :: IO () 17 | compileExample = do 18 | r <- compile "example" defaults { cCode = prePostCode } example 19 | putStrLn $ reportSchedule (compSchedule r) 20 | 21 | prePostCode :: [Name] -> [Name] -> [(Name, Type)] -> (String, String) 22 | prePostCode _ _ _ = 23 | ( unlines 24 | [ "#include " 25 | , "#include " 26 | , "unsigned long int a;" 27 | , "unsigned long int b;" 28 | , "unsigned long int x;" 29 | , "unsigned char running = 1;" 30 | ] 31 | , unlines 32 | [ "int main(int argc, char* argv[]) {" 33 | , " if (argc < 3) {" 34 | , " printf(\"usage: gcd \\n\");" 35 | , " }" 36 | , " else {" 37 | , " a = atoi(argv[1]);" 38 | , " b = atoi(argv[2]);" 39 | , " printf(\"Computing the GCD of %lu and %lu...\\n\", a, b);" 40 | , " while(running) {" 41 | , " example();" 42 | , " printf(\"iteration: a = %lu b = %lu\\n\", a, b);" 43 | , " }" 44 | , " printf(\"GCD result: %lu\\n\", a);" 45 | , " }" 46 | , " return 0;" 47 | , "}" 48 | ] 49 | ) 50 | 51 | -- | An example design that computes the greatest common divisor. 52 | example :: Atom () 53 | example = do 54 | 55 | -- External reference to value A. 56 | let a = word32' "a" 57 | 58 | -- External reference to value B. 59 | let b = word32' "b" 60 | 61 | -- The external running flag. 62 | let running = bool' "running" 63 | 64 | -- A rule to modify A. 65 | atom "a_minus_b" $ do 66 | cond $ value a >. value b 67 | a <== value a - value b 68 | 69 | -- A rule to modify B. 70 | atom "b_minus_a" $ do 71 | cond $ value b >. value a 72 | b <== value b - value a 73 | 74 | -- A rule to clear the running flag. 75 | atom "stop" $ do 76 | cond $ value a ==. value b 77 | running <== false 78 | 79 | -------------------------------------------------------------------------------- /lima-c/src/Language/LIMA/C/Example/Periodic.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Periodic 3 | -- Description: Example design which shows off periodic Atoms 4 | -- Copyright: (c) 2017 Benjamin Jones 5 | -- 6 | 7 | module Language.LIMA.C.Example.Periodic 8 | ( compileExample 9 | , example 10 | ) where 11 | 12 | import Language.LIMA 13 | import Language.LIMA.C 14 | 15 | -- | Invoke the LIMA compiler 16 | compileExample :: IO () 17 | compileExample = do 18 | let cfg = defaults { cCode = prePostCode } 19 | CompileResult schedule _ _ _ _ _ <- compile "example" cfg example 20 | putStrLn $ reportSchedule schedule 21 | 22 | prePostCode :: [Name] -> [Name] -> [(Name, Type)] -> (String, String) 23 | prePostCode _ _ _ = 24 | ( unlines 25 | [ "#include " 26 | , "#include " 27 | ] 28 | , unlines 29 | [ "int main(int argc, char* argv[]) {" 30 | , " while (1) {" 31 | , " example();" 32 | , " usleep(1000);" 33 | , " }" 34 | , " return 0;" 35 | , "}" 36 | ] 37 | ) 38 | 39 | -- | An example design that executes multiple tasks with different 40 | -- periodicity. 41 | example :: Atom () 42 | example = atom "top_level" $ do 43 | counter <- int64 "top_counter" 0 44 | probe "counter" (value counter) 45 | incr counter -- increments every tick 46 | 47 | period 4 $ atom "period_4_atom" $ do 48 | counter4 <- int64 "counter4" 0 49 | probe "counter4" (value counter4) 50 | incr counter4 -- increments every 4 ticks 51 | 52 | period 2 $ atom "period_4_2_atom" $ do 53 | counter42 <- int64 "counter_4_2" 0 54 | probe "counter42" (value counter42) 55 | incr counter42 -- increments every 2 ticks 56 | 57 | period 4 $ atom "period_4_4_atom" $ do 58 | counter44 <- int64 "counter_4_4" 0 59 | probe "counter44" (value counter44) 60 | incr counter44 -- increments every 4 ticks 61 | 62 | printAllProbes 63 | 64 | -- | Print to stdout all probe values 65 | printAllProbes :: Atom () 66 | printAllProbes = mapM_ printProbe =<< probes 67 | -------------------------------------------------------------------------------- /lima-c/src/Language/LIMA/C/Example/Probes.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module: Probes 3 | Description: Example usage of probes in LIMA 4 | Copyright: (c) 2015 Chris Hodapp 5 | 6 | This demonstrates the usage of LIMA's probe functionality. In this case, it 7 | simply uses @printf@ to log a probe's value. Most POSIX systems should be able 8 | to build and run the generated C code. 9 | 10 | -} 11 | module Language.LIMA.C.Example.Probes where 12 | 13 | import Data.Word 14 | import Language.LIMA 15 | import Language.LIMA.C 16 | 17 | -- | Invoke the LIMA compiler 18 | main :: IO () 19 | main = do 20 | let atomCfg = defaults { cCode = prePostCode , cRuleCoverage = False } 21 | r <- compile "probe_example" atomCfg example 22 | putStrLn $ reportSchedule (compSchedule r) 23 | 24 | -- | Generate a code comment about the given probe. 25 | probeStr :: (Name, Type) -> String 26 | probeStr (n, t) = "// Probe: " ++ n ++ ", type: " ++ show t 27 | 28 | -- | Use 'action' to call @PROBE_PRINTF@ on a probe given as (name, value). 29 | -- This will work only on integer-valued probes. 30 | logProbe :: (String, UE) -> Atom () 31 | logProbe (str, ue_) = action probeFn [ue_] 32 | where probeFn v = "PROBE_PRINTF(\"%u, " ++ str ++ 33 | ": %i\\n\", __global_clock, " ++ head v ++ ")" 34 | 35 | -- | Top-level rule 36 | example :: Atom () 37 | example = do 38 | 39 | -- Include in the once-per-second clock: 40 | sec <- tickSecond 41 | 42 | -- Compute minutes and hours as well (probes take arbitrary expressions): 43 | probe "Minutes" $ (value sec) `div_` 60 44 | probe "Hours" $ (value sec) `div_` 3600 45 | 46 | -- At 1/200 of our base rate (~ 5 seconds), we call 'logProbe' on all of the 47 | -- probes that are in use. 48 | period 200 $ atom "monitor" $ do 49 | mapM_ logProbe =<< probes 50 | 51 | prePostCode :: [Name] -> [Name] -> [(Name, Type)] -> (String, String) 52 | prePostCode _ _ probeList = 53 | ( unlines $ [ "// ---- This source is automatically generated by LIMA ----" 54 | , "#define PROBE_PRINTF printf" 55 | , "#include " 56 | , "#include " 57 | , "#include " 58 | ] ++ map probeStr probeList 59 | -- Basic stub to call with a 1 millisecond delay (do not attempt anything like 60 | -- this in production - use an interrupt): 61 | , unlines [ "int main(void) {" 62 | , " while (true) {" 63 | , " probe_example();" 64 | , " usleep(1000);" 65 | , " }" 66 | , " return 0;" 67 | , "}" 68 | , "// ---- End automatically-generated source ----" 69 | ]) 70 | 71 | -- | Count up seconds of runtime, assuming our base rate is 1 millisecond: 72 | tickSecond :: Atom (V Word64) 73 | tickSecond = do 74 | 75 | sec <- word64 "seconds" 0 76 | 77 | -- Add a probe to the clock: 78 | probe "Seconds" $ value sec 79 | 80 | period 1000 $ exactPhase 0 $ atom "second" $ incr sec 81 | 82 | return sec 83 | -------------------------------------------------------------------------------- /lima-c/src/Language/LIMA/C/Scheduling.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Language.LIMA.C.Scheduling 3 | -- Description: Rule scheduling 4 | -- Copyright: (c) 2013 Tom Hawkins & Lee Pike 5 | -- Copyright: (c) 2017 Benjamin Jones 6 | -- 7 | -- Algorithms for scheduling rules in LIMA 8 | 9 | module Language.LIMA.C.Scheduling 10 | ( schedule 11 | , Schedule 12 | , reportSchedule 13 | ) where 14 | 15 | import Text.Printf 16 | import Data.List 17 | 18 | import Language.LIMA.Analysis 19 | import Language.LIMA.Elaboration 20 | import Language.LIMA.UeMap 21 | 22 | -- | Schedule expressed as a 'UeMap' and a list of (period, phase, rules). 23 | type Schedule = (UeMap, [(Int, Int, [Rule])]) 24 | 25 | schedule :: [Rule] -> UeMap -> Schedule 26 | schedule rules' mp = (mp, concatMap spread periods) 27 | where 28 | rules = [ r | r@(Rule{}) <- rules' ] 29 | 30 | -- Algorithm for assigning rules to phases for a given period 31 | -- (assuming they aren't given an exact phase): 32 | 33 | -- 1. List the rules by their offsets, highest first. 34 | 35 | -- 2. If the list is empty, stop. 36 | 37 | -- 3. Otherwise, take the head of the list and assign its phase as follows: 38 | -- find the set of phases containing the minimum number of rules such that 39 | -- they are at least as large as the rule's offset. Then take the smallest 40 | -- of those phases. 41 | 42 | -- 4. Go to (2). 43 | 44 | -- Algorithm properties: for each period, 45 | 46 | -- A. Each rule is scheduled no earlier than its offset. 47 | 48 | -- B. The phase with the most rules is the minimum of all possible schedules 49 | -- that satisfy (A). 50 | 51 | -- XXX Check if this is true. 52 | -- C. The sum of the difference between between each rule's offset and it's 53 | -- scheduled phase is the minimum of all schedules satisfying (A) and (B). 54 | 55 | spread :: (Int, [Rule]) -> [(Int, Int, [Rule])] 56 | spread (period, rules_) = 57 | placeRules (placeExactRules (replicate period []) exactRules) 58 | orderedByPhase 59 | where 60 | (minRules,exactRules) = partition (\r -> case rulePhase r of 61 | MinPhase _ -> True 62 | ExactPhase _ -> False) rules_ 63 | placeExactRules :: [[Rule]] -> [Rule] -> [[Rule]] 64 | placeExactRules ls [] = ls 65 | placeExactRules ls (r:rst) = placeExactRules (insertAt (getPh r) r ls) 66 | rst 67 | 68 | orderedByPhase :: [Rule] 69 | orderedByPhase = sortBy (\r0 r1 -> compare (getPh r1) (getPh r0)) minRules 70 | getPh r = case rulePhase r of 71 | MinPhase i -> i 72 | ExactPhase i -> i 73 | 74 | -- Initially, ls contains all the exactPhase rules. We put rules in those 75 | -- lists according to the algorithm, and then filter out the phase-lists 76 | -- with no rules. 77 | placeRules :: [[Rule]] -> [Rule] -> [(Int, Int, [Rule])] 78 | placeRules ls [] = filter (\(_,_,rls) -> not (null rls)) 79 | (zip3 (repeat period) [0..(period-1)] ls) 80 | placeRules ls (r:rst) = placeRules (insertAt (lub r ls) r ls) rst 81 | 82 | lub :: Rule -> [[Rule]] -> Int 83 | lub r ls = let minI = getPh r 84 | lub' i [] = i -- unreachable. Included to prevent missing 85 | -- cases ghc warnings. 86 | lub' i ls_ | (head ls_) == minimum ls_ = i 87 | | otherwise = lub' (i+1) (tail ls_) 88 | in lub' minI (drop minI $ map length ls) 89 | 90 | -- Cons rule r onto the list at index i in ls. 91 | insertAt :: Int -> Rule -> [[Rule]] -> [[Rule]] 92 | insertAt i r ls = (take i ls) ++ ((r:(ls !! i)):(drop (i+1) ls)) 93 | 94 | periods = foldl grow [] [ (rulePeriod r, r) | r <- rules ] 95 | 96 | grow :: [(Int, [Rule])] -> (Int, Rule) -> [(Int, [Rule])] 97 | grow [] (a, b) = [(a, [b])] 98 | grow ((a, bs):rest) (a', b) | a' == a = (a, b : bs) : rest 99 | | otherwise = (a, bs) : grow rest (a', b) 100 | 101 | -- | Generate a rule scheduling report for the given schedule. 102 | reportSchedule :: Schedule -> String 103 | reportSchedule (mp, schedule_) = concat 104 | [ "Rule Scheduling Report\n\n" 105 | , "Period Phase Exprs Rule\n" 106 | , "------ ----- ----- ----\n" 107 | , concatMap (reportPeriod mp) schedule_ 108 | , " -----\n" 109 | , printf " %5i\n" $ sum $ map (ruleComplexity mp) rules 110 | , "\n" 111 | , "Hierarchical Expression Count\n\n" 112 | , " Total Local Rule\n" 113 | , " ------ ------ ----\n" 114 | , reportUsage "" $ usage mp rules 115 | , "\n" 116 | ] 117 | where 118 | rules = concat $ [ r | (_, _, r) <- schedule_ ] 119 | 120 | reportPeriod :: UeMap -> (Int, Int, [Rule]) -> String 121 | reportPeriod mp (period, phase, rules) = concatMap reportRule rules 122 | where 123 | reportRule :: Rule -> String 124 | reportRule rule = printf "%6i %5i %5i %s\n" period phase (ruleComplexity mp rule) (show rule) 125 | 126 | 127 | data Usage = Usage String Int [Usage] deriving Eq 128 | 129 | instance Ord Usage where compare (Usage a _ _) (Usage b _ _) = compare a b 130 | 131 | reportUsage :: String -> Usage -> String 132 | reportUsage i node@(Usage name n subs) = printf " %6i %6i %s\n" (totalComplexity node) n (i ++ name) ++ concatMap (reportUsage (" " ++ i)) subs 133 | 134 | totalComplexity :: Usage -> Int 135 | totalComplexity (Usage _ n subs) = n + sum (map totalComplexity subs) 136 | 137 | usage :: UeMap -> [Rule] -> Usage 138 | usage mp = head . foldl insertUsage [] . map (usage' mp) 139 | 140 | usage' :: UeMap -> Rule -> Usage 141 | usage' mp rule = f $ split $ ruleName rule 142 | where 143 | f :: [String] -> Usage 144 | f [] = undefined 145 | f [name] = Usage name (ruleComplexity mp rule) [] 146 | f (name:names) = Usage name 0 [f names] 147 | 148 | split :: String -> [String] 149 | split "" = [] 150 | split s = a : if null b then [] else split (tail b) where (a,b) = span (/= '.') s 151 | 152 | insertUsage :: [Usage] -> Usage -> [Usage] 153 | insertUsage [] u = [u] 154 | insertUsage (a@(Usage n1 i1 s1) : rest) b@(Usage n2 i2 s2) | n1 == n2 = Usage n1 (max i1 i2) (sort $ foldl insertUsage s1 s2) : rest 155 | | otherwise = a : insertUsage rest b 156 | -------------------------------------------------------------------------------- /lima-c/src/Language/LIMA/C/Util.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Util 3 | -- Description: reporting & debugging 4 | -- Copyright: (c) 2013 Tom Hawkins & Lee Pike 5 | -- Copyright: (c) 2017 Benjamin Jones 6 | -- 7 | -- reporting & debugging for LIMA 8 | 9 | module Language.LIMA.C.Util 10 | ( -- * Printing Utilities 11 | printString 12 | , printE 13 | , printProbe 14 | ) where 15 | 16 | import Control.Monad 17 | import Data.Bits 18 | import Data.Int 19 | import Data.List 20 | import Data.Word 21 | import Text.Printf 22 | 23 | import Language.LIMA 24 | 25 | 26 | -- | Print a string in C using @printf@, appending a newline. 27 | printString :: String -> Atom () 28 | printString s = action (\ _ -> "printf(\"" ++ s ++ "\\n\")") [] 29 | 30 | -- | Print an integral value in C using @printf@. 31 | printE :: Expr a 32 | => String -- ^ printf format string to use 33 | -> String -- ^ Prefix for printed value 34 | -> E a -- ^ Integral value to print 35 | -> Atom () 36 | printE fmt name' value' = 37 | action (\ v' -> concat ["printf(\"", name', ": %\" ", fmt, " \"\\n\", " 38 | , head v', ")" 39 | ]) 40 | [ue value'] 41 | 42 | -- | Print the value of a probe to the console (along with its name). 43 | printProbe :: (String, UE) -> Atom () 44 | printProbe (str, ue_) = 45 | let t = typeOf ue_ 46 | fmt = printfFmt t 47 | in case t of 48 | Bool -> printE fmt str (ruInt :: E Int8) 49 | Int8 -> printE fmt str (ruInt :: E Int8) 50 | Int16 -> printE fmt str (ruInt :: E Int16) 51 | Int32 -> printE fmt str (ruInt :: E Int32) 52 | Int64 -> printE fmt str (ruInt :: E Int64) 53 | Word8 -> printE fmt str (ruInt :: E Word8) 54 | Word16 -> printE fmt str (ruInt :: E Word16) 55 | Word32 -> printE fmt str (ruInt :: E Word32) 56 | Word64 -> printE fmt str (ruInt :: E Word64) 57 | Double -> printE fmt str (ruFloat :: E Double) 58 | Float -> printE fmt str (ruFloat :: E Float) 59 | where ruInt :: E a 60 | ruInt = Retype ue_ 61 | ruFloat :: E a 62 | ruFloat = Retype ue_ 63 | 64 | printfFmt :: Type -> String 65 | printfFmt Bool = "\"d\"" 66 | printfFmt Int8 = "PRId8" -- these macros require 67 | printfFmt Int16 = "PRId16" 68 | printfFmt Int32 = "PRId32" 69 | printfFmt Int64 = "PRId64" 70 | printfFmt Word8 = "PRIu8" 71 | printfFmt Word16 = "PRIu16" 72 | printfFmt Word32 = "PRIu32" 73 | printfFmt Word64 = "PRIu64" 74 | printfFmt Float = "\"f\"" 75 | printfFmt Double = "\"f\"" 76 | -------------------------------------------------------------------------------- /lima-sally/.gitignore: -------------------------------------------------------------------------------- 1 | .cabal-sandbox/ 2 | cabal.sandbox.config 3 | dist/ 4 | deps 5 | test/*.c 6 | test/*.h 7 | .hlint.yaml 8 | tags 9 | -------------------------------------------------------------------------------- /lima-sally/.travis.yml: -------------------------------------------------------------------------------- 1 | # This file has been modified from the original generated version -- see 2 | # https://github.com/hvr/multi-ghc-travis 3 | language: c 4 | sudo: false 5 | 6 | matrix: 7 | include: 8 | - env: CABALVER=1.24 GHCVER=7.10.3 9 | compiler: ": #GHC 7.10.3" 10 | addons: {apt: {packages: [cabal-install-1.24,ghc-7.10.3,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}} 11 | - env: CABALVER=1.24 GHCVER=8.0.1 12 | compiler: ": #GHC 8.0.1" 13 | addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}} 14 | 15 | before_install: 16 | - unset CC 17 | - export HAPPYVER=1.19.5 18 | - export ALEXVER=3.1.7 19 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:/opt/happy/$HAPPYVER/bin:/opt/alex/$ALEXVER/bin:$PATH 20 | 21 | install: 22 | - cabal --version 23 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 24 | - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ]; 25 | then 26 | zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz > 27 | $HOME/.cabal/packages/hackage.haskell.org/00-index.tar; 28 | fi 29 | - travis_retry cabal update -v 30 | - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config 31 | 32 | # Here starts the actual work to be performed for the package under test; 33 | # any command which exits with a non-zero exit code causes the build to fail. 34 | script: 35 | - cabal check || true 36 | - bash install.sh 37 | - cabal sdist 38 | 39 | # EOF 40 | -------------------------------------------------------------------------------- /lima-sally/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for atom-sally 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /lima-sally/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016, Benjamin Jones 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Benjamin Jones nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /lima-sally/README.md: -------------------------------------------------------------------------------- 1 | # LIMA to Sally Translator 2 | 3 | [![Build Status](https://travis-ci.org/GaloisInc/lima.svg?branch=master)](https://travis-ci.org/GaloisInc/lima) 4 | 5 | This is a library for translating [LIMA](https://github.com/galoisinc) to the 6 | input language of [Sally](https://github.com/SRI-CSL/sally). 7 | 8 | See the README for the overall LIMA project [here](https://github.com/galoisinc). 9 | 10 | This is a work in progress, please check back soon! 11 | -------------------------------------------------------------------------------- /lima-sally/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /lima-sally/build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | cabal sandbox init 4 | cabal sandbox add-source ../lima 5 | cabal sandbox add-source ../dependencies/language-sally 6 | 7 | cabal configure --enable-tests 8 | cabal install --only-dependencies 9 | cabal build 10 | 11 | cabal test 12 | -------------------------------------------------------------------------------- /lima-sally/lima-sally.cabal: -------------------------------------------------------------------------------- 1 | name: lima-sally 2 | version: 0.1.0.0 3 | synopsis: Translator from LIMA to Sally 4 | description: This library is a translator that takes (distributed) 5 | Atom specifications and produces transition system models 6 | in the Sally (https://github.com/SRI-CSL/sally) input language. 7 | 8 | license: ISC 9 | license-file: LICENSE 10 | author: Benjamin F Jones 11 | maintainer: bjones@galois.com 12 | copyright: Galois, Inc. 2016 13 | category: Language 14 | build-type: Simple 15 | extra-source-files: ChangeLog.md 16 | cabal-version: >=1.10 17 | 18 | flag develop 19 | Description: Turn off compiler optimization during development 20 | Manual: True 21 | Default: False 22 | 23 | library 24 | exposed-modules: Language.Sally 25 | , Language.Sally.Config 26 | , Language.Sally.FaultModel 27 | , Language.Sally.Translation 28 | 29 | build-depends: base >= 4.8 && < 5 30 | , bytestring >= 0.10.6 31 | , containers >= 0.5 32 | , text >= 1.2 33 | , wl-pprint-text >= 1.1 34 | , lima >= 0.1.0.0 35 | , filepath >= 1.4.1 36 | , language-sally >= 0.1.1.0 37 | 38 | hs-source-dirs: src 39 | default-language: Haskell2010 40 | 41 | ghc-options: -Wall 42 | if flag(develop) 43 | ghc-options: -Wall -O0 44 | 45 | test-suite atom-sally-test 46 | type: exitcode-stdio-1.0 47 | hs-source-dirs: test 48 | main-is: Spec.hs 49 | build-depends: base 50 | , lima-sally >= 0.1.0.0 51 | , lima >= 0.1.0.0 52 | , containers >= 0.5 53 | , filepath >= 1.4.1 54 | 55 | default-language: Haskell2010 56 | -------------------------------------------------------------------------------- /lima-sally/src/Language/Sally.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Language.Sally 3 | -- Copyright : Benjamin F Jones 2016 4 | -- License : BSD3 5 | -- 6 | -- Maintainer : benjaminfjones@gmail.com 7 | -- Stability : experimental 8 | -- Portability : unknown 9 | -- 10 | -- Module for exporting the translator API. 11 | 12 | module Language.Sally ( 13 | -- * Language.Sally 14 | compileToSally 15 | -- * Language.Sally.PPrint 16 | , hPutSystem 17 | , putSystemLn 18 | -- * Language.Sally.Translation 19 | , translaborate 20 | -- * Language.Sally.Config 21 | , TrConfig(..) 22 | , FaultAssump(..) 23 | , defaultCfg 24 | , hybridMFA 25 | -- * Language.Sally.FaultModel 26 | , module Language.Sally.FaultModel 27 | -- * Language.Sally.Types 28 | , nameFromS 29 | , nameFromT 30 | ) where 31 | 32 | import System.IO 33 | import Language.LIMA 34 | 35 | import Language.Sally.Config 36 | import Language.Sally.FaultModel 37 | import Language.Sally.PPrint 38 | import Language.Sally.Translation 39 | import Language.Sally.Types 40 | 41 | 42 | -- | Compile an Atom specification to Sally model. 43 | -- 44 | -- Configuration and query string are currently optional. The resulting model 45 | -- is written to the filename 'fname' on disk. 46 | compileToSally 47 | :: String -- ^ specification name 48 | -> TrConfig -- ^ translator configuration 49 | -> FilePath -- ^ file to write compiled model to 50 | -> Atom () -- ^ Atom spec to compile 51 | -> Maybe String -- ^ (optional) query string to append to the model 52 | -> IO () 53 | compileToSally nm config fname spec mQuery = do 54 | tr <- translaborate (nameFromS nm) config spec 55 | withFile fname WriteMode $ \h -> do 56 | hPutSystem h tr 57 | case mQuery of 58 | Just q -> do 59 | hPutStrLn h "\n\n;; Query" 60 | hPutStrLn h q 61 | Nothing -> return () 62 | -------------------------------------------------------------------------------- /lima-sally/src/Language/Sally/Config.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Language.Sally.Config 3 | -- Copyright : Galois Inc. 2016 4 | -- License : BSD3 5 | -- 6 | -- Maintainer : bjones@galois.com 7 | -- Stability : experimental 8 | -- Portability : unknown 9 | -- 10 | -- Translation configuration, including settings for the fault model, 11 | -- the way variables are rendered, etc. 12 | -- 13 | module Language.Sally.Config 14 | ( TrConfig(..) 15 | , FaultAssump(..) 16 | , defaultCfg 17 | , hybridMFA 18 | , Weights 19 | ) where 20 | 21 | import Language.Sally.FaultModel 22 | import Language.Sally.Types 23 | import Data.Map.Strict (Map) 24 | import qualified Data.Map.Strict as Map 25 | 26 | 27 | -- | Translation configuration, including settings for the fault model. 28 | data TrConfig = TrConfig 29 | { -- | maximum fault assumption / fault model to use 30 | cfgMFA :: FaultAssump 31 | -- | use top-level name space in variables names? 32 | -- TODO this doesn't work currently because of 33 | -- the way Atom generates names during 34 | -- 'elaborate' 35 | , cfgTopNameSpace :: Bool 36 | -- | turn debugging output on, causes extra variables and 37 | -- transitions to be generated that aid in 38 | -- debugging 39 | , cfgDebug :: Bool 40 | , cfgMessageDelay :: Rational 41 | } 42 | 43 | -- | Default configuration 44 | defaultCfg :: TrConfig 45 | defaultCfg = TrConfig 46 | { cfgMFA = NoFaults 47 | , cfgTopNameSpace = True 48 | , cfgDebug = False 49 | , cfgMessageDelay = 1 50 | } 51 | 52 | -- | Assignment of weights to each fault type 53 | type Weights = Map FaultType Int 54 | 55 | -- | Type representing possible fault model assumptions 56 | data FaultAssump = 57 | -- | No faulty nodes 58 | NoFaults 59 | -- | Hybrid faults with weights and a constant term 60 | -- TODO: elaborate 61 | | HybridFaults Weights Int 62 | -- | Fixed configuration of faulty nodes. Nodes not specified are assigned 63 | -- 'NonFaulty'. 64 | | FixedFaults (Map Name FaultType) 65 | 66 | -- | An example fault type weighting that is appropriate for systems like 67 | -- OM(1). 68 | hybridMFA :: FaultAssump 69 | hybridMFA = 70 | let ws = [ (NonFaulty, 0) 71 | , (ManifestFaulty , 1) 72 | , (SymmetricFaulty, 2) 73 | , (ByzantineFaulty, 3) 74 | ] 75 | in HybridFaults (Map.fromList ws) 1 76 | -------------------------------------------------------------------------------- /lima-sally/src/Language/Sally/FaultModel.hs: -------------------------------------------------------------------------------- 1 | module Language.Sally.FaultModel 2 | ( FaultType(..) 3 | , faultTypeMin 4 | , faultTypeMax 5 | ) 6 | where 7 | 8 | import Language.Sally.Types 9 | 10 | 11 | -- | Enumerate the types of faults that a node can have in our model. 12 | data FaultType = NonFaulty 13 | | ManifestFaulty 14 | | SymmetricFaulty 15 | | ByzantineFaulty 16 | deriving (Eq, Ord, Show, Enum, Bounded) 17 | 18 | faultTypeMin :: Int 19 | faultTypeMin = fromEnum (minBound :: FaultType) 20 | 21 | faultTypeMax :: Int 22 | faultTypeMax = fromEnum (maxBound :: FaultType) 23 | 24 | -- | Turn fault types into integers for the Sally encoding 25 | instance ToSallyExpr FaultType where 26 | toSallyExpr = SELit . SConstInt . fromIntegral . fromEnum 27 | -------------------------------------------------------------------------------- /lima-sally/test/.gitignore: -------------------------------------------------------------------------------- 1 | *.mcmt 2 | -------------------------------------------------------------------------------- /lima-sally/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import Data.Int 6 | import qualified Data.Map.Strict as Map 7 | import System.FilePath.Posix 8 | 9 | import Language.LIMA hiding (compile) 10 | import Language.Sally 11 | 12 | testDir :: FilePath 13 | testDir = "test" 14 | 15 | type MsgType = Int64 16 | 17 | msgType :: Type 18 | msgType = Int64 -- Atom 'Type' value 19 | 20 | -- Test Atoms ----------------------------------------------------------- 21 | 22 | 23 | -- | 'x' starts at 0, increases each tick up to 10 24 | -- Property: G(atom1!x >= 0) 25 | atom1 :: Atom () 26 | atom1 = atom "atom1" $ do 27 | x <- int8 "x" 0 28 | cond $ value x <. 10 29 | x <== value x + 1 30 | 31 | 32 | -- | Two Atoms communicate through a flag 33 | -- Property: G(atom2!alice!a => atom2!flag) 34 | atom2 :: Atom() 35 | atom2 = atom "atom2" $ do 36 | f <- bool "flag" False 37 | 38 | atom "alice" $ do 39 | a <- bool "a" False 40 | cond (value f) 41 | a <== true 42 | 43 | atom "bob" $ do 44 | f <== true 45 | 46 | 47 | -- | Two Atoms communicate through a *channel* 48 | -- Property: G((/= atom3!bob!msg -1) => atom3!alice!done) 49 | -- F((/= atom3!bob!msg -1)) 50 | atom3 :: Atom() 51 | atom3 = atom "atom3" $ do 52 | 53 | let 54 | -- | Special message values indicating "no message present", and "correct 55 | -- (intended) message" 56 | missingMsgValue = -1 :: MsgType 57 | goodMsgValue = 1 :: MsgType 58 | 59 | (cin, cout) <- channel "aTob" msgType 60 | 61 | atom "alice" $ do 62 | done <- bool "done" False 63 | cond $ not_ (value done) 64 | writeChannel cin (Const goodMsgValue) 65 | done <== true 66 | 67 | atom "bob" $ do 68 | msg <- int64 "msg" missingMsgValue 69 | cond $ fullChannel cout 70 | v <- readChannel cout 71 | msg <== v 72 | 73 | -- | A minimal version of atom3, where two agents commicate one message over a 74 | -- channel. This version has no "done" flags. 75 | -- Property: G((/= atom3min!bob!msg -1) => (= atom3min!__t 1)) 76 | -- F((= atom3min!__t 1)) 77 | atom3min :: Atom() 78 | atom3min = atom "atom3" $ do 79 | 80 | let 81 | -- | Special message values indicating "no message present", and "correct 82 | -- (intended) message" 83 | missingMsgValue, goodMsgValue :: MsgType 84 | missingMsgValue = -1 85 | goodMsgValue = 1 86 | 87 | (cin, cout) <- channel "aTob" msgType 88 | 89 | atom "alice" $ do 90 | writeChannel cin (Const goodMsgValue) 91 | 92 | atom "bob" $ do 93 | msg <- int64 "msg" missingMsgValue 94 | cond $ fullChannel cout 95 | v <- readChannel cout 96 | msg <== v 97 | 98 | -- | A periodic version of atom3, where two agents commicate one message over a 99 | -- channel. 100 | atom3Per :: Atom() 101 | atom3Per = atom "atom3Per" $ do 102 | 103 | let 104 | -- | Special message values indicating "no message present", and "correct 105 | -- (intended) message" 106 | missingMsgValue, goodMsgValue :: MsgType 107 | missingMsgValue = -1 108 | goodMsgValue = 1 109 | nodeBPeriod = 3 110 | 111 | (cin, cout) <- channel "aTob" msgType 112 | 113 | atom "alice" $ do 114 | done <- var "done" False 115 | cond $ not_ (value done) 116 | writeChannel cin (Const goodMsgValue) 117 | done <== Const True 118 | 119 | period nodeBPeriod . atom "bob" $ do 120 | msg <- int64 "msg" missingMsgValue 121 | cond $ fullChannel cout 122 | v <- readChannel cout 123 | msg <== v 124 | 125 | -- | Three Atoms communicate through two channels 126 | -- 127 | -- Property: node C is done implies that node C's 'msg' variable equals 1 128 | -- ('goodMsgValue'). Futhermore, node C is done implies that the global time 129 | -- is equal to 2. 130 | -- 131 | -- (=> A4!atom4!nodeC!done (and (= A4!atom4!nodeC!msg 1) 132 | -- (= A4!__t 2))) 133 | atom4 :: Atom() 134 | atom4 = atom "atom4" $ do 135 | 136 | let 137 | -- | Special message values indicating "no message present", and "correct 138 | -- (intended) message" 139 | missingMsgValue, goodMsgValue :: MsgType 140 | missingMsgValue = -1 141 | goodMsgValue = 1 142 | 143 | (cinA2B, coutA2B) <- channel "a2b" msgType 144 | (cinB2C, coutB2C) <- channel "b2c" msgType 145 | 146 | atom "nodeA" $ do 147 | done <- bool "done" False 148 | writeChannel cinA2B (Const goodMsgValue) 149 | done <== Const True 150 | 151 | atom "nodeB" $ do 152 | done <- bool "done" False 153 | msg <- int64 "msg" missingMsgValue 154 | cond (fullChannel coutA2B) 155 | v <- readChannel coutA2B 156 | writeChannel cinB2C v 157 | msg <== v 158 | done <== Const True 159 | 160 | atom "nodeC" $ do 161 | done <- bool "done" False 162 | msg <- int64 "msg" missingMsgValue 163 | cond (fullChannel coutB2C) 164 | v <- readChannel coutB2C 165 | msg <== v 166 | done <== Const True 167 | 168 | -- | Atom setting and using a timer based on the time at which it 169 | -- received a message. 170 | atom5 :: Atom() 171 | atom5 = atom "atom5" $ do 172 | 173 | let 174 | -- | Special message values indicating "no message present", and "correct 175 | -- (intended) message" 176 | missingMsgValue, goodMsgValue :: MsgType 177 | missingMsgValue = -1 178 | goodMsgValue = 1 179 | 180 | (cin, cout) <- channel "chan" msgType 181 | 182 | atom "alice" $ do 183 | done <- bool "done" False 184 | writeChannel cin (Const goodMsgValue) 185 | done <== Const True 186 | 187 | atom "bob" $ do 188 | 189 | rxTime <- word64 "rxTime" 0 190 | 191 | atom "recMsg" $ do 192 | msg <- int64 "msg" missingMsgValue 193 | cond $ fullChannel cout 194 | m <- readChannel cout 195 | msg <== m 196 | rxTime <== clock 197 | 198 | atom "timerDone" $ do 199 | local <- bool "local" False 200 | cond (value rxTime + 1000 >. clock) 201 | local <== Const True 202 | 203 | -- | An atom for testing the difference between the regular guard 'cond' and 204 | -- the non-inheriting version 'cond\''. 205 | atom6 :: Atom () 206 | atom6 = atom "atom6" $ do 207 | a <- bool "a" True 208 | b <- bool "b" True 209 | 210 | -- take at least one transition 211 | cond (value a) -- subnode inherits 212 | cond' (value b) -- subnode ignores 213 | a <== false 214 | b <== false 215 | 216 | -- sub_node does not inherit guard on 'a' 217 | atom "subnode" $ do 218 | c <- bool "c" True 219 | cond (value c) 220 | c <== false 221 | 222 | -- | Test use of assertions. In C code they produce assertions. In Sally 223 | -- models they produce safety property queries. 224 | atom7 :: Atom () 225 | atom7 = atom "atom7" $ do 226 | x <- int8 "x" 0 227 | cond $ value x <. 10 228 | x <== value x + 1 229 | assert "x nonnegative" (value x >=. 0) 230 | 231 | -- | Test use of assertions with sub-atoms. 232 | atom8 :: Atom () 233 | atom8 = atom "atom8" $ do 234 | x <- int8 "x" 0 235 | cond $ value x <. 10 236 | incr x 237 | assert "x nonnegative" (value x >=. 0) 238 | 239 | atom "sub_atom8" $ do 240 | y <- int8 "y" 0 241 | incr y 242 | assert "y nonnegative" (value y >=. 0) 243 | 244 | -- | Test some aspects of generated calendar framework in the presence of 245 | -- multiple channels. 246 | atom9 :: Atom () 247 | atom9 = atom "atom9" $ do 248 | (tx1, rx1) <- channel "chan1" Bool 249 | (tx2, rx2) <- channel "chan2" Bool 250 | (tx3, rx3) <- channel "chan3" Bool 251 | writeChannel tx1 true 252 | writeChannel tx2 true 253 | writeChannel tx3 true 254 | 255 | -- Examples of Layerd Atoms -------------------------------------------------- 256 | 257 | -- | A simple system A --> B where the link inbetween is realized as a 258 | -- redundant switched ethernet network. 259 | atomWithSWEther :: Atom () 260 | atomWithSWEther = atom "atomLayered" $ do 261 | 262 | -- declare the switched ethernet fabric for 2 nodes with 2 internal switches 263 | chans <- mkSWEther 2 2 264 | let (nodeAToE, eToNodeA) = chans !! 0 :: (ChanInput, ChanOutput) 265 | let (nodeBToE, eToNodeB) = chans !! 1 :: (ChanInput, ChanOutput) 266 | 267 | -- node A 268 | atom "node_A" $ do 269 | msg <- int64 "msg" 0 270 | -- send a message 271 | atom "sender" $ do 272 | done <- bool "done" False 273 | cond $ not_ (value done) 274 | writeChannel nodeAToE (1 :: E MsgType) 275 | done <== true 276 | 277 | atom "receiver" $ do 278 | -- store received messages 279 | cond $ fullChannel eToNodeA 280 | v <- readChannel eToNodeA 281 | msg <== v 282 | 283 | atom "node_B" $ do 284 | msg <- int64 "msg" 0 285 | -- store received messages 286 | cond $ fullChannel eToNodeB 287 | v <- readChannel eToNodeB 288 | msg <== v 289 | -- pretend to send messages from B 290 | atom "dummy_subnode_B" $ do 291 | cond (v ==. Const 42) 292 | writeChannel nodeBToE (0 :: E MsgType) 293 | 294 | -- | A simple system of three nodes connected to a bus. 295 | atomWithBus :: Atom () 296 | atomWithBus = atom "atomBus" $ do 297 | -- some constants with type annotations so we don't have to repeat them 298 | let zero = Const 0 :: E Int64 299 | one = Const 1 :: E Int64 300 | two = Const 2 :: E Int64 301 | three = Const 3 :: E Int64 302 | 303 | -- create the bus fabric, getting back channel endpoints that nodes can use 304 | [csA, csB, csC] <- mkStarBus 3 305 | 306 | -- Function that makes a node parametrized on 'per', a period (counted in 307 | -- terms of messages received), 'cin' a channel input to the bus, and 'cout' 308 | -- a channel outout from the bus. The node listens for messages from A B or 309 | -- C and increments counters accordingly. Every 'per' messages it receives 310 | -- it broadcasts it's own message to the bus. 311 | let mkNode ident per cin cout = atom ("node_" ++ show ident) $ do 312 | seenA <- int64 "seenA" 0 313 | seenB <- int64 "seenB" 0 314 | seenC <- int64 "seenC" 0 315 | counter <- int64 "counter" 0 316 | 317 | -- listener 318 | atom "listener" $ do 319 | cond $ fullChannel cout 320 | v <- readChannel cout 321 | -- TODO this is awkward to express 322 | seenA <== mux (v ==. one) (1 + value seenA) (value seenA) 323 | seenB <== mux (v ==. two) (1 + value seenB) (value seenB) 324 | seenC <== mux (v ==. three) (1 + value seenC) (value seenC) 325 | incr counter 326 | 327 | -- broadcaster 328 | atom "broadcaster" $ do 329 | cond $ value counter >. per 330 | counter <== zero 331 | writeChannel cin (Const ident) 332 | 333 | -- create nodes with different parameters using the mkNode function 334 | mkNode (1 :: Int64) two (fst csA) (snd csA) -- node 1, period 2 335 | mkNode (2 :: Int64) three (fst csB) (snd csB) -- node 2, period 3 336 | mkNode (3 :: Int64) one (fst csC) (snd csC) -- node 3, period 1 337 | 338 | -- kickstart the system by putting a message on the bus as node C 339 | -- done <- bool "done" False 340 | -- cond $ not_ (value done) 341 | -- done <== true 342 | -- writeChannel (fst csC) three 343 | 344 | 345 | -- Configurations -------------------------------------------------------------- 346 | 347 | -- | Default config for these specs 348 | defSpecCfg :: TrConfig 349 | defSpecCfg = defaultCfg { cfgDebug = True } 350 | 351 | -- | Example of a hybrid fault model configuration. 352 | hybridCfg :: TrConfig 353 | hybridCfg = defSpecCfg { cfgMFA = HybridFaults ws 0 } 354 | where ws = Map.fromList [ (NonFaulty, 0), (ManifestFaulty, 1), (SymmetricFaulty, 2) 355 | , (ByzantineFaulty, 3) 356 | ] 357 | 358 | -- | Example of a fixed fault mapping (specific to 'atom2' above). 359 | fixedCfg :: TrConfig 360 | fixedCfg = defSpecCfg { cfgMFA = FixedFaults mp } 361 | where mp = Map.fromList [ ("A2b!atom2!alice", NonFaulty) 362 | , ("A2b!atom2!bob", ByzantineFaulty) 363 | ] 364 | 365 | -- Main ----------------------------------------------------------------- 366 | 367 | putHeader :: IO () 368 | putHeader = putStrLn (replicate 72 '-') 369 | 370 | testCompile :: (String, Atom (), TrConfig, String) -> IO () 371 | testCompile (nm, spec, cfg, q) = do 372 | let fname = testDir nm ++ ".mcmt" 373 | compileToSally nm cfg fname spec (Just q) 374 | putStrLn ("compiled " ++ fname) 375 | 376 | -- | List of (Name, Atom, Query) to translate and print 377 | suite :: [(String, Atom (), TrConfig, String)] 378 | suite = 379 | [ ("A1", atom1, hybridCfg, 380 | "(query A1_transition_system (=> A1_assumptions (<= 0 A1!atom1!x)))") 381 | , ("A1b", atom1, defSpecCfg, 382 | "(query A1b_transition_system (=> A1b_assumptions (<= 0 A1b!atom1!x)))") 383 | , ("A2", atom2, hybridCfg, 384 | "(query A2_transition_system (=> A2_assumptions (=> A2!atom2!alice!a A2!atom2!flag)))") 385 | , ("A2b", atom2, fixedCfg, 386 | "(query A2b_transition_system (=> A2b_assumptions (=> A2b!atom2!alice!a A2b!atom2!flag)))") 387 | , ("A3", atom3, hybridCfg, 388 | unlines [ "(query A3_transition_system" 389 | , " (=> (not (= A3!atom3!bob!msg (-1))) A3!atom3!alice!done))"]) 390 | -- different config from A3 391 | , ("A3b", atom3, defSpecCfg, 392 | unlines [ "(query A3b_transition_system" 393 | , " (=> (not (= A3b!atom3!bob!msg (-1))) A3b!atom3!alice!done))"]) 394 | -- fewer state vars & different property 395 | , ("A3min", atom3min, defSpecCfg, 396 | unlines [ "(query A3min_transition_system" 397 | , " (=> (not (= A3min!atom3!bob!msg (-1))) (>= A3min!__global_clock 1)))"]) 398 | -- receiver has a long period 399 | , ("A3per", atom3Per, defSpecCfg, 400 | unlines [ "(query A3per_transition_system" 401 | , " (<= 0 A3per!__global_clock))" 402 | , "" 403 | , "(query A3per_transition_system" 404 | , " (=> (not (= A3per!atom3Per!bob!msg (-1))) (>= A3per!__global_clock 1)))"]) 405 | , ("A4", atom4, defSpecCfg, 406 | unlines [ "(query A4_transition_system" 407 | , " (=> A4!atom4!nodeC!done (= A4!atom4!nodeC!msg 1)))" 408 | , "\n\n" 409 | , "(query A4_transition_system" 410 | , " (=> A4!atom4!nodeC!done (= A4!__global_clock 2)))"]) 411 | -- A5 uses 'clock' which isn't yet fully supported 412 | -- , ("A5", atom5, defSpecCfg, "") 413 | , ("A6", atom6, defSpecCfg, "") 414 | , ("A7", atom7, defSpecCfg, "") 415 | , ("A8", atom8, defSpecCfg, "") 416 | , ("A9", atom9, defSpecCfg, "") 417 | , ("ASWEther", atomWithSWEther, defSpecCfg, "") 418 | , ("ABus", atomWithBus, defSpecCfg, "") 419 | ] 420 | 421 | main :: IO () 422 | main = mapM_ testCompile suite 423 | -------------------------------------------------------------------------------- /lima/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017 Benjamin Jones 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any purpose 4 | with or without fee is hereby granted, provided that the above copyright notice 5 | and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH 8 | REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND 9 | FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, 10 | INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS 11 | OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER 12 | TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF 13 | THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /lima/README.md: -------------------------------------------------------------------------------- 1 | # Atom 2 | 3 | [![Build Status](https://travis-ci.org/GaloisInc/atom.svg?branch=master)](https://travis-ci.org/GaloisInc/atom) 4 | 5 | **This is a FORK of the original Atom project** 6 | 7 | This new version of Atom is *work in progress*. The main goal is to support 8 | generating transition system models from Atom specifications, for use in model 9 | checking. 10 | 11 | Below is the contents of the original README.md. 12 | 13 | ----- 14 | 15 | # Atom: An EDSL for Embedded Hard Realtime Applications 16 | 17 | Atom is a Haskell EDSL for designing hard realtime embedded software. Based on guarded atomic actions (similar to STM), Atom enables highly concurrent programming without the need for mutex locking. In addition, Atom performs compile-time task scheduling and generates code with deterministic execution time and constant memory use, simplifying the process of timing verification and memory consumption in hard realtime applications. Without mutex locking and run-time task scheduling, Atom eliminates the need and overhead of RTOSes for many embedded applications. 18 | 19 | # Additional Information 20 | - [Hackage package](http://hackage.haskell.org/package/atom). 21 | - Homepage of [Tom Hawkins](http://tomahawkins.org/), the original creator. 22 | - [CUFP 2008](http://cufp.galois.com/2008/schedule.html) talk, "Controlling Hybrid Vehicles with Haskell" 23 | - [Monitoring Distributed Real-Time Systems](http://www.cs.indiana.edu/~lepike/pubs/survey.pdf) from Alwyn Goodloe and Lee Pike 24 | -------------------------------------------------------------------------------- /lima/lima.cabal: -------------------------------------------------------------------------------- 1 | name: lima 2 | version: 0.1.0.0 3 | 4 | category: Language, Embedded 5 | 6 | synopsis: An EDSL for embedded hard realtime applications. 7 | 8 | description: 9 | LIMA is a Haskell EDSL for designing hard realtime embedded software. 10 | Based on guarded atomic actions (similar to STM), LIMA enables 11 | highly concurrent programming without the need for mutex locking. 12 | 13 | In addition, LIMA performs compile-time task scheduling and generates code 14 | with deterministic execution time and constant memory use, simplifying the 15 | process of timing verification and memory consumption in hard realtime 16 | applications. 17 | 18 | Without mutex locking and run-time task scheduling, LIMA eliminates 19 | the need and overhead of RTOSes for many embedded applications. 20 | 21 | author: Tom Hawkins (2007-2010), 22 | Benjamin Jones , Lee Pike 23 | (2015-2016) 24 | maintainer: Benjamin Jones , Lee Pike 25 | 26 | 27 | license: ISC 28 | license-file: LICENSE 29 | 30 | homepage: https://github.com/galoisinc/lima 31 | 32 | build-type: Simple 33 | cabal-version: >= 1.10 34 | 35 | flag develop 36 | Description: Turn off compiler optimization during development 37 | Manual: True 38 | Default: False 39 | 40 | library 41 | default-language: Haskell2010 42 | hs-source-dirs: src 43 | build-depends: 44 | base >= 4.8 && < 5 45 | , monadLib >= 3.7.0 && < 4 46 | , mtl 47 | , process 48 | , syb 49 | , containers 50 | , bimap 51 | , pretty 52 | , graphviz >= 2999.19 && < 2999.20 53 | , text 54 | , filepath 55 | 56 | 57 | exposed-modules: 58 | Language.LIMA 59 | Language.LIMA.Analysis 60 | Language.LIMA.Channel 61 | Language.LIMA.Channel.Types 62 | Language.LIMA.Common 63 | Language.LIMA.Common.Fader 64 | Language.LIMA.Common.Threshold 65 | Language.LIMA.Common.ValidData 66 | Language.LIMA.Elaboration 67 | Language.LIMA.Expressions 68 | Language.LIMA.Inspect 69 | Language.LIMA.Language 70 | Language.LIMA.Types 71 | Language.LIMA.UeMap 72 | Language.LIMA.Graph 73 | 74 | other-extensions: GADTs, DeriveDataTypeable 75 | 76 | ghc-options: -Wall 77 | if flag(develop) 78 | ghc-options: -Wall -O0 79 | 80 | source-repository head 81 | type: git 82 | location: git://github.com/GaloisInc/lima.git 83 | -------------------------------------------------------------------------------- /lima/src/Language/LIMA.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module: Language.LIMA 3 | Description: Top-level LIMA module 4 | Copyright: (c) 2013 Tom Hawkins & Lee Pike 5 | Copyright: (c) 2017 Benjamin Jones 6 | 7 | LIMA is a Haskell DSL for designing hard realtime embedded software. 8 | 9 | Based on guarded atomic actions (similar to STM), LIMA enables highly 10 | concurrent programming without the need for mutex locking. 11 | In addition, LIMA performs compile-time task scheduling and generates code 12 | with deterministic execution time and constant memory use, simplifying the 13 | process of timing verification and memory consumption in hard realtime 14 | applications. Without mutex locking and run-time task scheduling, 15 | LIMA eliminates the need and overhead of RTOSes for many embedded applications. 16 | -} 17 | 18 | module Language.LIMA 19 | ( -- * Common 20 | -- | Module: "Language.LIMA.Common" 21 | Timer, timer, startTimer, startTimerIf, timerDone, oneShotRise, 22 | oneShotFall, debounce, lookupTable, linear, hysteresis, clocked, 23 | mkSWEther, mkStarBus, 24 | -- ** Signal fading 25 | -- | Module: "Language.LIMA.Common.Fader" 26 | Fader, FaderInit (..), fader, fadeToA, fadeToB, fadeToCenter, 27 | -- ** Thresholds 28 | -- | Module: "Language.LIMA.Common.Threshold" 29 | boolThreshold, doubleThreshold, 30 | -- ** Valid/Invalid data 31 | -- | Module: "Language.LIMA.Common.ValidData" 32 | ValidData, validData, getValidData, whenValid, whenInvalid, 33 | -- * Language & EDSL 34 | -- | Module: "Language.LIMA.Language" 35 | Atom, CompCtx(..), defCCtx, defSCtx, atom, getName, period, getPeriod, 36 | phase, exactPhase, getPhase, cond, cond', Assign (..), incr, decr, var, 37 | var', array, array', bool, bool', int8, int8', int16, int16', int32, 38 | int32', int64, int64', word8, word8', word16, word16', word32, word32', 39 | word64, word64', float, float', double, double', action, call, probe, 40 | probes, assert, cover, assertImply, Name, path, clock, nextCoverage, 41 | -- ** channels 42 | channel, ChanInput (..), ChanOutput (..), 43 | writeChannelWithDelay, writeChannel, readChannel, initChannel, 44 | fullChannel, ChannelDelay(..), 45 | -- * Expressions 46 | -- | Module: "Language.LIMA.Expressions" 47 | E(..), V(..), UE(..), UV(..), A(..), UA(..), Expr(..), Expression(..), 48 | Variable(..), Type(..), Const(..), Width(..), TypeOf(..), bytes, ue, uv, 49 | NumE, IntegralE, FloatingE, EqE, OrdE, true, false, 50 | value, not_, (&&.), (||.), and_, or_, any_, all_, imply, (.&.), complement, 51 | (.|.), xor, (.<<.), (.>>.), rol, ror, bitSize, isSigned, (==.), (/=.), 52 | (<.), (<=.), (>.), (>=.), min_, minimum_, max_, maximum_, limit, div_, 53 | div0_, mod_, mod0_, mux, (!), (!.), ubool, unot, uand, uor, ueq, umux, 54 | ) where 55 | 56 | import Language.LIMA.Common 57 | import Language.LIMA.Common.Fader 58 | import Language.LIMA.Common.Threshold 59 | import Language.LIMA.Common.ValidData 60 | import Language.LIMA.Language 61 | -------------------------------------------------------------------------------- /lima/src/Language/LIMA/Analysis.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Analysis 3 | -- Description: - 4 | -- Copyright: (c) 2013 Tom Hawkins & Lee Pike 5 | 6 | module Language.LIMA.Analysis 7 | ( topo 8 | , ruleComplexity 9 | ) where 10 | 11 | import Language.LIMA.Elaboration 12 | import Language.LIMA.UeMap 13 | 14 | -- | Topologically sorts a list of expressions and subexpressions. 15 | topo :: UeMap -> [Hash] -> [(Hash, Int)] 16 | topo mp ues = reverse ues' 17 | where 18 | start = 0 19 | (_, ues') = foldl collect (start, []) ues 20 | collect :: (Int, [(Hash, Int)]) -> Hash -> (Int, [(Hash, Int)]) 21 | collect (n, ues_) ue | any ((== ue) . fst) ues_ = (n, ues_) 22 | collect (n, ues_) ue = (n' + 1, (ue, n') : ues'') 23 | where (n', ues'') = foldl collect (n, ues_) $ ueUpstream ue mp 24 | 25 | -- | Number of UE's computed in rule. 26 | ruleComplexity :: UeMap -> Rule -> Int 27 | ruleComplexity mp = length . (topo mp) . allUEs 28 | 29 | -------------------------------------------------------------------------------- /lima/src/Language/LIMA/Channel.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Language.LIMA.Channel 3 | -- Copyright : Galois Inc. 2016 4 | -- License : BSD3 5 | -- 6 | -- Maintainer : bjones@galois.com 7 | -- Stability : experimental 8 | -- Portability : unknown 9 | -- 10 | -- First class channels for atom-atom communication. The intention is that 11 | -- channels and operations on them may be translated differently depending on 12 | -- the target. For example in the C code generator they are translated into 13 | -- pairs of (value, ready flag) variables. 14 | -- 15 | module Language.LIMA.Channel 16 | ( -- * Channel Declarations 17 | channel 18 | -- * Channel operations 19 | , writeChannelWithDelay 20 | , writeChannel 21 | , readChannel 22 | , initChannel 23 | , fullChannel 24 | -- * misc exports 25 | , channelPrefix 26 | ) 27 | where 28 | 29 | import MonadLib 30 | 31 | import Language.LIMA.Types 32 | import Language.LIMA.Channel.Types 33 | import Language.LIMA.Elaboration 34 | import Language.LIMA.Expressions 35 | import Language.LIMA.UeMap (newUE) 36 | 37 | 38 | -- Channel API ------------------------------------------------ 39 | 40 | -- | Declare a typed channel. Returns channel input/output handles. 41 | channel :: Name -- ^ channel name 42 | -> Type -- ^ type of values in the channel 43 | -> Atom (ChanInput, ChanOutput) 44 | channel name t = do 45 | -- add the __chanel_ prefix to the channel name before registering the name 46 | -- to try to separate the channel and variable namespaces somewhat 47 | let sName = channelPrefix ++ name 48 | name' <- addName sName 49 | (st, (g, atom)) <- get 50 | let cin = mkChanInput (gChannelId g) name' t 51 | cout = mkChanOutput (gChannelId g) name' t 52 | set (st, ( g { gChannelId = gChannelId g + 1 53 | , gState = gState g ++ [StateChannel sName t] 54 | } 55 | , atom 56 | ) 57 | ) 58 | return (cin, cout) 59 | 60 | -- | Write a message to a typed channel. The write operation happens once 61 | -- (i.e. the last writeChannel in the sequence is used) after the assignment 62 | -- (computation) phase of the Atom's execution. 63 | -- 64 | -- The write operation overwrites the content of the given channel. 65 | writeChannelWithDelay :: Expr a => ChannelDelay -> ChanInput -> E a -> Atom () 66 | writeChannelWithDelay d cin e = do 67 | (st, (g, atom)) <- get 68 | let (h, st0) = newUE (ue e) st 69 | set (st0, (g, atom { atomChanWrite = atomChanWrite atom 70 | ++ [(cin, h, d)] })) 71 | 72 | -- | Default delay specialization of the above. 73 | writeChannel :: Expr a => ChanInput -> E a -> Atom () 74 | writeChannel = writeChannelWithDelay DelayDefault 75 | 76 | -- | Read a message from a typed channel. This action returns an expression 77 | -- representing the value of the last message written (or the initial content). 78 | -- In the course of reading a message, it is consumed. 79 | readChannel :: ChanOutput -> Atom (E a) 80 | readChannel cout = do 81 | (st, (g, atom)) <- get 82 | set (st, (g, atom { atomChanRead = atomChanRead atom ++ [cout] })) 83 | return . VRef . V . chanVar $ cout 84 | 85 | -- | Place a channel value and time *directly* on the calendar at 86 | -- initialization time. This differs from 'writeChannelWithDelay' in that no 87 | -- node has to fire in order for the value and time to appear on the calendar. 88 | initChannel :: ChanInput -> Const -> ChannelDelay -> Atom () 89 | initChannel cin c d = do 90 | (st, (g, atom)) <- get 91 | set (st, (g, atom { atomChanInit = atomChanInit atom ++ [(cin, c, d)] })) 92 | return () 93 | 94 | -- | Check if the channel contains a message. 95 | fullChannel :: ChanOutput -> E Bool 96 | fullChannel = VRef . V . readyVar 97 | 98 | 99 | -- Helpers ------------------------------------------------------------------- 100 | 101 | -- | State struct name prefix for channel variables 102 | channelPrefix :: String 103 | channelPrefix = "__channel_" 104 | 105 | -- | Construct a channel variable which, in the C code generation case, is a 106 | -- stand-in for part of the global state sructure (the part storing the channel 107 | -- content). 108 | chanVar :: HasChan b => b -> UV 109 | chanVar c = UVChannel (chanID c) (chanName c) (chanType c) 110 | 111 | -- | Not exported. Use condChannel instead to condition execution of an Atom 112 | -- on the readiness of a channel. 113 | readyVar :: HasChan b => b -> UV 114 | readyVar c = UVChannelReady (chanID c) (chanName c) 115 | -------------------------------------------------------------------------------- /lima/src/Language/LIMA/Channel/Types.hs: -------------------------------------------------------------------------------- 1 | module Language.LIMA.Channel.Types ( 2 | ChanInput (..) 3 | , ChanOutput (..) 4 | , ChannelDelay(..) 5 | , mkChanInput 6 | , mkChanOutput 7 | , HasChan(..) 8 | ) where 9 | 10 | import Data.Word (Word64) 11 | 12 | import Language.LIMA.Types 13 | import Language.LIMA.Expressions 14 | 15 | 16 | -- | Input side of a typed channel 17 | data ChanInput = ChanInput 18 | { cinID :: Int 19 | , cinName :: Name 20 | , cinType :: Type 21 | } 22 | deriving (Eq, Show) 23 | 24 | mkChanInput :: Int -> Name -> Type -> ChanInput 25 | mkChanInput = ChanInput 26 | 27 | -- | Output side of a typed channel 28 | data ChanOutput = ChanOutput 29 | { coutID :: Int 30 | , coutName :: Name 31 | , coutType :: Type 32 | } 33 | deriving (Eq, Show) 34 | 35 | mkChanOutput :: Int -> Name -> Type -> ChanOutput 36 | mkChanOutput = ChanOutput 37 | 38 | -- | Channel delay specification 39 | data ChannelDelay = DelayDefault 40 | | DelayTicks Word64 41 | deriving (Eq, Show) 42 | 43 | 44 | -- Channel Operations -------------------------------------------------- 45 | 46 | class HasChan b where 47 | chanID :: b -> Int 48 | chanName :: b -> Name 49 | chanType :: b -> Type 50 | 51 | instance HasChan ChanInput where 52 | chanID = cinID 53 | chanName = cinName 54 | chanType = cinType 55 | 56 | instance HasChan ChanOutput where 57 | chanID = coutID 58 | chanName = coutName 59 | chanType = coutType 60 | -------------------------------------------------------------------------------- /lima/src/Language/LIMA/Common.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Common 3 | -- Description: Common functions. 4 | -- Copyright: (c) 2013 Tom Hawkins & Lee Pike 5 | -- 6 | -- Common LIMA functions 7 | 8 | module Language.LIMA.Common 9 | ( 10 | -- * Timers 11 | Timer 12 | , timer 13 | , startTimer 14 | , startTimerIf 15 | , timerDone 16 | -- * One Shots 17 | , oneShotRise 18 | , oneShotFall 19 | -- * Debouncing 20 | , debounce 21 | -- * Lookup Tables 22 | , lookupTable 23 | , linear 24 | -- * Hysteresis 25 | , hysteresis 26 | -- * Periodic clocks 27 | , clocked 28 | -- * switched architectures 29 | , mkSWEther 30 | -- * bus architectures 31 | , mkStarBus 32 | -- * Common rewrites 33 | -- , rewritePeriodPhase 34 | ) 35 | where 36 | 37 | import Data.Int 38 | import Data.Maybe (mapMaybe) 39 | import Data.Word 40 | import MonadLib -- re-exports Control.Monad 41 | import Text.Printf 42 | 43 | import Language.LIMA.Language 44 | import qualified Language.LIMA.Elaboration as E 45 | 46 | -- | A Timer. 47 | newtype Timer = Timer { timerVar :: V Word64 } 48 | 49 | -- | Creates a new timer. 50 | timer :: Name -> Atom Timer 51 | timer name = do 52 | timer' <- word64 name 0 53 | return $ Timer timer' 54 | 55 | -- | Starts a Timer. A timer can be restarted at any time. 56 | startTimer :: Timer -- ^ Timer to start 57 | -> E Word64 -- ^ Number of clock ticks the timer shall run 58 | -> Atom () 59 | startTimer t = startTimerIf t true 60 | 61 | -- | Conditionally start a Timer. 62 | startTimerIf :: Timer -- ^ Timer to start conditionally 63 | -> E Bool -- ^ Condition for starting the timer 64 | -> E Word64 -- ^ Number of ticks the timer shall run 65 | -> Atom () 66 | startTimerIf t a time = timerVar t <== mux a (clock + time) (value (timerVar t)) 67 | 68 | -- | 'True' when a timer has completed. Note that this remains 'True' until 69 | -- the timer is restarted. 70 | timerDone :: Timer -> E Bool 71 | timerDone t = value (timerVar t) <=. clock 72 | 73 | -- | One-shot on a rising transition. 74 | oneShotRise :: E Bool -> Atom (E Bool) 75 | oneShotRise a = do 76 | last' <- bool "last" False 77 | last' <== a 78 | return $ a &&. not_ (value last') 79 | 80 | -- | One-shot on a falling transition. 81 | oneShotFall :: E Bool -> Atom (E Bool) 82 | oneShotFall = oneShotRise . not_ 83 | 84 | -- | Debounces a boolean given an on and off time (ticks) and an initial state. 85 | debounce :: Name -- ^ Name of the resulting atom 86 | -> E Word64 -- ^ On time in ticks 87 | -> E Word64 -- ^ Off time in ticks 88 | -> Bool -- ^ Initial value 89 | -> E Bool -- ^ The boolean to debounce 90 | -> Atom (E Bool) -- ^ Resulting debounced boolean 91 | debounce name onTime offTime init' a = atom name $ do 92 | lst <- bool "last" init' 93 | out <- bool "out" init' 94 | timer' <- timer "timer" 95 | atom "on" $ do 96 | cond $ a &&. not_ (value lst) 97 | startTimer timer' onTime 98 | lst <== a 99 | atom "off" $ do 100 | cond $ not_ a &&. value lst 101 | startTimer timer' offTime 102 | lst <== a 103 | atom "set" $ do 104 | cond $ a ==. value lst 105 | cond $ timerDone timer' 106 | out <== value lst 107 | return $ value out 108 | 109 | -- | 1-D lookup table. @x@ values out of table range are clipped at end @y@ 110 | -- values. Input table must be monotonically increasing in @x@. 111 | lookupTable :: FloatingE a 112 | => [(E a, E a)] -- ^ (@x@, @y@) lookup table 113 | -> E a -- ^ Input @x@ value 114 | -> E a -- ^ Output @y@ value 115 | lookupTable table x = mux (x >=. x1) y1 $ foldl f y0 table' 116 | where 117 | (_, y0) = head table 118 | (x1, y1) = last table 119 | table' = zip (init table) (tail table) 120 | f a ((a0,b0),(a1,b1)) = mux (x >=. a0) interp a 121 | where 122 | slope = (b1 - b0) / (a1 - a0) 123 | interp = (x - a0) * slope + b0 124 | 125 | -- | Linear extrapolation and interpolation on a line with 2 points. 126 | -- The two @x@ points must be different to prevent a divide-by-zero. 127 | linear :: FloatingE a 128 | => (E a, E a) -- ^ First point, (x1, y1) 129 | -> (E a, E a) -- ^ Second point, (x2, y2) 130 | -> E a -- ^ Input @x@ value 131 | -> E a -- ^ Interpolated/extrapolated @y@ value 132 | linear (x1, y1) (x2, y2) a = slope * a + inter 133 | where 134 | slope = (y2 - y1) / (x2 - x1) 135 | inter = y1 - slope * x1 136 | 137 | -- | Hysteresis returns 'True' when the input exceeds @max@ and 'False' when 138 | -- the input is less than @min@. The state is held when the input is between 139 | -- @min@ and @max@. 140 | hysteresis :: OrdE a 141 | => E a -- ^ min 142 | -> E a -- ^ max 143 | -> E a -- ^ Input 144 | -> Atom (E Bool) 145 | hysteresis a b u = do 146 | s <- bool "s" False 147 | s <== mux (u >. max') true (mux (u <. min') false (value s)) 148 | return $ value s 149 | where 150 | min' = min_ a b 151 | max' = max_ a b 152 | 153 | 154 | -- Periodic clock functions ---------------------------------------------------- 155 | 156 | -- | Takes a node and conditions its execution on a regular clock with given 157 | -- (exact) phase and period. Note that, strictly speaking, the given phase can 158 | -- be larger than the period. This has the effect of delaying execution some 159 | -- number of extra periods. 160 | clocked :: Word64 -- ^ period 161 | -> Word64 -- ^ phase 162 | -> ([ChanOutput] -> Atom a) -- ^ node to clock 163 | -> Atom a 164 | clocked per pha node = do 165 | b <- cctxPeriodicity <$> ask 166 | if b 167 | 168 | -- periodicity through calendar automata option 169 | then do 170 | clkId <- getNewClock 171 | let nm = "clock" ++ show clkId 172 | -- let newSubAtom = atom nm $ do 173 | let newSubAtom = do 174 | (ki, ko) <- channel (nm ++ "_kick_channel") Bool 175 | (ii, io) <- channel (nm ++ "_init_channel") Bool 176 | (ni, no) <- channel (nm ++ "_node_channel") Bool 177 | 178 | atom "kicker" $ do 179 | cond $ fullChannel ko ||. fullChannel io 180 | initChannel ii (CBool True) (DelayTicks pha) 181 | _ <- readChannel io 182 | writeChannelWithDelay (DelayTicks per) ki (Const True) 183 | writeChannelWithDelay (DelayTicks 0) ni (Const True) 184 | 185 | atom "node" $ do 186 | cond $ fullChannel no 187 | _ <- readChannel no 188 | node [io] 189 | 190 | name' <- E.addName nm 191 | (st1, (g1, parent)) <- get 192 | ctx <- ask 193 | let ((a, nts), atst) = E.buildAtom ctx st1 g1 { E.gState = [] } name' 194 | newSubAtom 195 | (st2, (g2, child)) = atst 196 | set (st2, ( g2 { E.gState = E.gState g1 197 | ++ [E.StateHierarchy nm (E.gState g2)] } 198 | , parent { E.atomSubs = E.atomSubs parent ++ [child] })) 199 | put (reverse nts) 200 | return a 201 | 202 | -- periodicity through scheduler option 203 | else period (fromIntegral per) (phase (fromIntegral pha) (node [])) 204 | 205 | 206 | -- Switched Architectures ------------------------------------------------------ 207 | 208 | typ :: Type 209 | typ = Int64 210 | 211 | type Typ = Int64 212 | 213 | typDef :: Typ 214 | typDef = 0 215 | 216 | -- | Instantiate a switched, broadcasting ethernet network. The outputs are a 217 | -- channel input/output for each node. 218 | -- 219 | -- o--e--\ /--e--o 220 | -- \ S / 221 | -- \/ \/ 222 | -- /\ /\ 223 | -- / S \ 224 | -- o--e--/ \--e--o 225 | -- 226 | -- In the diagram, o's are nodes, e's are "endpoints" and S's are switches. 227 | -- Furthermore, the nodes and endpoints on the right hand side are the same 228 | -- as the nodes and endpoints on the left hand side. The diagram is just 229 | -- unrolled for illustrative purposes. 230 | -- 231 | -- TODO: The type of messages handled by the network is fixed to be 'typ' 232 | -- defined above. This is due to a limitation with the channel types that needs 233 | -- to be addressed. 234 | -- 235 | mkSWEther :: Int -- ^ number of nodes on each side of the network 236 | -> Int -- ^ number of switches in the network 237 | -- (# of redundant channels) 238 | -> Atom [(ChanInput, ChanOutput)] 239 | -- ^ n-(input, output) pairs to connect to nodes on left/right sides 240 | mkSWEther n m = do 241 | let bar i = [ l | l <- [0..n-1], l /= i ] :: [Int] 242 | rn = [0..n-1] :: [Int] 243 | rm = [0..m-1] :: [Int] 244 | let mkEndChans nm = unzip <$> mapM (`channel` typ) [nm ++ show i | i <- rn] 245 | (nte_i, nte_o) <- mkEndChans "node_to_end_" 246 | (etn_i, etn_o) <- mkEndChans "end_to_node_" 247 | let res = zip nte_i etn_o -- nte_o and etn_i are internal to the network 248 | 249 | -- generate the internal channels: [ [ (in_k_j, [out_1, ...]) ] ] 250 | -- where in_k_j goes from endpoint j to switch k and out_1 .. out_{n-1} go 251 | -- from switch k to the other endpoints (but not the j-th. 252 | internalChans <- 253 | forM rm $ \k -> -- loop over switches 254 | forM rn $ \j -> do -- loop over endpoints 255 | in_k_j <- channel (printf "in_s%d_e%d" k j) typ 256 | let mkOChan i = do c <- channel (printf "out_s%v_e%v_e%v" k j i) typ 257 | return (i,c) 258 | outs <- mapM mkOChan (bar j) 259 | return (in_k_j, outs) 260 | 261 | -- generate the switches: 262 | -- each one listes on each incoming chan and broadcast to all outgoing chans 263 | forM_ rm $ \k -> 264 | atom (printf "sw%v" k) $ do 265 | let myChans = internalChans !! k -- :: [ (in_k_j, outs) ]_j 266 | forM_ rn $ \j -> do 267 | let (myIn, myOuts) = myChans !! j 268 | atom (printf "handler_%v_%v" k j) $ do 269 | cond $ fullChannel (snd myIn) 270 | v <- readChannel (snd myIn) 271 | mapM_ ((`writeChannel` (v :: E Typ)) . fst . snd) myOuts 272 | 273 | -- generate the endpoints 274 | forM_ rn $ \j -> do 275 | let myOuts = map (fst . (!! j)) internalChans 276 | let myNodeCout = nte_o !! j 277 | atom ("endpoint_to_net" ++ show j) $ do 278 | -- listen on special endpoint channel and broadcast 279 | cond $ fullChannel myNodeCout 280 | v <- readChannel myNodeCout 281 | mapM_ ((`writeChannel` (v :: E Typ)) . fst) myOuts -- broadcast 282 | 283 | -- listen to all switches and write any receives to special node channel 284 | -- input 285 | -- Note: This has to buffered somehow 286 | buffer <- var (printf "buffer_%v" j) typDef 287 | ready <- bool (printf "ready_%v" j) False 288 | let myIns = concatMap (mapMaybe (\(_, allouts) -> lookup j allouts)) 289 | internalChans 290 | forM_ (zip [0..] myIns) $ \(l, cl) -> 291 | atom (printf "endpoint_from_net_f%v_to_e%v" (l :: Int) j) $ do 292 | cond $ fullChannel (snd cl) 293 | v <- readChannel (snd cl) 294 | -- writeChannel (etn_i !! j) (v :: E Typ) 295 | buffer <== v 296 | ready <== true 297 | 298 | -- write out the buffer 299 | atom (printf "endpoint_from_net_writer_e%v" j) $ do 300 | cond (value ready) 301 | writeChannel (etn_i !! j) (value buffer) 302 | ready <== false 303 | 304 | return res 305 | 306 | 307 | -- Bus Architectures ----------------------------------------------------------- 308 | 309 | -- | Make a "star interconnect" bus for 'n' nodes. 310 | -- 311 | -- o o o 312 | -- | | | 313 | -- \_____S_____/ 314 | -- 315 | -- In the diagram, o's are nodes and the S represents the star interconnect. 316 | -- Each of the lines is a bidirectional channel, implemented as a pair of channels. 317 | -- The user gets back only "half" of each of the bidirectional channels, 318 | -- specifically the half that it can operate on (sending messsages to the bus, 319 | -- receiving messages from bus). 320 | -- 321 | -- The type of messages on the bus is fixed to be 'Typ' defined above. See 322 | -- TODO above. 323 | -- 324 | mkStarBus :: Int -- ^ number of nodes on the bus 325 | -> Atom [(ChanInput, ChanOutput)] 326 | -- ^ for each node, a channel input/output pair for the node to 327 | -- communicate to the bus with 328 | mkStarBus n = do 329 | -- make channels from nodes to star 330 | let mkChans nm = unzip <$> mapM (`channel` typ) [nm ++ show i | i <- [0..n-1]] 331 | (nts_i, nts_o) <- mkChans "inward" -- "nts" = "node to star" 332 | 333 | -- make channels from star to nodes 334 | (stn_i, stn_o) <- mkChans "outward" -- "stn" = "star to node" 335 | 336 | -- make the star node: listens to all incoming channels, 337 | -- on reciept it broadcasts to all outgoing channels. 338 | atom "star" $ 339 | forM_ [0..n-1] $ \i -> do 340 | -- buffer writes to stn_i 341 | buffer <- var (printf "buffer_%v" i) typDef 342 | ready <- bool (printf "ready_%v" i) False 343 | let c = nts_o !! i 344 | -- listen for incoming from other notes than the i-th 345 | forM_ [ j | j <- [0..n-1], i /= j ] $ \j -> 346 | atom (printf "listen_inward_%v_%v" i j) $ do 347 | cond $ fullChannel c 348 | m' <- readChannel c 349 | -- buffer messages to all the other nodes attached to the bus 350 | buffer <== m' 351 | ready <== true 352 | -- write out the buffers when they're ready 353 | atom (printf "writer_%v" i) $ do 354 | cond (value ready) 355 | writeChannel (stn_i !! i) (value buffer) 356 | ready <== false 357 | 358 | -- return the channel end points that are relevant to the nodes 359 | return [(nts_i !! i, stn_o !! i) | i <- [0..n-1]] 360 | -------------------------------------------------------------------------------- /lima/src/Language/LIMA/Common/Fader.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Fader 3 | -- Description: Fades one signal to another 4 | -- Copyright: (c) 2013 Tom Hawkins & Lee Pike 5 | -- 6 | -- Fades one signal to another. 7 | 8 | module Language.LIMA.Common.Fader 9 | ( Fader 10 | , FaderInit (..) 11 | , fader 12 | , fadeToA 13 | , fadeToB 14 | , fadeToCenter 15 | ) where 16 | 17 | import Language.LIMA.Expressions 18 | import Language.LIMA.Language 19 | import Data.Int (Int32) 20 | 21 | -- | Fader object. 22 | data Fader = Fader (V Int32) 23 | 24 | -- | Fader initalization. 25 | data FaderInit = OnA -- ^ Start at signal A 26 | | OnB -- ^ Start at signal B 27 | | OnCenter -- ^ Start at average of A and B 28 | 29 | toA, toB, toCenter :: Int32 30 | toA = 0 31 | toB = 1 32 | toCenter = 2 33 | 34 | -- | Fader construction 35 | fader :: Name -- ^ Name 36 | -> Double -- ^ Fade rate 37 | -> FaderInit -- ^ Initialization 38 | -> E Double -- ^ Signal A 39 | -> E Double -- ^ Signal B 40 | -> Atom (Fader, E Double) 41 | fader name_ rate init_ a b = atom name_ $ do 42 | --assert "positiveRate" $ rate >= 0 43 | 44 | target <- int32 "target" $ case init_ of OnA -> toA 45 | OnB -> toB 46 | OnCenter -> toCenter 47 | perA <- double "perA" $ case init_ of OnA -> 1 48 | OnB -> 0 49 | OnCenter -> 0.5 50 | 51 | atom "toA" $ do 52 | cond $ value target ==. Const toA 53 | cond $ value perA <. 1 54 | perA <== mux (1 - value perA <. Const rate) 1 (value perA + Const rate) 55 | 56 | atom "toB" $ do 57 | cond $ value target ==. Const toB 58 | cond $ value perA >. 0 59 | perA <== mux (value perA <. Const rate) 0 (value perA - Const rate) 60 | 61 | atom "toCenterFrom0" $ do 62 | cond $ value target ==. Const toCenter 63 | cond $ value perA <. 0.5 64 | perA <== mux (0.5 - value perA <. Const rate) 0.5 (value perA + Const rate) 65 | 66 | atom "toCenterFrom1" $ do 67 | cond $ value target ==. Const toCenter 68 | cond $ value perA >. 0.5 69 | perA <== mux (value perA - 0.5 <. Const rate) 0.5 (value perA - Const rate) 70 | 71 | return (Fader target, (a * value perA + b * (1 - value perA)) / 2) 72 | 73 | -- | Fade to signal A. 74 | fadeToA :: Fader -> Atom () 75 | fadeToA (Fader target) = target <== Const toA 76 | 77 | -- | Fade to signal B. 78 | fadeToB :: Fader -> Atom () 79 | fadeToB (Fader target) = target <== Const toB 80 | 81 | -- | Fade to center, i.e. average of signal A and B. 82 | fadeToCenter :: Fader -> Atom () 83 | fadeToCenter (Fader target) = target <== Const toCenter 84 | -------------------------------------------------------------------------------- /lima/src/Language/LIMA/Common/Threshold.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Threshold 3 | -- Description: Time integrated threshold functions 4 | -- Copyright: (c) 2013 Tom Hawkins & Lee Pike 5 | -- 6 | -- Time integrated threshold functions typically used in condition monitoring. 7 | module Language.LIMA.Common.Threshold 8 | ( boolThreshold 9 | , doubleThreshold 10 | ) where 11 | 12 | import Language.LIMA.Expressions 13 | import Language.LIMA.Language 14 | import Data.Int (Int32) 15 | 16 | -- | Boolean thresholding over time. Output is set when internal counter hits 17 | -- limit, and cleared when counter is 0. 18 | boolThreshold :: Name -> Int32 -> Bool -> E Bool -> Atom (E Bool) 19 | boolThreshold name_ num init_ input = atom name_ $ do 20 | --assert "positiveNumber" $ num >= 0 21 | 22 | state <- bool "state" init_ 23 | count <- int32 "count" (if init_ then num else 0) 24 | 25 | atom "update" $ do 26 | cond $ value count >. Const 0 &&. value count <. Const num 27 | count <== value count + mux input (Const 1) (Const (-1)) 28 | 29 | atom "low" $ do 30 | cond $ value count ==. Const 0 31 | state <== false 32 | 33 | atom "high" $ do 34 | cond $ value count ==. Const num 35 | state <== true 36 | 37 | return $ value state 38 | 39 | -- | Integrating threshold. Output is set with integral reaches limit, and 40 | -- cleared when integral reaches 0. 41 | doubleThreshold :: Name -> Double -> E Double -> Atom (E Bool) 42 | doubleThreshold name_ lim input = atom name_ $ do 43 | --assert "positiveLimit" $ lim >= 0 44 | 45 | state <- bool "state" False 46 | sum_ <- double "sum" 0 47 | 48 | -- TODO: Figure out what the below translates to in the newer library 49 | -- (high,low) <- priority 50 | 51 | atom "update" $ do 52 | sum_ <== value sum_ + input 53 | -- low 54 | 55 | atom "clear" $ do 56 | cond $ value sum_ <=. 0 57 | state <== false 58 | sum_ <== 0 59 | -- high 60 | 61 | atom "set" $ do 62 | cond $ value sum_ >=. Const lim 63 | state <== true 64 | sum_ <== Const lim 65 | -- high 66 | 67 | return $ value state 68 | -------------------------------------------------------------------------------- /lima/src/Language/LIMA/Common/ValidData.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: ValidData 3 | -- Description: Capturing data that can either be valid or invalid 4 | -- Copyright: (c) 2013 Tom Hawkins & Lee Pike 5 | -- 6 | -- Capturing data that can either be valid or invalid. 7 | module Language.LIMA.Common.ValidData 8 | ( ValidData 9 | , validData 10 | , getValidData 11 | , whenValid 12 | , whenInvalid 13 | ) where 14 | 15 | import Language.LIMA.Expressions 16 | import Language.LIMA.Language 17 | 18 | -- | 'ValidData' captures the data and its validity condition. 19 | -- 'ValidData' is abstract to prevent rules from using invalid data. 20 | data ValidData a = ValidData a (E Bool) 21 | 22 | -- | Create 'ValidData' given the data and validity condition. 23 | validData :: a -> E Bool -> ValidData a 24 | validData = ValidData 25 | 26 | -- | Get a valid data. Action is disabled if data is invalid. 27 | getValidData :: ValidData a -> Atom a 28 | getValidData (ValidData a v) = cond v >> return a 29 | 30 | -- | Action enabled if 'ValidData' is valid. 31 | whenValid :: ValidData a -> Atom () 32 | whenValid (ValidData _ v) = cond v 33 | 34 | -- | Action enabled if 'ValidData' is not valid. 35 | whenInvalid :: ValidData a -> Atom () 36 | whenInvalid (ValidData _ v) = cond $ not_ v 37 | -------------------------------------------------------------------------------- /lima/src/Language/LIMA/Elaboration.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Elaboration 3 | -- Description: - 4 | -- Copyright: (c) 2013 Tom Hawkins & Lee Pike 5 | 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | 10 | module Language.LIMA.Elaboration 11 | ( 12 | -- * Atom monad and container. 13 | Atom 14 | , CompCtx (..) 15 | , defCCtx 16 | , defSCtx 17 | , AtomDB (..) 18 | , Global (..) 19 | , Rule (..) 20 | , ChanInfo (..) 21 | , StateHierarchy (..) 22 | , buildAtom 23 | -- * Type Aliases and Utilities 24 | , Phase (..) 25 | , elaborate 26 | , var 27 | , var' 28 | , array 29 | , array' 30 | , addName 31 | , allUVs 32 | , allUEs 33 | , isHierarchyEmpty 34 | , initialGlobal 35 | , getChannels 36 | ) where 37 | 38 | import qualified Control.Monad.State.Strict as S 39 | 40 | import Data.Function (on) 41 | import Data.Char (isAlpha, isAlphaNum) 42 | import Data.List (intercalate, nub, sort) 43 | import qualified Data.Map.Strict as Map 44 | import Data.Map.Strict (Map) 45 | import Data.Maybe (isJust, isNothing) 46 | 47 | import MonadLib 48 | import MonadLib.Derive 49 | 50 | import Language.LIMA.Types 51 | import Language.LIMA.Channel.Types 52 | import Language.LIMA.Expressions hiding (typeOf) 53 | import Language.LIMA.UeMap 54 | 55 | 56 | -- | Global data kept in each 'Atom' monad computation. 57 | data Global = Global 58 | { gRuleId :: Int -- ^ integer supply for rule IDs 59 | , gVarId :: Int -- ^ integer supply for variable IDs 60 | , gArrayId :: Int -- ^ integer supply for array IDs 61 | , gChannelId :: Int -- ^ integer supply for channel IDs 62 | , gClockId :: Int -- ^ integer supply for clock IDs 63 | , gState :: [StateHierarchy] -- ^ global state hierarchies 64 | , gProbes :: [(String, Hash)] -- ^ probe names and expression hashes 65 | , gPeriod :: Int -- ^ Atom global period, used by sub-atoms 66 | -- that don't specify a period 67 | , gPhase :: Phase -- ^ Atom global phase 68 | } 69 | deriving (Show) 70 | 71 | -- | Initial global state for the 'Atom' monad. 72 | initialGlobal :: Global 73 | initialGlobal = Global 74 | { gRuleId = 0 75 | , gVarId = 0 76 | , gArrayId = 0 77 | , gChannelId = 0 78 | , gClockId = 0 79 | , gState = [] 80 | , gProbes = [] 81 | , gPeriod = 1 82 | , gPhase = MinPhase 0 83 | } 84 | 85 | -- | The atom database value. This is an intermediate representation of an atom 86 | -- computation. 87 | data AtomDB = AtomDB 88 | { -- | Internal Atom identifier 89 | atomId :: Int 90 | -- | Atom name 91 | , atomName :: Name 92 | -- | Names used at this level. 93 | , atomNames :: [Name] 94 | -- | Enabling condition. 95 | , atomEnable :: Hash 96 | -- | Non-hereditary component on enable cond 97 | , atomEnableNH :: Hash 98 | -- | Sub atoms. 99 | , atomSubs :: [AtomDB] 100 | -- | Atom period, if not the default of 1 then the global period is used 101 | , atomPeriod :: Int 102 | -- | Atom phase constraint 103 | , atomPhase :: Phase 104 | -- | Sequence of (variable, shared expr) assignments arising from '<==' 105 | , atomAssigns :: [(MUV, Hash)] 106 | -- | Sequence of custom actions to take (only supported by the C code 107 | -- generator), see 'action' 108 | , atomActions :: [([String] -> String, [Hash])] 109 | -- | Sequence of assertion statements 110 | , atomAsserts :: [(Name, Hash)] 111 | -- | Sequence of coverage statements 112 | , atomCovers :: [(Name, Hash)] 113 | -- | Set of (channel input, channel value hash) pairs for writes 114 | , atomChanWrite :: [(ChanInput, Hash, ChannelDelay)] 115 | -- | Set of channel outputs which are read by the atom 116 | , atomChanRead :: [ChanOutput] 117 | -- | Set of channel initializations 118 | , atomChanInit :: [(ChanInput, Const, ChannelDelay)] 119 | } 120 | 121 | -- | Show AtomDB instance for debugging purposes. 122 | instance Show AtomDB where 123 | show a = "AtomDB { " ++ intercalate ", " [ show (atomId a) 124 | , atomName a 125 | , "subs " ++ show (length (atomSubs a)) 126 | , "per " ++ show (atomPeriod a) 127 | , "pha " ++ show (atomPhase a) 128 | ] ++ " }" -- TODO more detail? 129 | instance Eq AtomDB where (==) = (==) `on` atomId 130 | instance Ord AtomDB where compare a b = compare (atomId a) (atomId b) 131 | 132 | -- | A 'Rule' corresponds to an atomic action of one of three forms: 133 | -- 134 | -- 1. an atomic computation, e.g. variable assignment, channel reads and 135 | -- writes. 136 | -- 2. an assertion statement 137 | -- 3. a coverage statement 138 | -- 139 | -- XXX sum of records leads to partial record field functions 140 | data Rule 141 | = -- | An atomic computation. All the fields, except for 'ruleEnable' and 142 | -- 'ruleEnableNH' are simply copied from a corresponding 'AtomDB' value. 143 | Rule 144 | { ruleId :: Int 145 | , ruleName :: Name 146 | , ruleEnable :: Hash 147 | , ruleEnableNH :: Hash 148 | , ruleAssigns :: [(MUV, Hash)] 149 | , ruleActions :: [([String] -> String, [Hash])] 150 | , rulePeriod :: Int 151 | , rulePhase :: Phase 152 | , ruleChanWrite :: [(ChanInput, Hash, ChannelDelay)] 153 | , ruleChanRead :: [ChanOutput] 154 | , ruleChanInit :: [(ChanInput, Const, ChannelDelay)] 155 | } 156 | | -- | An assertion statement 157 | Assert 158 | { ruleName :: Name 159 | , ruleEnable :: Hash 160 | , ruleEnableNH :: Hash 161 | , ruleAssert :: Hash 162 | } 163 | | -- | A coverage statement 164 | Cover 165 | { ruleName :: Name 166 | , ruleEnable :: Hash 167 | , ruleEnableNH :: Hash 168 | , ruleCover :: Hash 169 | } 170 | 171 | -- | Show Rule instance, mainly for debugging. 172 | instance Show Rule where 173 | show r@Rule{} = "Rule { " ++ intercalate ", " [ show (ruleId r) 174 | , ruleName r 175 | -- , show (ruleEnable r) 176 | -- , show (ruleEnableNH r) 177 | ] ++ " }" -- TODO more detail? 178 | show _r@Assert{} = "Assert{}" 179 | show _r@Cover{} = "Cover{}" 180 | 181 | -- | Compiled channel info used to return channel info from the elaboration 182 | -- functions. 183 | data ChanInfo = ChanInfo 184 | { cinfoSrc :: Maybe Int -- ^ ruleId of source, either this or next is set 185 | , cinfoRecv :: Maybe Int -- ^ ruleId of receiver 186 | , cinfoId :: Int -- ^ internal channel ID 187 | , cinfoName :: Name -- ^ user supplied channel name 188 | , cinfoType :: Type -- ^ channel type 189 | , cinfoValueExpr :: Maybe Hash -- ^ hash to channel value expression, may 190 | -- or may not be set 191 | , cinfoInit :: Maybe (Const, ChannelDelay) -- ^ chan initialization 192 | } 193 | deriving (Eq, Show) 194 | 195 | -- | A StateHierarchy is a namespaced global state structure which is the 196 | -- result of elaborating an 'Atom' monad computation. 197 | data StateHierarchy 198 | = StateHierarchy Name [StateHierarchy] -- ^ A namespaced hierarchy 199 | | StateVariable Name Const -- ^ A state variable with name and 200 | -- initial value 201 | | StateArray Name [Const] -- ^ A state array with name and list 202 | -- of initial values 203 | | StateChannel Name Type -- ^ A channel with name and channel 204 | -- value type 205 | deriving (Show) 206 | 207 | 208 | -- | Given a hash for the parent Atom's enable expression and an 'AtomDB', 209 | -- produce a list of 'Rule's in context of a `UeState` expression sharing 210 | -- cache. 211 | elaborateRules :: Hash -> AtomDB -> UeState [Rule] 212 | elaborateRules parentEnable atom = 213 | if isRule then do r <- rule 214 | rs <- rules 215 | return (r : rs) 216 | else rules 217 | where 218 | -- Are there either assignments, actions, or writeChannels to be done? 219 | -- This check has the effect that atoms used as trivial outer shells 220 | -- around other immediate atoms are not translated into rules. 221 | isRule = not $ null (atomAssigns atom) 222 | && null (atomActions atom) 223 | && null (atomChanWrite atom) 224 | 225 | -- combine the parent enable and the child enable conditions 226 | enable :: UeState Hash 227 | enable = do 228 | st <- S.get 229 | let (h,st') = newUE (uand (recoverUE st parentEnable) 230 | (recoverUE st (atomEnable atom))) 231 | st 232 | S.put st' 233 | return h 234 | 235 | -- *don't* combine the parent enableNH and the child enableNH conditions 236 | enableNH :: UeState Hash 237 | enableNH = return (atomEnableNH atom) 238 | 239 | -- creat a 'Rule' from the 'AtomDB' and enable condition(s) 240 | rule :: UeState Rule 241 | rule = do 242 | h <- enable 243 | h' <- enableNH 244 | assigns <- S.foldM (\prs pr -> do pr' <- enableAssign pr 245 | return $ pr' : prs) [] 246 | (atomAssigns atom) 247 | return Rule 248 | { ruleId = atomId atom 249 | , ruleName = atomName atom 250 | , ruleEnable = h 251 | , ruleEnableNH = h' 252 | , ruleAssigns = assigns 253 | , ruleActions = atomActions atom 254 | , rulePeriod = atomPeriod atom 255 | , rulePhase = atomPhase atom 256 | , ruleChanWrite = atomChanWrite atom 257 | , ruleChanRead = atomChanRead atom 258 | , ruleChanInit = atomChanInit atom 259 | } 260 | 261 | assert :: (Name, Hash) -> UeState Rule 262 | assert (name, u) = do 263 | h <- enable 264 | h' <- enableNH 265 | return Assert 266 | { ruleName = name 267 | , ruleEnable = h 268 | , ruleEnableNH = h' 269 | , ruleAssert = u 270 | } 271 | 272 | cover :: (Name, Hash) -> UeState Rule 273 | cover (name, u) = do 274 | h <- enable 275 | h' <- enableNH 276 | return Cover 277 | { ruleName = name 278 | , ruleEnable = h 279 | , ruleEnableNH = h' 280 | , ruleCover = u 281 | } 282 | 283 | -- essentially maps 'ellaborateRules' over the asserts, covers, and 284 | -- subatoms in the given 'AtomDB' 285 | rules :: UeState [Rule] 286 | rules = do 287 | asserts <- S.foldM (\rs e -> do r <- assert e 288 | return (r:rs) 289 | ) [] (atomAsserts atom) 290 | covers <- S.foldM (\rs e -> do r <- cover e 291 | return (r:rs) 292 | ) [] (atomCovers atom) 293 | rules' <- S.foldM (\rs db -> do en <- enable 294 | r <- elaborateRules en db 295 | return (r:rs) 296 | ) [] (atomSubs atom) 297 | return $ asserts ++ covers ++ concat rules' 298 | 299 | -- push the enable condition into each assignment. In the code generator 300 | -- this results in assignments like @uint64_t __6 = __0 ? __5 : __3;@ 301 | -- where @__0@ is the 'enable' condition. 302 | enableAssign :: (MUV, Hash) -> UeState (MUV, Hash) 303 | enableAssign (uv', ue') = do 304 | e <- enable 305 | enh <- enableNH 306 | h <- maybeUpdate (MUVRef uv') -- insert variable into the UE map 307 | st <- S.get 308 | -- conjoin the regular enable condition and the non-inherited one, 309 | -- creating a new UE in the process 310 | let andes = uand (recoverUE st e) (recoverUE st enh) 311 | (e', st') = newUE andes st 312 | S.put st' 313 | let muxe = umux (recoverUE st' e') (recoverUE st' ue') (recoverUE st' h) 314 | (h',st'') = newUE muxe st' 315 | S.put st'' 316 | return (uv', h') 317 | 318 | -- | Renormalize 'Rule' IDs starting at the given 'Int'. 319 | reIdRules :: Int -> [Rule] -> [Rule] 320 | reIdRules _ [] = [] 321 | reIdRules i (a:b) = case a of 322 | Rule{} -> a { ruleId = i } : reIdRules (i + 1) b 323 | _ -> a : reIdRules i b 324 | 325 | -- | Get a list of all channels written to in the given list of rules. 326 | getChannels :: [Rule] -> Map Int ChanInfo 327 | getChannels rs = Map.unionsWith mergeInfo (map getChannels' rs) 328 | where getChannels' :: Rule -> Map Int ChanInfo 329 | getChannels' r@Rule{} = 330 | -- TODO: fwrite and fread could be refactored in more concise way 331 | let fwrite :: (ChanInput, Hash, ChannelDelay) -> (Int, ChanInfo) 332 | fwrite (c, h, _) = ( chanID c 333 | , ChanInfo 334 | { cinfoSrc = Just (ruleId r) 335 | , cinfoRecv = Nothing 336 | , cinfoId = chanID c 337 | , cinfoName = chanName c 338 | , cinfoType = chanType c 339 | , cinfoValueExpr = Just h 340 | , cinfoInit = Nothing 341 | } 342 | ) 343 | fread :: ChanOutput -> (Int, ChanInfo) 344 | fread c = ( chanID c 345 | , ChanInfo 346 | { cinfoSrc = Nothing 347 | , cinfoRecv = Just (ruleId r) 348 | , cinfoId = chanID c 349 | , cinfoName = chanName c 350 | , cinfoType = chanType c 351 | , cinfoValueExpr = Nothing 352 | , cinfoInit = Nothing 353 | } 354 | ) 355 | finit :: (ChanInput, Const, ChannelDelay) -> (Int, ChanInfo) 356 | finit (c, v, d) = ( chanID c 357 | , ChanInfo 358 | { cinfoSrc = Just (ruleId r) 359 | , cinfoRecv = Nothing 360 | , cinfoId = chanID c 361 | , cinfoName = chanName c 362 | , cinfoType = chanType c 363 | , cinfoValueExpr = Nothing 364 | , cinfoInit = Just (v, d) 365 | } 366 | ) 367 | m = Map.fromList (map fwrite (ruleChanWrite r) 368 | ++ map fread (ruleChanRead r) 369 | ++ map finit (ruleChanInit r)) 370 | in m 371 | getChannels' _ = Map.empty -- asserts and coverage statements have no channels 372 | 373 | -- Merge two channel info records, in particular this unions the 374 | -- `cinfoSrc` fields and also the `cinfoRecv` fields. 375 | mergeInfo :: ChanInfo -> ChanInfo -> ChanInfo 376 | mergeInfo c1 c2 = 377 | if (cinfoId c1 == cinfoId c2) && -- check invariant 378 | (cinfoName c1 == cinfoName c2) && 379 | (cinfoType c1 == cinfoType c2) && 380 | (cinfoValueExpr c1 == cinfoValueExpr c2 || -- either equal or 381 | isNothing (cinfoValueExpr c1) || -- one is a Nothing 382 | isNothing (cinfoValueExpr c2)) && 383 | (cinfoInit c1 == cinfoInit c2 || -- either equal or 384 | isNothing (cinfoInit c1) || -- one is a Nothing 385 | isNothing (cinfoInit c2)) 386 | then c1 { cinfoSrc = muxMaybe (cinfoSrc c1) (cinfoSrc c2) 387 | , cinfoRecv = muxMaybe (cinfoRecv c1) (cinfoRecv c2) 388 | , cinfoValueExpr = muxMaybe (cinfoValueExpr c1) 389 | (cinfoValueExpr c2) 390 | , cinfoInit = muxMaybe (cinfoInit c1) (cinfoInit c2) 391 | } 392 | else error $ "Elaboration: getChannels: mismatch occured" 393 | ++ "\n" ++ show c1 394 | ++ "\n" ++ show c2 395 | 396 | -- | Evaluate the computation carried by the given atom and return an 'AtomDB' 397 | -- value, the intermediate representation for atoms at this level. 398 | buildAtom 399 | :: CompCtx -- ^ compiler context to start with 400 | -> UeMap -- ^ untyped expression map to start with 401 | -> Global -- ^ global data to start with 402 | -> Name -- ^ top-level name of the atom design 403 | -> Atom a -- ^ atom to evaluate 404 | -> ((a, CompNotes), AtomSt) -- ^ atom return value, underlying final 405 | -- evaluation state, and emitted warnings 406 | buildAtom ctx st g name at = 407 | let (h,st') = newUE (ubool True) st 408 | initAtst = (st', ( g { gRuleId = gRuleId g + 1 } 409 | , AtomDB 410 | { atomId = gRuleId g 411 | , atomName = name 412 | , atomNames = [] 413 | , atomEnable = h 414 | , atomEnableNH = h 415 | , atomSubs = [] 416 | , atomPeriod = gPeriod g 417 | , atomPhase = gPhase g 418 | , atomAssigns = [] 419 | , atomActions = [] 420 | , atomAsserts = [] 421 | , atomCovers = [] 422 | , atomChanWrite = [] 423 | , atomChanRead = [] 424 | , atomChanInit = [] 425 | } 426 | ) 427 | ) 428 | in runAtom ctx initAtst at 429 | 430 | -- | Atom State type. 431 | type AtomSt = (UeMap, (Global, AtomDB)) 432 | -- | Compiler Warnings. 433 | type CompNotes = [String] 434 | -- | Compiler Context, used to switch certain operations depending on the 435 | -- compiler backend, e.g. switch from "scheduled periodicity" to "clocked 436 | -- periodicity". 437 | data CompCtx = CompCtx { 438 | -- ^ periodicity type to compile with; True = clocked periodicty, False = 439 | -- scheduled periodicity (only applicable to, and the default for, the C 440 | -- code backend). 441 | cctxPeriodicity :: Bool 442 | } 443 | 444 | -- | The default C code backend compilation context; scheduled periodicity is 445 | -- enabled. 446 | defCCtx :: CompCtx 447 | defCCtx = CompCtx { cctxPeriodicity = False } 448 | 449 | -- | The default Sally Model backend compilation context; clocked periodicity 450 | -- is enabled. 451 | defSCtx :: CompCtx 452 | defSCtx = CompCtx { cctxPeriodicity = True } 453 | 454 | -- | The Atom monad is a state monad over the cache and intermediate 455 | -- representation data needed to specifiy a guarded atomic action. 456 | newtype Atom a = Atom { unAtom :: ReaderT CompCtx 457 | (WriterT CompNotes 458 | (StateT AtomSt Id)) a } 459 | deriving (Applicative, Functor, Monad) 460 | 461 | -- | Witness for the isomorphism between the newtype 'Atom' and the 'StateT' 462 | -- underneath. 463 | isoS :: Iso (ReaderT CompCtx (WriterT CompNotes (StateT AtomSt Id))) Atom 464 | isoS = Iso Atom unAtom 465 | 466 | -- | To get the non-unary type-class constraints we have to do a little work 467 | instance StateM Atom AtomSt where 468 | get = derive_get isoS 469 | set = derive_set isoS 470 | 471 | instance ReaderM Atom CompCtx where 472 | ask = derive_ask isoS 473 | 474 | instance WriterM Atom CompNotes where 475 | put = derive_put isoS 476 | 477 | -- | Run the state computation starting from the given initial 'AtomSt'. 478 | runAtom :: CompCtx -> AtomSt -> Atom a -> ((a, CompNotes), AtomSt) 479 | runAtom ctx st = runId -- ((a, i1), i2) 480 | . runStateT st -- IdT ((a, i1), i2) 481 | . runWriterT -- StateT i2 IdT (a, i1) 482 | . runReaderT ctx -- WriterT i1 (StateT i2 IdT) a 483 | . unAtom -- ReaderT i0 (WriterT i1 (StateT i2 IdT)) a 484 | 485 | -- | Given a top level name and design, elaborates design and returns a design 486 | -- database. 487 | -- 488 | -- XXX elaborate is a bit hacky since we're threading state through this 489 | -- function, but I don't want to go change all the UeState monads to UeStateT 490 | -- monads. 491 | -- 492 | elaborate :: CompCtx -> UeMap -> Name -> Atom () 493 | -> IO (Maybe ( UeMap 494 | , ( StateHierarchy, [Rule], [ChanInfo], [Name], [Name] 495 | , [(Name, Type)]) 496 | )) 497 | elaborate ctx st name atom = do 498 | -- buildAtom runs the state computation contained by the atom, at the 499 | -- top-level here the atom result value is discarded 500 | let ((_, nts), atst) = buildAtom ctx st initialGlobal name atom 501 | (st0, (g, atomDB)) = atst 502 | (h, st1) = newUE (ubool True) st0 503 | (getRules, st2) = S.runState (elaborateRules h atomDB) st1 504 | rules = reIdRules 0 (reverse getRules) 505 | -- channel source and dest are numbered based on 'ruleId's in 'rules' 506 | channels = Map.elems (getChannels rules) 507 | coverageNames = [ name' | Cover name' _ _ _ <- rules ] 508 | assertionNames = [ name' | Assert name' _ _ _ <- rules ] 509 | probeNames = [ (n, typeOf a st2) | (n, a) <- gProbes g ] 510 | -- emit warnings 511 | mapM_ (\m -> putStrLn ("WARNING: " ++ m)) (reverse nts) 512 | if null rules 513 | then do 514 | putStrLn "ERROR: Design contains no rules. Nothing to do." 515 | return Nothing 516 | else do 517 | mapM_ (checkEnable st2) rules 518 | oks <- mapM checkAssignConflicts rules 519 | return $ if and oks 520 | then Just ( st2 521 | , ( trimState . StateHierarchy name $ gState g 522 | , rules 523 | , channels 524 | , assertionNames 525 | , coverageNames 526 | , probeNames 527 | ) 528 | ) 529 | else Nothing 530 | 531 | -- | Remove namespaces in a 'StateHierarchy' that have no state in them. 532 | trimState :: StateHierarchy -> StateHierarchy 533 | trimState a = case a of 534 | StateHierarchy name items -> 535 | StateHierarchy name (filter f . map trimState $ items) 536 | a' -> a' 537 | where 538 | f (StateHierarchy _ []) = False 539 | f _ = True 540 | 541 | -- | Check if state hierarchy is empty 542 | isHierarchyEmpty :: StateHierarchy -> Bool 543 | isHierarchyEmpty h = case h of 544 | StateHierarchy _ [] -> True 545 | StateHierarchy _ i -> all isHierarchyEmpty i 546 | StateVariable _ _ -> False 547 | StateArray _ _ -> False 548 | StateChannel _ _ -> False 549 | 550 | -- | Checks that a rule will not be trivially disabled. 551 | checkEnable :: UeMap -> Rule -> IO () 552 | checkEnable st rule 553 | | let f = (fst $ newUE (ubool False) st) in 554 | ruleEnable rule == f || ruleEnableNH rule == f 555 | = putStrLn $ "WARNING: Rule will never execute: " ++ show rule 556 | | otherwise = return () 557 | 558 | -- | Check that a variable is assigned more than once in a rule. Will 559 | -- eventually be replaced consistent assignment checking. 560 | checkAssignConflicts :: Rule -> IO Bool 561 | checkAssignConflicts rule@Rule{} = 562 | if length vars /= length vars' 563 | then do 564 | putStrLn $ "ERROR: Rule " 565 | ++ show rule 566 | ++ " contains multiple assignments to the same variable(s)." 567 | return False 568 | else 569 | return True 570 | where 571 | vars = map fst (ruleAssigns rule) 572 | vars' = nub vars 573 | checkAssignConflicts _ = return True 574 | 575 | -- | Generic local variable declaration. 576 | var :: Expr a => Name -> a -> Atom (V a) 577 | var name init' = do 578 | name' <- addName name 579 | (st, (g, atom)) <- get 580 | let uv' = UV (gVarId g) name' c 581 | c = constant init' 582 | set (st, ( g { gVarId = gVarId g + 1 583 | , gState = gState g ++ [StateVariable name c] 584 | } 585 | , atom 586 | ) 587 | ) 588 | return $ V uv' 589 | 590 | -- | Generic external variable declaration. 591 | var' :: Name -> Type -> V a 592 | var' name t = V $ UVExtern name t 593 | 594 | -- | Generic array declaration. 595 | array :: Expr a => Name -> [a] -> Atom (A a) 596 | array name [] = error $ "ERROR: arrays can not be empty: " ++ name 597 | array name init' = do 598 | name' <- addName name 599 | (st, (g, atom)) <- get 600 | let ua = UA (gArrayId g) name' c 601 | c = map constant init' 602 | set (st, ( g { gArrayId = gArrayId g + 1 603 | , gState = gState g ++ [StateArray name c] 604 | } 605 | , atom 606 | ) 607 | ) 608 | return $ A ua 609 | 610 | -- | Generic external array declaration. 611 | array' :: Name -> Type -> A a 612 | array' name t = A $ UAExtern name t 613 | 614 | -- | Add a name to the AtomDB and check that it is unique, throws an exception 615 | -- if not. 616 | -- 617 | -- Note: the name returned is prefixed with the state hierarchy selector. 618 | addName :: Name -> Atom Name 619 | addName name = do 620 | (st, (g, atom)) <- get 621 | checkName name 622 | if name `elem` atomNames atom 623 | then error $ unwords [ "ERROR: Name \"" ++ name ++ "\" not unique in" 624 | , show atom ++ "." ] 625 | else do 626 | set (st, (g, atom { atomNames = name : atomNames atom })) 627 | return $ atomName atom ++ "." ++ name 628 | 629 | -- still accepts some malformed names, like "_.." or "_][" 630 | checkName :: Name -> Atom () 631 | checkName name = 632 | if (\ x -> isAlpha x || x == '_') (head name) && 633 | all (\ x -> isAlphaNum x || x `elem` "._[]") (tail name) 634 | then return () 635 | else error $ "ERROR: Name \"" ++ name ++ "\" is not a valid identifier." 636 | 637 | -- | All the variables that directly and indirectly control the value of an expression. 638 | allUVs :: UeMap -> [Rule] -> Hash -> [MUV] 639 | allUVs st rules ue' = fixedpoint next $ nearestUVs ue' st 640 | where 641 | assigns = concat [ ruleAssigns r | r@Rule{} <- rules ] 642 | previousUVs :: MUV -> [MUV] 643 | previousUVs u = concat [ nearestUVs ue_ st | (uv', ue_) <- assigns, u == uv' ] 644 | next :: [MUV] -> [MUV] 645 | next uvs = sort $ nub $ uvs ++ concatMap previousUVs uvs 646 | 647 | -- | Apply the function until a fixedpoint is found. Why is this not in 648 | -- Prelude? 649 | fixedpoint :: Eq a => (a -> a) -> a -> a 650 | fixedpoint f a | a == f a = a 651 | | otherwise = fixedpoint f $ f a 652 | 653 | -- | All primary expressions used in a rule. 654 | allUEs :: Rule -> [Hash] 655 | allUEs rule = ruleEnable rule : ruleEnableNH rule : ues 656 | where 657 | index :: MUV -> [Hash] 658 | index (MUVArray _ ue') = [ue'] 659 | index _ = [] 660 | ues = case rule of 661 | Rule{} -> 662 | concat [ ue' : index uv' | (uv', ue') <- ruleAssigns rule ] 663 | ++ concatMap snd (ruleActions rule) 664 | ++ map (\(_, h, _) -> h) (ruleChanWrite rule) 665 | Assert _ _ _ a -> [a] 666 | Cover _ _ _ a -> [a] 667 | 668 | -- | Left biased combination of maybe values. `muxMaybe` has the property that 669 | -- if one of the two inputs is a `Just`, then the output will also be. 670 | muxMaybe :: Maybe a -> Maybe a -> Maybe a 671 | muxMaybe x y = if isJust x then x 672 | else y 673 | -------------------------------------------------------------------------------- /lima/src/Language/LIMA/Graph.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : src.Language.LIMA.Graph 3 | -- Copyright : Benjamin Jones 2017 4 | -- License : ISC 5 | -- 6 | -- Maintainer : bjones@galois.com 7 | -- Stability : experimental 8 | -- Portability : unknown 9 | -- 10 | -- Produce GraphViz graphs from Atoms 11 | -- 12 | 13 | {-# LANGUAGE MultiParamTypeClasses #-} 14 | {-# LANGUAGE OverloadedStrings #-} 15 | 16 | module Language.LIMA.Graph ( 17 | graphAtom 18 | , ex 19 | ) where 20 | 21 | import Control.Monad (forM_) 22 | import Data.Int 23 | import Data.GraphViz hiding (DotGraph) 24 | import Data.GraphViz.Types.Monadic 25 | import Data.GraphViz.Types.Generalised 26 | import qualified Data.Map.Strict as Map 27 | import qualified Data.Text.Lazy as T 28 | import Data.Text.Lazy (Text) 29 | 30 | import Language.LIMA 31 | import qualified Language.LIMA.Elaboration as E 32 | import Language.LIMA.UeMap (emptyMap) 33 | 34 | 35 | -- Atrributes for nodes and edges ---------------------------------------------- 36 | 37 | chanAttrs :: Attributes 38 | chanAttrs = [color Purple, style solid] 39 | 40 | subAtomArrAttrs :: Attributes 41 | subAtomArrAttrs = [color Black, style dotted] 42 | 43 | atomAttrs :: Attributes 44 | atomAttrs = [textLabel "\\N", color Black, shape DiamondShape] 45 | 46 | 47 | -- Graph producing functions --------------------------------------------------- 48 | 49 | graphAtom :: FilePath -> Atom () -> IO () 50 | graphAtom fp atm = do 51 | g <- mkDotGraph atm 52 | fp' <- Data.GraphViz.addExtension (runGraphvizCommand Dot g) Png fp 53 | putStrLn ("wrote filename: " ++ fp') 54 | 55 | 56 | mkDotGraph :: Atom () -> IO (DotGraph Text) 57 | mkDotGraph atm = do 58 | let ((_a, _nts), (_u, (_g, adb))) = E.buildAtom E.defCCtx emptyMap 59 | E.initialGlobal "top" atm 60 | tname = T.pack (E.atomName adb) 61 | res <- E.elaborate E.defCCtx emptyMap "top" atm 62 | let rules = case res of 63 | Nothing -> error "ERROR: Atom failed to compile." 64 | Just (_, (_, r, _, _, _, _)) -> r 65 | let ruleMap = Map.fromList [(E.ruleId r, r) | r@E.Rule{} <- rules] 66 | let cs = Map.toList $ E.getChannels rules 67 | 68 | return $ 69 | digraph (Str tname) $ do 70 | flatten adb 71 | addChannels cs ruleMap 72 | 73 | where 74 | flatten adb = do 75 | let subs = E.atomSubs adb 76 | let n = T.pack (E.atomName adb) 77 | if null subs 78 | then 79 | node n atomAttrs 80 | else 81 | cluster (Str n) $ do 82 | node n atomAttrs 83 | let gps = map flatten subs 84 | sequence_ gps 85 | forM_ subs $ \s -> 86 | edge n (T.pack (E.atomName s)) subAtomArrAttrs 87 | 88 | addChannels cs rm = forM_ cs $ \(_cid, cinf) -> do 89 | let s0 = E.cinfoSrc cinf 90 | let r0 = E.cinfoRecv cinf 91 | case (s0, r0) of 92 | (Just s, Just r) -> edge (lk rm s) (lk rm r) chanAttrs 93 | _ -> return () 94 | 95 | lk rm i = case Map.lookup i rm of 96 | Nothing -> error "ERROR: internal rule Id error" 97 | Just r -> T.pack (E.ruleName r) 98 | 99 | 100 | -- | Example atom for testing purposes 101 | ex :: Atom () 102 | ex = atom "ex" $ do 103 | (cin, cout) <- channel "phone" Bool 104 | 105 | atom "a1" $ do 106 | x <- bool "x" False 107 | x <== true 108 | writeChannel cin true 109 | 110 | atom "a2" $ do 111 | a <- int64 "a" (0 :: Int64) 112 | cond $ fullChannel cout 113 | _m <- readChannel cout 114 | incr a 115 | -------------------------------------------------------------------------------- /lima/src/Language/LIMA/Inspect.hs: -------------------------------------------------------------------------------- 1 | module Language.LIMA.Inspect 2 | ( ppAtomDB 3 | -- * re-export from Text.PrettyPrint 4 | , render 5 | ) 6 | where 7 | 8 | import Text.PrettyPrint 9 | 10 | import Language.LIMA.Elaboration 11 | import Language.LIMA.UeMap 12 | 13 | ppAtomDB :: AtomDB -> Doc 14 | ppAtomDB a = 15 | text "AtomDB" <+> text (atomName a) <+> parens (int (atomId a)) $$ 16 | nest 2 ( 17 | text "atom enable =" <+> int (atomEnable a) $$ 18 | text "period =" <+> int (atomPeriod a) $$ 19 | text "phase =" <+> ppPhase (atomPhase a) $$ 20 | text "assigns:" $$ 21 | nest 2 (vcat (map ppAssign (atomAssigns a))) $$ 22 | text "sub atoms:" <+> hcat (map (int . atomId) (atomSubs a))) 23 | 24 | ppAssign :: (MUV, Hash) -> Doc 25 | ppAssign (m,h) = text "assign" <> parens (ppMUV m <> comma <> int h) 26 | 27 | ppPhase :: Phase -> Doc 28 | ppPhase = text . show 29 | 30 | ppMUV :: MUV -> Doc 31 | ppMUV = text . show 32 | 33 | -------------------------------------------------------------------------------- /lima/src/Language/LIMA/Language.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Language 3 | -- Description: Definitions for the language/EDSL itself 4 | -- Copyright: (c) 2013 Tom Hawkins & Lee Pike 5 | -- 6 | -- Definitions for the LIMA EDSL itself 7 | 8 | module Language.LIMA.Language 9 | ( 10 | module Language.LIMA.Expressions 11 | , module Language.LIMA.Channel 12 | , module Language.LIMA.Channel.Types 13 | -- * Primary Language Containers 14 | , Atom 15 | -- * Compilation parameters 16 | , CompCtx (..) 17 | , defCCtx 18 | , defSCtx 19 | -- * Hierarchical Rule Declarations 20 | , atom 21 | , getNewClock 22 | , getName 23 | , getCompiledName 24 | , period 25 | , getPeriod 26 | , phase 27 | , exactPhase 28 | , getPhase 29 | -- * Action Directives 30 | , cond 31 | , cond' 32 | , Assign (..) 33 | , incr 34 | , decr 35 | -- * Variable Declarations 36 | , var 37 | , var' 38 | , array 39 | , array' 40 | , bool 41 | , bool' 42 | , int8 43 | , int8' 44 | , int16 45 | , int16' 46 | , int32 47 | , int32' 48 | , int64 49 | , int64' 50 | , word8 51 | , word8' 52 | , word16 53 | , word16' 54 | , word32 55 | , word32' 56 | , word64 57 | , word64' 58 | , float 59 | , float' 60 | , double 61 | , double' 62 | -- * Custom Actions 63 | , action 64 | , call 65 | -- * Probing 66 | , probe 67 | , probes 68 | -- * Assertions and Functional Coverage 69 | , assert 70 | , cover 71 | , assertImply 72 | -- * Utilities 73 | , Name 74 | , path 75 | , clock 76 | -- * Code Coverage 77 | , nextCoverage 78 | -- * Rewriting 79 | -- , rewriteAtom 80 | ) where 81 | 82 | import Data.Int 83 | import Data.Word 84 | import Data.List (foldl') 85 | 86 | import MonadLib 87 | 88 | import Language.LIMA.Channel 89 | import Language.LIMA.Channel.Types 90 | import Language.LIMA.Elaboration hiding (Atom) 91 | import qualified Language.LIMA.Elaboration as E 92 | import Language.LIMA.Expressions 93 | import Language.LIMA.UeMap hiding (typeOf) 94 | import Language.LIMA.Types 95 | 96 | infixr 1 <== 97 | 98 | -- | The Atom monad captures variable and transition rule declarations. 99 | type Atom = E.Atom 100 | 101 | -- | Creates a hierarchical node, where each node could be an atomic rule. 102 | atom :: Name -> Atom a -> Atom a 103 | atom name design = do 104 | name' <- addName name 105 | (st1, (g1, parent)) <- get 106 | ctx <- ask 107 | let ((a, nts), atst) = buildAtom ctx st1 g1 { gState = [] } name' design 108 | (st2, (g2, child)) = atst 109 | set (st2, ( g2 { gState = gState g1 ++ [StateHierarchy name $ gState g2] } 110 | , parent { atomSubs = atomSubs parent ++ [child] })) 111 | put (reverse nts) 112 | return a 113 | 114 | -- | Return the next available clock Id 115 | getNewClock :: Atom Int 116 | getNewClock = do 117 | (st, (g, a)) <- get 118 | let clkId = gClockId g 119 | set (st, (g { gClockId = clkId+1 }, a)) 120 | return clkId 121 | 122 | -- | Return the top-level name of the atom. 123 | getName :: Atom Name 124 | getName = do 125 | (_st, (_g, a)) <- get 126 | return (atomName a) 127 | 128 | -- | Get the "most-unique" name of an atom in a non-atom context. 129 | getCompiledName :: Atom a -> Name 130 | getCompiledName atm = 131 | let ((_, _nts), atst) = buildAtom defCCtx emptyMap initialGlobal "" atm 132 | (_u, (_g, db)) = atst 133 | in case atomSubs db of 134 | [d] -> atomName d -- unique subatom found 135 | _ -> atomName db -- no subatoms found 136 | 137 | -- | Defines the period of execution of sub-rules as a factor of the base rate 138 | -- of the system. Rule period is bound by the closest period assertion. For 139 | -- example: 140 | -- 141 | -- > period 10 $ period 2 a -- Rules in 'a' have a period of 2, not 10. 142 | period :: Int -> Atom a -> Atom a 143 | period n _ | n <= 0 = error "ERROR: Execution period must be greater than 0." 144 | period n atom' = do 145 | (st, (g, a)) <- get 146 | set (st, (g { gPeriod = n }, a)) 147 | r <- atom' 148 | (st', (g', a')) <- get 149 | set (st', (g' { gPeriod = gPeriod g }, a')) 150 | return r 151 | 152 | -- | Returns the execution period of the current scope. 153 | getPeriod :: Atom Int 154 | getPeriod = do 155 | (_, (g, _)) <- get 156 | return $ gPeriod g 157 | 158 | phase' :: (Int -> Phase) -> Int -> Atom a -> Atom a 159 | phase' _ n _ | n < 0 = error $ "ERROR: phase " ++ show n ++ " must be at least 0." 160 | phase' phType n atom' = do 161 | (st, (g, a)) <- get 162 | if n >= gPeriod g 163 | then error $ "ERROR: phase " ++ show n ++ " must be less than the current period " 164 | ++ show (gPeriod g) ++ "." 165 | else do set (st, (g { gPhase = phType n }, a)) 166 | r <- atom' 167 | (st', (g', a')) <- get 168 | set (st', (g' { gPhase = gPhase g }, a')) 169 | return r 170 | 171 | -- | Defines the earliest phase within the period at which the rule should 172 | -- execute; the scheduler attempt to find an optimal phase from 0 <= @n@ < 173 | -- period (thus, the 'phase' must be at least zero and less than the current 174 | -- 'period'). 175 | phase :: Int -> Atom a -> Atom a 176 | phase = phase' MinPhase 177 | 178 | -- | Ensures an atom is scheduled only at phase @n@. 179 | exactPhase :: Int -> Atom a -> Atom a 180 | exactPhase = phase' ExactPhase 181 | 182 | -- | Returns the phase of the current scope. 183 | getPhase :: Atom Int 184 | getPhase = do 185 | (_, (g, _)) <- get 186 | return $ case gPhase g of 187 | MinPhase ph -> ph 188 | ExactPhase ph -> ph 189 | 190 | -- | Returns the current atom hierarchical path. 191 | path :: Atom String 192 | path = do 193 | (_, (_, atom')) <- get 194 | return $ atomName atom' 195 | 196 | -- | Local boolean variable declaration. 197 | bool :: Name -> Bool -> Atom (V Bool) 198 | bool = var 199 | 200 | -- | External boolean variable declaration. 201 | bool' :: Name -> V Bool 202 | bool' name = var' name Bool 203 | 204 | -- | Local int8 variable declaration. 205 | int8 :: Name -> Int8 -> Atom (V Int8) 206 | int8 = var 207 | 208 | -- | External int8 variable declaration. 209 | int8' :: Name -> V Int8 210 | int8' name = var' name Int8 211 | 212 | -- | Local int16 variable declaration. 213 | int16 :: Name -> Int16 -> Atom (V Int16) 214 | int16 = var 215 | 216 | -- | External int16 variable declaration. 217 | int16' :: Name -> V Int16 218 | int16' name = var' name Int16 219 | 220 | -- | Local int32 variable declaration. 221 | int32 :: Name -> Int32 -> Atom (V Int32) 222 | int32 = var 223 | 224 | -- | External int32 variable declaration. 225 | int32' :: Name -> V Int32 226 | int32' name = var' name Int32 227 | 228 | -- | Local int64 variable declaration. 229 | int64 :: Name -> Int64 -> Atom (V Int64) 230 | int64 = var 231 | 232 | -- | External int64 variable declaration. 233 | int64' :: Name -> V Int64 234 | int64' name = var' name Int64 235 | 236 | -- | Local word8 variable declaration. 237 | word8 :: Name -> Word8 -> Atom (V Word8) 238 | word8 = var 239 | 240 | -- | External word8 variable declaration. 241 | word8' :: Name -> V Word8 242 | word8' name = var' name Word8 243 | 244 | -- | Local word16 variable declaration. 245 | word16 :: Name -> Word16 -> Atom (V Word16) 246 | word16 = var 247 | 248 | -- | External word16 variable declaration. 249 | word16' :: Name -> V Word16 250 | word16' name = var' name Word16 251 | 252 | -- | Local word32 variable declaration. 253 | word32 :: Name -> Word32 -> Atom (V Word32) 254 | word32 = var 255 | 256 | -- | External word32 variable declaration. 257 | word32' :: Name -> V Word32 258 | word32' name = var' name Word32 259 | 260 | -- | Local word64 variable declaration. 261 | word64 :: Name -> Word64 -> Atom (V Word64) 262 | word64 = var 263 | 264 | -- | External word64 variable declaration. 265 | word64' :: Name -> V Word64 266 | word64' name = var' name Word64 267 | 268 | -- | Local float variable declaration. 269 | float :: Name -> Float -> Atom (V Float) 270 | float = var 271 | 272 | -- | External float variable declaration. 273 | float' :: Name -> V Float 274 | float' name = var' name Float 275 | 276 | -- | Local double variable declaration. 277 | double :: Name -> Double -> Atom (V Double) 278 | double = var 279 | 280 | -- | External double variable declaration. 281 | double' :: Name -> V Double 282 | double' name = var' name Double 283 | 284 | -- | Declares an action, which executes C code that is optionally passed 285 | -- some parameters. 286 | action :: ([String] -> String) -- ^ A function which receives a list of 287 | -- C parameters, and returns C code that 288 | -- should be executed. 289 | -> [UE] -- ^ A list of expressions; the supplied functions receive 290 | -- parameters which correspond to these expressions. 291 | -> Atom () 292 | action f ues = do 293 | (st, (g, a)) <- get 294 | let (st', hashes) = 295 | foldl' (\(accSt,hs) ue' -> 296 | let (h,accSt') = newUE ue' accSt in (accSt',h:hs)) 297 | (st,[]) ues 298 | set (st', (g, a { atomActions = atomActions a ++ [(f, hashes)] })) 299 | 300 | -- | Calls an external C function of type 'void f(void)'. 301 | call :: Name -- ^ Function @f@ 302 | -> Atom () 303 | call n = action (\ _ -> n ++ "()") [] 304 | 305 | -- | Declares a probe. A probe allows inspecting any expression, remotely to 306 | -- its context, at any desired rate. 307 | probe :: Expr a => Name -- ^ Human-readable probe name 308 | -> E a -- ^ Expression to inspect 309 | -> Atom () 310 | probe name a = do 311 | (st, (g, atom')) <- get 312 | let (h,st') = newUE (ue a) st 313 | if any (\ (n, _) -> name == n) $ gProbes g 314 | then error $ "ERROR: Duplicated probe name: " ++ name 315 | else set (st', (g { gProbes = (name, h) : gProbes g }, atom')) 316 | 317 | -- | Fetches all declared probes to current design point. The list contained 318 | -- therein is (probe name, untyped expression). 319 | -- See 'Language.LIMA.Unit.printProbe'. 320 | probes :: Atom [(String, UE)] 321 | probes = do 322 | (st, (g, _)) <- get 323 | let (strs,hs) = unzip (gProbes g) 324 | let g' = zip strs (map (recoverUE st) hs) 325 | return g' 326 | 327 | -- | Increments a 'NumE' 'V'. 328 | incr :: (Assign a, NumE a) => V a -> Atom () 329 | incr a = a <== value a + 1 330 | 331 | -- | Decrements a 'NumE' 'V'. 332 | decr :: (Assign a, NumE a) => V a -> Atom () 333 | decr a = a <== value a - 1 334 | 335 | 336 | class Expr a => Assign a where 337 | -- | Assign an 'E' to a 'V'. 338 | (<==) :: V a -> E a -> Atom () 339 | v <== e = do 340 | (st, (g, atom')) <- get 341 | let (h,st0) = newUE (ue e) st 342 | let (muv,st1) = newUV (uv v) st0 343 | set (st1, (g, atom' { atomAssigns = (muv, h) : atomAssigns atom' })) 344 | 345 | instance Assign Bool 346 | instance Assign Int8 347 | instance Assign Int16 348 | instance Assign Int32 349 | instance Assign Int64 350 | instance Assign Word8 351 | instance Assign Word16 352 | instance Assign Word32 353 | instance Assign Word64 354 | instance Assign Float 355 | instance Assign Double 356 | 357 | -- | Adds an enabling condition to an atom subtree of rules. 358 | -- This condition must be true before any rules in hierarchy 359 | -- are allowed to execute. 360 | cond :: E Bool -> Atom () 361 | cond c = do 362 | (st, (g, atom')) <- get 363 | let ae = recoverUE st (atomEnable atom') 364 | let (h, st') = newUE (uand ae (ue c)) st 365 | set (st', (g, atom' { atomEnable = h })) 366 | 367 | -- | Similar to 'cond', but does not inherit the enable condition from its 368 | -- parent. 369 | cond' :: E Bool -> Atom () 370 | cond' c = do 371 | (st, (g, atom')) <- get 372 | let (h, st') = newUE (ue c) st -- no inheritance 373 | set (st', (g, atom' { atomEnableNH = h })) 374 | 375 | -- | Reference to the 64-bit free running clock. 376 | clock :: E Word64 377 | clock = value $ word64' "__global_clock" 378 | 379 | -- | Rule coverage information. (current coverage index, coverage data) 380 | nextCoverage :: Atom (E Word32, E Word32) 381 | nextCoverage = do 382 | action (const "__coverage_index = (__coverage_index + 1) % __coverage_len") [] 383 | return (value $ word32' "__coverage_index", value $ word32' "__coverage[__coverage_index]") 384 | 385 | -- | An assertions checks that an 'E Bool' is true. Assertions are checked 386 | -- between the execution of every rule. Parent enabling conditions can 387 | -- disable assertions, but period and phase constraints do not. Assertion 388 | -- names should be globally unique. 389 | assert :: Name -> E Bool -> Atom () 390 | assert name check = do 391 | (st, (g, atom')) <- get 392 | -- TODO 393 | -- let names = map fst (atomAsserts atom') 394 | -- when (name `elem` names) 395 | -- (liftIO $ putStrLn $ "WARNING: Assertion name already used: " ++ name) 396 | let (chk,st') = newUE (ue check) st 397 | set (st', (g, atom' { atomAsserts = (name, chk) : atomAsserts atom' })) 398 | 399 | -- | Implication assertions. Creates an implicit coverage point for the 400 | -- precondition. 401 | assertImply :: Name -> E Bool -> E Bool -> Atom () 402 | assertImply name a b = do 403 | assert name $ imply a b 404 | cover (name ++ "Precondition") a 405 | 406 | -- | A functional coverage point tracks if an event has occurred (true). 407 | -- Coverage points are checked at the same time as assertions. 408 | -- Coverage names should be globally unique. 409 | cover :: Name -> E Bool -> Atom () 410 | cover name check = do 411 | (st, (g, atom')) <- get 412 | -- TODO 413 | -- let names = map fst (atomCovers atom') 414 | -- when (name `elem` names) 415 | -- (liftIO . putStrLn $ "WARNING: Coverage name already used: " ++ name) 416 | let (chk,st') = newUE (ue check) st 417 | set (st', (g, atom' { atomCovers = (name, chk) : atomCovers atom' })) 418 | -------------------------------------------------------------------------------- /lima/src/Language/LIMA/Types.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Language.LIMA.Types 3 | -- Copyright : Galois Inc. 2016 4 | -- License : BSD3 5 | -- 6 | -- Maintainer : bjones@galois.com 7 | -- Stability : experimental 8 | -- Portability : unknown 9 | -- 10 | -- Collect common types for the LIMA DSL and code generator. 11 | -- 12 | module Language.LIMA.Types ( 13 | UID 14 | , Name 15 | , Path 16 | , Phase(..) 17 | ) where 18 | 19 | 20 | type UID = Int 21 | 22 | -- | A name. 23 | type Name = String 24 | 25 | -- | A hierarchical name. 26 | type Path = [Name] 27 | 28 | -- | A phase is either the minimum phase or the exact phase. 29 | data Phase = MinPhase Int | ExactPhase Int 30 | deriving (Show) 31 | -------------------------------------------------------------------------------- /lima/src/Language/LIMA/UeMap.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: UeMap 3 | -- Description: Sharing for UEs, based on IntMaps. 4 | -- Copyright: (c) 2013 Tom Hawkins & Lee Pike 5 | -- 6 | -- Sharing for 'UE's, based on IntMaps. The idea is to share subexpressions 7 | -- of 'UE's. 8 | {-# LANGUAGE CPP #-} 9 | 10 | module Language.LIMA.UeMap 11 | ( UeElem (..) 12 | , MUV (..) 13 | , UeMap 14 | , emptyMap 15 | , Hash 16 | , typeOf 17 | , UeState 18 | , recoverUE 19 | , getUE 20 | , newUE 21 | , newUV 22 | , maybeUpdate 23 | , ueUpstream 24 | , nearestUVs 25 | , arrayIndices 26 | , isMathHCall 27 | ) where 28 | 29 | import Control.Monad.State.Strict 30 | import qualified Data.Bimap as M 31 | import Data.List (nub) 32 | import Data.Maybe (fromMaybe) 33 | #if __GLASGOW_HASKELL__ >= 800 34 | import GHC.Stack 35 | #endif 36 | 37 | import Language.LIMA.Expressions hiding (typeOf) 38 | import qualified Language.LIMA.Expressions as E 39 | 40 | type Hash = Int 41 | 42 | -- | Keys corresponding to untyped variables in the UeMap. 43 | data MUV 44 | = MUV Int String Const -- ^ internal ID, name, initial value 45 | | MUVArray UA Hash 46 | | MUVExtern String Type -- ^ external name, type 47 | | MUVChannel Int String Type -- ^ internal ID, channel name, type 48 | | MUVChannelReady Int String -- ^ internal ID, channel name 49 | deriving (Show, Eq, Ord) 50 | 51 | -- | Transforms a 'UV' into a 'MUV', returning the possibly updated map. 52 | newUV :: UV -> UeMap -> (MUV, UeMap) 53 | newUV u mp = 54 | case u of 55 | UV i j k -> (MUV i j k, mp) 56 | UVExtern i j -> (MUVExtern i j, mp) 57 | UVArray arr ue_ -> let (h,mp') = newUE ue_ mp 58 | in (MUVArray arr h, mp') 59 | UVChannel i j k -> (MUVChannel i j k, mp) 60 | UVChannelReady i j -> (MUVChannelReady i j, mp) 61 | 62 | -- | Corresponds to 'UE's --- the elements in the sharing structure. 63 | data UeElem 64 | = MUVRef !MUV 65 | | MUConst !Const 66 | | MUCast !Type !Hash 67 | | MUAdd !Hash !Hash 68 | | MUSub !Hash !Hash 69 | | MUMul !Hash !Hash 70 | | MUDiv !Hash !Hash 71 | | MUMod !Hash !Hash 72 | | MUNot !Hash 73 | | MUAnd [Hash] 74 | | MUBWNot !Hash 75 | | MUBWAnd !Hash !Hash 76 | | MUBWOr !Hash !Hash 77 | | MUBWXor !Hash !Hash 78 | | MUBWShiftL !Hash !Hash 79 | | MUBWShiftR !Hash !Hash 80 | | MUEq !Hash !Hash 81 | | MULt !Hash !Hash 82 | | MUMux !Hash !Hash !Hash 83 | | MUF2B !Hash 84 | | MUD2B !Hash 85 | | MUB2F !Hash 86 | | MUB2D !Hash 87 | 88 | -- math.h: 89 | | MUPi 90 | | MUExp !Hash 91 | | MULog !Hash 92 | | MUSqrt !Hash 93 | | MUPow !Hash !Hash 94 | | MUSin !Hash 95 | | MUAsin !Hash 96 | | MUCos !Hash 97 | | MUAcos !Hash 98 | | MUSinh !Hash 99 | | MUCosh !Hash 100 | | MUAsinh !Hash 101 | | MUAcosh !Hash 102 | | MUAtan !Hash 103 | | MUAtanh !Hash 104 | deriving (Show, Eq, Ord) 105 | 106 | typeOf :: Hash -> UeMap -> Type 107 | typeOf h mp = case getUE h mp of 108 | MUVRef (MUV _ _ a) -> E.typeOf a 109 | MUVRef (MUVArray a _) -> E.typeOf a 110 | MUVRef (MUVExtern _ t) -> t 111 | MUVRef (MUVChannel _ _ t) -> t 112 | MUVRef (MUVChannelReady{}) -> Bool 113 | MUCast t _ -> t 114 | MUConst c -> E.typeOf c 115 | MUAdd a _ -> typeOf' a 116 | MUSub a _ -> typeOf' a 117 | MUMul a _ -> typeOf' a 118 | MUDiv a _ -> typeOf' a 119 | MUMod a _ -> typeOf' a 120 | MUNot _ -> Bool 121 | MUAnd _ -> Bool 122 | MUBWNot a -> typeOf' a 123 | MUBWAnd a _ -> typeOf' a 124 | MUBWOr a _ -> typeOf' a 125 | MUBWXor a _ -> typeOf' a 126 | MUBWShiftL a _ -> typeOf' a 127 | MUBWShiftR a _ -> typeOf' a 128 | MUEq _ _ -> Bool 129 | MULt _ _ -> Bool 130 | MUMux _ a _ -> typeOf' a 131 | MUF2B _ -> Word32 132 | MUD2B _ -> Word64 133 | MUB2F _ -> Float 134 | MUB2D _ -> Double 135 | 136 | -- math.h: 137 | MUPi -> Double 138 | MUExp a -> typeOf' a 139 | MULog a -> typeOf' a 140 | MUSqrt a -> typeOf' a 141 | MUPow a _ -> typeOf' a 142 | MUSin a -> typeOf' a 143 | MUAsin a -> typeOf' a 144 | MUCos a -> typeOf' a 145 | MUAcos a -> typeOf' a 146 | MUSinh a -> typeOf' a 147 | MUCosh a -> typeOf' a 148 | MUAsinh a -> typeOf' a 149 | MUAcosh a -> typeOf' a 150 | MUAtan a -> typeOf' a 151 | MUAtanh a -> typeOf' a 152 | where 153 | typeOf' h' = typeOf h' mp 154 | 155 | -- | An entry in the Map. 156 | type UeMap = (Hash, M.Bimap Int UeElem) 157 | 158 | -- | Wrapped in the State Monad. 159 | type UeState a = State UeMap a 160 | 161 | -- | Get the element associated with a 'Hash' value. It's a runtime error if 162 | -- the element is not in the map. 163 | #if __GLASGOW_HASKELL__ >= 800 164 | getUE :: HasCallStack => Hash -> UeMap -> UeElem 165 | #else 166 | getUE :: Hash -> UeMap -> UeElem 167 | #endif 168 | getUE h (_, mp) = 169 | flip fromMaybe (M.lookup h mp) $ 170 | error $ "Error looking up hash " ++ show h 171 | ++ " in the UE map\n" ++ show mp 172 | #if __GLASGOW_HASKELL__ >= 800 173 | ++ "\n" ++ prettyCallStack callStack 174 | #endif 175 | 176 | -- | Put a new 'UE' in the map, unless it's already in there, and return the 177 | -- hash pointing to the 'UE' and a new map. 178 | newUE :: UE -> UeMap -> (Hash, UeMap) 179 | newUE ue_ = runState (share ue_) 180 | 181 | emptyMap :: UeMap 182 | emptyMap = (0, M.empty) 183 | 184 | -- | Create the sharing map. 185 | share :: UE -> UeState Hash 186 | share e = case e of 187 | UVRef (UV i j k) -> maybeUpdate (MUVRef $ MUV i j k) 188 | UVRef (UVExtern i j) -> maybeUpdate (MUVRef $ MUVExtern i j) 189 | UVRef (UVArray arr a) -> unOp a (MUVRef . MUVArray arr) 190 | UVRef (UVChannel i j k) -> maybeUpdate (MUVRef $ MUVChannel i j k) 191 | UVRef (UVChannelReady i j) -> maybeUpdate (MUVRef $ MUVChannelReady i j) 192 | UConst a -> maybeUpdate (MUConst a) 193 | UCast t a -> unOp a (MUCast t) 194 | UAdd a b -> binOp (a,b) MUAdd 195 | USub a b -> binOp (a,b) MUSub 196 | UMul a b -> binOp (a,b) MUMul 197 | UDiv a b -> binOp (a,b) MUDiv 198 | UMod a b -> binOp (a,b) MUMod 199 | UNot a -> unOp a MUNot 200 | UAnd ls -> listOp ls MUAnd 201 | UBWNot a -> unOp a MUBWNot 202 | UBWAnd a b -> binOp (a,b) MUBWAnd 203 | UBWOr a b -> binOp (a,b) MUBWOr 204 | UBWXor a b -> binOp (a,b) MUBWXor 205 | UBWShiftL a b -> binOp (a,b) MUBWShiftL 206 | UBWShiftR a b -> binOp (a,b) MUBWShiftR 207 | UEq a b -> binOp (a,b) MUEq 208 | ULt a b -> binOp (a,b) MULt 209 | UMux a b c -> triOp (a,b,c) MUMux 210 | UF2B a -> unOp a MUF2B 211 | UD2B a -> unOp a MUD2B 212 | UB2F a -> unOp a MUB2F 213 | UB2D a -> unOp a MUB2D 214 | 215 | -- math.h: 216 | UPi -> maybeUpdate (MUPi) 217 | UExp a -> unOp a MUExp 218 | ULog a -> unOp a MULog 219 | USqrt a -> unOp a MUSqrt 220 | UPow a b -> binOp (a,b) MUPow 221 | USin a -> unOp a MUSin 222 | UAsin a -> unOp a MUAsin 223 | UCos a -> unOp a MUCos 224 | UAcos a -> unOp a MUAcos 225 | USinh a -> unOp a MUSinh 226 | UCosh a -> unOp a MUCosh 227 | UAsinh a -> unOp a MUAsinh 228 | UAcosh a -> unOp a MUAcosh 229 | UAtan a -> unOp a MUAtan 230 | UAtanh a -> unOp a MUAtanh 231 | 232 | -- XXX I could combine some of the following functions (unOp, binOp, etc.) to 233 | -- slightly reduce code... 234 | unOp :: UE -> (Hash -> UeElem) -> UeState Hash 235 | unOp e code = do 236 | h <- share e 237 | maybeUpdate (code h) 238 | 239 | binOp :: (UE, UE) -> (Hash -> Hash -> UeElem) -> UeState Hash 240 | binOp (e0,e1) code = do 241 | h0 <- share e0 242 | h1 <- share e1 243 | maybeUpdate (code h0 h1) 244 | 245 | triOp :: (UE, UE, UE) -> (Hash -> Hash -> Hash -> UeElem) -> UeState Hash 246 | triOp (e0,e1,e2) code = do 247 | h0 <- share e0 248 | h1 <- share e1 249 | h2 <- share e2 250 | maybeUpdate (code h0 h1 h2) 251 | 252 | listOp :: [UE] -> ([Hash] -> UeElem) -> UeState Hash 253 | listOp es code = do 254 | hashes <- foldM (\hashes e -> do h <- share e 255 | return (h:hashes) 256 | ) [] es 257 | maybeUpdate (code hashes) 258 | 259 | -- | Lookup an element in the map, and if it's in there, do nothing, but return 260 | -- its hash value. Otherwise, update the map and return the new hash value 261 | -- for the inserted element. 262 | maybeUpdate :: UeElem -> UeState Hash 263 | maybeUpdate e = do 264 | st <- get 265 | let mp = snd st 266 | case M.lookupR e mp of 267 | Nothing -> do let hash = fst st + 1 268 | put (hash, M.insert hash e mp) 269 | return hash 270 | Just h -> return h 271 | 272 | -- | Get a 'UE' back out of the 'UeMap'. 273 | recoverUE :: UeMap -> Hash -> UE 274 | recoverUE st h = case getUE h st of 275 | MUVRef (MUV i j k) -> UVRef (UV i j k) 276 | MUVRef (MUVArray i a) -> UVRef (UVArray i (recover' a)) 277 | MUVRef (MUVExtern i j) -> UVRef (UVExtern i j) 278 | MUVRef (MUVChannel i j k) -> UVRef (UVChannel i j k) 279 | MUVRef (MUVChannelReady i j) -> UVRef (UVChannelReady i j) 280 | MUCast t a -> UCast t (recover' a) 281 | MUConst a -> UConst a 282 | MUAdd a b -> UAdd (recover' a) (recover' b) 283 | MUSub a b -> USub (recover' a) (recover' b) 284 | MUMul a b -> UMul (recover' a) (recover' b) 285 | MUDiv a b -> UDiv (recover' a) (recover' b) 286 | MUMod a b -> UMod (recover' a) (recover' b) 287 | MUNot a -> UNot (recover' a) 288 | MUAnd a -> UAnd $ map recover' a 289 | MUBWNot a -> UBWNot (recover' a) 290 | MUBWAnd a b -> UBWAnd (recover' a) (recover' b) 291 | MUBWOr a b -> UBWOr (recover' a) (recover' b) 292 | MUBWXor a b -> UBWXor (recover' a) (recover' b) 293 | MUBWShiftL a b -> UBWShiftL (recover' a) (recover' b) 294 | MUBWShiftR a b -> UBWShiftR (recover' a) (recover' b) 295 | MUEq a b -> UEq (recover' a) (recover' b) 296 | MULt a b -> ULt (recover' a) (recover' b) 297 | MUMux a b c -> UMux (recover' a) (recover' b) (recover' c) 298 | MUF2B a -> UF2B (recover' a) 299 | MUD2B a -> UD2B (recover' a) 300 | MUB2F a -> UB2F (recover' a) 301 | MUB2D a -> UB2D (recover' a) 302 | 303 | -- math.h: 304 | MUPi -> UPi 305 | MUExp a -> UExp (recover' a) 306 | MULog a -> ULog (recover' a) 307 | MUSqrt a -> USqrt (recover' a) 308 | MUPow a b -> UPow (recover' a) (recover' b) 309 | MUSin a -> USin (recover' a) 310 | MUAsin a -> UAsin (recover' a) 311 | MUCos a -> UCos (recover' a) 312 | MUAcos a -> UAcos (recover' a) 313 | MUSinh a -> USinh (recover' a) 314 | MUCosh a -> UCosh (recover' a) 315 | MUAsinh a -> UAsinh (recover' a) 316 | MUAcosh a -> UAcosh (recover' a) 317 | MUAtan a -> UAtan (recover' a) 318 | MUAtanh a -> UAtanh (recover' a) 319 | where recover' = recoverUE st 320 | 321 | -- | The list of Hashes to adjacent upstream of a UE. 322 | ueUpstream :: Hash -> UeMap -> [Hash] 323 | ueUpstream h t = case getUE h t of 324 | MUVRef MUV{} -> [] 325 | MUVRef (MUVArray _ a) -> [a] 326 | MUVRef MUVExtern{} -> [] 327 | MUVRef MUVChannel{} -> [] 328 | MUVRef MUVChannelReady{} -> [] 329 | MUCast _ a -> [a] 330 | MUConst _ -> [] 331 | MUAdd a b -> [a, b] 332 | MUSub a b -> [a, b] 333 | MUMul a b -> [a, b] 334 | MUDiv a b -> [a, b] 335 | MUMod a b -> [a, b] 336 | MUNot a -> [a] 337 | MUAnd a -> a 338 | MUBWNot a -> [a] 339 | MUBWAnd a b -> [a, b] 340 | MUBWOr a b -> [a, b] 341 | MUBWXor a b -> [a, b] 342 | MUBWShiftL a b -> [a, b] 343 | MUBWShiftR a b -> [a, b] 344 | MUEq a b -> [a, b] 345 | MULt a b -> [a, b] 346 | MUMux a b c -> [a, b, c] 347 | MUF2B a -> [a] 348 | MUD2B a -> [a] 349 | MUB2F a -> [a] 350 | MUB2D a -> [a] 351 | 352 | -- math.h: 353 | MUPi -> [] 354 | MUExp a -> [a] 355 | MULog a -> [a] 356 | MUSqrt a -> [a] 357 | MUPow a b -> [a, b] 358 | MUSin a -> [a] 359 | MUAsin a -> [a] 360 | MUCos a -> [a] 361 | MUAcos a -> [a] 362 | MUSinh a -> [a] 363 | MUCosh a -> [a] 364 | MUAsinh a -> [a] 365 | MUAcosh a -> [a] 366 | MUAtan a -> [a] 367 | MUAtanh a -> [a] 368 | 369 | -- | The list of all UVs that directly control the value of an expression. 370 | nearestUVs :: Hash -> UeMap -> [MUV] 371 | nearestUVs h mp = nub $ f h 372 | where 373 | f :: Hash -> [MUV] 374 | f hash = case getUE hash mp of 375 | (MUVRef u@(MUVArray _ h')) -> [u] ++ f h' 376 | (MUVRef u) -> [u] 377 | _ -> concatMap f $ ueUpstream hash mp 378 | 379 | -- | All array indexing subexpressions. 380 | arrayIndices :: Hash -> UeMap -> [(UA, Hash)] 381 | arrayIndices h mp = nub $ f h 382 | where 383 | f :: Hash -> [(UA, Hash)] 384 | f hash = case getUE hash mp of 385 | (MUVRef (MUVArray ua h')) -> (ua, h') : f h' 386 | _ -> concatMap f $ ueUpstream hash mp 387 | 388 | -- | Determine if untyped expression involes a math.h function call 389 | isMathHCall :: UeElem -> Bool 390 | isMathHCall fc = 391 | case fc of 392 | MUPi -> True 393 | MUExp _ -> True 394 | MULog _ -> True 395 | MUSqrt _ -> True 396 | MUPow _ _ -> True 397 | MUSin _ -> True 398 | MUAsin _ -> True 399 | MUCos _ -> True 400 | MUAcos _ -> True 401 | MUSinh _ -> True 402 | MUCosh _ -> True 403 | MUAsinh _ -> True 404 | MUAcosh _ -> True 405 | MUAtan _ -> True 406 | MUAtanh _ -> True 407 | _ -> False 408 | 409 | -------------------------------------------------------------------------------- /scripts/renamer.sh: -------------------------------------------------------------------------------- 1 | find . -not \( -path './.git*' \) -type f -exec sed -i bak 's/slim/lima/g' \{\} \; 2 | find . -not \( -path './.git*' \) -type f -exec sed -i bak 's/SLIM/LIMA/g' \{\} \; 3 | find . -name '*bak' -delete 4 | --------------------------------------------------------------------------------