├── .gitignore ├── .travis.yml ├── CODE_OF_CONDUCT.md ├── LICENSE ├── Makefile ├── README.md ├── stack-7.10.yaml ├── stack-8.0.2.yaml ├── stack.mk ├── stack.yaml ├── tower-aadl ├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── default.conf ├── src │ └── Tower │ │ ├── AADL.hs │ │ └── AADL │ │ ├── AST.hs │ │ ├── AST │ │ └── Common.hs │ │ ├── Build │ │ ├── Common.hs │ │ └── SeL4.hs │ │ ├── CodeGen.hs │ │ ├── Compile.hs │ │ ├── Config.hs │ │ ├── FromTower.hs │ │ ├── Identifier.hs │ │ ├── Names.hs │ │ ├── Platform.hs │ │ ├── Priorities.hs │ │ ├── Render.hs │ │ ├── Render │ │ ├── Common.hs │ │ └── Types.hs │ │ └── Threads.hs ├── test-echronos │ ├── Simple.hs │ ├── SyncTxRx.hs │ ├── Test1.hs │ └── TestPerSender.hs ├── test │ ├── External.hs │ ├── Simple.hs │ ├── SyncTxRx.hs │ ├── Test1.hs │ └── TestPerSender.hs └── tower-aadl.cabal ├── tower-config ├── .gitignore ├── Makefile ├── src │ ├── Ivory │ │ └── Tower │ │ │ ├── Config.hs │ │ │ └── Config │ │ │ ├── Document.hs │ │ │ ├── Options.hs │ │ │ ├── Parser.hs │ │ │ ├── Preprocess.hs │ │ │ └── TOML.hs │ └── Text │ │ ├── LICENSE │ │ ├── README.md │ │ ├── TOML.hs │ │ └── TOML │ │ ├── Parser.hs │ │ └── Value.hs ├── tests │ ├── Main.hs │ ├── resources1 │ │ ├── child1.config │ │ ├── root.config │ │ └── trivial.config │ └── resources2 │ │ ├── child2.config │ │ └── resources3 │ │ └── child3.config └── tower-config.cabal ├── tower-hal ├── LICENSE ├── Makefile ├── Setup.hs ├── src │ └── Ivory │ │ └── Tower │ │ └── HAL │ │ ├── Bus │ │ ├── CAN.hs │ │ ├── CAN │ │ │ ├── Fragment.hs │ │ │ ├── Sched.hs │ │ │ └── sched.dot │ │ ├── I2C.hs │ │ ├── I2C │ │ │ └── DeviceAddr.hs │ │ ├── Interface.hs │ │ ├── SPI.hs │ │ ├── SPI │ │ │ └── DeviceHandle.hs │ │ ├── Sched.hs │ │ ├── Sched │ │ │ └── Internal.hs │ │ ├── SchedAsync.hs │ │ └── UART.hs │ │ └── RingBuffer.hs └── tower-hal.cabal ├── tower-mini ├── .gitignore ├── Makefile ├── default.conf ├── src │ └── Tower │ │ ├── Mini.hs │ │ └── Mini │ │ └── Component.hs ├── test │ ├── Integrated.hs │ ├── Simple.hs │ └── cfiles │ │ ├── intermon1.c │ │ ├── intermon1.h │ │ ├── intermon2.c │ │ └── intermon2.h └── tower-mini.cabal └── tower ├── .gitignore ├── Makefile ├── src └── Ivory │ ├── Tower.hs │ └── Tower │ ├── AST.hs │ ├── AST │ ├── Chan.hs │ ├── Comment.hs │ ├── Emitter.hs │ ├── Graph.hs │ ├── Handler.hs │ ├── Init.hs │ ├── Monitor.hs │ ├── Period.hs │ ├── Signal.hs │ ├── SyncChan.hs │ ├── Thread.hs │ └── Tower.hs │ ├── Backend.hs │ ├── Coroutine.hs │ ├── Handler.hs │ ├── Monad │ ├── Base.hs │ ├── Handler.hs │ ├── Monitor.hs │ └── Tower.hs │ ├── Monitor.hs │ ├── Options.hs │ ├── SrcLoc │ ├── Location.hs │ └── Plugin.hs │ ├── Tower.hs │ └── Types │ ├── Chan.hs │ ├── ChanMap.hs │ ├── Dependencies.hs │ ├── Emitter.hs │ ├── SignalCode.hs │ ├── Signalable.hs │ ├── ThreadCode.hs │ ├── Time.hs │ └── Unique.hs └── tower.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | .cabal-sandbox 3 | cabal.sandbox.config 4 | TAGS 5 | .hpc 6 | *.aadl 7 | *.swp 8 | .stack-work 9 | /tower-aadl/test_external_codegen 10 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: false 2 | language: c 3 | 4 | cache: 5 | directories: 6 | - $HOME/.stack 7 | 8 | matrix: 9 | include: 10 | - env: GHCVER=7.10.3 STACK_YAML=stack.yaml 11 | addons: {apt: {packages: [ghc-7.10.3], sources: [hvr-ghc]}} 12 | - env: GHCVER=8.0.2 STACK_YAML=stack-8.0.2.yaml 13 | addons: {apt: {packages: [ghc-8.0.2], sources: [hvr-ghc]}} 14 | 15 | before_install: 16 | # Download and unpack the stack executable 17 | - mkdir -p ~/.local/bin 18 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 19 | - export PATH=$HOME/.local/bin:/opt/ghc/$GHCVER/bin:$PATH 20 | - ghc --version 21 | - stack --version 22 | install: 23 | # Check out depenendency repos, then check out the branch that 24 | # matches the current branch name in this repo. If one doesn't 25 | # exist, don't fail, in case we're branched in this repo but just 26 | # depending on master elsewhere. 27 | # 28 | # Travis seems to have no problem with the multi-line if above, 29 | # but barfs when we format this one nicely. 30 | - for repo in ivory; do git clone https://github.com/galoisinc/$repo; (cd $repo; git checkout $TRAVIS_BRANCH) || true; export ${repo^^}_REPO=$PWD/$repo; done 31 | # tweak the relative paths in stack.yaml 32 | - export STACK_YAML=$PWD/$STACK_YAML 33 | - sed -i "s;\.\./;$PWD/;g" $STACK_YAML 34 | script: 35 | - make travis-test 36 | -------------------------------------------------------------------------------- /CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Contributor Code of Conduct 2 | 3 | As contributors and maintainers of this project, and in the interest of 4 | fostering an open and welcoming community, we pledge to respect all people who 5 | contribute through reporting issues, posting feature requests, updating 6 | documentation, submitting pull requests or patches, and other activities. 7 | 8 | We are committed to making participation in this project a harassment-free 9 | experience for everyone, regardless of level of experience, gender, gender 10 | identity and expression, sexual orientation, disability, personal appearance, 11 | body size, race, ethnicity, age, religion, or nationality. 12 | 13 | Examples of unacceptable behavior by participants include: 14 | 15 | * The use of sexualized language or imagery 16 | * Personal attacks 17 | * Trolling or insulting/derogatory comments 18 | * Public or private harassment 19 | * Publishing other's private information, such as physical or electronic 20 | addresses, without explicit permission 21 | * Other unethical or unprofessional conduct 22 | 23 | Project maintainers have the right and responsibility to remove, edit, or 24 | reject comments, commits, code, wiki edits, issues, and other contributions 25 | that are not aligned to this Code of Conduct, or to ban temporarily or 26 | permanently any contributor for other behaviors that they deem inappropriate, 27 | threatening, offensive, or harmful. 28 | 29 | By adopting this Code of Conduct, project maintainers commit themselves to 30 | fairly and consistently applying these principles to every aspect of managing 31 | this project. Project maintainers who do not follow or enforce the Code of 32 | Conduct may be permanently removed from the project team. 33 | 34 | This Code of Conduct applies both within project spaces and in public spaces 35 | when an individual is representing the project or its community. 36 | 37 | Instances of abusive, harassing, or otherwise unacceptable behavior may be 38 | reported by contacting a project maintainer at 39 | [smaccm@galois.com](mailto:smaccm@galois.com). 40 | All complaints will be reviewed and investigated and will result in a response 41 | that is deemed necessary and appropriate to the circumstances. Maintainers are 42 | obligated to maintain confidentiality with regard to the reporter of an 43 | incident. 44 | 45 | 46 | This Code of Conduct is adapted from the [Contributor Covenant][homepage], 47 | version 1.3.0, available at 48 | [http://contributor-covenant.org/version/1/3/0/][version] 49 | 50 | [homepage]: http://contributor-covenant.org 51 | [version]: http://contributor-covenant.org/version/1/3/0/ 52 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (C) 2014-2015, Galois, Inc. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are 6 | met: 7 | 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the distribution. 14 | 15 | 3. Neither the name of the author nor the names of its contributors 16 | may be used to endorse or promote products derived from this software 17 | without specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | include stack.mk 2 | 3 | SUBDIRS = tower tower-config tower-aadl tower-hal tower-mini 4 | 5 | default: $(SUBDIRS) 6 | 7 | $(SUBDIRS): 8 | make -C $@ test 9 | 10 | .PHONY: $(SUBDIRS) 11 | 12 | TRAVIS_STACK ?= stack --no-terminal 13 | 14 | travis-test: 15 | $(TRAVIS_STACK) setup 16 | $(TRAVIS_STACK) build --test --no-run-tests --haddock --no-haddock-deps --pedantic 17 | make $(SUBDIRS) 18 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # [Tower][tower] 2 | 3 | ## About 4 | 5 | Tower is a concurrency framework for the [Ivory language][ivory]. Tower 6 | composes Ivory programs into monitors which communicate with synchronous 7 | channels. 8 | 9 | Tower uses pluggable backends to support individual operating systems and 10 | target architectures. A backend for the [FreeRTOS][freertos] operating 11 | system running on the [STM32][] line of microcontrollers is available in 12 | the [ivory-tower-stm32][] repo, and a backend for general purpose POSIX 13 | operating systems is available in the [ivory-tower-posix][] repo. 14 | 15 | [![Build Status](https://travis-ci.org/GaloisInc/tower.svg?branch=tower-9)](https://travis-ci.org/GaloisInc/tower) 16 | 17 | ## Copyright and license 18 | Copyright 2015 [Galois, Inc.][galois] 19 | 20 | Licensed under the BSD 3-Clause License; you may not use this work except in 21 | compliance with the License. A copy of the License is included in the LICENSE 22 | file. 23 | 24 | Portions Copyright (c) 2013-2014, Spiros Eliopoulos, derived from the now 25 | unmaintained `toml` package. 26 | 27 | [ivory]: http://github.com/GaloisInc/ivory 28 | [tower]: http://github.com/GaloisInc/tower 29 | [ivory-tower-stm32]: http://github.com/GaloisInc/ivory-tower-stm32 30 | [ivory-tower-posix]: http://github.com/GaloisInc/ivory-tower-posix 31 | [overview]: http://smaccmpilot.org/software/tower-overview.html 32 | 33 | [STM32]: http://www.st.com/stm32 34 | [freertos]: http://freertos.org 35 | [galois]: http://galois.com 36 | 37 | 38 | ## Contributing 39 | 40 | This project adheres to the 41 | [Contributor Covenant code of conduct](CODE_OF_CONDUCT.md). 42 | By participating, you are expected to uphold this code. Please report unaccpetable 43 | behavior to [smaccm@galois.com](mailto:smaccm@galois.com). 44 | 45 | -------------------------------------------------------------------------------- /stack-7.10.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration.html 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | resolver: lts-6.10 5 | 6 | # Local packages, usually specified by relative directory name 7 | packages: 8 | - tower/ 9 | - tower-aadl/ 10 | - tower-config/ 11 | - tower-hal/ 12 | - tower-mini/ 13 | - location: ../ivory 14 | extra-dep: true 15 | subdirs: 16 | - ivory 17 | - ivory-artifact 18 | - ivory-backend-c 19 | - ivory-opts 20 | - ivory-serialize 21 | - ivory-stdlib 22 | 23 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 24 | extra-deps: 25 | - th-abstraction-0.2.5.0 26 | - monadLib-3.7.3 27 | 28 | # Override default flag values for local packages and extra-deps 29 | flags: {} 30 | 31 | # Extra package databases containing global packages 32 | extra-package-dbs: [] 33 | 34 | install-ghc: true 35 | 36 | # Control whether we use the GHC we find on the path 37 | # system-ghc: true 38 | 39 | # Require a specific version of stack, using version ranges 40 | # require-stack-version: -any # Default 41 | # require-stack-version: >= 1.0.0 42 | 43 | # Override the architecture used by stack, especially useful on Windows 44 | # arch: i386 45 | # arch: x86_64 46 | 47 | # Extra directories used by stack for building 48 | # extra-include-dirs: [/path/to/dir] 49 | # extra-lib-dirs: [/path/to/dir] 50 | 51 | # Allow a newer minor version of GHC than the snapshot specifies 52 | # compiler-check: newer-minor 53 | -------------------------------------------------------------------------------- /stack-8.0.2.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration.html 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | resolver: lts-9.0 5 | 6 | # Local packages, usually specified by relative directory name 7 | packages: 8 | - tower/ 9 | - tower-aadl/ 10 | - tower-config/ 11 | - tower-hal/ 12 | - tower-mini/ 13 | - location: ../ivory 14 | extra-dep: true 15 | subdirs: 16 | - ivory 17 | - ivory-artifact 18 | - ivory-backend-c 19 | - ivory-opts 20 | - ivory-serialize 21 | - ivory-stdlib 22 | 23 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 24 | extra-deps: 25 | - th-abstraction-0.2.5.0 26 | - monadLib-3.7.3 27 | 28 | # Override default flag values for local packages and extra-deps 29 | flags: {} 30 | 31 | # Extra package databases containing global packages 32 | extra-package-dbs: [] 33 | 34 | install-ghc: true 35 | 36 | # Control whether we use the GHC we find on the path 37 | # system-ghc: true 38 | 39 | # Require a specific version of stack, using version ranges 40 | # require-stack-version: -any # Default 41 | # require-stack-version: >= 1.0.0 42 | 43 | # Override the architecture used by stack, especially useful on Windows 44 | # arch: i386 45 | # arch: x86_64 46 | 47 | # Extra directories used by stack for building 48 | # extra-include-dirs: [/path/to/dir] 49 | # extra-lib-dirs: [/path/to/dir] 50 | 51 | # Allow a newer minor version of GHC than the snapshot specifies 52 | # compiler-check: newer-minor 53 | -------------------------------------------------------------------------------- /stack.mk: -------------------------------------------------------------------------------- 1 | default: 2 | stack build . 3 | test: 4 | stack build . --test 5 | 6 | clean: 7 | 8 | distclean: clean 9 | stack clean 10 | 11 | .PHONY: default test clean distclean 12 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | stack-8.0.2.yaml -------------------------------------------------------------------------------- /tower-aadl/.gitignore: -------------------------------------------------------------------------------- 1 | RAMSES_PATH 2 | test_codegen 3 | -------------------------------------------------------------------------------- /tower-aadl/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (C) 2013, Galois, Inc. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are 6 | met: 7 | 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the distribution. 14 | 15 | 3. Neither the name of the author nor the names of its contributors 16 | may be used to endorse or promote products derived from this software 17 | without specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /tower-aadl/Makefile: -------------------------------------------------------------------------------- 1 | include ../stack.mk 2 | 3 | test: default 4 | stack exec -- test --src-dir=test_codegen 5 | 6 | test-external: default 7 | stack exec -- test-external --src-dir=test_external_codegen 8 | 9 | .PHONY: test-echronos 10 | test-echronos: default 11 | stack exec -- test-echronos --src-dir=test_echronos_codegen --lib-dir="" 12 | -------------------------------------------------------------------------------- /tower-aadl/README.md: -------------------------------------------------------------------------------- 1 | # [Tower-AADL][tower-aadl] 2 | 3 | A backend from Tower to AADL. 4 | -------------------------------------------------------------------------------- /tower-aadl/default.conf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/GaloisInc/tower/a43f5e36c6443472ea2dc15bbd49faf8643a6f87/tower-aadl/default.conf -------------------------------------------------------------------------------- /tower-aadl/src/Tower/AADL/AST.hs: -------------------------------------------------------------------------------- 1 | -- 2 | -- AST for the fragment of AADL we generate. 3 | -- 4 | -- (c) 2014 Galois, Inc. 5 | -- 6 | 7 | module Tower.AADL.AST where 8 | 9 | import qualified Ivory.Language.Syntax.Type as I 10 | import qualified Ivory.Tower.AST.Comment as C 11 | 12 | ---------------------------------------- 13 | 14 | data System = System 15 | { systemName :: !Name 16 | , systemComponents :: [Process] 17 | -- ^ For eChronos and seL4, there will be one process per system. 18 | , systemProperties :: [SystemProperty] 19 | } deriving (Show, Eq) 20 | 21 | data Process = Process 22 | { processName :: !Name 23 | , processComponents :: [Thread] 24 | } deriving (Show, Eq) 25 | 26 | data SystemProperty = 27 | SystemOS !String 28 | | SystemHW !String 29 | | SystemAddr (Maybe Integer) 30 | deriving (Show, Eq) 31 | 32 | data Thread = Thread 33 | { threadName :: !Name 34 | , threadFeatures :: [Feature] 35 | , threadProperties :: [ThreadProperty] 36 | , threadComments :: [C.Comment] 37 | } deriving (Show, Eq) 38 | 39 | data Feature = 40 | InputFeature Input 41 | | OutputFeature Output 42 | | SignalFeature SignalInfo 43 | deriving (Show, Eq, Ord) 44 | 45 | -- | Init Channel 46 | -- data InitChan = InitChan 47 | -- { initChanCallback :: [SourcePath] 48 | -- , initChanOutput :: [(Output, Bound)] 49 | -- } deriving (Show, Eq, Ord) 50 | 51 | -- | Input channels 52 | data Input = Input 53 | { inputId :: !ChanId 54 | , inputLabel :: !ChanLabel 55 | , inputType :: !I.Type 56 | , inputCallback :: [SourcePath] 57 | , inputQueue :: Maybe Integer 58 | , inputSendsEvents :: SendsEvents 59 | } deriving (Show, Eq, Ord) 60 | 61 | -- | Output channels 62 | data Output = Output 63 | { outputId :: !ChanId 64 | , outputLabel :: !ChanLabel 65 | , outputType :: !I.Type 66 | , outputEmitter :: FuncSym 67 | } deriving (Show, Eq, Ord) 68 | 69 | -- | Path to a .c file and a function symbol in the file. If the funtion symbol 70 | -- is generated (i.e., in external threads), no filepath is given. 71 | type SourcePath = (FilePath, FuncSym) 72 | type SendsEvents = [(ChanLabel, Bound)] 73 | data SourceTexts = SourceTexts [FilePath] 74 | deriving (Show, Eq, Ord) 75 | 76 | data ThreadProperty = 77 | DispatchProtocol DispatchProtocol 78 | | ThreadType !ThreadType 79 | | ExecTime (Integer, Integer) 80 | -- ^ Min bound, max bound. 81 | | StackSize Integer 82 | | Priority Int 83 | | EntryPoint [FuncSym] 84 | | SourceText [FilePath] 85 | -- ^ Path to a .c file 86 | | SendEvents SendsEvents 87 | | External 88 | | InitProperty FuncSym 89 | deriving (Show, Eq) 90 | 91 | data DispatchProtocol = 92 | Periodic !Integer 93 | | Signal !SignalName !Address 94 | | Aperiodic 95 | | Sporadic 96 | deriving (Show, Eq) 97 | 98 | data SignalInfo = SignalInfo 99 | { signalInfoName :: SignalName 100 | , signalInfoNumber :: SignalNumber 101 | , signalInfoCallback :: [SourcePath] 102 | , signalInfoSendsEvents :: SendsEvents 103 | } deriving (Show, Eq, Ord) 104 | 105 | data ThreadType = 106 | Passive 107 | | Active 108 | deriving (Show, Eq) 109 | 110 | -- | An AADL variable. 111 | type LocalId = String 112 | 113 | -- | An AADL identifier. 114 | type Name = String 115 | 116 | -- Unique through the system. 117 | data ChanId = 118 | SynchChanId Integer 119 | | SignalChanId Integer 120 | | PeriodChanId Integer 121 | | InitChanId String 122 | deriving (Show, Read, Eq, Ord) 123 | 124 | type ChanLabel = String 125 | 126 | -- | Channel bound. 127 | type Bound = Integer 128 | 129 | -- | Function symbol. 130 | type FuncSym = String 131 | 132 | type SignalName = String 133 | 134 | type Address = Integer 135 | 136 | type SignalNumber = Int 137 | -------------------------------------------------------------------------------- /tower-aadl/src/Tower/AADL/AST/Common.hs: -------------------------------------------------------------------------------- 1 | -- 2 | -- Pre-processing helpers for the AST to extract all of the channels associated 3 | -- with a process. 4 | -- 5 | -- (c) 2014 Galois, Inc. 6 | -- 7 | 8 | module Tower.AADL.AST.Common 9 | ( ThdIds 10 | , getTxThds 11 | , getRxThds 12 | , filterEndpoints 13 | , threadsChannels 14 | , extractTypes 15 | , allConnections 16 | , connectedThreadsSize 17 | , emptyConnections 18 | , towerTime 19 | ) where 20 | 21 | 22 | import Prelude () 23 | import Prelude.Compat hiding (id) 24 | 25 | import Tower.AADL.AST 26 | import qualified Ivory.Language.Syntax.Type as I 27 | 28 | import qualified Data.Map.Strict as M 29 | import qualified Data.Set as S 30 | import Data.List (foldl') 31 | 32 | -------------------------------------------------------------------------------- 33 | 34 | type ThreadChans = (LocalId, ChanLabel) 35 | 36 | -- Used in system composition. All the threads that are connected. 37 | data ThdIds = ThdIds 38 | { chanTxThds :: S.Set ThreadChans 39 | , chanRxThds :: S.Set ThreadChans 40 | } deriving (Show, Eq) 41 | 42 | instance Monoid ThdIds where 43 | mempty = ThdIds mempty mempty 44 | c0 `mappend` c1 = 45 | ThdIds (chanTxThds c0 `mappend` chanTxThds c1) 46 | (chanRxThds c0 `mappend` chanRxThds c1) 47 | 48 | getTxThds :: ThdIds -> [ThreadChans] 49 | getTxThds = S.toList . chanTxThds 50 | 51 | getRxThds :: ThdIds -> [ThreadChans] 52 | getRxThds = S.toList . chanRxThds 53 | 54 | -- A mapping from channels to the sending and receiving threads on the channel. 55 | type Connections = M.Map ChanId ThdIds 56 | 57 | -- Interface below hides the data structure. 58 | 59 | allConnections :: Connections -> [ThdIds] 60 | allConnections = M.elems 61 | 62 | connectedThreadsSize :: ThdIds -> Int 63 | connectedThreadsSize thds = 64 | S.size (chanTxThds thds) * S.size (chanRxThds thds) 65 | 66 | emptyConnections :: Connections -> Bool 67 | emptyConnections = M.null 68 | 69 | -- | Remove connections that don't have both endpoints. 70 | filterEndpoints :: Connections -> Connections 71 | filterEndpoints = M.filter go 72 | where 73 | go c = not (S.null (chanTxThds c) || S.null (chanRxThds c)) 74 | 75 | -- Given a list of pairs of AADL threads and local variables, Create their 76 | -- connections. 77 | threadsChannels :: [(Thread, LocalId)] -> Connections 78 | threadsChannels ls = foldl' go M.empty ls 79 | where 80 | go :: Connections -> (Thread, LocalId) -> Connections 81 | go cs (th, id) = 82 | (M.unionWith mappend) (threadChannels th id) cs 83 | 84 | threadChannels :: Thread -> LocalId -> Connections 85 | threadChannels th id = foldl' go M.empty (getThreadEndpoints th) 86 | where 87 | go :: Connections -> Endpoint -> Connections 88 | go cs = insertConnectionId id cs 89 | 90 | data Endpoint = 91 | InputEp Input 92 | -- | SignalEp SignalInfo 93 | | OutputEp Output 94 | deriving (Show, Eq) 95 | 96 | endPointId :: Endpoint -> ChanId 97 | endPointId ep = case ep of 98 | InputEp rx -> inputId rx 99 | OutputEp tx -> outputId tx 100 | -- SignalEp s -> SignalChanId $ fromIntegral (signalInfoNumber s) 101 | 102 | newChan :: LocalId -> Endpoint -> ThdIds 103 | newChan l ep = 104 | case ep of 105 | InputEp c -> ThdIds S.empty (S.singleton (l, inputLabel c)) 106 | OutputEp c -> ThdIds (S.singleton (l, outputLabel c)) S.empty 107 | -- TODO JED: This is probably wrong 108 | -- SignalEp c -> ThdIds S.empty (S.singleton (l, signalInfoName c)) 109 | 110 | -- Add the id to the connections map, creating a new channel if needed. 111 | insertConnectionId :: LocalId -> Connections -> Endpoint -> Connections 112 | insertConnectionId l cs ep = 113 | M.insertWith mappend (endPointId ep) (newChan l ep) cs 114 | 115 | getThreadEndpoints :: Thread -> [Endpoint] 116 | getThreadEndpoints t = 117 | concatMap go (threadFeatures t) 118 | where 119 | go f = 120 | case f of 121 | InputFeature rx -> [InputEp rx] 122 | OutputFeature tx -> [OutputEp tx] 123 | SignalFeature _ -> [] 124 | 125 | -- Extract a unique instance of the channel types defined in the system. 126 | extractTypes :: System -> [I.Type] 127 | extractTypes sys = S.toList $ S.map getTy (S.fromList fs) 128 | where 129 | fs :: [Feature] 130 | fs = concatMap threadFeatures 131 | $ concatMap processComponents 132 | $ systemComponents sys 133 | getTy f = case f of 134 | InputFeature rx -> inputType rx 135 | OutputFeature tx -> outputType tx 136 | -- TODO JED: Wouldn't this be so much nicer if the Time module told us what 137 | -- type to put here? 138 | SignalFeature _ -> towerTime 139 | 140 | towerTime :: I.Type 141 | towerTime = I.TyInt I.Int64 142 | -------------------------------------------------------------------------------- /tower-aadl/src/Tower/AADL/Build/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types #-} 2 | -- Create Ramses build script. 3 | -- 4 | -- (c) 2015 Galois, Inc. 5 | -- 6 | 7 | module Tower.AADL.Build.Common where 8 | 9 | import Data.Char 10 | import Data.Maybe (maybeToList, fromMaybe) 11 | import System.FilePath 12 | import Text.PrettyPrint.Leijen hiding (()) 13 | 14 | import Ivory.Artifact 15 | import Ivory.Tower 16 | 17 | import qualified Ivory.Compile.C.CmdlineFrontend as O 18 | 19 | import Tower.AADL.Config (AADLConfig(..)) 20 | import Tower.AADL.Compile 21 | 22 | data Required 23 | = Req 24 | | Opt 25 | deriving (Read, Show, Eq) 26 | 27 | data Assign 28 | = Equals 29 | | ColonEq 30 | | QuestionEq 31 | | PlusEq 32 | deriving (Read, Show, Eq) 33 | 34 | data Export 35 | = NoExport 36 | | Export 37 | deriving (Read, Show, Eq) 38 | 39 | data MkStmt 40 | = Include Required FilePath 41 | | Var Export String Assign String 42 | | Target String [String] [String] 43 | | IfNDef String [MkStmt] [MkStmt] 44 | | Comment String 45 | deriving (Read, Show, Eq) 46 | 47 | 48 | -- Combinators to make building make statements easier ------------------------ 49 | include :: FilePath -> MkStmt 50 | include fname = Include Req fname 51 | 52 | includeOpt :: FilePath -> MkStmt 53 | includeOpt fname = Include Opt fname 54 | 55 | infixr 4 ?=, =:, +=, === 56 | 57 | (?=) :: String -> String -> MkStmt 58 | var ?= val = Var NoExport var QuestionEq val 59 | 60 | (=:) :: String -> String -> MkStmt 61 | var =: val = Var NoExport var ColonEq val 62 | 63 | (+=) :: String -> String -> MkStmt 64 | var += val = Var NoExport var PlusEq val 65 | 66 | (===) :: String -> String -> MkStmt 67 | var === val = Var NoExport var Equals val 68 | 69 | export :: MkStmt -> MkStmt 70 | export (Var _ var assign val) = Var Export var assign val 71 | export s = s 72 | ------------------------------------------------------------------------------- 73 | 74 | -- Makefile pretty printer ---------------------------------------------------- 75 | renderExport :: Export -> Doc 76 | renderExport NoExport = empty 77 | renderExport Export = text "export " 78 | 79 | renderAssign :: Assign -> Doc 80 | renderAssign Equals = char '=' 81 | renderAssign ColonEq = text " := " 82 | renderAssign QuestionEq = text " ?= " 83 | renderAssign PlusEq = text " += " 84 | 85 | renderMkStmt :: MkStmt -> Doc 86 | renderMkStmt (Include Req fp) = text "include" <+> text fp 87 | renderMkStmt (Include Opt fp) = text "-include" <+> text fp 88 | renderMkStmt (Var expt var assign val) = 89 | renderExport expt <> text var <> renderAssign assign <> text val 90 | renderMkStmt (Target name deps actions) = 91 | text name <> text ":" <+> hsep (map text deps) 92 | <> foldr (\str acc -> linebreak <> char '\t' <> text str <> acc) empty actions 93 | <> linebreak 94 | renderMkStmt (IfNDef var t e) = 95 | text "ifndef" <+> text var 96 | <$$> vsep (map renderMkStmt t) 97 | <$$> text "else" 98 | <$$> vsep (map renderMkStmt e) 99 | <$$> text "endif" 100 | renderMkStmt (Comment msg) = char '#' <+> text msg 101 | 102 | renderMkStmts :: [MkStmt] -> String 103 | renderMkStmts stmts = show $ 104 | foldr (\mkstmt acc -> renderMkStmt mkstmt <> linebreak <> linebreak <> acc) 105 | empty 106 | (autogenComment : stmts) 107 | where 108 | autogenComment = Comment "This makefile is autogenerated. DO NOT EDIT." 109 | ------------------------------------------------------------------------------- 110 | 111 | ramsesMakefileName :: String 112 | ramsesMakefileName = "ramses.mk" 113 | 114 | aadlFilesMk :: String 115 | aadlFilesMk = "AADL_FILES.mk" 116 | 117 | componentLibsName :: String 118 | componentLibsName = "componentlibs.mk" 119 | 120 | mkLib :: AADLConfig -> [String] -> String 121 | mkLib c aadlFileNames = 122 | unlines (map go aadlFileNames) ++ [] 123 | where 124 | go m = m ++ "_LIBS += " ++ configLibDir c 125 | 126 | makefileName :: String 127 | makefileName = "Makefile" 128 | 129 | aadlDocNames :: CompiledDocs -> [String] 130 | aadlDocNames docs = map docName $ 131 | maybeToList (tyDoc docs) ++ thdDocs docs 132 | -------------------------------------------------------------------------------- 133 | -- Helpers 134 | 135 | shellVar :: String -> String 136 | shellVar = map toUpper 137 | 138 | -------------------------------------------------------------------------------- 139 | -- Support for OS Specific Code generation 140 | -------------------------------------------------------------------------------- 141 | 142 | data OSSpecific a = OSSpecific 143 | { osSpecificName :: String 144 | , osSpecificConfig :: a 145 | , osSpecificArtifacts :: String -> AADLConfig -> [String] -> [Located Artifact] 146 | , osSpecificSrcDir :: AADLConfig -> Located Artifact -> Located Artifact 147 | , osSpecificTower :: forall e. Tower e () 148 | , osSpecificOptsApps :: AADLConfig -> O.Opts -> O.Opts 149 | , osSpecificOptsLibs :: AADLConfig -> O.Opts -> O.Opts 150 | } 151 | 152 | defaultOptsUpdate :: AADLConfig -> O.Opts -> O.Opts 153 | defaultOptsUpdate c copts = 154 | copts { O.outDir = Just (dir configSrcsDir c) 155 | , O.outHdrDir = Just (dir configHdrDir c) 156 | , O.outArtDir = Just dir 157 | } 158 | where 159 | dir = fromMaybe "." (O.outDir copts) 160 | -------------------------------------------------------------------------------- /tower-aadl/src/Tower/AADL/Build/SeL4.hs: -------------------------------------------------------------------------------- 1 | -- Create Ramses build script. 2 | -- 3 | -- (c) 2015 Galois, Inc. 4 | -- 5 | 6 | module Tower.AADL.Build.SeL4 where 7 | 8 | import System.FilePath (()) 9 | import Data.Maybe ( fromMaybe ) 10 | 11 | import Ivory.Artifact 12 | 13 | import qualified Ivory.Compile.C.CmdlineFrontend as O 14 | 15 | import Tower.AADL.Config (AADLConfig(..), lib, maybeFP) 16 | import Tower.AADL.Build.Common 17 | 18 | -------------------------------------------------------------------------------- 19 | -- Ramses build 20 | 21 | -- Ramses Makefile ------------------------------------------------------------ 22 | ramsesMakefile :: AADLConfig -> [MkStmt] 23 | ramsesMakefile c = 24 | [ include aadlFilesMk 25 | , "RAMSES_PATH" ?= maybeFP (configRamsesPath c) 26 | , "SMACCM_PATH" ?= "./" 27 | , export $"RAMSES_DIR" === "$(RAMSES_PATH)/ramses_resource" 28 | , export $"AADL2RTOS_CONFIG_DIR" === "$(RAMSES_PATH)/aadl2rtos_resource" 29 | , Target ".PHONY" ["all", "tower-clean", "ramses", camkesMakefileName] [] 30 | , Target "all" [camkesMakefileName] [] 31 | , Target "ramses" [] 32 | ["java -jar $(RAMSES_PATH)/ramses.jar -g rtos -i $(AADL2RTOS_CONFIG_DIR) \ 33 | \-o . -l trace -s sys.impl -m SMACCM_SYS.aadl,$(AADL_LIST)"] 34 | , Target camkesMakefileName [] 35 | [ "make ramses" 36 | , if configCustomMakefile c 37 | then "" 38 | else unwords ["cp ", mkTp, camkesMakefileName] 39 | , "rm -rf ../../libs/" ++ lib c 40 | , unwords ["cp -r ", lib c, "../../libs/"] 41 | , unwords ["cp -r ", lib c "include" "*", configHdrDir c] 42 | ] 43 | , Target "tower-clean" [] 44 | [ rm aadlFilesMk 45 | , rm kbuildName 46 | , rm kconfigName 47 | , rm camkesMakefileName 48 | , rm "*.aadl" 49 | , rm (configSrcsDir c) 50 | , rm (configHdrDir c) 51 | ] 52 | ] 53 | where 54 | rm s = "-rm -rf " ++ s 55 | mkTp = "make_template" makefileName 56 | 57 | -------------------------------------------------------------------------------- 58 | -- Kbuild, Kconfig 59 | 60 | kbuildLib :: String -> [MkStmt] 61 | kbuildLib dir = 62 | [ "libs-$(CONFIG_LIB_" ++ shellVar dir ++ ")" += dir 63 | , Target dir ["common", "$(libc)"] [] 64 | ] 65 | 66 | kbuildApp :: String -> String -> [MkStmt] 67 | kbuildApp libdir dir = 68 | [ "apps-$(CONFIG_APP_" ++ shellVar dir ++ ")" += dir 69 | , Target dir ["libsel4", "libmuslc", "libsel4platsupport", "libsel4muslccamkes" 70 | ,"libsel4camkes", "libsel4sync", "libsel4debug", "libsel4bench" 71 | ,libdir] [] 72 | ] 73 | 74 | kbuildName :: String 75 | kbuildName = "Kbuild" 76 | 77 | kconfigLib :: String -> String -> String 78 | kconfigLib prog dir = unlines 79 | [ "menuconfig LIB_" ++ shellVar dir 80 | , " bool \"Shared code for " ++ prog ++ " app.\"" 81 | , " default n" 82 | , " help" 83 | , " Generated from Ivory/Tower." 84 | ] 85 | 86 | kconfigApp :: String -> String -> String 87 | kconfigApp prog dir = unlines 88 | [ "config APP_" ++ shellVar dir 89 | , " bool \"Generated code for " ++ prog ++ " .\"" 90 | , " default n" 91 | , " select APP_CAMKES_EXECUTIVE" 92 | , " help" 93 | , " Generated AADL from " ++ prog 94 | ] 95 | 96 | kconfigName :: String 97 | kconfigName = "Kconfig" 98 | 99 | camkesMakefileName :: String 100 | camkesMakefileName = "camkesmakefile.mk" 101 | 102 | makefileLib :: AADLConfig -> [MkStmt] 103 | makefileLib c = 104 | [ Comment "Targets" 105 | , "TARGETS" =: lib c ++ ".a" 106 | , Comment "Header files/directories this library provides" 107 | , "HDRFILES" =: "$(wildcard ${SOURCE_DIR}/include/*)" 108 | , "CFILES" =: "$(patsubst $(SOURCE_DIR)/%,%,$(wildcard $(SOURCE_DIR)/src/*.c))" 109 | , include "$(SEL4_COMMON)/common.mk" 110 | , "CFLAGS" += "-DODROID" 111 | ] 112 | 113 | makefileApp :: String -> [MkStmt] 114 | makefileApp dir = 115 | [ Comment "Include assumes this is driven by seL4 build." 116 | , "CFLAGS" += "-DODROID" 117 | , includeOpt (fromApps componentLibsName) 118 | , includeOpt (fromApps camkesMakefileName) 119 | , includeOpt ramsesMakefileName 120 | ] 121 | where 122 | fromApps fl = "apps" dir fl 123 | 124 | camkesArtifacts :: String -> AADLConfig -> [String] -> [Located Artifact] 125 | camkesArtifacts appname cfg aadl_docs = map Root ls 126 | where 127 | ls :: [Artifact] 128 | ls = artifactString 129 | ramsesMakefileName 130 | (renderMkStmts (ramsesMakefile cfg)) 131 | : osSpecific 132 | osSpecific = 133 | (if configCustomKConfig cfg 134 | then [] 135 | else [ artifactString 136 | kbuildName 137 | (renderMkStmts (kbuildApp l appname)) 138 | , artifactString 139 | kconfigName 140 | (kconfigApp appname appname) 141 | ]) ++ 142 | -- apps 143 | [ artifactString 144 | makefileName 145 | (renderMkStmts (makefileApp appname)) 146 | , artifactString 147 | componentLibsName 148 | (mkLib cfg aadl_docs) 149 | ] ++ 150 | -- libs 151 | map (artifactPath l) 152 | [ artifactString 153 | kbuildName 154 | (renderMkStmts (kbuildLib l)) 155 | , artifactString 156 | kconfigName 157 | (kconfigLib appname l) 158 | , artifactString 159 | makefileName 160 | (renderMkStmts (makefileLib cfg)) 161 | ] 162 | l = lib cfg 163 | 164 | defaultCAmkESOS :: OSSpecific () 165 | defaultCAmkESOS = 166 | let libSrcDir cfg = lib cfg "src" 167 | libHdrDir cfg = lib cfg "include" 168 | in 169 | OSSpecific 170 | { osSpecificName = "CAmkES" 171 | , osSpecificConfig = () 172 | , osSpecificArtifacts = camkesArtifacts 173 | , osSpecificSrcDir = 174 | \cfg l -> case l of 175 | Src a -> Root (artifactPath (libSrcDir cfg) a) 176 | Incl a -> Root (artifactPath (libHdrDir cfg) a) 177 | _ -> l 178 | , osSpecificTower = return () 179 | , osSpecificOptsApps = defaultOptsUpdate 180 | , osSpecificOptsLibs = \cfg copts -> 181 | let dir = fromMaybe "." (O.outDir copts) 182 | in copts { O.outDir = Just (dir libSrcDir cfg) 183 | , O.outHdrDir = Just (dir libHdrDir cfg) 184 | , O.outArtDir = Just dir 185 | } 186 | } 187 | -------------------------------------------------------------------------------- /tower-aadl/src/Tower/AADL/CodeGen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | 9 | -- 10 | -- Code generation for AADL targets. 11 | -- 12 | -- (c) 2015 Galois, Inc. 13 | -- 14 | 15 | module Tower.AADL.CodeGen where 16 | 17 | import Prelude () 18 | import Prelude.Compat 19 | 20 | import qualified Ivory.Language as I 21 | import qualified Ivory.Artifact as I 22 | 23 | import qualified Ivory.Tower.AST as A 24 | import Ivory.Tower.Backend 25 | import qualified Ivory.Tower.Types.Dependencies as T 26 | import qualified Ivory.Tower.Types.Emitter as T 27 | import qualified Ivory.Tower.Types.SignalCode as T 28 | import qualified Ivory.Tower.Types.Unique as T 29 | 30 | import Tower.AADL.Names 31 | 32 | import qualified Data.Map.Strict as M 33 | 34 | -------------------------------------------------------------------------------- 35 | 36 | type PackageName = String 37 | 38 | data AADLBackend = AADLBackend 39 | 40 | instance TowerBackend AADLBackend where 41 | newtype TowerBackendCallback AADLBackend a 42 | = AADLCallback I.ModuleDef 43 | deriving Monoid 44 | data TowerBackendEmitter AADLBackend = AADLEmitter (String -> I.ModuleDef) 45 | newtype TowerBackendHandler AADLBackend a = AADLHandler (String -> I.ModuleDef) 46 | deriving Monoid 47 | -- Takes a ModuleDef (containing the emitter declaration) and returns the 48 | -- monitor module name and monitor module. 49 | data TowerBackendMonitor AADLBackend 50 | = AADLMonitor (String, I.ModuleDef) 51 | -- Pass in dependency modules 52 | newtype TowerBackendOutput AADLBackend 53 | = AADLOutput ([PackageName], [I.Module] -> [I.Module]) 54 | 55 | callbackImpl _be sym f = 56 | AADLCallback 57 | $ I.incl 58 | $ I.voidProc (T.showUnique sym) 59 | $ \r -> I.body 60 | $ I.noReturn 61 | $ f r 62 | 63 | emitterImpl _be emitterAst _impl = emitterCode 64 | where 65 | emitterCode :: forall b. I.IvoryArea b 66 | => (T.Emitter b, TowerBackendEmitter AADLBackend) 67 | emitterCode = 68 | ( T.Emitter $ \ref -> I.call_ (procFromEmitter "") ref 69 | , AADLEmitter 70 | (\monName -> I.incl (procFromEmitter monName 71 | :: I.Def('[I.ConstRef s b] 'I.:-> ()) 72 | )) 73 | ) 74 | where 75 | sym = T.showUnique (A.emitter_name emitterAst) 76 | procFromEmitter :: I.IvoryArea b 77 | => String 78 | -> I.Def('[I.ConstRef s b] 'I.:-> ()) 79 | procFromEmitter monName = I.importProc sym hdr 80 | where hdr = smaccmPrefix $ monName ++ ".h" 81 | 82 | handlerImpl _be _ast emittersDefs callbacks = 83 | AADLHandler $ 84 | case mconcat callbacks of 85 | AADLCallback cdefs -> \monName -> cdefs >> mconcat (edefs monName) 86 | where 87 | edefs monName = map (\(AADLEmitter edef) -> edef monName) emittersDefs 88 | 89 | monitorImpl _be ast handlers moddef = 90 | AADLMonitor $ 91 | ( nm 92 | , do mconcat $ map handlerModules handlers 93 | moddef 94 | ) 95 | where 96 | nm = threadFile ast 97 | handlerModules :: SomeHandler AADLBackend -> I.ModuleDef 98 | handlerModules (SomeHandler (AADLHandler h)) = h (A.monitorName ast) 99 | 100 | towerImpl _be ast ms = 101 | AADLOutput 102 | ( map (\(AADLMonitor m) -> fst m) ms ++ actPkgs 103 | , \deps -> [ mkMod m deps | AADLMonitor m <- ms ] 104 | ++ actMods 105 | ) 106 | where 107 | (actPkgs, actMods) = activeSrcs ast 108 | mkMod (nm, mMod) deps = I.package nm $ mapM_ I.depend deps >> mMod 109 | 110 | activeSrcs :: A.Tower -> ([PackageName], [I.Module]) 111 | activeSrcs t = unzip $ map activeSrc (A.towerThreads t) 112 | 113 | activeSrc :: A.Thread -> (PackageName, I.Module) 114 | activeSrc t = 115 | case t of 116 | A.PeriodThread p 117 | -> ( pkg 118 | , I.package pkg $ do 119 | I.incl $ mkPeriodCallback p 120 | I.incl $ mkPeriodEmitter p 121 | ) 122 | where pkg = periodicCallback p 123 | A.InitThread{} 124 | -> ( initCallback 125 | , I.package initCallback $ do 126 | I.incl mkInitCallback 127 | I.incl mkInitEmitter 128 | ) 129 | A.SignalThread s 130 | -> ( pkg 131 | , I.package pkg $ do 132 | I.incl $ mkSignalCallback s 133 | I.incl $ mkSignalEmitter s 134 | ) 135 | where pkg = signalCallback s 136 | 137 | mkPeriodCallback :: A.Period 138 | -> I.Def ('[I.ConstRef s ('I.Stored TowerTime)] 'I.:-> ()) 139 | mkPeriodCallback p = 140 | I.proc (periodicCallback p) $ \time -> I.body $ 141 | I.call_ (mkPeriodEmitter p) time 142 | 143 | mkPeriodEmitter :: A.Period -> I.Def ('[I.ConstRef s ('I.Stored TowerTime)] 'I.:-> ()) 144 | mkPeriodEmitter p = I.importProc (periodicEmitter p) (threadEmitterHeader $ A.PeriodThread p) -- XXX pass in higher up 145 | 146 | mkInitCallback :: I.Def ('[I.ConstRef s ('I.Stored TowerTime)] 'I.:-> ()) 147 | mkInitCallback = 148 | I.proc initCallback $ \time -> I.body $ 149 | I.call_ mkInitEmitter time 150 | 151 | mkInitEmitter :: I.Def ('[I.ConstRef s ('I.Stored TowerTime)] 'I.:-> ()) 152 | mkInitEmitter = I.importProc initEmitter (threadEmitterHeader $ A.InitThread A.Init) -- XXX pass in higher up 153 | 154 | mkSignalCallback :: A.Signal 155 | -> I.Def ('[I.ConstRef s ('I.Stored TowerTime)] 'I.:-> ()) 156 | mkSignalCallback s = 157 | I.proc (signalCallback s) $ \time -> I.body $ 158 | I.call_ (mkSignalEmitter s) time 159 | 160 | mkSignalEmitter :: A.Signal -> I.Def ('[I.ConstRef s ('I.Stored TowerTime)] 'I.:-> ()) 161 | mkSignalEmitter s = I.importProc (signalEmitter s) (threadEmitterHeader $ A.SignalThread s) 162 | 163 | genIvoryCode :: TowerBackendOutput AADLBackend 164 | -> T.Dependencies 165 | -> T.SignalCode 166 | -> ([String], [I.Module], [I.Located I.Artifact]) 167 | genIvoryCode 168 | (AADLOutput (packages, modsF)) 169 | T.Dependencies 170 | { T.dependencies_modules = modDeps 171 | , T.dependencies_depends = depends 172 | , T.dependencies_artifacts = artifacts 173 | } 174 | T.SignalCode 175 | { T.signalcode_signals = signals 176 | } = (packages, modules, artifacts) 177 | where 178 | modules = modDeps 179 | ++ modsF depends 180 | ++ go (mkSignalCode (modsF depends)) signals 181 | go c cs = M.elems $ M.mapWithKey c cs 182 | 183 | mkSignalCode :: [I.Module] -> String -> T.GeneratedSignal -> I.Module 184 | mkSignalCode deps sigNm 185 | T.GeneratedSignal { T.unGeneratedSignal = s } 186 | = I.package sigNm (mapM_ I.depend deps >> (s (return ()))) 187 | 188 | type TowerTime = I.Sint64 189 | -------------------------------------------------------------------------------- /tower-aadl/src/Tower/AADL/Compile.hs: -------------------------------------------------------------------------------- 1 | -- 2 | -- Data types and helpers for compiled artifacts. 3 | -- 4 | -- (c) 2014 Galois, Inc. 5 | -- 6 | 7 | module Tower.AADL.Compile where 8 | 9 | import Ivory.Artifact 10 | 11 | import Data.Maybe 12 | 13 | import Text.PrettyPrint.Leijen 14 | 15 | import Tower.AADL.Render.Common 16 | 17 | -------------------------------------------------------------------------------- 18 | 19 | -- | AADL package imports 20 | type Import = String 21 | 22 | header :: Doc 23 | header = renderStringComment "File generated from Tower-AADL compiler" <$$> empty 24 | 25 | mkTowerDoc :: Doc -> Doc 26 | mkTowerDoc doc = header <$$> doc <$$> empty 27 | 28 | -- | Place the given construct into a package. 29 | renderPackage :: String -> Doc -> [Import] -> Doc 30 | renderPackage nm doc imports = mkTowerDoc $ 31 | text "package" <+> nm' 32 | <$$> text "public" 33 | <$$> vsep (map renderImport imports) 34 | <$$$> doc 35 | <$$$> stmt (text "end" <+> nm') 36 | where nm' = text nm 37 | 38 | renderImport :: Import -> Doc 39 | renderImport i = tab (stmt (text "with" <+> text i)) 40 | 41 | -------------------------------------------------------------------------------- 42 | -- Compiled documents 43 | 44 | -- | Document type 45 | data DocType = TypeDoc | ThreadDoc | SystemDoc | CodeDoc 46 | deriving (Show, Eq) 47 | 48 | data CompiledDoc = CompiledDoc 49 | { docType :: DocType 50 | , docName :: !String 51 | , docImpl :: Doc 52 | } deriving Show 53 | 54 | data CompiledDocs = CompiledDocs 55 | { sysDoc :: CompiledDoc 56 | , thdDocs :: [CompiledDoc] 57 | , tyDoc :: Maybe CompiledDoc 58 | } deriving Show 59 | 60 | compiledDocs :: CompiledDoc 61 | -> [CompiledDoc] 62 | -> Maybe CompiledDoc 63 | -> CompiledDocs 64 | compiledDocs = CompiledDocs 65 | 66 | compiledDoc :: DocType -> String -> Doc -> CompiledDoc 67 | compiledDoc = CompiledDoc 68 | 69 | aTypesPkg :: CompiledDocs -> Bool 70 | aTypesPkg = isJust . tyDoc 71 | 72 | 73 | compiledTypesDoc :: Doc -> CompiledDoc 74 | compiledTypesDoc = CompiledDoc TypeDoc typesPkg 75 | 76 | renderCompiledDocs :: CompiledDocs -> [Located Artifact] 77 | renderCompiledDocs docs = map mkArtifact individual_docs 78 | where 79 | mkArtifact cdoc = Root $ artifactString fname contents 80 | where 81 | fname = docName cdoc ++ ".aadl" 82 | contents = displayS (renderPretty 0.4 100 (renderDocPkg cdoc)) "" 83 | 84 | individual_docs :: [CompiledDoc] 85 | individual_docs = thdDocs docs ++ (sysDoc docs : maybeToList (tyDoc docs)) 86 | 87 | -- | Render a packaged system, using the extra imports (thread names) if 88 | -- compiling a system. 89 | renderDocPkg :: CompiledDoc -> Doc 90 | renderDocPkg d = 91 | renderPackage (docName d) (docImpl d) imps 92 | where 93 | imps = case docType d of 94 | TypeDoc -> defaultImports False 95 | ThreadDoc -> defaultImports (aTypesPkg docs) 96 | SystemDoc -> defaultImports (aTypesPkg docs) ++ map docName (thdDocs docs) 97 | CodeDoc -> [] 98 | 99 | -------------------------------------------------------------------------------- 100 | -------------------------------------------------------------------------------- /tower-aadl/src/Tower/AADL/Config.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE CPP #-} 3 | 4 | -- 5 | -- Map the Tower AST into the AADL AST. 6 | -- 7 | -- (c) 2014 Galois, Inc. 8 | -- 9 | 10 | module Tower.AADL.Config where 11 | 12 | import Data.List 13 | import Data.Char (toUpper) 14 | import Ivory.Tower.Options (TOpts(..)) 15 | import Ivory.Tower.Config 16 | import qualified System.Console.GetOpt as O 17 | import qualified System.Directory as D 18 | 19 | import Tower.AADL.Platform (OS(..), HW(..)) 20 | import Tower.AADL.Priorities (PriorityMap, emptyPriorityMap) 21 | 22 | ---------------------------------------- 23 | 24 | data AADLConfig = AADLConfig 25 | { configSrcsDir :: FilePath 26 | -- ^ Location of/to put C sources relative to genDirOpts. 27 | , configHdrDir :: FilePath 28 | -- ^ Location of/to put C headers relative to genDirOpts. 29 | , configLibDir :: FilePath 30 | -- ^ Location of/to put C lib sources relative to genDirOpts. 31 | , configSystemName :: String 32 | -- ^ System name. 33 | , configSystemOS :: OS 34 | -- ^ Operating system name. 35 | , configSystemHW :: HW 36 | -- ^ HW name. 37 | , configSystemAddr :: Maybe Integer 38 | -- ^ Flash load address 39 | , configPriorities :: PriorityMap 40 | -- ^ Priorities for threads. 41 | , configCustomMakefile :: Bool 42 | -- ^ If True, user provides custom Makefile. 43 | , configCustomKConfig :: Bool 44 | -- ^ If True, user provides custom Kconfig, Kbuild. 45 | , configRamsesPath :: Maybe FilePath 46 | -- ^ Location of Ramses jar executable. Nothing means it's in the path. 47 | , configEchronosPath :: Maybe FilePath 48 | -- ^ Location of eChronos. 49 | } 50 | deriving (Show) 51 | 52 | defaultAADLConfig :: AADLConfig 53 | defaultAADLConfig = AADLConfig 54 | { configSrcsDir = "user_code" 55 | , configHdrDir = "include" 56 | , configLibDir = "smaccmpilot" 57 | , configSystemName = "sys" 58 | , configSystemOS = CAmkES 59 | , configSystemHW = QEMU 60 | , configSystemAddr = Nothing 61 | , configPriorities = emptyPriorityMap 62 | , configCustomMakefile = False 63 | , configCustomKConfig = False 64 | , configRamsesPath = Nothing 65 | , configEchronosPath = Nothing 66 | } 67 | 68 | lib :: AADLConfig -> String 69 | lib c = "lib" ++ configLibDir c 70 | 71 | aadlConfigParser :: AADLConfig -> ConfigParser AADLConfig 72 | aadlConfigParser dflt = subsection "aadl" p `withDefault` dflt 73 | where 74 | p = do 75 | os <- (subsection "os" osParser) `withDefault` (configSystemOS dflt) 76 | hw <- (subsection "os" hwParser) `withDefault` (configSystemHW dflt) 77 | addr <- (subsection "os" addrParser) `withDefault` (configSystemAddr dflt) 78 | return dflt { configSystemOS = os, configSystemHW = hw, configSystemAddr = addr } 79 | osParser = string >>= \s -> 80 | case map toUpper s of 81 | "CAMKES" -> return CAmkES 82 | "ECHRONOS" -> return EChronos 83 | _ -> fail ("expected AADL OS, got " ++ s) 84 | hwParser = string >>= \s -> 85 | case map toUpper s of 86 | "QEMU" -> return QEMU 87 | "ODROID" -> return ODROID 88 | "PIXHAWK" -> return PIXHAWK 89 | _ -> fail ("expected AADL HW Platform, got " ++ s) 90 | addrParser = integer >>= \i -> return (Just i) 91 | 92 | ---------------------------------------- 93 | -- Additional command line opts 94 | 95 | data Flag = LibDir String 96 | deriving (Show, Read, Eq) 97 | 98 | options :: [O.OptDescr Flag] 99 | options = 100 | [ O.Option "" ["lib-dir"] (O.ReqArg LibDir "DIR") "library directory name" ] 101 | 102 | parseAADLOpts :: AADLConfig -> TOpts -> (AADLConfig, [String], [String]) 103 | parseAADLOpts c topts = (foldl' go c flags, nonOpts, errs) 104 | where 105 | (flags, nonOpts, errs) = O.getOpt O.Permute options (topts_args topts) 106 | go c' (LibDir dir) = c' { configLibDir = dir } 107 | 108 | -- Turn relative paths into absolute paths. 109 | makeAbsPaths :: AADLConfig -> IO AADLConfig 110 | makeAbsPaths cfg = do 111 | rp <- mkAbsFP (configRamsesPath cfg) 112 | cep <- mkAbsFP (configEchronosPath cfg) 113 | return cfg { configRamsesPath = rp 114 | , configEchronosPath = cep 115 | } 116 | 117 | mkAbsFP :: Maybe FilePath -> IO (Maybe FilePath) 118 | mkAbsFP mfp = 119 | case mfp of 120 | Nothing -> return Nothing 121 | #if __GLASGOW_HASKELL__ <= 784 122 | Just fp -> Just `fmap` D.canonicalizePath fp 123 | #else 124 | Just fp -> Just `fmap` D.makeAbsolute fp 125 | #endif 126 | 127 | maybeFP :: Maybe FilePath -> String 128 | maybeFP = maybe "" id 129 | -------------------------------------------------------------------------------- /tower-aadl/src/Tower/AADL/Identifier.hs: -------------------------------------------------------------------------------- 1 | 2 | module Ivory.Compile.AADL.Identifier where 3 | 4 | identifier :: String -> String 5 | identifier s = escapeReserved $ map aux s 6 | where 7 | aux '-' = '_' 8 | aux ' ' = '_' 9 | aux a = a 10 | 11 | escapeReserved :: String -> String 12 | escapeReserved w | w `elem` reserved = 'x':w 13 | | otherwise = w 14 | where 15 | reserved = 16 | [ "mode" 17 | , "port" 18 | , "group" 19 | , "public" 20 | , "private" 21 | , "properties" 22 | , "end" 23 | , "data" 24 | , "subprogram" 25 | , "thread" 26 | , "process" 27 | , "system" 28 | , "abstract" 29 | , "memory" 30 | , "processor" 31 | , "bus" 32 | , "device" 33 | , "virtual" 34 | , "extends" 35 | , "prototypes" 36 | , "features" 37 | , "flows" 38 | , "modes" 39 | , "subcomponents" 40 | , "calls" 41 | , "connections" 42 | , "flows" 43 | , "modes" 44 | , "refined" 45 | , "in" 46 | , "out" 47 | , "feature" 48 | , "event" 49 | , "provides" 50 | , "requires" 51 | , "access" 52 | , "parameter" 53 | , "inverse" 54 | , "source" 55 | , "sink" 56 | , "classifier" 57 | , "binding" 58 | , "and" 59 | , "or" 60 | , "not" 61 | , "true" 62 | , "false" 63 | , "delta" 64 | , "reference" 65 | , "compute" 66 | , "type" 67 | , "aadlboolean" 68 | , "aadlstring" 69 | , "aadlreal" 70 | , "aadlinteger" 71 | , "enumeration" 72 | , "units" 73 | , "constant" 74 | , "record" 75 | , "range" 76 | , "list" 77 | , "of" 78 | , "inherit" 79 | , "applies" 80 | , "to" 81 | , "all" 82 | ] 83 | 84 | -------------------------------------------------------------------------------- /tower-aadl/src/Tower/AADL/Names.hs: -------------------------------------------------------------------------------- 1 | -- 2 | -- String munging common across modules. 3 | -- 4 | -- (c) 2015 Galois, Inc. 5 | -- 6 | 7 | module Tower.AADL.Names 8 | ( periodicEmitter 9 | , periodicCallback 10 | , signalEmitter 11 | , signalCallback 12 | , systemInit 13 | , initEmitter 14 | , initCallback 15 | , prettyTime 16 | , threadFile 17 | , threadEmitterHeader 18 | , smaccmPrefix 19 | ) where 20 | 21 | import qualified Ivory.Tower.AST as A 22 | import qualified Ivory.Tower.Types.Time as T 23 | import qualified Ivory.Tower.AST.Period as P 24 | import qualified Ivory.Tower.AST.Signal as S 25 | 26 | -- add aadl2rtos prefix 27 | smaccmPrefix :: String -> String 28 | smaccmPrefix = ("smaccm_" ++) 29 | 30 | threadEmitterHeader :: A.Thread -> String 31 | threadEmitterHeader t = 32 | smaccmPrefix $ A.threadName t ++ ".h" 33 | 34 | ------------------------------------------------------------ 35 | 36 | periodicEmitter :: P.Period -> String 37 | periodicEmitter p = "emitter_" ++ prettyTime p 38 | 39 | periodicCallback :: P.Period -> String 40 | periodicCallback p = "callback_" ++ prettyTime p 41 | 42 | ------------------------------------------------------------ 43 | 44 | systemInit :: String 45 | systemInit = "systemInit" 46 | 47 | initEmitter :: String 48 | initEmitter = "emitter_" ++ systemInit 49 | 50 | initCallback :: String 51 | initCallback = "callback_" ++ systemInit 52 | 53 | ------------------------------------------------------------ 54 | 55 | signalEmitter :: S.Signal -> String 56 | signalEmitter s = "emitter_" ++ S.signal_name s 57 | 58 | signalCallback :: S.Signal -> String 59 | signalCallback s = "callback_" ++ S.signal_name s 60 | 61 | ------------------------------------------------------------ 62 | 63 | prettyTime :: P.Period -> String 64 | prettyTime p = T.prettyTime (P.period_dt p) 65 | 66 | threadFile :: A.Monitor -> String 67 | threadFile m = A.monitorName m ++ "_monitor" 68 | -------------------------------------------------------------------------------- /tower-aadl/src/Tower/AADL/Platform.hs: -------------------------------------------------------------------------------- 1 | module Tower.AADL.Platform where 2 | 3 | data HW = 4 | QEMU 5 | | ODROID 6 | | PIXHAWK 7 | deriving (Show, Read, Eq) 8 | 9 | data OS = 10 | CAmkES 11 | | EChronos 12 | deriving (Show, Read, Eq) 13 | 14 | -------------------------------------------------------------------------------- /tower-aadl/src/Tower/AADL/Priorities.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | -- 3 | -- Setting priorities for AADL threads. 4 | -- 5 | -- (c) 2015 Galois, Inc. 6 | -- 7 | 8 | module Tower.AADL.Priorities where 9 | 10 | import Prelude () 11 | import Prelude.Compat 12 | 13 | import Data.List 14 | import qualified Data.Map as M 15 | 16 | import Tower.AADL.Threads 17 | import qualified Ivory.Tower.AST as A 18 | 19 | ---------------------------------------- 20 | 21 | type Priority a = (Enum a, Bounded a, Ord a) 22 | 23 | newtype SeL4Priority = SP Int 24 | deriving (Read, Show, Eq, Ord) 25 | 26 | instance Bounded SeL4Priority where 27 | minBound = SP 120 28 | maxBound = SP 140 29 | 30 | mkSeL4Priority :: Int -> SeL4Priority 31 | mkSeL4Priority n = 32 | let SP maxP = maxBound 33 | SP minP = minBound 34 | in SP (min (max minP n) maxP) 35 | 36 | instance Enum SeL4Priority where 37 | toEnum = mkSeL4Priority 38 | fromEnum (SP n) = n 39 | succ (SP n) = mkSeL4Priority (n + 1) 40 | pred (SP n) = mkSeL4Priority (n - 1) 41 | 42 | newtype EChronosPriority = EP Int 43 | deriving (Read, Show, Eq, Ord) 44 | 45 | instance Bounded EChronosPriority where 46 | minBound = EP 1 47 | maxBound = EP 255 48 | 49 | mkEChronosPriority :: Int -> EChronosPriority 50 | mkEChronosPriority n = 51 | let EP maxP = maxBound 52 | EP minP = minBound 53 | in EP (min (max minP n) maxP) 54 | 55 | instance Enum EChronosPriority where 56 | toEnum = mkEChronosPriority 57 | fromEnum (EP n) = n 58 | succ (EP n) = mkEChronosPriority (n + 1) 59 | pred (EP n) = mkEChronosPriority (n - 1) 60 | 61 | minPriority :: Bounded a => a 62 | minPriority = minBound 63 | 64 | maxPriority :: Bounded a => a 65 | maxPriority = maxBound 66 | 67 | incPriority :: Enum a => a -> a 68 | incPriority = succ 69 | 70 | decPriority :: Enum a => a -> a 71 | decPriority = pred 72 | 73 | ---------------------------------------- 74 | 75 | minPer :: Priority a => a 76 | minPer = incPriority minPriority 77 | 78 | maxPer :: Priority a => a 79 | maxPer = maxPriority 80 | 81 | perPriorities :: Priority a => [a] 82 | perPriorities = iterate incPriority minPer 83 | 84 | sigPriorities :: Priority a => [a] 85 | sigPriorities = iterate decPriority maxPer 86 | 87 | -- | Map from monitor names to priorities 88 | type AbstractPriorityMap a = M.Map String a 89 | type PriorityMap = AbstractPriorityMap Int 90 | 91 | emptyPriorityMap :: PriorityMap 92 | emptyPriorityMap = M.empty 93 | 94 | getPriority :: String -> PriorityMap -> Int 95 | getPriority nm mp = 96 | M.findWithDefault (error $ "Internal error: lookup of monitor " 97 | ++ nm ++ " in priority map.") 98 | nm mp 99 | 100 | mkSeL4Priorities :: ActiveThreads -> PriorityMap 101 | mkSeL4Priorities thds = 102 | fromEnum <$> (mkPriorities thds :: AbstractPriorityMap SeL4Priority) 103 | 104 | mkEChronosPriorities :: ActiveThreads -> PriorityMap 105 | mkEChronosPriorities thds = 106 | fromEnum <$> (mkPriorities thds :: AbstractPriorityMap EChronosPriority) 107 | 108 | -- Initialization threads have the lowest priorties. 109 | -- External threads have maximum bound. 110 | -- Periodic are rate monotonic starting from minimum priority. 111 | mkPriorities :: Priority a => ActiveThreads -> AbstractPriorityMap a 112 | mkPriorities thds = 113 | M.unions [i, p, s, e, fp, fe] 114 | where 115 | go f t = M.fromList (map f t) 116 | 117 | i = case atThreadsInit thds of 118 | NoInit -> M.empty 119 | HasInit -> M.fromList [(A.threadName (A.InitThread A.Init), minPriority)] 120 | 121 | p = go (\(t,pri) -> (A.threadName (A.PeriodThread t), pri)) 122 | (zip orderedPeriodic perPriorities) 123 | 124 | s = go (\(t,pri) -> (A.threadName (A.SignalThread t), pri)) 125 | (zip orderedSigs sigPriorities) 126 | 127 | e = go (\t -> (A.monitorName t, maxPriority)) (atThreadsExternal thds) 128 | 129 | fp = go (\t -> (A.monitorName t, incPriority minPriority)) (atThreadsFromPeriodic thds) 130 | 131 | fe = go (\(t,_) -> (A.monitorName t, maxPriority)) (atThreadsFromExternal thds) 132 | 133 | orderedPeriodic = reverse (sort pts) 134 | orderedSigs = sort (atThreadsSignal thds) 135 | 136 | pts = atThreadsPeriodic thds 137 | -------------------------------------------------------------------------------- /tower-aadl/src/Tower/AADL/Render/Common.hs: -------------------------------------------------------------------------------- 1 | -- 2 | -- Render helpers. 3 | -- 4 | -- (c) 2014 Galois, Inc. 5 | -- 6 | 7 | module Tower.AADL.Render.Common where 8 | 9 | import Text.PrettyPrint.Leijen 10 | 11 | import Tower.AADL.AST 12 | import qualified Ivory.Tower.AST.Comment as C 13 | import qualified Ivory.Tower.SrcLoc.Location as L 14 | 15 | -------------------------------------------------------------------------------- 16 | -- NamesSpaces 17 | 18 | typesPkg, sMACCMPkg, dataModelPkg, baseTypesPkg :: String 19 | typesPkg = "Data_Types" 20 | sMACCMPkg = "SMACCM_SYS" 21 | dataModelPkg = "Data_Model" 22 | baseTypesPkg = "Base_Types" 23 | 24 | -- @ns :: d1@ 25 | nameSpace :: Doc -> Doc -> Doc 26 | nameSpace d0 d1 = d0 <> colon <> colon <> d1 27 | 28 | fromSMACCM :: Doc -> Doc 29 | fromSMACCM = nameSpace (text sMACCMPkg) 30 | 31 | fromBaseTypes :: Doc -> Doc 32 | fromBaseTypes = nameSpace (text baseTypesPkg) 33 | 34 | fromTypeDefs :: Doc -> Doc 35 | fromTypeDefs = nameSpace (text typesPkg) 36 | 37 | fromDataModel :: Doc -> Doc 38 | fromDataModel = nameSpace (text dataModelPkg) 39 | 40 | -- | Imports for all packages 41 | baseImports :: [String] 42 | baseImports = 43 | [ baseTypesPkg 44 | , dataModelPkg 45 | ] 46 | 47 | -- | Imports for non-type definition packages. Include typesPkg only if data 48 | -- types defined. 49 | defaultImports :: Bool -> [String] 50 | defaultImports b = 51 | baseImports 52 | ++ (if b then [typesPkg] else []) 53 | ++ [ sMACCMPkg ] 54 | 55 | -------------------------------------------------------------------------------- 56 | -- Helpers 57 | 58 | external :: Doc 59 | external = stmt $ fromSMACCM (text "Is_External") ==> text "true" 60 | 61 | sendsEventsTo :: Doc 62 | sendsEventsTo = text "Sends_Events_To" 63 | 64 | srcText :: Doc 65 | srcText = text "Source_Text" 66 | 67 | primSrc :: Doc 68 | primSrc = text "CommPrim_Source_Text" 69 | 70 | entrySrc :: Doc 71 | entrySrc = text "Compute_Entrypoint_Source_Text" 72 | 73 | initEntryPoint :: Doc 74 | initEntryPoint = text "Initialize_Entrypoint_Source_Text" 75 | 76 | firstLevelHandlerText :: Doc 77 | firstLevelHandlerText = text "First_Level_Interrupt_Handler" 78 | 79 | firstLevelHandler :: String -> Doc 80 | firstLevelHandler name = stmt (fromSMACCM firstLevelHandlerText ==> (dquotes (text name))) 81 | 82 | isISR :: Doc 83 | isISR = stmt (fromSMACCM (text "Is_ISR") ==> text "true") 84 | 85 | sigName :: String -> Doc 86 | sigName name = stmt (fromSMACCM (text "Signal_Name") ==> (dquotes (text name))) 87 | 88 | sigNum :: Int -> Doc 89 | sigNum number = stmt (fromSMACCM (text "Signal_Number") ==> (int number)) 90 | 91 | mkImpl :: Doc -> Doc 92 | mkImpl d = d <> dot <> text "impl" 93 | 94 | tab :: Doc -> Doc 95 | tab = indent 2 96 | 97 | stmt :: Doc -> Doc 98 | stmt d = d <> semi 99 | 100 | (==>) :: Doc -> Doc -> Doc 101 | (==>) d0 d1 = d0 <+> equals <> rangle <+> d1 102 | 103 | (->>) :: Doc -> Doc -> Doc 104 | (->>) d0 d1 = d0 <+> char '-' <> rangle <+> d1 105 | 106 | -- | Skip a line. 107 | (<$$$>) :: Doc -> Doc -> Doc 108 | (<$$$>) d0 d1 = d0 <$$> empty <$$> d1 109 | 110 | -- | Separate with line breaks. 111 | skipLines :: [Doc] -> Doc 112 | skipLines = vsep . (punctuate linebreak) 113 | 114 | txChan :: Doc 115 | txChan = text "Output_" 116 | 117 | mkTxChan :: ChanLabel -> Doc 118 | mkTxChan l = txChan <> text l 119 | 120 | rxChan :: Doc 121 | rxChan = text "Input_" 122 | 123 | mkRxChan :: ChanLabel -> Doc 124 | mkRxChan l = rxChan <> text l 125 | 126 | -- | Takes the kind of block, block name, statements (e.g., features/properties) etc. 127 | renderBlk :: Doc -> Doc -> [Doc] -> Doc 128 | renderBlk kind nm stmts = 129 | kind <+> nm 130 | <$$> tab (vsep stmts) 131 | <$$> stmt (text "end" <+> nm) 132 | 133 | prettyTime :: Integer -> Doc 134 | prettyTime i = t 135 | where 136 | t = case i `mod` 1000 of 137 | 0 -> integer (i `div` 1000) <+> text "ms" 138 | _ -> integer i <+> text "us" 139 | 140 | -------------------------------------------------------------------------------- 141 | -- Comments 142 | 143 | renderStringComment :: String -> Doc 144 | renderStringComment = renderComment . C.UserComment 145 | 146 | renderComment :: C.Comment -> Doc 147 | renderComment c = text "--" <+> cm 148 | where 149 | cm = case c of 150 | C.UserComment s -> text s 151 | C.SourcePos s -> renderSrcLoc s 152 | 153 | renderSrcLoc :: L.SrcLoc -> Doc 154 | renderSrcLoc s = case s of 155 | L.NoLoc 156 | -> text "No source location" 157 | L.SrcLoc rng msrc 158 | -> case msrc of 159 | Nothing -> renderRng rng 160 | Just src -> text src <> colon <> renderRng rng 161 | 162 | -- Ignore the column. 163 | renderRng :: L.Range -> Doc 164 | renderRng (L.Range (L.Position _ ln0 _) (L.Position _ ln1 _)) = 165 | if ln0 == ln1 166 | then int ln0 167 | else int ln0 <+> char '-' <+> int ln1 168 | 169 | -- | Renders a list [foo, bar, ...] as `("foo", "bar", ...)` 170 | renderLs :: [String] -> Doc 171 | renderLs ls = 172 | lparen 173 | <> (hsep $ punctuate comma $ map (dquotes . text) ls) 174 | <> rparen 175 | -------------------------------------------------------------------------------- /tower-aadl/src/Tower/AADL/Threads.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiWayIf #-} 2 | 3 | -- 4 | -- Map the Tower AST into the AADL AST. 5 | -- 6 | -- (c) 2014 Galois, Inc. 7 | -- 8 | 9 | module Tower.AADL.Threads 10 | ( HMap 11 | , ActiveThreads(..) 12 | , PassiveThreads(..) 13 | , HasInit(..) 14 | , emptyHMap 15 | , fromHMap 16 | , toPassiveThreads 17 | , toActiveThreads 18 | ) where 19 | 20 | 21 | import Prelude () 22 | import Data.Monoid 23 | import Prelude.Compat hiding (init) 24 | import Data.Maybe (isJust) 25 | import Data.List (find) 26 | 27 | import qualified Ivory.Tower.AST as A 28 | import qualified Ivory.Tower.Types.Unique as U 29 | 30 | ---------------------------------------- 31 | 32 | -- Handler unique names that come from either periodic or external threads. 33 | type HMap = [U.Unique] 34 | 35 | emptyHMap :: HMap 36 | emptyHMap = [] 37 | 38 | fromHMap :: HMap -> A.Handler -> Bool 39 | fromHMap hmap h = 40 | isJust 41 | $ find (\u -> u == A.handler_name h) hmap 42 | 43 | data HasInit = NoInit | HasInit deriving (Show, Read, Eq, Ord) 44 | 45 | instance Monoid HasInit where 46 | mempty = NoInit 47 | HasInit `mappend` _ = HasInit 48 | _ `mappend` HasInit = HasInit 49 | _ `mappend` _ = NoInit 50 | 51 | -- Intermediate data types that collect Tower elements into groups that are 52 | -- meaningful for AADL (notably, distinguishing active and passive threads). 53 | 54 | data ActiveThreads = ActiveThreads 55 | { atThreadsInit :: HasInit 56 | , atThreadsPeriodic :: [A.Period] 57 | , atThreadsSignal :: [A.Signal] 58 | , atThreadsExternal :: [A.Monitor] 59 | , atThreadsFromPeriodic :: [A.Monitor] 60 | , atThreadsFromExternal :: [(A.Monitor, HMap)] -- From external or periodic threads 61 | } deriving Show 62 | 63 | data PassiveThreads = PassiveThreads 64 | { ptThreadsPassive :: [A.Monitor] 65 | } deriving Show 66 | 67 | instance Monoid ActiveThreads where 68 | mempty = ActiveThreads mempty [] [] [] [] [] 69 | ActiveThreads a0 b0 c0 d0 e0 f0 `mappend` ActiveThreads a1 b1 c1 d1 e1 f1 = 70 | ActiveThreads (a0 <> a1) (b0 <> b1) (c0 <> c1) (d0 <> d1) (e0 <> e1) (f0 <> f1) 71 | 72 | instance Monoid PassiveThreads where 73 | mempty = PassiveThreads [] 74 | PassiveThreads a0 `mappend` PassiveThreads a1 = 75 | PassiveThreads (a0++a1) 76 | 77 | injectInitThread :: ActiveThreads 78 | injectInitThread = mempty { atThreadsInit = HasInit } 79 | 80 | injectPeriodicThread :: A.Period -> ActiveThreads 81 | injectPeriodicThread m = mempty { atThreadsPeriodic = [m] } 82 | 83 | injectSignalThread :: A.Signal -> ActiveThreads 84 | injectSignalThread t = mempty { atThreadsSignal = [t] } 85 | 86 | injectExternalThread :: A.Monitor -> ActiveThreads 87 | injectExternalThread m = mempty { atThreadsExternal = [m] } 88 | 89 | injectFromExternal :: (A.Monitor, HMap) -> ActiveThreads 90 | injectFromExternal m = mempty { atThreadsFromExternal = [m] } 91 | 92 | injectPassiveThread :: A.Monitor -> PassiveThreads 93 | injectPassiveThread m = mempty { ptThreadsPassive = [m] } 94 | 95 | ---------------------------------------- 96 | 97 | -- All monitors except monitors that are labeled as external. For each passive 98 | -- monitor, we also record whether any of its handlers send or receive messages 99 | -- to an external monitor. 100 | toPassiveThreads :: A.Tower -> PassiveThreads 101 | toPassiveThreads t = mconcat (map injectPassiveThread pts) 102 | where 103 | ms = A.tower_monitors t 104 | pts = filter (not . isExternalMonitor) 105 | $ filter (not . isFromExternalMon t) 106 | ms 107 | 108 | toActiveThreads :: A.Tower -> ActiveThreads 109 | toActiveThreads t = 110 | mconcat (map towerThreadToThread (A.towerThreads t)) 111 | <> mconcat (map injectExternalThread iem) 112 | <> mconcat (map injectFromExternal (mkExternalActiveThreads t)) 113 | where 114 | towerThreadToThread thd = 115 | case thd of 116 | A.InitThread{} -> injectInitThread 117 | A.PeriodThread p -> injectPeriodicThread p 118 | A.SignalThread s -> injectSignalThread s 119 | 120 | iem = filter isExternalMonitor (A.tower_monitors t) 121 | 122 | mkExternalActiveThreads :: A.Tower -> [(A.Monitor, HMap)] 123 | mkExternalActiveThreads t = map go ms 124 | where 125 | ms = filter (isFromExternalMon t) (A.tower_monitors t) 126 | 127 | go :: A.Monitor -> (A.Monitor, HMap) 128 | go m = (m, mp) 129 | where 130 | mp = map A.handler_name (handlersFromExternalMon t m) 131 | 132 | ---------------------------------------- 133 | 134 | isFromExternalMon :: A.Tower -> A.Monitor -> Bool 135 | isFromExternalMon t m = not $ null $ handlersFromExternalMon t m 136 | 137 | handlersFromExternalMon :: A.Tower -> A.Monitor -> [A.Handler] 138 | handlersFromExternalMon t m = 139 | filter (isFromExternalMonH t) (A.monitor_handlers m) 140 | 141 | -- Does the handler handle a message sent by a handler in an external monitor? 142 | isFromExternalMonH :: A.Tower -> A.Handler -> Bool 143 | isFromExternalMonH t h = 144 | isJust $ find (\h' -> A.handler_name h' == A.handler_name h) fromExts 145 | where 146 | ms = A.tower_monitors t 147 | extMs = filter isExternalMonitor ms 148 | extHs = concatMap A.monitor_handlers extMs 149 | fromExts = map snd $ concatMap (A.handlerOutboundHandlers t) extHs 150 | 151 | -- Is this an external monitor? 152 | isExternalMonitor :: A.Monitor -> Bool 153 | isExternalMonitor m = A.monitor_external m == A.MonitorExternal 154 | -------------------------------------------------------------------------------- /tower-aadl/test-echronos/Simple.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE QuasiQuotes #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | 10 | {-# OPTIONS_GHC -fno-warn-orphans #-} 11 | 12 | module Main where 13 | 14 | import Ivory.Tower 15 | import Ivory.Language 16 | import Tower.AADL 17 | import Ivory.Tower.Config 18 | 19 | simpleTower :: Tower e () 20 | simpleTower = do 21 | towerModule towerDepModule 22 | towerDepends towerDepModule 23 | 24 | (c1in, c1out) <- channel 25 | (chtx, chrx) <- channel 26 | per <- period (Microseconds 1000) 27 | 28 | monitor "periodicM" $ do 29 | s <- state "local_st" 30 | handler per "tickh" $ do 31 | e <- emitter c1in 1 32 | callback $ \_ -> do 33 | emit e (constRef (s :: Ref 'Global ('Stored Uint8))) 34 | 35 | monitor "withsharedM" $ do 36 | s <- state "last_m2_chan1_message" 37 | 38 | handler c1out "fromActiveh" $ do 39 | e <- emitter chtx 1 40 | callback $ \m -> do 41 | refCopy s m 42 | emitV e true 43 | 44 | handler chrx "readStateh" $ do 45 | callback $ \_m -> do 46 | s' <- deref s 47 | call_ debug_print "rsh: " 48 | call_ debug_printhex8 s' 49 | call_ debug_println "" 50 | 51 | -------------------------------------------------------------------------------- 52 | debug_println :: Def('[IString] ':-> ()) 53 | debug_println = importProc "debug_println" "debug.h" 54 | 55 | debug_printhex8 :: Def('[Uint8] ':-> ()) 56 | debug_printhex8 = importProc "debug_printhex8" "debug.h" 57 | 58 | debug_print :: Def('[IString] ':-> ()) 59 | debug_print = importProc "debug_print" "debug.h" 60 | 61 | [ivory| 62 | struct Foo { foo :: Stored Uint8 } 63 | |] 64 | 65 | fooMod :: Module 66 | fooMod = package "foo" (defStruct (Proxy :: Proxy "Foo")) 67 | 68 | simpleTower2 :: Tower e () 69 | simpleTower2 = do 70 | towerModule fooMod 71 | towerDepends fooMod 72 | 73 | (c1in, c1out) <- channel 74 | per <- period (Microseconds 1000) 75 | monitor "m1" $ do 76 | s <- state "local_st" 77 | handler per "tick" $ do 78 | e <- emitter c1in 1 79 | callback $ \_ -> emit e (constRef (s :: Ref 'Global ('Struct "Foo"))) 80 | -- callback $ \_ -> emit e (constRef (s :: Ref Global (Array 3 (Stored Uint8)))) 81 | 82 | monitor "m2" $ do 83 | s <- state "last_m2_chan1_message" 84 | handler c1out "chan1msg" $ do 85 | callback $ \m -> 86 | refCopy s m 87 | 88 | -------------------------------------------------------------------------------- 89 | 90 | main :: IO () 91 | main = compileTowerAADL id p simpleTower 92 | where 93 | p topts = fmap fst $ 94 | getConfig' topts $ aadlConfigParser (defaultAADLConfig 95 | { configSystemOS = EChronos 96 | , configSystemAddr = Nothing 97 | , configSystemHW = PIXHAWK }) 98 | 99 | [ivory| 100 | import (stdio.h, printf) void printf(string x, uint8_t y) 101 | |] 102 | 103 | towerDepModule :: Module 104 | towerDepModule = package "towerDeps" $ do 105 | incl debug_println 106 | incl debug_print 107 | incl debug_printhex8 108 | incl printf 109 | -------------------------------------------------------------------------------- /tower-aadl/test-echronos/SyncTxRx.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE QuasiQuotes #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | {-# LANGUAGE PostfixOperators #-} 10 | 11 | {-# OPTIONS_GHC -fno-warn-orphans #-} 12 | 13 | -------------------------------------------------------------------------------- 14 | -- Single call from an active to a passive thread. 15 | -- 16 | -- (c) 2015 Galois, Inc. 17 | -- 18 | -------------------------------------------------------------------------------- 19 | 20 | module Main where 21 | 22 | import Ivory.Tower 23 | import Ivory.Language 24 | import Tower.AADL 25 | 26 | test1 :: Tower e () 27 | test1 = do 28 | towerModule towerDepModule 29 | towerDepends towerDepModule 30 | 31 | (c1in, c1out) <- channel 32 | per <- period (100`ms`) 33 | 34 | monitor "sender" $ do 35 | handler per "tick" $ do 36 | e <- emitter c1in 1 37 | callback $ \msg -> do 38 | m <- deref msg 39 | call_ printf "Sender ping received %llu. Writing to receiver.\n" m 40 | emitV e (m+1) 41 | 42 | monitor "rx_monitor" $ do 43 | handler c1out "receiver" $ do 44 | callback $ \msg -> do 45 | m <- deref msg 46 | call_ printf "receiver1 msg received %llu.\n" m 47 | 48 | -------------------------------------------------------------------------------- 49 | -- Compiler 50 | 51 | main :: IO () 52 | main = 53 | runCompileAADL 54 | initialOpts { genDirOpts = Just "syncTxRx" 55 | } 56 | test1 57 | 58 | -------------------------------------------------------------------------------- 59 | -- Helpers 60 | 61 | printf :: Def('[IString, ITime] :-> ()) 62 | printf = importProc "printf" "stdio.h" 63 | 64 | towerDepModule :: Module 65 | towerDepModule = package "towerDeps" (incl printf) 66 | -------------------------------------------------------------------------------- /tower-aadl/test-echronos/Test1.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE QuasiQuotes #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | {-# LANGUAGE PostfixOperators #-} 10 | 11 | {-# OPTIONS_GHC -fno-warn-orphans #-} 12 | 13 | -------------------------------------------------------------------------------- 14 | -- Single call from an active to a passive thread. 15 | -- 16 | -- (c) 2015 Galois, Inc. 17 | -- 18 | -------------------------------------------------------------------------------- 19 | 20 | module Main where 21 | 22 | import Ivory.Tower 23 | import Ivory.Language 24 | import Tower.AADL 25 | 26 | -- test1 :: Tower e () 27 | -- test1 = do 28 | -- towerModule towerDepModule 29 | -- towerDepends towerDepModule 30 | 31 | -- (c1in, c1out) <- channel 32 | 33 | -- -- per0 <- period (100`ms`) 34 | -- -- per1 <- period (1`ms`) 35 | 36 | -- -- monitor "sender0" $ do 37 | -- -- handler per0 "tick0" $ do 38 | -- -- e <- emitter c1in 1 39 | -- -- callback $ \msg -> do 40 | -- -- m <- deref msg 41 | -- -- call_ printf "Sender ping received %d. Writing to receiver.\n" m 42 | -- -- emitV e (m+1) 43 | 44 | -- -- monitor "sender1" $ do 45 | -- -- handler per1 "tick1" $ do 46 | -- -- e <- emitter c1in 1 47 | -- -- callback $ \msg -> do 48 | -- -- m <- deref msg 49 | -- -- call_ printf "Sender ping received %d. Writing to receiver.\n" m 50 | -- -- emitV e (m+1) 51 | 52 | -- -- monitor "rx_monitor" $ do 53 | -- -- handler c1out "receiver1" $ do 54 | -- -- callback $ \msg -> do 55 | -- -- m <- deref msg 56 | -- -- call_ printf "receiver1 msg received %d.\n" m 57 | 58 | test1 :: Tower e () 59 | test1 = do 60 | towerModule towerDepModule 61 | towerDepends towerDepModule 62 | 63 | (c1in, c1out) <- channel 64 | per <- period (100`ms`) 65 | 66 | monitor "sender" $ do 67 | handler per "tick" $ do 68 | e <- emitter c1in 1 69 | callback $ \msg -> do 70 | m <- deref msg 71 | call_ printf "Sender ping received %d. Writing to receiver.\n" m 72 | emitV e (m+1) 73 | 74 | monitor "rx_monitor" $ do 75 | handler c1out "receiver1" $ do 76 | callback $ \msg -> do 77 | m <- deref msg 78 | call_ printf "receiver1 msg received %d.\n" m 79 | 80 | handler c1out "receiver2" $ do 81 | callback $ \msg -> do 82 | m <- deref msg 83 | call_ printf "receiver2 msg received %d.\n" m 84 | 85 | -------------------------------------------------------------------------------- 86 | -- Compiler 87 | 88 | main :: IO () 89 | main = 90 | runCompileAADL 91 | initialOpts { genDirOpts = Just "test1" } 92 | test1 93 | 94 | -------------------------------------------------------------------------------- 95 | -- Helpers 96 | 97 | printf :: Def('[IString, ITime] :-> ()) 98 | printf = importProc "printf" "stdio.h" 99 | 100 | towerDepModule :: Module 101 | towerDepModule = package "towerDeps" (incl printf) 102 | -------------------------------------------------------------------------------- /tower-aadl/test-echronos/TestPerSender.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE QuasiQuotes #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | {-# LANGUAGE PostfixOperators #-} 10 | 11 | {-# OPTIONS_GHC -fno-warn-orphans #-} 12 | 13 | -------------------------------------------------------------------------------- 14 | -- Call from a periodic thread. 15 | -- 16 | -- (c) 2015 Galois, Inc. 17 | -- 18 | -------------------------------------------------------------------------------- 19 | 20 | module Main where 21 | 22 | import Ivory.Tower 23 | import Ivory.Language 24 | import Tower.AADL 25 | 26 | test0 :: Tower e () 27 | test0 = do 28 | towerModule towerDepModule 29 | towerDepends towerDepModule 30 | 31 | (cin, _) <- channel 32 | per <- period (100`ms`) 33 | 34 | monitor "sender" $ do 35 | handler per "tick" $ do 36 | e <- emitter cin 1 37 | callback $ \msg -> do 38 | m <- deref msg 39 | call_ printf "Sender ping received %llu. Writing to receiver.\n" m 40 | emitV e (m+1) 41 | 42 | -------------------------------------------------------------------------------- 43 | -- Compiler 44 | 45 | main :: IO () 46 | main = 47 | runCompileAADL 48 | initialOpts { genDirOpts = Just "test_per" 49 | } 50 | test0 51 | 52 | -------------------------------------------------------------------------------- 53 | -- Helpers 54 | 55 | printf :: Def('[IString, ITime] :-> ()) 56 | printf = importProc "printf" "stdio.h" 57 | 58 | towerDepModule :: Module 59 | towerDepModule = package "towerDeps" (incl printf) 60 | -------------------------------------------------------------------------------- /tower-aadl/test/External.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE QuasiQuotes #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | 9 | {-# OPTIONS_GHC -fno-warn-orphans #-} 10 | 11 | module Main where 12 | 13 | import Ivory.Tower 14 | import Ivory.Language 15 | import Tower.AADL 16 | import Ivory.Tower.Config 17 | 18 | simpleTower :: Tower e () 19 | simpleTower = do 20 | towerModule towerDepModule 21 | towerDepends towerDepModule 22 | 23 | (c1in, c1out) <- channel 24 | (chtx, chrx) <- channel 25 | per <- period (Microseconds 1000) 26 | 27 | monitor "periodicM" $ do 28 | s <- state "local_st" 29 | handler per "send" $ do 30 | e <- emitter c1in 1 31 | callback $ \_ -> do 32 | emit e (constRef (s :: Ref 'Global ('Stored Uint8))) 33 | handler chrx "rcv" $ callback $ \msg -> do 34 | n' <- deref msg 35 | store s (n' + 1) 36 | call_ printf "received: %u\n" n' 37 | 38 | {- 39 | monitor "withsharedM" $ do 40 | s <- state "last_m2_chan1_message" 41 | 42 | handler c1out "fromActiveh" $ do 43 | e <- emitter chtx 1 44 | callback $ \m -> do 45 | refCopy s m 46 | emitV e true 47 | 48 | handler chrx "readStateh" $ do 49 | callback $ \_m -> do 50 | s' <- deref s 51 | call_ printf "rsh: %u\n" s' 52 | -} 53 | 54 | ext_chan1 <- channel 55 | ext_chan2 <- channel 56 | 57 | externalMonitor "extMon" $ do 58 | 59 | handler c1out "send_ext" $ do 60 | e <- emitter (fst ext_chan1) 1 61 | callback $ \msg -> emit e msg 62 | 63 | handler (snd ext_chan2) "rcv_ext" $ do 64 | e <- emitter chtx 1 65 | callback $ \msg -> emit e msg 66 | 67 | 68 | 69 | 70 | main :: IO () 71 | main = compileTowerAADL id p simpleTower 72 | where 73 | p topts = getConfig topts $ aadlConfigParser defaultAADLConfig 74 | 75 | [ivory| 76 | import (stdio.h, printf) void printf(string x, uint8_t y) 77 | |] 78 | 79 | towerDepModule :: Module 80 | towerDepModule = package "towerDeps" $ do 81 | incl printf 82 | -------------------------------------------------------------------------------- /tower-aadl/test/Simple.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE QuasiQuotes #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | 9 | {-# OPTIONS_GHC -fno-warn-orphans #-} 10 | 11 | module Main where 12 | 13 | import Ivory.Tower 14 | import Ivory.Language 15 | import Tower.AADL 16 | import Ivory.Tower.Config 17 | 18 | simpleTower :: Tower e () 19 | simpleTower = do 20 | towerModule towerDepModule 21 | towerDepends towerDepModule 22 | 23 | (c1in, c1out) <- channel 24 | (chtx, chrx) <- channel 25 | per <- period (Microseconds 1000) 26 | 27 | monitor "periodicM" $ do 28 | s <- state "local_st" 29 | handler per "tickh" $ do 30 | e <- emitter c1in 1 31 | callback $ \_ -> do 32 | emit e (constRef (s :: Ref 'Global ('Stored Uint8))) 33 | 34 | monitor "withsharedM" $ do 35 | s <- state "last_m2_chan1_message" 36 | 37 | handler c1out "fromActiveh" $ do 38 | e <- emitter chtx 1 39 | callback $ \m -> do 40 | refCopy s m 41 | emitV e true 42 | 43 | handler chrx "readStateh" $ do 44 | callback $ \_m -> do 45 | s' <- deref s 46 | call_ printf "rsh: %u\n" s' 47 | 48 | -------------------------------------------------------------------------------- 49 | 50 | [ivory| 51 | struct Foo { foo :: Stored Uint8 } 52 | |] 53 | 54 | fooMod :: Module 55 | fooMod = package "foo" (defStruct (Proxy :: Proxy "Foo")) 56 | 57 | simpleTower2 :: Tower e () 58 | simpleTower2 = do 59 | towerModule fooMod 60 | towerDepends fooMod 61 | 62 | (c1in, c1out) <- channel 63 | per <- period (Microseconds 1000) 64 | monitor "m1" $ do 65 | s <- state "local_st" 66 | handler per "tick" $ do 67 | e <- emitter c1in 1 68 | callback $ \_ -> emit e (constRef (s :: Ref 'Global ('Struct "Foo"))) 69 | -- callback $ \_ -> emit e (constRef (s :: Ref Global (Array 3 (Stored Uint8)))) 70 | 71 | monitor "m2" $ do 72 | s <- state "last_m2_chan1_message" 73 | handler c1out "chan1msg" $ do 74 | callback $ \m -> 75 | refCopy s m 76 | 77 | -------------------------------------------------------------------------------- 78 | 79 | main :: IO () 80 | main = compileTowerAADL id p simpleTower 81 | where 82 | p topts = getConfig topts $ aadlConfigParser defaultAADLConfig 83 | 84 | [ivory| 85 | import (stdio.h, printf) void printf(string x, uint8_t y) 86 | |] 87 | 88 | towerDepModule :: Module 89 | towerDepModule = package "towerDeps" $ do 90 | incl printf 91 | -------------------------------------------------------------------------------- /tower-aadl/test/SyncTxRx.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE QuasiQuotes #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | {-# LANGUAGE PostfixOperators #-} 10 | 11 | {-# OPTIONS_GHC -fno-warn-orphans #-} 12 | 13 | -------------------------------------------------------------------------------- 14 | -- Single call from an active to a passive thread. 15 | -- 16 | -- (c) 2015 Galois, Inc. 17 | -- 18 | -------------------------------------------------------------------------------- 19 | 20 | module Main where 21 | 22 | import Ivory.Tower 23 | import Ivory.Language 24 | import Tower.AADL 25 | 26 | test1 :: Tower e () 27 | test1 = do 28 | towerModule towerDepModule 29 | towerDepends towerDepModule 30 | 31 | (c1in, c1out) <- channel 32 | per <- period (100`ms`) 33 | 34 | monitor "sender" $ do 35 | handler per "tick" $ do 36 | e <- emitter c1in 1 37 | callback $ \msg -> do 38 | m <- deref msg 39 | call_ printf "Sender ping received %llu. Writing to receiver.\n" m 40 | emitV e (m+1) 41 | 42 | monitor "rx_monitor" $ do 43 | handler c1out "receiver" $ do 44 | callback $ \msg -> do 45 | m <- deref msg 46 | call_ printf "receiver1 msg received %llu.\n" m 47 | 48 | -------------------------------------------------------------------------------- 49 | -- Compiler 50 | 51 | main :: IO () 52 | main = 53 | runCompileAADL 54 | initialOpts { genDirOpts = Just "syncTxRx" 55 | } 56 | test1 57 | 58 | -------------------------------------------------------------------------------- 59 | -- Helpers 60 | 61 | printf :: Def('[IString, ITime] :-> ()) 62 | printf = importProc "printf" "stdio.h" 63 | 64 | towerDepModule :: Module 65 | towerDepModule = package "towerDeps" (incl printf) 66 | -------------------------------------------------------------------------------- /tower-aadl/test/Test1.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE QuasiQuotes #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | {-# LANGUAGE PostfixOperators #-} 10 | 11 | {-# OPTIONS_GHC -fno-warn-orphans #-} 12 | 13 | -------------------------------------------------------------------------------- 14 | -- Single call from an active to a passive thread. 15 | -- 16 | -- (c) 2015 Galois, Inc. 17 | -- 18 | -------------------------------------------------------------------------------- 19 | 20 | module Main where 21 | 22 | import Ivory.Tower 23 | import Ivory.Language 24 | import Tower.AADL 25 | 26 | -- test1 :: Tower e () 27 | -- test1 = do 28 | -- towerModule towerDepModule 29 | -- towerDepends towerDepModule 30 | 31 | -- (c1in, c1out) <- channel 32 | 33 | -- -- per0 <- period (100`ms`) 34 | -- -- per1 <- period (1`ms`) 35 | 36 | -- -- monitor "sender0" $ do 37 | -- -- handler per0 "tick0" $ do 38 | -- -- e <- emitter c1in 1 39 | -- -- callback $ \msg -> do 40 | -- -- m <- deref msg 41 | -- -- call_ printf "Sender ping received %d. Writing to receiver.\n" m 42 | -- -- emitV e (m+1) 43 | 44 | -- -- monitor "sender1" $ do 45 | -- -- handler per1 "tick1" $ do 46 | -- -- e <- emitter c1in 1 47 | -- -- callback $ \msg -> do 48 | -- -- m <- deref msg 49 | -- -- call_ printf "Sender ping received %d. Writing to receiver.\n" m 50 | -- -- emitV e (m+1) 51 | 52 | -- -- monitor "rx_monitor" $ do 53 | -- -- handler c1out "receiver1" $ do 54 | -- -- callback $ \msg -> do 55 | -- -- m <- deref msg 56 | -- -- call_ printf "receiver1 msg received %d.\n" m 57 | 58 | test1 :: Tower e () 59 | test1 = do 60 | towerModule towerDepModule 61 | towerDepends towerDepModule 62 | 63 | (c1in, c1out) <- channel 64 | per <- period (100`ms`) 65 | 66 | monitor "sender" $ do 67 | handler per "tick" $ do 68 | e <- emitter c1in 1 69 | callback $ \msg -> do 70 | m <- deref msg 71 | call_ printf "Sender ping received %d. Writing to receiver.\n" m 72 | emitV e (m+1) 73 | 74 | monitor "rx_monitor" $ do 75 | handler c1out "receiver1" $ do 76 | callback $ \msg -> do 77 | m <- deref msg 78 | call_ printf "receiver1 msg received %d.\n" m 79 | 80 | handler c1out "receiver2" $ do 81 | callback $ \msg -> do 82 | m <- deref msg 83 | call_ printf "receiver2 msg received %d.\n" m 84 | 85 | -------------------------------------------------------------------------------- 86 | -- Compiler 87 | 88 | main :: IO () 89 | main = 90 | runCompileAADL 91 | initialOpts { genDirOpts = Just "test1" } 92 | test1 93 | 94 | -------------------------------------------------------------------------------- 95 | -- Helpers 96 | 97 | printf :: Def('[IString, ITime] :-> ()) 98 | printf = importProc "printf" "stdio.h" 99 | 100 | towerDepModule :: Module 101 | towerDepModule = package "towerDeps" (incl printf) 102 | -------------------------------------------------------------------------------- /tower-aadl/test/TestPerSender.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE QuasiQuotes #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | {-# LANGUAGE PostfixOperators #-} 10 | 11 | {-# OPTIONS_GHC -fno-warn-orphans #-} 12 | 13 | -------------------------------------------------------------------------------- 14 | -- Call from a periodic thread. 15 | -- 16 | -- (c) 2015 Galois, Inc. 17 | -- 18 | -------------------------------------------------------------------------------- 19 | 20 | module Main where 21 | 22 | import Ivory.Tower 23 | import Ivory.Language 24 | import Tower.AADL 25 | 26 | test0 :: Tower e () 27 | test0 = do 28 | towerModule towerDepModule 29 | towerDepends towerDepModule 30 | 31 | (cin, _) <- channel 32 | per <- period (100`ms`) 33 | 34 | monitor "sender" $ do 35 | handler per "tick" $ do 36 | e <- emitter cin 1 37 | callback $ \msg -> do 38 | m <- deref msg 39 | call_ printf "Sender ping received %llu. Writing to receiver.\n" m 40 | emitV e (m+1) 41 | 42 | -------------------------------------------------------------------------------- 43 | -- Compiler 44 | 45 | main :: IO () 46 | main = 47 | runCompileAADL 48 | initialOpts { genDirOpts = Just "test_per" 49 | } 50 | test0 51 | 52 | -------------------------------------------------------------------------------- 53 | -- Helpers 54 | 55 | printf :: Def('[IString, ITime] :-> ()) 56 | printf = importProc "printf" "stdio.h" 57 | 58 | towerDepModule :: Module 59 | towerDepModule = package "towerDeps" (incl printf) 60 | -------------------------------------------------------------------------------- /tower-aadl/tower-aadl.cabal: -------------------------------------------------------------------------------- 1 | name: tower-aadl 2 | version: 0.0.1.0 3 | author: Galois, Inc. 4 | maintainer: leepike@galois.com 5 | category: Language 6 | build-type: Simple 7 | cabal-version: >= 1.10 8 | license: BSD3 9 | 10 | library 11 | exposed-modules: Tower.AADL 12 | , Tower.AADL.AST 13 | , Tower.AADL.AST.Common 14 | , Tower.AADL.Build.Common 15 | , Tower.AADL.Build.SeL4 16 | , Tower.AADL.CodeGen 17 | , Tower.AADL.Compile 18 | , Tower.AADL.Config 19 | , Tower.AADL.FromTower 20 | , Tower.AADL.Platform 21 | , Tower.AADL.Priorities 22 | , Tower.AADL.Names 23 | , Tower.AADL.Render 24 | , Tower.AADL.Threads 25 | , Tower.AADL.Render.Common 26 | , Tower.AADL.Render.Types 27 | 28 | build-depends: base >= 4.6 29 | , base-compat 30 | , containers 31 | , directory 32 | , filepath 33 | , wl-pprint 34 | , ivory >= 0.1.0.2 35 | , ivory-artifact 36 | , ivory-backend-c 37 | , tower 38 | , tower-config 39 | , pretty-show 40 | 41 | hs-source-dirs: src 42 | default-language: Haskell2010 43 | ghc-options: -Wall -fno-warn-orphans 44 | 45 | executable test 46 | hs-source-dirs: test 47 | main-is: Simple.hs 48 | build-depends: base >= 4.6 49 | , base-compat 50 | , ivory >= 0.1.0.1 51 | , tower 52 | , tower-config 53 | , tower-aadl 54 | default-language: Haskell2010 55 | ghc-options: -Wall 56 | 57 | executable test-echronos 58 | hs-source-dirs: test-echronos 59 | main-is: Simple.hs 60 | build-depends: base >= 4.6 61 | , base-compat 62 | , ivory >= 0.1.0.1 63 | , tower 64 | , tower-config 65 | , tower-aadl 66 | default-language: Haskell2010 67 | ghc-options: -Wall 68 | 69 | executable test-external 70 | hs-source-dirs: test 71 | main-is: External.hs 72 | build-depends: base >= 4.6 73 | , base-compat 74 | , ivory >= 0.1.0.1 75 | , tower 76 | , tower-config 77 | , tower-aadl 78 | default-language: Haskell2010 79 | ghc-options: -Wall 80 | 81 | -------------------------------------------------------------------------------- /tower-config/.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | -------------------------------------------------------------------------------- /tower-config/Makefile: -------------------------------------------------------------------------------- 1 | include ../stack.mk 2 | -------------------------------------------------------------------------------- /tower-config/src/Ivory/Tower/Config.hs: -------------------------------------------------------------------------------- 1 | 2 | module Ivory.Tower.Config 3 | ( module Ivory.Tower.Config.Parser 4 | , getConfig' 5 | , getConfig 6 | ) where 7 | 8 | import Ivory.Artifact 9 | import Ivory.Tower.Options hiding (parseOpts) 10 | import Ivory.Tower.Config.Parser 11 | import Ivory.Tower.Config.Options 12 | import Ivory.Tower.Config.Document 13 | import Ivory.Tower.Config.TOML 14 | 15 | getConfig' :: TOpts -> ConfigParser a -> IO (a, TOpts) 16 | getConfig' topts p = do 17 | (cfgopts, t') <- getCfgOpts topts 18 | d <- getDocument (cfgopts_configfile cfgopts) 19 | (cfgopts_configpath cfgopts) 20 | case d of 21 | Left e -> topts_error t' ("Error in tower getConfig: " ++ e) 22 | Right toml -> do 23 | let conf_artifact = artifactString "build.conf" (ppValue (Left toml)) 24 | case runConfigParser p (Left toml) of 25 | Left e -> topts_error t' ("Error parsing config file: " ++ e) 26 | Right c -> do 27 | case topts_outdir t' of 28 | Just dir -> putArtifact_ dir conf_artifact 29 | Nothing -> return () 30 | case cfgopts_debug cfgopts of 31 | True -> printArtifact conf_artifact 32 | False -> return () 33 | return (c, t') 34 | 35 | getConfig :: TOpts -> ConfigParser a -> IO a 36 | getConfig topts p = do 37 | (c, t') <- getConfig' topts p 38 | finalizeOpts t' 39 | return c 40 | -------------------------------------------------------------------------------- /tower-config/src/Ivory/Tower/Config/Document.hs: -------------------------------------------------------------------------------- 1 | 2 | module Ivory.Tower.Config.Document where 3 | 4 | import Ivory.Tower.Config.Preprocess 5 | import Ivory.Tower.Config.TOML 6 | 7 | getDocument :: FilePath -> [FilePath] -> IO (Either String TOML) 8 | getDocument root path = do 9 | b <- getPreprocessedFile root path 10 | case b of 11 | Right bs -> return (tomlParse bs) 12 | Left e -> return (Left e) 13 | 14 | 15 | -------------------------------------------------------------------------------- /tower-config/src/Ivory/Tower/Config/Options.hs: -------------------------------------------------------------------------------- 1 | 2 | module Ivory.Tower.Config.Options 3 | ( CfgOpts(..) 4 | , getCfgOpts 5 | ) where 6 | 7 | import Ivory.Tower.Options 8 | import System.Console.GetOpt 9 | (OptDescr(..), ArgDescr(..), usageInfo) 10 | import qualified Ivory.Compile.C.CmdlineFrontend.Options as C 11 | 12 | data CfgOpts = CfgOpts 13 | { cfgopts_configfile :: FilePath 14 | , cfgopts_configpath :: [FilePath] 15 | , cfgopts_debug :: Bool 16 | } deriving (Show) 17 | 18 | initialCfgOpts :: CfgOpts 19 | initialCfgOpts = CfgOpts 20 | { cfgopts_configfile = "default.conf" 21 | , cfgopts_configpath = ["."] 22 | , cfgopts_debug = False 23 | } 24 | 25 | setConfigFile :: FilePath -> C.OptParser CfgOpts 26 | setConfigFile f = C.success (\t -> t { cfgopts_configfile = f }) 27 | 28 | clearConfigPath :: C.OptParser CfgOpts 29 | clearConfigPath = C.success (\t -> t { cfgopts_configpath = [] }) 30 | 31 | setConfigPath :: FilePath -> C.OptParser CfgOpts 32 | setConfigPath p = C.success (\t -> t { cfgopts_configpath = cfgopts_configpath t ++ [p] }) 33 | 34 | setConfigDebug :: C.OptParser CfgOpts 35 | setConfigDebug = C.success (\t -> t { cfgopts_debug = True }) 36 | 37 | cfgOptions :: [OptDescr (C.OptParser CfgOpts)] 38 | cfgOptions = [ Option "" ["conf-file"] (ReqArg setConfigFile "PATH") 39 | "path to tower application config file. default: default.conf" 40 | , Option "" ["conf-path"] (ReqArg setConfigPath "PATH") 41 | "extend include path for tower application config file. default: ." 42 | , Option "" ["clear-conf-path"] (NoArg clearConfigPath) 43 | "clear config file path" 44 | , Option "" ["debug-conf"] (NoArg setConfigDebug) 45 | "print debugging info for config" 46 | ] 47 | 48 | getCfgOpts :: TOpts -> IO (CfgOpts, TOpts) 49 | getCfgOpts topts = 50 | let (unused, mkCfgOpts) = parseOpts cfgOptions (topts_args topts) 51 | topts' = topts 52 | { topts_args = unused 53 | , topts_error = \s -> topts_error topts $ unlines 54 | [ s 55 | , "" 56 | , "tower-config options:" 57 | , usageInfo "" cfgOptions 58 | ] 59 | } 60 | in case mkCfgOpts of 61 | Right mkcfg -> return (mkcfg initialCfgOpts, topts') 62 | Left es -> topts_error topts' (unlines es) 63 | 64 | -------------------------------------------------------------------------------- /tower-config/src/Ivory/Tower/Config/Parser.hs: -------------------------------------------------------------------------------- 1 | 2 | module Ivory.Tower.Config.Parser 3 | ( ConfigParser() 4 | , runConfigParser 5 | , string 6 | , integer 7 | , double 8 | , bool 9 | , array 10 | , subsection 11 | , withDefault 12 | , (<|>) 13 | , () 14 | ) where 15 | 16 | import Prelude () 17 | import Prelude.Compat 18 | 19 | import qualified Data.Map as M 20 | import Text.TOML.Value 21 | import Data.Either (lefts, rights) 22 | import Data.List (intercalate) 23 | 24 | newtype ConfigParser a = 25 | ConfigParser 26 | { unConfigParser :: Value -> Either String a 27 | } 28 | 29 | instance Functor ConfigParser where 30 | fmap f c = ConfigParser $ \v -> fmap f (unConfigParser c v) 31 | 32 | instance Applicative ConfigParser where 33 | pure a = ConfigParser (const (pure a)) 34 | (ConfigParser f) <*> (ConfigParser a) = ConfigParser (\v -> (f v) <*> (a v)) 35 | 36 | instance Monad ConfigParser where 37 | return = pure 38 | (ConfigParser a) >>= f = ConfigParser 39 | (\v -> a v >>= \b -> unConfigParser (f b) v) 40 | fail e = ConfigParser (const (Left e)) 41 | 42 | runConfigParser :: ConfigParser a -> Value -> Either String a 43 | runConfigParser = unConfigParser 44 | 45 | configParser :: String -> (Value -> Maybe a) -> ConfigParser a 46 | configParser e p = ConfigParser $ \v -> 47 | case p v of 48 | Just a -> Right a 49 | Nothing -> Left ("expected " ++ e ++ ", got " ++ show v) 50 | 51 | string :: ConfigParser String 52 | string = configParser "string" $ \v -> 53 | case v of 54 | Right (VString a) -> Just a 55 | _ -> Nothing 56 | 57 | integer :: ConfigParser Integer 58 | integer = configParser "integer" $ \v -> 59 | case v of 60 | Right (VInteger a) -> Just a 61 | _ -> Nothing 62 | 63 | double :: ConfigParser Double 64 | double = configParser "double" $ \v -> 65 | case v of 66 | Right (VDouble a) -> Just a 67 | -- The Scientific type that attoparsec now uses will parse numbers 68 | -- like `1.0` as integers, so we account for that here. This means 69 | -- `1` will parse as a double, but this doesn't seem too harmful. 70 | Right (VInteger i) -> Just (fromIntegral i) 71 | _ -> Nothing 72 | 73 | bool :: ConfigParser Bool 74 | bool = configParser "bool" $ \v -> 75 | case v of 76 | Right (VBool a) -> Just a 77 | _ -> Nothing 78 | 79 | array :: ConfigParser a -> ConfigParser [a] 80 | array p = ConfigParser $ \v -> 81 | case v of 82 | Right (VArray as) -> 83 | let bs = map (\a -> unConfigParser p (Right a)) as 84 | in case lefts bs of 85 | [] -> Right (rights bs) 86 | es -> Left ("got following errors when parsing array elements: " ++ 87 | intercalate "; " es) 88 | _ -> Left ("expected array, got " ++ show v) 89 | 90 | subsection :: String -> ConfigParser a -> ConfigParser a 91 | subsection key vparser = ConfigParser $ \v -> 92 | case v of 93 | Left (TOML toml) -> case M.lookup key toml of 94 | Just v' -> unConfigParser vparser v' 95 | Nothing -> Left ("failed to find subsection named " 96 | ++ key ++ " in " ++ show toml) 97 | _ -> Left ("expected subsection, got " ++ show v) 98 | 99 | infixr 1 <|> 100 | (<|>) :: ConfigParser a -> ConfigParser a -> ConfigParser a 101 | (<|>) a b = ConfigParser $ \v -> 102 | case unConfigParser a v of 103 | Right r -> Right r 104 | Left _ -> unConfigParser b v 105 | 106 | infix 0 107 | () :: ConfigParser a -> String -> ConfigParser a 108 | () a lbl = a <|> fail lbl 109 | 110 | withDefault :: ConfigParser a -> a -> ConfigParser a 111 | withDefault a d = a <|> return d 112 | 113 | -------------------------------------------------------------------------------- /tower-config/src/Ivory/Tower/Config/Preprocess.hs: -------------------------------------------------------------------------------- 1 | 2 | module Ivory.Tower.Config.Preprocess 3 | ( getPreprocessedFile 4 | ) where 5 | 6 | import Data.Either (lefts, rights) 7 | import qualified Data.ByteString.Char8 as B 8 | import System.FilePath 9 | import System.Directory 10 | 11 | data Line 12 | = Literal B.ByteString 13 | | Include Importance FilePath 14 | deriving (Eq, Show) 15 | 16 | data Importance 17 | = Mandatory 18 | | Optional 19 | deriving (Eq, Show) 20 | 21 | directive :: String -> B.ByteString -> Maybe FilePath 22 | directive tag l = 23 | if and [ l /= B.empty, h == B.empty, t' == B.empty ] 24 | then Just (B.unpack h') 25 | else Nothing 26 | where 27 | (h , t ) = beforeafter (B.pack ("#" ++ tag ++ " \"")) l 28 | (h', t') = beforeafter (B.pack "\"") t 29 | beforeafter s m = let (b, a) = B.breakSubstring s m 30 | a' = B.drop (B.length s) a 31 | in (b,a') 32 | 33 | getLines :: FilePath -> IO [Line] 34 | getLines f = do 35 | b <- B.readFile f 36 | let ls = B.lines b 37 | return (map mkln ls) 38 | where 39 | mkln b = case directive "include" b of 40 | Just s -> Include Mandatory s 41 | Nothing -> case directive "optional" b of 42 | Just s -> Include Optional s 43 | Nothing -> Literal b 44 | 45 | findInclude :: FilePath -> [FilePath] -> IO (Maybe FilePath) 46 | findInclude _ [] = return Nothing 47 | findInclude f (p:ps) = do 48 | e <- doesFileExist fp 49 | if e then return (Just fp) 50 | else findInclude f ps 51 | where fp = p f 52 | 53 | -- This has terrible worst case complexity because unlines is strict. 54 | -- I suspect config files will be small enough that it wont matter. 55 | -- XXX this will loop forever on circular dependencies 56 | getPreprocessedFile :: FilePath -> [FilePath] 57 | -> IO (Either String B.ByteString) 58 | getPreprocessedFile root path = aux (Include Mandatory root) 59 | where 60 | run f = do 61 | ls <- getLines f 62 | bs <- mapM aux ls 63 | case (lefts bs) of 64 | [] -> return (Right (B.unlines (rights bs))) 65 | es -> return (Left ("In file " ++ f ++ ": " ++ unlines es)) 66 | aux (Literal b) = return (Right b) 67 | aux (Include i p) = do 68 | found <- findInclude p path 69 | case found of 70 | Just f' -> run f' 71 | Nothing -> case i of 72 | Mandatory -> return (Left ("could not find include named " ++ p)) 73 | Optional -> return (Right (B.empty)) 74 | 75 | 76 | -------------------------------------------------------------------------------- /tower-config/src/Ivory/Tower/Config/TOML.hs: -------------------------------------------------------------------------------- 1 | 2 | module Ivory.Tower.Config.TOML 3 | ( TOML 4 | , TOMLV 5 | , Value 6 | , ppValue 7 | , tomlParse 8 | ) where 9 | 10 | import qualified Data.Map as M 11 | import Data.List (intercalate) 12 | import Text.TOML.Value 13 | import qualified Text.TOML as T 14 | import qualified Data.ByteString.Char8 as B 15 | 16 | ppValue :: Value -> String 17 | ppValue = aux [] 18 | where 19 | aux ctx (Left (TOML toml)) = header ctx ++ ppBindings ctx (M.toList toml) 20 | aux _ (Right tomlv) = ppTOMLV tomlv 21 | ppBindings ctx as = intercalate "\n" $ 22 | map ppBinding (values as) ++ map (ppSubsection ctx) (subsections as) 23 | 24 | ppTOMLV (VString a) = "\"" ++ a ++ "\"" -- XXX not escape safe 25 | ppTOMLV (VInteger a) = show a 26 | ppTOMLV (VDouble a) = show a 27 | ppTOMLV (VBool True) = "true" 28 | ppTOMLV (VBool False) = "false" 29 | ppTOMLV (VArray as) = "[ " ++ (intercalate ", " (map ppTOMLV as)) ++ " ]" 30 | ppTOMLV (VDocument _) = error "Tower.Config.ppValue VDocument not supported" 31 | 32 | header [] = "" 33 | header sections = "[" ++ (intercalate "." sections) ++ "]\n" 34 | 35 | values [] = [] 36 | values ((s,Right v):as) = (s,v):(values as) 37 | values ((_,Left _):as) = values as 38 | 39 | ppBinding (s,v) = s ++ " = " ++ ppTOMLV v 40 | 41 | subsections [] = [] 42 | subsections ((_,Right _):as) = subsections as 43 | subsections ((s,Left v):as) = (s,v):(subsections as) 44 | 45 | ppSubsection ctx (s,v) = aux (ctx ++ [s]) (Left v) 46 | 47 | 48 | tomlParse :: B.ByteString -> Either String TOML 49 | tomlParse bs = T.parse bs 50 | -------------------------------------------------------------------------------- /tower-config/src/Text/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013-2014, Spiros Eliopoulos 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 7 | are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 16 | 3. Neither the name of the author nor the names of his contributors 17 | may be used to endorse or promote products derived from this software 18 | without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 21 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 22 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 24 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 26 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 27 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 28 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 29 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 30 | POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /tower-config/src/Text/README.md: -------------------------------------------------------------------------------- 1 | # TOML 2 | 3 | This work is derived from the `[toml][]` package version 0.1.3. 4 | 5 | [toml]: https://github.com/seliopou/toml/ 6 | 7 | ## Copyright 8 | Copyright (c) 2013-2014, Spiros Eliopoulos 9 | 10 | See LICENSE file included in this directory. 11 | 12 | -------------------------------------------------------------------------------- /tower-config/src/Text/TOML.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Text.TOML where 3 | 4 | import qualified Data.Attoparsec.ByteString.Char8 as A 5 | import qualified Data.ByteString.Char8 as B 6 | import Data.List ( foldl', groupBy ) 7 | import Data.Either ( rights ) 8 | import qualified Data.Map as M 9 | 10 | import Text.TOML.Parser 11 | 12 | parse :: B.ByteString -> Either String TOML 13 | parse bs = process `fmap` parse' bs 14 | 15 | parse' :: B.ByteString -> Either String [Token] 16 | parse' bs = (A.eitherResult $ A.feed (A.parse document bs) "") 17 | 18 | process :: [Token] -> TOML 19 | process ts = go (group ts) tempty 20 | where 21 | go [] m = m 22 | go ((ks, kvs):gs) m = go gs (okalter ks kvs m) 23 | 24 | okalter :: [B.ByteString] -> [(B.ByteString, TOMLV)] -> TOML -> TOML 25 | okalter [] kvs t = insertMany kvs t 26 | okalter (k:ks) kvs t = liftT (M.alter (Just . f) (B.unpack k)) t 27 | where f Nothing = liftTV (okalter ks kvs) (Left tempty) 28 | f (Just t') = liftTV (okalter ks kvs) t' 29 | 30 | insertMany :: [(B.ByteString, TOMLV)] -> TOML -> TOML 31 | insertMany kvs m = foldl' (flip $ uncurry tinsert) m kvs' 32 | where kvs' = [(B.unpack k, Right v) | (k, v) <- kvs] 33 | 34 | -- NB: groupBy will never produce an empty group. 35 | group :: [Either [a] b] -> [([a], [b])] 36 | group ts = alternate $ (map omg) $ (groupBy right ts) 37 | where 38 | omg _ls@((Left l):_) = Left l 39 | omg rs@((Right _):_) = Right (rights rs) 40 | omg _xs = error "Text.TOML.group.omg: unexpected input" 41 | -- Only key-value pairs are grouped together 42 | right (Right _) (Right _) = True 43 | right _ _ = False 44 | 45 | -- If the token list starts with a Right, then there are key-value pairs that 46 | -- don't belong to a keygroup. Assign that one the 'empty' keygroup, and match 47 | -- pairs. If the token list starts with a right, then there are no "global" 48 | -- key-value pairs, and it's ok to straight zip the partition. 49 | -- 50 | alternate [] = [] 51 | alternate ((Left l) : []) = (l , []) : [] 52 | alternate ((Right r) : gs) = ([], r ) : (alternate gs) 53 | alternate ((Left l ) : (Right r) : gs) = (l , r ) : (alternate gs) 54 | alternate ((Left l1) : (Left l2) : gs) = (l1, []) : (alternate $ (Left l2) : gs) 55 | 56 | -------------------------------------------------------------------------------- /tower-config/src/Text/TOML/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE CPP #-} 3 | module Text.TOML.Parser 4 | ( module Text.TOML.Value 5 | , document 6 | , keygroup 7 | , keyval 8 | , value 9 | , Token 10 | ) where 11 | 12 | import Control.Applicative 13 | import qualified Data.ByteString.Char8 as B 14 | import Data.Attoparsec.ByteString.Char8 15 | import Data.Scientific (floatingOrInteger) 16 | 17 | import Text.TOML.Value 18 | 19 | 20 | type Token = Either [B.ByteString] (B.ByteString, TOMLV) 21 | 22 | document :: Parser [Token] 23 | document = smb *> many ekk <* endOfInput 24 | where 25 | smb = skipMany blank 26 | ekk = (eitherP keygroup keyval) <* smb 27 | 28 | keygroup :: Parser [B.ByteString] 29 | keygroup = do 30 | skipMany blank 31 | between lbrace rbrace skey 32 | where skey = keyg `sepBy` period 33 | 34 | keyval :: Parser (B.ByteString, TOMLV) 35 | keyval = do 36 | k <- keyv 37 | v <- equal *> value 38 | return (k, v) 39 | 40 | keyg :: Parser B.ByteString 41 | keyg = lexeme $ takeWhile1 $ notInClass " \t\n]." 42 | keyv :: Parser B.ByteString 43 | keyv = lexeme $ takeWhile1 $ notInClass " \t\n=" 44 | 45 | value :: Parser TOMLV 46 | value = (array "array") 47 | <|> (bool "bool") 48 | <|> (str "string") 49 | <|> (num "number") 50 | where 51 | array = VArray <$> between lbrace rbrace (value `sepBy` comma) 52 | bool = VBool <$> (true *> return True <|> false *> return False) 53 | str = VString <$> between quote quote (many (notChar '"')) 54 | num = do 55 | n <- lexeme $ scientific 56 | case floatingOrInteger n of 57 | Right i -> return $ VInteger i 58 | Left d -> return $ VDouble d 59 | 60 | whatever :: Parser a -> Parser () 61 | whatever p = p >> return () 62 | lexeme :: Parser a -> Parser a 63 | lexeme p = do { x <- p; _ <- many spc; return x } 64 | spc :: Parser Char 65 | spc = char ' ' <|> char '\t' 66 | comment :: Parser () 67 | comment = whatever $ char '#' *> takeTill (=='\n') 68 | line :: Parser a -> Parser () 69 | line p = p *> (lexeme endOfLine) 70 | blank :: Parser () 71 | blank = line $ lexeme $ (try comment) <|> return () 72 | 73 | quote :: Parser B.ByteString 74 | quote = lexeme $ string "\"" 75 | lbrace :: Parser B.ByteString 76 | lbrace = lexeme $ string "[" 77 | rbrace :: Parser B.ByteString 78 | rbrace = lexeme $ string "]" 79 | comma :: Parser B.ByteString 80 | comma = lexeme $ string "," 81 | period :: Parser B.ByteString 82 | period = lexeme $ string "." 83 | equal :: Parser B.ByteString 84 | equal = lexeme $ string "=" 85 | true :: Parser B.ByteString 86 | true = lexeme $ string "true" 87 | false :: Parser B.ByteString 88 | false = lexeme $ string "false" 89 | 90 | between :: Parser a -> Parser b -> Parser c -> Parser c 91 | between a b p = do { _ <- a; e <- p; _ <- b; return e } 92 | -------------------------------------------------------------------------------- /tower-config/src/Text/TOML/Value.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Text.TOML.Value 3 | ( TOML (..) 4 | , TOMLV (..) 5 | , Value 6 | , tempty 7 | , tinsert 8 | , liftT 9 | , liftTV 10 | )where 11 | 12 | import Data.Map ( Map ) 13 | import qualified Data.Map as M 14 | 15 | type Value = Either TOML TOMLV 16 | 17 | newtype TOML = TOML (Map String Value) 18 | deriving ( Eq, Ord, Show ) 19 | 20 | data TOMLV 21 | = VString String 22 | | VInteger Integer 23 | | VDouble Double 24 | | VBool Bool 25 | | VArray [TOMLV] 26 | | VDocument TOML 27 | deriving ( Eq, Ord, Show ) 28 | 29 | tempty :: TOML 30 | tempty = TOML M.empty 31 | 32 | liftT :: (Map String Value -> Map String Value) -> TOML -> TOML 33 | liftT f (TOML m) = (TOML $ f m) 34 | 35 | liftTV :: (TOML -> TOML) -> Value -> Value 36 | liftTV f (Left t) = Left $ f t 37 | liftTV f (Right _) = Left $ f tempty 38 | 39 | tinsert :: String -> Value -> TOML -> TOML 40 | tinsert k v t = liftT (M.insert k v) t 41 | -------------------------------------------------------------------------------- /tower-config/tests/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Main where 4 | 5 | import Ivory.Tower.Config 6 | import Ivory.Tower.Config.Preprocess 7 | import Ivory.Tower.Config.Document 8 | import Ivory.Tower.Config.Options 9 | import Ivory.Tower.Config.TOML 10 | import System.Exit 11 | import Data.List (intercalate) 12 | import qualified Data.ByteString.Char8 as B 13 | import qualified Ivory.Tower.Options as O 14 | 15 | data ClockConfig = ClockConfig Integer Integer deriving (Eq, Show) 16 | 17 | clockConfigParser :: ConfigParser ClockConfig 18 | clockConfigParser = do 19 | xtal_mhz <- subsection "xtalMHz" integer 20 | sysclk_mhz <- subsection "sysclkMHz" integer 21 | return (ClockConfig xtal_mhz sysclk_mhz) 22 | 23 | sample1 :: B.ByteString 24 | sample1 = B.pack $ unlines 25 | [ "bar = \"hello world\"" 26 | , "[clockconfig.sub1.sub2]" 27 | , "foo = 121212" 28 | , "[clockconfig.sub1]" 29 | , "foo = 11111" 30 | , "[clockconfig]" 31 | , "xtalMHz = 8" 32 | , "sysclkMHz = 168" 33 | , "[clockconfig.pll]" 34 | , "foo = 999" 35 | , "[clockconfig.sub2]" 36 | , "foo = [ 22222, \"heterogenous array\"]" 37 | , "[clockconfig.sub1]" 38 | , "foo = \"overridden\"" 39 | ] 40 | 41 | testParse :: B.ByteString -> ConfigParser a -> Maybe a 42 | testParse bs p = do 43 | case tomlParse bs of 44 | Left _ -> Nothing 45 | Right doc -> case runConfigParser p (Left doc) of 46 | Right v -> Just v 47 | Left _ -> Nothing 48 | 49 | parseCC :: B.ByteString -> Maybe ClockConfig 50 | parseCC s = testParse s 51 | $ subsection "clockconfig" clockConfigParser 52 | 53 | getpllfoo :: B.ByteString -> Maybe Integer 54 | getpllfoo s = testParse s 55 | $ subsection "clockconfig" 56 | $ subsection "pll" 57 | $ subsection "foo" 58 | $ integer 59 | 60 | getsub1foo :: B.ByteString -> Maybe String 61 | getsub1foo s = testParse s 62 | $ subsection "clockconfig" 63 | $ subsection "sub1" 64 | $ subsection "foo" 65 | $ string 66 | 67 | main :: IO () 68 | main = do 69 | test "parseCC" 70 | (parseCC sample1 `equality` Just (ClockConfig 8 168)) 71 | 72 | test "subsectionval" 73 | (getpllfoo sample1 `equality` Just 999) 74 | 75 | test "subsectionval override" 76 | (getsub1foo sample1 `equality` Just "overridden") 77 | 78 | test "show" 79 | (ppValue (Left parsed) `equality` canonical) 80 | 81 | trivialfile 82 | multiincludefile 83 | optionparsing 84 | exitSuccess 85 | where 86 | equality a b = (a,b) 87 | parsed = case tomlParse sample1 of 88 | Right a -> a 89 | Left e -> error ("parsing failed: " ++ e) 90 | canonical = intercalate "\n" 91 | [ "bar = \"hello world\"" 92 | , "[clockconfig]" 93 | , "sysclkMHz = 168" 94 | , "xtalMHz = 8" 95 | , "[clockconfig.pll]" 96 | , "foo = 999" 97 | , "[clockconfig.sub1]" 98 | , "foo = \"overridden\"" 99 | , "[clockconfig.sub1.sub2]" 100 | , "foo = 121212" 101 | , "[clockconfig.sub2]" 102 | , "foo = [ 22222, \"heterogenous array\" ]" 103 | ] 104 | 105 | test n (a,b) | a == b = putStrLn (n ++ ": Passed") 106 | | otherwise = do putStrLn (n ++ ": Failed\n" ++ 107 | "\tlhs was " ++ show a ++ "\n" ++ 108 | "\trhs was " ++ show b) 109 | exitFailure 110 | 111 | 112 | trivialfile :: IO () 113 | trivialfile = do 114 | putStrLn "get trivial.config: " 115 | f <- getPreprocessedFile "trivial.config" ["./tests/resources1"] 116 | case f of 117 | Right bs -> case check bs of 118 | Just True -> putStrLn "Passed" 119 | a -> putStrLn ("Failed check of trivial.config: got " ++ show a) 120 | >> exitFailure 121 | Left e -> putStrLn ("Failed with error: " ++ e) >> exitFailure 122 | where 123 | check s = testParse s 124 | $ subsection "trivial" 125 | $ subsection "foo" 126 | $ bool 127 | 128 | multiincludefile :: IO () 129 | multiincludefile = do 130 | putStrLn "get root.config: " 131 | f <- getDocument "root.config" ["./tests/resources1", "./tests/resources2"] 132 | case f of 133 | Right v -> case runConfigParser parser (Left v) of 134 | Right ("at root",True, (2 :: Integer),"in child3") -> putStrLn "Passed" 135 | Right res -> err ("Wrong result when parsing root.config: " ++ show res) 136 | Left e -> err ("Failed to parse root.config: got " ++ show e) 137 | Left e -> err ("Failed with error: " ++ e) 138 | where 139 | err s = putStrLn s >> exitFailure 140 | parser = do 141 | rp <- subsection "rootsection" 142 | $ subsection "root_property" 143 | $ string 144 | c1foo <- subsection "child1" 145 | $ subsection "foo" 146 | $ bool 147 | c2foo <- subsection "child2" 148 | $ subsection "foo" 149 | $ integer 150 | c3foo <- subsection "child3" 151 | $ subsection "foo" 152 | $ string 153 | return (rp, c1foo, c2foo, c3foo) 154 | 155 | optionparsing :: IO () 156 | optionparsing = do 157 | putStrLn "parse options:\n" 158 | (cfgopts, extras) <- getCfgOpts topts 159 | d <- getDocument (cfgopts_configfile cfgopts) 160 | (cfgopts_configpath cfgopts) 161 | case (d, O.topts_args extras) of 162 | (Right _, []) -> putStrLn "Passed" 163 | (Left e, _) -> putStrLn ("Failed with error: " ++ e) >> exitFailure 164 | (_, rs) -> putStrLn ("Failed to parse options: " ++ unwords rs) >> exitFailure 165 | where 166 | topts = O.TOpts 167 | { O.topts_outdir = Nothing 168 | , O.topts_help = False 169 | , O.topts_args = [ "--conf-file=root.config" 170 | , "--conf-path=./tests/resources1" 171 | , "--conf-path=./tests/resources2" 172 | ] 173 | , O.topts_error = error "option parsing fail" 174 | } 175 | -------------------------------------------------------------------------------- /tower-config/tests/resources1/child1.config: -------------------------------------------------------------------------------- 1 | [child1] 2 | foo = true 3 | -------------------------------------------------------------------------------- /tower-config/tests/resources1/root.config: -------------------------------------------------------------------------------- 1 | #include "child1.config" 2 | #optional "resources3/child3.config" 3 | 4 | # just a comment 5 | 6 | #optional "definitely_does_not_exist" 7 | 8 | [rootsection] 9 | root_property = "at root" 10 | -------------------------------------------------------------------------------- /tower-config/tests/resources1/trivial.config: -------------------------------------------------------------------------------- 1 | [trivial] 2 | foo = true 3 | -------------------------------------------------------------------------------- /tower-config/tests/resources2/child2.config: -------------------------------------------------------------------------------- 1 | [child2] 2 | foo = 2 3 | -------------------------------------------------------------------------------- /tower-config/tests/resources2/resources3/child3.config: -------------------------------------------------------------------------------- 1 | #include "child2.config" 2 | [child3] 3 | foo = "in child3" 4 | -------------------------------------------------------------------------------- /tower-config/tower-config.cabal: -------------------------------------------------------------------------------- 1 | name: tower-config 2 | version: 0.1.0.0 3 | author: Galois, Inc. 4 | maintainer: pat@galois.com 5 | category: Language 6 | homepage: http://ivorylang.org 7 | build-type: Simple 8 | cabal-version: >= 1.10 9 | license: BSD3 10 | source-repository this 11 | type: git 12 | location: https://github.com/GaloisInc/tower 13 | 14 | library 15 | exposed-modules: Ivory.Tower.Config, 16 | Ivory.Tower.Config.Document, 17 | Ivory.Tower.Config.Parser, 18 | Ivory.Tower.Config.TOML, 19 | Ivory.Tower.Config.Options, 20 | Ivory.Tower.Config.Preprocess, 21 | Text.TOML, 22 | Text.TOML.Parser, 23 | Text.TOML.Value 24 | 25 | build-depends: base >= 4.6, 26 | base-compat >= 0.6, 27 | attoparsec >= 0.12.1.2, 28 | bytestring, 29 | containers, 30 | directory, 31 | filepath, 32 | scientific, 33 | ivory-artifact, 34 | ivory-backend-c, 35 | tower 36 | hs-source-dirs: src 37 | default-language: Haskell2010 38 | 39 | ghc-options: -Wall 40 | 41 | test-suite tests 42 | type: exitcode-stdio-1.0 43 | hs-source-dirs: tests 44 | main-is: Main.hs 45 | default-language: Haskell98 46 | ghc-options: -Wall 47 | build-depends: base >= 4.6, 48 | bytestring, 49 | containers, 50 | directory, 51 | filepath, 52 | tower, 53 | tower-config 54 | 55 | -------------------------------------------------------------------------------- /tower-hal/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Jamey Sharp 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 Jamey Sharp 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 | -------------------------------------------------------------------------------- /tower-hal/Makefile: -------------------------------------------------------------------------------- 1 | include ../stack.mk 2 | -------------------------------------------------------------------------------- /tower-hal/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /tower-hal/src/Ivory/Tower/HAL/Bus/CAN.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE QuasiQuotes #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# OPTIONS_GHC -fno-warn-orphans #-} 8 | 9 | module Ivory.Tower.HAL.Bus.CAN where 10 | 11 | import Ivory.Language 12 | 13 | -- CAN arbitration rules: 14 | -- * Higher priorities have lower numeric values. 15 | -- * Convert standard-frame 11-bit IDs to 29 bits by 16 | -- choosing the highest-priority 29-bit ID that has the 17 | -- same most-significant 11 bits as the original ID. In 18 | -- other words, pad with 18 zeroes on the right. 19 | -- * Standard frames are higher priority than extended 20 | -- frames with the same 29-bit ID, so append a 1 for 21 | -- extended frames or a 0 for standard frames. 22 | -- * Remote frames are lower priority than data frames of 23 | -- the same ID, so append a 1 for remote frames or a 0 for 24 | -- data frames. 25 | 26 | [ivory| 27 | bitdata CANArbitrationField :: Bits 32 = can_arbitration_field 28 | { _ :: Bit 29 | , can_arbitration_id :: Bits 29 30 | , can_arbitration_ide :: Bit 31 | , can_arbitration_rtr :: Bit 32 | } 33 | 34 | struct can_message 35 | { can_message_id :: Stored CANArbitrationField 36 | ; can_message_len :: Stored (Ix 9) 37 | ; can_message_buf :: Array 8 (Stored Uint8) 38 | } 39 | |] 40 | 41 | standardCANID :: Bits 11 -> Bit -> CANArbitrationField 42 | standardCANID stdid rtr = fromRep $ withBits 0 $ do 43 | setField can_arbitration_id $ fromRep $ safeCast (toRep stdid) `iShiftL` 18 44 | setField can_arbitration_rtr rtr 45 | 46 | extendedCANID :: Bits 29 -> Bit -> CANArbitrationField 47 | extendedCANID extid rtr = fromRep $ withBits 0 $ do 48 | setField can_arbitration_id extid 49 | setBit can_arbitration_ide 50 | setField can_arbitration_rtr rtr 51 | 52 | canDriverTypes :: Module 53 | canDriverTypes = package "canDriverTypes" $ do 54 | defStruct (Proxy :: Proxy "can_message") 55 | -------------------------------------------------------------------------------- /tower-hal/src/Ivory/Tower/HAL/Bus/CAN/sched.dot: -------------------------------------------------------------------------------- 1 | digraph { 2 | idle -> sched [ label="taskReq(this)" ]; 3 | idle -> hw [ label="taskReq(this) / txReq(this)" ]; 4 | idle -> idle [ label="taskAbort(this)" ]; 5 | sched -> hw [ label="txComplete(other, _) / txReq(this)" ]; 6 | sched -> idle [ label="taskAbort(this) / taskComplete(this, failed)" ]; 7 | hw -> reassign [ label="taskReq(other) / txAbort(this)" ]; 8 | hw -> abort [ label="taskAbort(this) / txAbort(this)" ]; 9 | { reassign abort } -> abort [ label="taskAbort(this)" ]; 10 | reassign -> idle [ label="txComplete(this, success) / taskComplete(this, success)" ]; 11 | reassign -> sched [ label="txComplete(this, failed)" ]; 12 | { hw abort } -> idle [ label="txComplete(this, status) / taskComplete(this, status)" ]; 13 | } 14 | -------------------------------------------------------------------------------- /tower-hal/src/Ivory/Tower/HAL/Bus/I2C.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# OPTIONS_GHC -fno-warn-orphans #-} 5 | 6 | module Ivory.Tower.HAL.Bus.I2C where 7 | 8 | import Ivory.Language 9 | import Ivory.Tower.HAL.Bus.I2C.DeviceAddr 10 | 11 | [ivory| 12 | struct i2c_transaction_request 13 | { tx_addr :: Stored I2CDeviceAddr 14 | ; tx_buf :: Array 128 (Stored Uint8) 15 | ; tx_len :: Stored (Ix 128) 16 | ; rx_len :: Stored (Ix 128) 17 | } 18 | 19 | struct i2c_transaction_result 20 | { resultcode :: Stored Uint8 21 | ; rx_buf :: Array 128 (Stored Uint8) 22 | } 23 | 24 | |] 25 | -------------------------------------------------------------------------------- /tower-hal/src/Ivory/Tower/HAL/Bus/I2C/DeviceAddr.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE DataKinds #-} 4 | 5 | module Ivory.Tower.HAL.Bus.I2C.DeviceAddr 6 | ( I2CDeviceAddr(..) 7 | , readAddr 8 | , writeAddr 9 | ) where 10 | 11 | import Ivory.Language 12 | 13 | newtype I2CDeviceAddr = I2CDeviceAddr Uint8 14 | deriving ( IvoryType, IvoryVar, IvoryExpr, IvoryEq, IvoryOrd 15 | , IvoryStore, IvoryInit, IvoryZeroVal) 16 | 17 | readAddr :: I2CDeviceAddr -> Uint8 18 | readAddr (I2CDeviceAddr a) = 2 * a + 1 19 | writeAddr :: I2CDeviceAddr -> Uint8 20 | writeAddr (I2CDeviceAddr a) = 2 * a 21 | -------------------------------------------------------------------------------- /tower-hal/src/Ivory/Tower/HAL/Bus/Interface.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | module Ivory.Tower.HAL.Bus.Interface where 4 | 5 | import Ivory.Language 6 | import Ivory.Tower 7 | 8 | data BackpressureTransmit value status = BackpressureTransmit 9 | { backpressureTransmit :: ChanInput value 10 | , backpressureComplete :: ChanOutput status 11 | } 12 | 13 | data AbortableTransmit value status = AbortableTransmit 14 | { abortableTransmit :: ChanInput value 15 | , abortableAbort :: ChanInput ('Stored IBool) 16 | , abortableComplete :: ChanOutput status 17 | } 18 | -------------------------------------------------------------------------------- /tower-hal/src/Ivory/Tower/HAL/Bus/SPI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# OPTIONS_GHC -fno-warn-orphans #-} 6 | 7 | module Ivory.Tower.HAL.Bus.SPI where 8 | 9 | import Ivory.Language 10 | import Ivory.Tower.HAL.Bus.SPI.DeviceHandle 11 | 12 | [ivory| 13 | struct spi_transaction_request 14 | { tx_device :: Stored SPIDeviceHandle 15 | ; tx_buf :: Array 128 (Stored Uint8) 16 | ; tx_len :: Stored (Ix 128) 17 | } 18 | 19 | struct spi_transaction_result 20 | { resultcode :: Stored Uint8 21 | ; rx_buf :: Array 128 (Stored Uint8) 22 | ; rx_idx :: Stored (Ix 128) 23 | } 24 | 25 | |] 26 | 27 | spiDriverTypes :: Module 28 | spiDriverTypes = package "spiDriverTypes" $ do 29 | defStruct (Proxy :: Proxy "spi_transaction_request") 30 | defStruct (Proxy :: Proxy "spi_transaction_result") 31 | -------------------------------------------------------------------------------- /tower-hal/src/Ivory/Tower/HAL/Bus/SPI/DeviceHandle.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE DataKinds #-} 4 | 5 | module Ivory.Tower.HAL.Bus.SPI.DeviceHandle 6 | ( SPIDeviceHandle(..) 7 | ) where 8 | 9 | import Ivory.Language 10 | 11 | newtype SPIDeviceHandle = SPIDeviceHandle Uint8 12 | deriving ( IvoryType, IvoryVar, IvoryExpr, IvoryEq, IvoryOrd 13 | , IvoryStore, IvoryInit, IvoryZeroVal) 14 | -------------------------------------------------------------------------------- /tower-hal/src/Ivory/Tower/HAL/Bus/Sched.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | 4 | module Ivory.Tower.HAL.Bus.Sched ( 5 | Task, task, schedule 6 | ) where 7 | 8 | import Control.Monad (forM) 9 | import Ivory.Language 10 | import Ivory.Stdlib 11 | import Ivory.Tower 12 | import Ivory.Tower.HAL.Bus.Interface 13 | import Ivory.Tower.HAL.Bus.Sched.Internal 14 | 15 | -- | Multiplex a request/response bus across any number of tasks that 16 | -- need to share it. Tasks may submit requests at any time, but only one 17 | -- task's request will be submitted to the bus at a time. When that 18 | -- request's response arrives, it is forwarded to the appropriate task 19 | -- and the next waiting task's request is sent. 20 | -- 21 | -- If multiple tasks have outstanding requests simultaneously, then this 22 | -- component will choose the highest-priority task first. Earlier tasks 23 | -- in the list given to 'schedule' are given higher priority. 24 | schedule :: (IvoryArea req, IvoryZero req, IvoryArea res, IvoryZero res, IvoryArea ready, IvoryZero ready) 25 | => String 26 | -> [Task req res] 27 | -> ChanOutput ready 28 | -> BackpressureTransmit req res 29 | -> Tower e () 30 | schedule name tasks ready (BackpressureTransmit reqChan resChan) = do 31 | let named nm = name ++ "_scheduler_" ++ nm 32 | monitor (name ++ "_scheduler") $ do 33 | -- Task IDs are either an index into the list of tasks, or one of 34 | -- two special values: 'no_task' or 'not_ready_task'. 35 | let no_task = 0 36 | let min_task = 1 37 | let max_task = length tasks 38 | let not_ready_task = maxBound 39 | 40 | response_task <- stateInit (named "response_task") $ ival not_ready_task 41 | 42 | -- Queue up to 1 request per task, which can arrive in any order. 43 | states <- forM (zip (map fromIntegral [min_task..max_task]) tasks) $ \ (taskId, taskBase@Task { .. }) -> do 44 | taskPending <- state $ (named $ taskName ++ "_pending") 45 | taskLastReq <- state $ (named $ taskName ++ "_last_req") 46 | 47 | handler taskReq (named taskName) $ do 48 | sendReq <- emitter reqChan 1 49 | callback $ \ req -> do 50 | was_pending <- deref taskPending 51 | assert $ iNot was_pending 52 | refCopy taskLastReq req 53 | store taskPending true 54 | 55 | current_task <- deref response_task 56 | when (current_task ==? no_task) $ do 57 | store response_task taskId 58 | emit sendReq $ constRef taskLastReq 59 | 60 | return TaskState { .. } 61 | 62 | let do_schedule sendReq = do 63 | conds <- forM states $ \ TaskState { .. } -> do 64 | pend <- deref taskPending 65 | return $ (pend ==>) $ do 66 | emit sendReq $ constRef taskLastReq 67 | store response_task taskId 68 | cond_ (conds ++ [true ==> store response_task no_task]) 69 | 70 | handler ready (named "ready") $ do 71 | sendReq <- emitter reqChan 1 72 | callback $ const $ do_schedule sendReq 73 | 74 | handler resChan (named "response") $ do 75 | sendReq <- emitter reqChan 1 76 | emitters <- forM states $ \ st -> do 77 | e <- emitter (taskRes $ taskBase st) 1 78 | return (st, e) 79 | callback $ \ res -> do 80 | current_task <- deref response_task 81 | assert $ current_task >=? fromIntegral min_task 82 | assert $ current_task <=? fromIntegral max_task 83 | cond_ $ do 84 | (TaskState { .. }, e) <- emitters 85 | return $ (current_task ==? taskId ==>) $ do 86 | was_pending <- deref taskPending 87 | assert was_pending 88 | store taskPending false 89 | emit e res 90 | do_schedule sendReq 91 | -------------------------------------------------------------------------------- /tower-hal/src/Ivory/Tower/HAL/Bus/Sched/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | module Ivory.Tower.HAL.Bus.Sched.Internal where 4 | 5 | import Ivory.Language 6 | import Ivory.Tower 7 | import Ivory.Tower.HAL.Bus.Interface 8 | 9 | data Task req res = Task 10 | { taskName :: String 11 | , taskReq :: ChanOutput req 12 | , taskRes :: ChanInput res 13 | } 14 | 15 | -- | Make a task with the given name for later scheduling. 16 | task :: (IvoryArea req, IvoryArea res) 17 | => String 18 | -> Tower e (Task req res, BackpressureTransmit req res) 19 | task taskName = do 20 | (backpressureTransmit, taskReq) <- channel 21 | (taskRes, backpressureComplete) <- channel 22 | return (Task { .. }, BackpressureTransmit { .. }) 23 | 24 | data TaskState req res = TaskState 25 | { taskBase :: Task req res 26 | , taskId :: Uint32 27 | , taskPending :: Ref 'Global ('Stored IBool) 28 | , taskLastReq :: Ref 'Global req 29 | } 30 | -------------------------------------------------------------------------------- /tower-hal/src/Ivory/Tower/HAL/Bus/SchedAsync.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | 4 | -- | This module works like 'Ivory.Tower.HAL.Bus.Sched', but 5 | -- reschedules tasks periodically, rather than as soon as the previous 6 | -- response returns. This can be useful for breaking cycles in the 7 | -- handler graph when requests immediately trigger responses. 8 | module Ivory.Tower.HAL.Bus.SchedAsync ( 9 | Task, task, schedule 10 | ) where 11 | 12 | import Control.Monad (forM) 13 | import Ivory.Language 14 | import Ivory.Stdlib 15 | import Ivory.Tower 16 | import Ivory.Tower.HAL.Bus.Interface 17 | import Ivory.Tower.HAL.Bus.Sched.Internal 18 | 19 | -- | Multiplex a request/response bus across any number of tasks that 20 | -- need to share it. Tasks may submit requests at any time, but only one 21 | -- task's request will be submitted to the bus at a time. When that 22 | -- request's response arrives, it is forwarded to the appropriate task 23 | -- and the next waiting task's request is sent. 24 | -- 25 | -- If multiple tasks have outstanding requests simultaneously, then this 26 | -- component will choose the highest-priority task first. Earlier tasks 27 | -- in the list given to 'schedule' are given higher priority. 28 | schedule :: (IvoryArea req, IvoryZero req, IvoryArea res, IvoryZero res, IvoryArea ready, IvoryZero ready, Time p) 29 | => String 30 | -> [Task req res] 31 | -> ChanOutput ready 32 | -> BackpressureTransmit req res 33 | -> p 34 | -> Tower e () 35 | schedule name tasks ready (BackpressureTransmit reqChan resChan) reschedule_period = do 36 | let named nm = name ++ "_schedulerasync_" ++ nm 37 | reschedule <- period reschedule_period 38 | monitor (name ++ "_schedulerasync") $ do 39 | -- Task IDs are either an index into the list of tasks, or one of 40 | -- three special values: 'no_task', 'not_ready_task', or 41 | -- 'reschedule_task'. 42 | let no_task = 0 43 | let min_task = 1 44 | let max_task = length tasks 45 | let not_ready_task = maxBound 46 | let reschedule_task = maxBound - 1 47 | 48 | response_task <- stateInit (named "response_task") $ ival not_ready_task 49 | has_pending_response <- stateInit (named "has_pending_response") $ ival false 50 | pending_response <- state (named "pending_response") 51 | 52 | -- Queue up to 1 request per task, which can arrive in any order. 53 | states <- forM (zip (map fromIntegral [min_task..max_task]) tasks) $ \ (taskId, taskBase@Task { .. }) -> do 54 | taskPending <- state $ (named $ taskName ++ "_pending") 55 | taskLastReq <- state $ (named $ taskName ++ "_last_req") 56 | 57 | handler taskReq (named taskName) $ do 58 | sendReq <- emitter reqChan 1 59 | callback $ \ req -> do 60 | was_pending <- deref taskPending 61 | assert $ iNot was_pending 62 | refCopy taskLastReq req 63 | store taskPending true 64 | 65 | current_task <- deref response_task 66 | when (current_task ==? no_task) $ do 67 | store response_task taskId 68 | emit sendReq $ constRef taskLastReq 69 | 70 | return TaskState { .. } 71 | 72 | let do_schedule sendReq = do 73 | conds <- forM states $ \ TaskState { .. } -> do 74 | pend <- deref taskPending 75 | return $ (pend ==>) $ do 76 | emit sendReq $ constRef taskLastReq 77 | store response_task taskId 78 | cond_ (conds ++ [true ==> store response_task no_task]) 79 | 80 | handler ready (named "ready") $ do 81 | callback $ const $ store response_task reschedule_task 82 | 83 | handler resChan (named "response") $ do 84 | callback $ \res -> do 85 | store has_pending_response true 86 | refCopy pending_response res 87 | 88 | handler reschedule (named "reschedule") $ do 89 | sendReq <- emitter reqChan 1 90 | emitters <- forM states $ \ st -> do 91 | e <- emitter (taskRes $ taskBase st) 1 92 | return (st, e) 93 | callback $ \ _ -> do 94 | current_task <- deref response_task 95 | has_resp <- deref has_pending_response 96 | when has_resp $ do 97 | store has_pending_response false 98 | assert $ current_task >=? fromIntegral min_task 99 | assert $ current_task <=? fromIntegral max_task 100 | cond_ $ do 101 | (TaskState { .. }, e) <- emitters 102 | return $ (current_task ==? taskId ==>) $ do 103 | was_pending <- deref taskPending 104 | assert was_pending 105 | store taskPending false 106 | emit e (constRef pending_response) 107 | store response_task reschedule_task 108 | when (current_task ==? reschedule_task) $ do_schedule sendReq 109 | -------------------------------------------------------------------------------- /tower-hal/src/Ivory/Tower/HAL/Bus/UART.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# OPTIONS_GHC -fno-warn-orphans #-} 5 | 6 | module Ivory.Tower.HAL.Bus.UART where 7 | 8 | import Ivory.Language 9 | 10 | [ivory| 11 | struct uart_transaction_request 12 | { tx_buf :: Array 128 (Stored Uint8) 13 | ; tx_len :: Stored Sint32 -- not (Ix 128) because of fencepost bugs 14 | } 15 | |] 16 | 17 | uartDriverTypes :: Module 18 | uartDriverTypes = package "uartDriverTypes" $ do 19 | defStruct (Proxy :: Proxy "uart_transaction_request") 20 | 21 | -------------------------------------------------------------------------------- /tower-hal/src/Ivory/Tower/HAL/RingBuffer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE KindSignatures #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | 8 | module Ivory.Tower.HAL.RingBuffer 9 | ( RingBuffer(..) 10 | , ringBuffer 11 | , monitorRingBuffer 12 | , bufferChan 13 | , bufferChans 14 | ) where 15 | 16 | import GHC.TypeLits 17 | import Ivory.Language 18 | import Ivory.Stdlib 19 | import Ivory.Tower 20 | 21 | data RingBuffer (n :: Nat) a = 22 | RingBuffer 23 | { ringbuffer_push :: forall s eff . ConstRef s a -> Ivory eff IBool 24 | , ringbuffer_pop :: forall s eff . Ref s a -> Ivory eff IBool 25 | , ringbuffer_empty :: forall eff . Ivory eff IBool 26 | , ringbuffer_moddef :: ModuleDef 27 | } 28 | 29 | 30 | monitorRingBuffer :: forall e n a 31 | . (ANat n, IvoryArea a, IvoryZero a) 32 | => String -> Monitor e (RingBuffer n a) 33 | monitorRingBuffer name = do 34 | n <- freshname name 35 | let b :: RingBuffer n a 36 | b = ringBuffer (showUnique n) 37 | monitorModuleDef (ringbuffer_moddef b) 38 | return b 39 | 40 | ringBuffer :: forall n a 41 | . (ANat n, IvoryArea a, IvoryZero a) 42 | => String -> RingBuffer n a 43 | ringBuffer s = RingBuffer 44 | { ringbuffer_push = call push_proc 45 | , ringbuffer_pop = call pop_proc 46 | , ringbuffer_empty = empty 47 | , ringbuffer_moddef = do 48 | incl push_proc 49 | incl pop_proc 50 | defMemArea insert_area 51 | defMemArea remove_area 52 | defMemArea buf_area 53 | } 54 | where 55 | named n = s ++ "_ringbuffer_" ++ n 56 | 57 | remove_area :: MemArea ('Stored (Ix n)) 58 | remove_area = area (named "remove") (Just (ival 0)) 59 | remove = addrOf remove_area 60 | insert_area :: MemArea ('Stored (Ix n)) 61 | insert_area = area (named "insert") (Just (ival 0)) 62 | insert = addrOf insert_area 63 | buf_area :: MemArea ('Array n a) 64 | buf_area = area (named "buf") Nothing 65 | buf = addrOf buf_area 66 | 67 | incr :: (GetAlloc eff ~ 'Scope s') 68 | => Ref s ('Stored (Ix n)) -> Ivory eff (Ix n) 69 | incr ix = do 70 | i <- deref ix 71 | ifte (i ==? (fromIntegral ((ixSize i) - 1))) 72 | (return 0) 73 | (return (i + 1)) 74 | 75 | full :: (GetAlloc eff ~ 'Scope s') => Ivory eff IBool 76 | full = do 77 | i <- incr insert 78 | r <- deref remove 79 | return (i ==? r) 80 | 81 | empty :: Ivory eff IBool 82 | empty = do 83 | i <- deref insert 84 | r <- deref remove 85 | return (i ==? r) 86 | 87 | push_proc :: Def('[ConstRef s a]':->IBool) 88 | push_proc = proc (named "push") $ \v -> body $ do 89 | f <- full 90 | ifte_ f (ret false) $ do 91 | i <- deref insert 92 | refCopy (buf ! i) v 93 | incr insert >>= store insert 94 | ret true 95 | 96 | pop_proc :: Def('[Ref s a]':->IBool) 97 | pop_proc = proc (named "pop") $ \v -> body $ do 98 | e <- empty 99 | ifte_ e (ret false) $ do 100 | r <- deref remove 101 | refCopy v (buf ! r) 102 | incr remove >>= store remove 103 | ret true 104 | 105 | -- | Wrapper to add a ringbuffer to a Tower chan. Periodically pops 106 | -- from the buffer at the given rate. 107 | bufferChan :: forall a t n e 108 | . (IvoryArea a, IvoryZero a, Time t, ANat n) 109 | => ChanOutput a 110 | -> t 111 | -> Proxy n 112 | -> Tower e (ChanOutput a) 113 | bufferChan input pop_period _buf_size = do 114 | out <- channel 115 | bufferChans input pop_period _buf_size (fst out) 116 | return (snd out) 117 | 118 | -- | Wrapper to add a ringbuffer between two Tower chans. Periodically 119 | -- pops from the buffer at the given rate. 120 | bufferChans :: forall a t n e 121 | . (IvoryArea a, IvoryZero a, Time t, ANat n) 122 | => ChanOutput a 123 | -> t 124 | -> Proxy n 125 | -> ChanInput a 126 | -> Tower e () 127 | bufferChans input pop_period _buf_size out = do 128 | p <- period pop_period 129 | monitor "frameBuffer" $ do 130 | (rb :: RingBuffer n a) <- monitorRingBuffer "frameBuffer" 131 | handler input "push" $ do 132 | callback $ \v -> do 133 | _ <- ringbuffer_push rb v 134 | return () 135 | handler p "periodic_pop" $ do 136 | e <- emitter out 1 137 | callback $ const $ do 138 | v <- local izero 139 | got <- ringbuffer_pop rb v 140 | ifte_ got (emit e (constRef v)) (return ()) 141 | -------------------------------------------------------------------------------- /tower-hal/tower-hal.cabal: -------------------------------------------------------------------------------- 1 | name: tower-hal 2 | version: 0.1.0.0 3 | license: BSD3 4 | license-file: LICENSE 5 | author: Jamey Sharp 6 | maintainer: jamey@galois.com 7 | build-type: Simple 8 | cabal-version: >=1.10 9 | 10 | library 11 | exposed-modules: Ivory.Tower.HAL.RingBuffer, 12 | Ivory.Tower.HAL.Bus.CAN, 13 | Ivory.Tower.HAL.Bus.Interface, 14 | Ivory.Tower.HAL.Bus.Sched, 15 | Ivory.Tower.HAL.Bus.SchedAsync, 16 | Ivory.Tower.HAL.Bus.Sched.Internal, 17 | Ivory.Tower.HAL.Bus.I2C, 18 | Ivory.Tower.HAL.Bus.UART, 19 | Ivory.Tower.HAL.Bus.SPI, 20 | Ivory.Tower.HAL.Bus.SPI.DeviceHandle, 21 | Ivory.Tower.HAL.Bus.CAN.Sched, 22 | Ivory.Tower.HAL.Bus.CAN.Fragment, 23 | Ivory.Tower.HAL.Bus.I2C.DeviceAddr 24 | build-depends: base >=4.6, 25 | ivory, 26 | ivory-serialize, 27 | ivory-stdlib, 28 | tower 29 | hs-source-dirs: src 30 | default-language: Haskell2010 31 | ghc-options: -Wall 32 | -------------------------------------------------------------------------------- /tower-mini/.gitignore: -------------------------------------------------------------------------------- 1 | *_codegen/ -------------------------------------------------------------------------------- /tower-mini/Makefile: -------------------------------------------------------------------------------- 1 | include ../stack.mk 2 | 3 | test_simple: 4 | stack test tower-mini:simple --test-arguments '--src-dir=simple_codegen' 5 | 6 | test_integrated: 7 | stack test tower-mini:integrated --test-arguments '--src-dir=integrated_codegen' 8 | -------------------------------------------------------------------------------- /tower-mini/default.conf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/GaloisInc/tower/a43f5e36c6443472ea2dc15bbd49faf8643a6f87/tower-mini/default.conf -------------------------------------------------------------------------------- /tower-mini/test/Simple.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE QuasiQuotes #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | 12 | {-# OPTIONS_GHC -fno-warn-orphans #-} 13 | 14 | module Main where 15 | 16 | import Ivory.Language 17 | 18 | import Ivory.Tower 19 | import Ivory.Tower.Config 20 | 21 | import Tower.Mini 22 | 23 | simpleTower :: Component e 24 | simpleTower = component "simple" $ tower $ do 25 | towerModule towerDepModule 26 | towerDepends towerDepModule 27 | 28 | (c1in, c1out) <- channel 29 | (chtx, chrx) <- channel 30 | per <- period (Microseconds 1000) 31 | 32 | monitor "periodicM" $ do 33 | s <- state "local_st" 34 | handler per "tickh" $ do 35 | e <- emitter c1in 1 36 | callback $ \_ -> do 37 | emit e (constRef (s :: Ref 'Global ('Stored Uint8))) 38 | 39 | monitor "withsharedM" $ do 40 | s <- state "last_m2_chan1_message" 41 | 42 | handler c1out "fromActiveh" $ do 43 | e <- emitter chtx 1 44 | callback $ \m -> do 45 | refCopy s m 46 | emitV e true 47 | 48 | handler chrx "readStateh" $ do 49 | callback $ \_m -> do 50 | s' <- deref s 51 | call_ printf "rsh: %u\n" s' 52 | 53 | -------------------------------------------------------------------------------- 54 | 55 | main :: IO () 56 | main = compileTowerMini id p [simpleTower] 57 | where 58 | p topts = getConfig topts $ miniConfigParser defaultMiniConfig 59 | 60 | -------------------------------------------------------------------------------- 61 | [ivory| 62 | import (stdio.h, printf) void printf(string x, uint8_t y) 63 | |] 64 | 65 | towerDepModule :: Module 66 | towerDepModule = package "towerDeps" $ do 67 | incl printf 68 | -------------------------------------------------------------------------------- /tower-mini/test/cfiles/intermon1.c: -------------------------------------------------------------------------------- 1 | #include "intermon1.h" 2 | 3 | static uint8_t the_data; 4 | static bool has_data = false; 5 | 6 | bool intermon1_get_data(uint8_t *out) { 7 | if (has_data) { 8 | *out = the_data; 9 | has_data = false; 10 | return true; 11 | } else { 12 | return false; 13 | } 14 | } 15 | 16 | void intermon1_put_data(const uint8_t *data) { 17 | the_data = *data; 18 | has_data = true; 19 | return; 20 | } 21 | -------------------------------------------------------------------------------- /tower-mini/test/cfiles/intermon1.h: -------------------------------------------------------------------------------- 1 | #ifndef __INTERMON1_H__ 2 | #define __INTERMON1_H__ 3 | 4 | #include 5 | #include 6 | #include 7 | 8 | #ifdef __cplusplus 9 | extern "C" { 10 | #endif 11 | 12 | /** 13 | * A stub for one of the intermediate monitors. The bool return value 14 | * indicates whether valid data was written to the pointer 15 | */ 16 | bool intermon1_get_data(uint8_t*); 17 | 18 | void intermon1_put_data(const uint8_t*); 19 | 20 | #ifdef __cplusplus 21 | } 22 | #endif 23 | 24 | #endif 25 | -------------------------------------------------------------------------------- /tower-mini/test/cfiles/intermon2.c: -------------------------------------------------------------------------------- 1 | #include "intermon2.h" 2 | 3 | static bool the_data; 4 | static bool has_data = false; 5 | 6 | bool intermon2_get_data(bool *out) { 7 | if (has_data) { 8 | *out = the_data; 9 | has_data = false; 10 | return true; 11 | } else { 12 | return false; 13 | } 14 | } 15 | 16 | void intermon2_put_data(const bool *data) { 17 | the_data = *data; 18 | has_data = true; 19 | return; 20 | } 21 | -------------------------------------------------------------------------------- /tower-mini/test/cfiles/intermon2.h: -------------------------------------------------------------------------------- 1 | #ifndef __INTERMON2_H__ 2 | #define __INTERMON2_H__ 3 | 4 | #include 5 | #include 6 | 7 | #ifdef __cplusplus 8 | extern "C" { 9 | #endif 10 | 11 | /** 12 | * A stub for one of the intermediate monitors. The bool return value 13 | * indicates whether valid data was written to the pointer 14 | */ 15 | bool intermon2_get_data(bool*); 16 | 17 | void intermon2_put_data(const bool*); 18 | 19 | #ifdef __cplusplus 20 | } 21 | #endif 22 | 23 | #endif 24 | -------------------------------------------------------------------------------- /tower-mini/tower-mini.cabal: -------------------------------------------------------------------------------- 1 | name: tower-mini 2 | version: 0.0.1.0 3 | author: Galois, Inc. 4 | maintainer: leepike@galois.com 5 | category: Language 6 | build-type: Simple 7 | cabal-version: >= 1.10 8 | license: BSD3 9 | 10 | library 11 | exposed-modules: Tower.Mini 12 | other-modules: Tower.Mini.Component 13 | 14 | build-depends: base >= 4.6 15 | , base-compat 16 | , containers 17 | , filepath 18 | , mainland-pretty >= 0.4.0.0 19 | , monadLib 20 | , ivory >= 0.1.0.2 21 | , ivory-artifact 22 | , ivory-backend-c 23 | , tower 24 | , tower-config 25 | , pretty-show 26 | 27 | hs-source-dirs: src 28 | default-language: Haskell2010 29 | ghc-options: -Wall -fno-warn-orphans 30 | 31 | test-suite simple 32 | type: exitcode-stdio-1.0 33 | hs-source-dirs: test 34 | main-is: Simple.hs 35 | build-depends: base >= 4.6 36 | , base-compat 37 | , containers 38 | , filepath 39 | , ivory 40 | , ivory-artifact 41 | , ivory-backend-c 42 | , tower 43 | , tower-config 44 | , tower-mini 45 | default-language: Haskell2010 46 | ghc-options: -Wall 47 | 48 | test-suite integrated 49 | type: exitcode-stdio-1.0 50 | hs-source-dirs: test 51 | main-is: Integrated.hs 52 | build-depends: base >= 4.6 53 | , base-compat 54 | , containers 55 | , filepath 56 | , ivory 57 | , ivory-artifact 58 | , ivory-backend-c 59 | , tower 60 | , tower-config 61 | , tower-mini 62 | default-language: Haskell2010 63 | ghc-options: -Wall 64 | -------------------------------------------------------------------------------- /tower/.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | -------------------------------------------------------------------------------- /tower/Makefile: -------------------------------------------------------------------------------- 1 | include ../stack.mk 2 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower.hs: -------------------------------------------------------------------------------- 1 | module Ivory.Tower 2 | ( module Ivory.Tower.Tower 3 | , module Ivory.Tower.Monitor 4 | , module Ivory.Tower.Handler 5 | , module Ivory.Tower.Coroutine 6 | ) where 7 | 8 | import Ivory.Tower.Tower 9 | import Ivory.Tower.Monitor 10 | import Ivory.Tower.Handler 11 | import Ivory.Tower.Coroutine 12 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/AST.hs: -------------------------------------------------------------------------------- 1 | 2 | module Ivory.Tower.AST 3 | ( module Ivory.Tower.AST.Init 4 | , module Ivory.Tower.AST.Chan 5 | , module Ivory.Tower.AST.SyncChan 6 | , module Ivory.Tower.AST.Signal 7 | , module Ivory.Tower.AST.Period 8 | , module Ivory.Tower.AST.Tower 9 | , module Ivory.Tower.AST.Monitor 10 | , module Ivory.Tower.AST.Handler 11 | , module Ivory.Tower.AST.Emitter 12 | , module Ivory.Tower.AST.Thread 13 | , module Ivory.Tower.AST.Graph 14 | , module Ivory.Tower.AST.Comment 15 | ) where 16 | 17 | import Ivory.Tower.AST.Init 18 | import Ivory.Tower.AST.Chan 19 | import Ivory.Tower.AST.SyncChan 20 | import Ivory.Tower.AST.Signal 21 | import Ivory.Tower.AST.Period 22 | import Ivory.Tower.AST.Tower 23 | import Ivory.Tower.AST.Monitor 24 | import Ivory.Tower.AST.Handler 25 | import Ivory.Tower.AST.Emitter 26 | import Ivory.Tower.AST.Thread 27 | import Ivory.Tower.AST.Graph 28 | import Ivory.Tower.AST.Comment 29 | 30 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/AST/Chan.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Ivory.Tower.AST.Chan 4 | ( Chan(..) 5 | ) where 6 | 7 | #if MIN_VERSION_mainland_pretty(0,6,0) 8 | import Text.PrettyPrint.Mainland.Class 9 | #endif 10 | import Text.PrettyPrint.Mainland 11 | 12 | import Ivory.Tower.AST.SyncChan 13 | import Ivory.Tower.AST.Signal 14 | import Ivory.Tower.AST.Period 15 | import Ivory.Tower.AST.Init 16 | 17 | data Chan 18 | = ChanSync SyncChan 19 | | ChanSignal Signal 20 | | ChanPeriod Period 21 | | ChanInit Init 22 | deriving (Eq, Show, Ord) 23 | 24 | instance Pretty Chan where 25 | ppr (ChanSync c) = "Sync:" <+> ppr c 26 | ppr (ChanSignal s) = "Signal:" <+> ppr s 27 | ppr (ChanPeriod p) = "Period:" <+> ppr p 28 | ppr (ChanInit _i) = "Init" 29 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/AST/Comment.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | -- 4 | -- User and source location comments. 5 | -- 6 | -- (c) 2014 Galois, Inc. 7 | -- 8 | 9 | module Ivory.Tower.AST.Comment where 10 | 11 | #if MIN_VERSION_mainland_pretty(0,6,0) 12 | import Text.PrettyPrint.Mainland.Class 13 | #endif 14 | import Text.PrettyPrint.Mainland 15 | 16 | import Ivory.Tower.SrcLoc.Location 17 | 18 | -------------------------------------------------------------------------------- 19 | 20 | data Comment = UserComment String 21 | | SourcePos SrcLoc 22 | deriving (Show, Eq, Ord) 23 | 24 | ppSrcLoc :: SrcLoc -> Doc 25 | ppSrcLoc s = case s of 26 | NoLoc 27 | -> text "No source location" 28 | SrcLoc rng msrc 29 | -> case msrc of 30 | Nothing -> ppRng rng 31 | Just src -> text src <> colon <> ppRng rng 32 | 33 | -- Ignore the column. 34 | ppRng :: Range -> Doc 35 | ppRng (Range (Position _ ln0 _) (Position _ ln1 _)) = 36 | if ln0 == ln1 37 | then text (show ln0) 38 | else text (show ln0) <+> char '-' <+> text (show ln1) 39 | 40 | instance Pretty Comment where 41 | ppr (UserComment s) = enclose "/*" "*/" (text s) 42 | ppr (SourcePos sl) = ppSrcLoc sl 43 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/AST/Emitter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | module Ivory.Tower.AST.Emitter where 5 | 6 | #if MIN_VERSION_mainland_pretty(0,6,0) 7 | import Text.PrettyPrint.Mainland.Class 8 | #endif 9 | import Text.PrettyPrint.Mainland 10 | 11 | import Ivory.Tower.AST.SyncChan 12 | import Ivory.Tower.Types.Unique 13 | 14 | data Emitter = Emitter 15 | { emitter_name :: Unique 16 | , emitter_chan :: SyncChan 17 | , emitter_bound :: Integer 18 | } deriving (Eq, Show, Ord) 19 | 20 | emitterName :: Emitter -> String 21 | emitterName = showUnique . emitter_name 22 | 23 | emitter :: Unique -> SyncChan -> Integer -> Emitter 24 | emitter i c b = Emitter 25 | { emitter_name = i 26 | , emitter_chan = c 27 | , emitter_bound = b 28 | } 29 | 30 | instance Pretty Emitter where 31 | ppr e@Emitter{..} = 32 | text (emitterName e) 33 | <+> parens ("bound=" <> integer emitter_bound) <> colon 34 | <+> ppr emitter_chan 35 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/AST/Graph.hs: -------------------------------------------------------------------------------- 1 | 2 | module Ivory.Tower.AST.Graph where 3 | 4 | import Data.Graph 5 | import Data.List (groupBy, nub) 6 | import Control.Monad (guard) 7 | import Ivory.Tower.AST.Thread 8 | import Ivory.Tower.AST.Handler 9 | import Ivory.Tower.AST.Monitor 10 | import Ivory.Tower.AST.Tower 11 | import Ivory.Tower.AST.Chan 12 | import Ivory.Tower.AST.Emitter 13 | 14 | import Ivory.Tower.Types.Unique 15 | 16 | import Text.PrettyPrint.Mainland 17 | 18 | data MessageSource = ThreadMessage Thread 19 | | HandlerMessage Monitor Handler 20 | deriving (Eq, Show, Ord) 21 | 22 | handlerMessageSource :: (Monitor, Handler) -> MessageSource 23 | handlerMessageSource = uncurry HandlerMessage 24 | 25 | type MessageVertex = (MessageSource, MessageSource, [MessageSource]) 26 | type MessageGraph = (Graph, Vertex -> MessageVertex, MessageSource -> Maybe Vertex) 27 | 28 | messageGraph :: Tower -> MessageGraph 29 | messageGraph t = graphFromEdges (handleredges ++ threadedges) 30 | where 31 | threadedges = do 32 | th <- towerThreads t 33 | let ms = ThreadMessage th 34 | ch = threadChan th 35 | return (ms, ms, map handlerMessageSource (towerChanHandlers t ch)) 36 | handleredges = do 37 | m <- tower_monitors t 38 | h <- monitor_handlers m 39 | let ms = HandlerMessage m h 40 | return (ms, ms, map handlerMessageSource (handlerOutboundHandlers t h)) 41 | 42 | handlerThreads :: Tower -> Handler -> [Thread] 43 | handlerThreads t h = do 44 | th <- towerThreads t 45 | guard $ h `elem` map snd (threadHandlers (messageGraph t) th) 46 | return th 47 | 48 | threadHandlers :: MessageGraph -> Thread -> [(Monitor, Handler)] 49 | threadHandlers (g, unv, tov) t 50 | = map mh 51 | $ filter (/= (ThreadMessage t)) 52 | $ map (fst3 . unv) 53 | $ nub 54 | $ reachable g threadv 55 | where 56 | fst3 (a,_,_) = a 57 | Just threadv = tov (ThreadMessage t) 58 | mh (HandlerMessage m h) = (m,h) 59 | mh _ = error "Ivory.Tower.AST.Graph.threadHandlers impossible" 60 | -- invariant - ThreadMessage never reachable from ThreadMessage 61 | -- (except itself is always "reachable" so we filter that out above.) 62 | 63 | graphviz :: MessageGraph -> String 64 | graphviz (g, unvertex, _) = pretty 80 $ stack $ 65 | [ text "digraph Tower {" 66 | , indent 4 $ stack $ map ppSubgraph monitors 67 | , empty 68 | , indent 4 (stack (map ppEdge (edges g))) 69 | , text "}" 70 | ] 71 | where 72 | eqmonitor ((ThreadMessage t1),_,_) ((ThreadMessage t2),_,_) = t1 == t2 73 | eqmonitor ((HandlerMessage m1 _),_,_) ((HandlerMessage m2 _),_,_) = m1 == m2 74 | eqmonitor _ _ = False 75 | monitors = groupBy eqmonitor (map unvertex (vertices g)) 76 | ppSubgraph ms@(((HandlerMessage m _),_,_):_) = stack 77 | [ text "subgraph " <+> text "cluster_" <> mname <+> text "{" 78 | , indent 4 $ text "color = blue" <> semi 79 | , indent 4 $ text "node [style=filled]" <> semi 80 | , indent 4 $ stack $ map (\h -> ppHandlerNode h <> semi) ms 81 | , indent 4 $ text "label =" <+> dquotes (text "monitor" <+> mname) <> semi 82 | , text "}" 83 | ] 84 | where mname = text (showUnique (monitor_name m)) 85 | ppSubgraph ([((ThreadMessage t),_,_)]) = 86 | tname <+> text "[style=filled]" <> semi 87 | where tname = text (threadName t) 88 | 89 | ppSubgraph _ = empty -- should be impossible. 90 | ppHandlerNode ((HandlerMessage _ h),_,_) = text (showUnique (handler_name h)) 91 | ppHandlerNode ((ThreadMessage t),_,_) = text (threadName t) 92 | ppEdge :: Edge -> Doc 93 | ppEdge (v1,v2) = ppHandlerNode (unvertex v1) 94 | <+> text "->" 95 | <+> ppHandlerNode (unvertex v2) <> semi 96 | 97 | -- For a given channel c, the list of all handlers (and their monitors) that 98 | -- handle c. 99 | towerChanHandlers :: Tower -> Chan -> [(Monitor, Handler)] 100 | towerChanHandlers t c = do 101 | m <- tower_monitors t 102 | h <- monitorChanHandlers m c 103 | return (m, h) 104 | 105 | -- For a given monitor and channel c, the list of handlers in the monitor that 106 | -- handle c. 107 | monitorChanHandlers :: Monitor -> Chan -> [Handler] 108 | monitorChanHandlers m c = filter p (monitor_handlers m) 109 | where p h = handler_chan h == c 110 | 111 | -- For a given handler, the list of all channels it emits on. 112 | handlerOutboundChans :: Handler -> [Chan] 113 | handlerOutboundChans h = map (ChanSync . emitter_chan) (handler_emitters h) 114 | 115 | -- For a given handler h, a list of all handlers (and their monitors) that handle messages emited by h. 116 | handlerOutboundHandlers :: Tower -> Handler -> [(Monitor, Handler)] 117 | handlerOutboundHandlers t h = do 118 | c <- handlerOutboundChans h 119 | towerChanHandlers t c 120 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/AST/Handler.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | module Ivory.Tower.AST.Handler 5 | ( Handler(..) 6 | , handlerName 7 | ) where 8 | 9 | #if MIN_VERSION_mainland_pretty(0,6,0) 10 | import Text.PrettyPrint.Mainland.Class 11 | #endif 12 | import Text.PrettyPrint.Mainland 13 | 14 | import Ivory.Tower.Types.Unique 15 | 16 | import Ivory.Tower.AST.Chan 17 | import Ivory.Tower.AST.Emitter 18 | import Ivory.Tower.AST.Comment 19 | 20 | data Handler = Handler 21 | { handler_name :: Unique 22 | , handler_chan :: Chan 23 | , handler_emitters :: [Emitter] 24 | , handler_callbacks :: [Unique] 25 | , handler_comments :: [Comment] 26 | } deriving (Eq, Show, Ord) 27 | 28 | handlerName :: Handler -> String 29 | handlerName = showUnique . handler_name 30 | 31 | instance Pretty Handler where 32 | ppr h@(Handler{..}) = hang 2 $ 33 | text (handlerName h) <> colon 34 | "Chan:" <+/> ppr handler_chan 35 | "Emitters:" <+/> pprList handler_emitters 36 | "Callbacks:" <+/> pprList (map showUnique handler_callbacks) 37 | "Comments:" <+/> pprList handler_comments 38 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/AST/Init.hs: -------------------------------------------------------------------------------- 1 | 2 | module Ivory.Tower.AST.Init where 3 | 4 | data Init = Init 5 | deriving (Eq, Show, Ord) 6 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/AST/Monitor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | module Ivory.Tower.AST.Monitor where 5 | 6 | #if MIN_VERSION_mainland_pretty(0,6,0) 7 | import Text.PrettyPrint.Mainland.Class 8 | #endif 9 | import Text.PrettyPrint.Mainland 10 | 11 | import Ivory.Tower.Types.Unique 12 | import Ivory.Tower.AST.Handler 13 | 14 | data Monitor = Monitor 15 | { monitor_name :: Unique 16 | , monitor_handlers :: [Handler] 17 | , monitor_external :: MonitorExternal 18 | } deriving (Eq, Show, Ord) 19 | 20 | monitorName :: Monitor -> String 21 | monitorName = showUnique . monitor_name 22 | 23 | data MonitorExternal = 24 | MonitorDefined 25 | | MonitorExternal 26 | deriving (Show, Read, Eq, Ord) 27 | 28 | instance Pretty Monitor where 29 | ppr m@(Monitor{..}) = hang 2 $ 30 | text (monitorName m) <+> parens (ppr monitor_external) <> colon 31 | hang 2 ("Handlers:" stack (map ppr monitor_handlers)) 32 | 33 | instance Pretty MonitorExternal where 34 | ppr MonitorDefined = "defined" 35 | ppr MonitorExternal = "external" 36 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/AST/Period.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Ivory.Tower.AST.Period where 4 | 5 | #if MIN_VERSION_mainland_pretty(0,6,0) 6 | import Text.PrettyPrint.Mainland.Class 7 | #endif 8 | import Text.PrettyPrint.Mainland 9 | 10 | import qualified Ivory.Language.Syntax.Type as I 11 | 12 | import Ivory.Tower.Types.Time 13 | 14 | data Period = Period 15 | { period_dt :: Microseconds 16 | , period_ty :: I.Type 17 | , period_phase :: Microseconds 18 | } deriving (Eq, Show, Ord) 19 | 20 | instance Pretty Period where 21 | ppr p = text (prettyTime (period_dt p)) 22 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/AST/Signal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | module Ivory.Tower.AST.Signal where 5 | 6 | #if MIN_VERSION_mainland_pretty(0,6,0) 7 | import Text.PrettyPrint.Mainland.Class 8 | #endif 9 | import Text.PrettyPrint.Mainland 10 | 11 | import Ivory.Tower.Types.Time 12 | 13 | data Signal = Signal 14 | -- Note: The Ord instance must sort first by deadline, 15 | -- otherwise interrupt handlers will not process 16 | -- interrupts in the correct order. 17 | { signal_deadline :: Microseconds 18 | , signal_name :: String 19 | , signal_number :: Int 20 | } deriving (Eq, Show, Ord) 21 | 22 | instance Pretty Signal where 23 | ppr Signal{..} = text signal_name <> colon 24 | <+/> "deadline=" <> ppr signal_deadline 25 | <+/> "number=" <> ppr signal_number 26 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/AST/SyncChan.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | module Ivory.Tower.AST.SyncChan where 5 | 6 | #if MIN_VERSION_mainland_pretty(0,6,0) 7 | import Text.PrettyPrint.Mainland.Class 8 | #endif 9 | import Text.PrettyPrint.Mainland 10 | 11 | import qualified Ivory.Language.Syntax.Type as I 12 | 13 | data SyncChan = SyncChan 14 | { sync_chan_label :: Integer 15 | , sync_chan_type :: I.Type 16 | } deriving (Eq, Show, Ord) 17 | 18 | instance Pretty SyncChan where 19 | ppr SyncChan{..} = 20 | integer sync_chan_label <+> "::" <+> text (show sync_chan_type) 21 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/AST/Thread.hs: -------------------------------------------------------------------------------- 1 | module Ivory.Tower.AST.Thread 2 | ( Thread(..) 3 | , threadName 4 | , threadUserCodeModName 5 | , threadGenCodeModName 6 | , threadLoopProcName 7 | , threadChan 8 | ) where 9 | 10 | import Ivory.Tower.Types.Time 11 | import Ivory.Tower.AST.Period 12 | import Ivory.Tower.AST.Signal 13 | import Ivory.Tower.AST.Chan 14 | import Ivory.Tower.AST.Init 15 | 16 | data Thread = SignalThread Signal 17 | | PeriodThread Period 18 | | InitThread Init 19 | deriving (Eq, Show) 20 | 21 | threadName :: Thread -> String 22 | threadName (SignalThread s) = "thread_signal_" ++ signal_name s 23 | threadName (InitThread _) = "thread_init" 24 | threadName (PeriodThread p) = 25 | "thread_period_" 26 | ++ prettyTime (period_dt p) 27 | ++ if toMicroseconds ph == 0 28 | then "" 29 | else "_phase_" ++ prettyTime ph 30 | where 31 | ph = period_phase p 32 | 33 | threadUserCodeModName :: Thread -> String 34 | threadUserCodeModName t = "tower_user_" ++ threadName t 35 | 36 | threadGenCodeModName :: Thread -> String 37 | threadGenCodeModName t = "tower_gen_" ++ threadName t 38 | 39 | threadLoopProcName :: Thread -> String 40 | threadLoopProcName t = "loop_" ++ threadName t 41 | 42 | threadChan :: Thread -> Chan 43 | threadChan (PeriodThread p) = ChanPeriod p 44 | threadChan (SignalThread s) = ChanSignal s 45 | threadChan (InitThread i) = ChanInit i 46 | 47 | instance Ord Thread where 48 | 49 | -- Init threads are greater than all other threads. 50 | compare (InitThread i1) (InitThread i2) 51 | = i1 `compare` i2 52 | compare (InitThread{}) _ 53 | = GT 54 | compare _ (InitThread{}) 55 | = LT 56 | 57 | compare (PeriodThread p0) (PeriodThread p1) 58 | = compare (period_dt p0) (period_dt p1) 59 | -- Lexigraphical ordering on tie 60 | compare (SignalThread s0) (SignalThread s1) 61 | = let d0 = signal_deadline s0 in 62 | let d1 = signal_deadline s1 in 63 | if d0 == d1 64 | then compare (signal_name s0) (signal_name s1) 65 | else compare d0 d1 66 | 67 | compare (SignalThread s) (PeriodThread p) 68 | = breakTie (<=) (signal_deadline s) (period_dt p) 69 | compare (PeriodThread p) (SignalThread s) 70 | = breakTie (<) (period_dt p) (signal_deadline s) 71 | 72 | breakTie :: (a -> a -> Bool) 73 | -> a -> a -> Ordering 74 | breakTie op a b 75 | | a `op` b = LT 76 | | otherwise = GT 77 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/AST/Tower.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Ivory.Tower.AST.Tower 4 | ( Tower(..) 5 | , towerThreads 6 | , towerFindMonitorByName 7 | ) where 8 | 9 | import Prelude () 10 | import Prelude.Compat 11 | 12 | import Data.List (find, union) 13 | #if MIN_VERSION_mainland_pretty(0,6,0) 14 | import Text.PrettyPrint.Mainland.Class 15 | #endif 16 | import Text.PrettyPrint.Mainland 17 | 18 | import Ivory.Tower.Types.Unique 19 | import Ivory.Tower.AST.SyncChan 20 | import Ivory.Tower.AST.Signal 21 | import Ivory.Tower.AST.Period 22 | import Ivory.Tower.AST.Monitor 23 | import Ivory.Tower.AST.Thread 24 | import Ivory.Tower.AST.Init 25 | 26 | data Tower = Tower 27 | { tower_monitors :: [Monitor] 28 | , tower_syncchans :: [SyncChan] 29 | , tower_signals :: [Signal] 30 | , tower_periods :: [Period] 31 | } deriving (Eq, Show) 32 | 33 | instance Monoid Tower where 34 | mempty = Tower 35 | { tower_monitors = [] 36 | , tower_syncchans = [] 37 | , tower_signals = [] 38 | , tower_periods = [] 39 | } 40 | mappend a b = Tower 41 | { tower_monitors = tower_monitors a `mappend` tower_monitors b 42 | , tower_syncchans = tower_syncchans a `mappend` tower_syncchans b 43 | , tower_signals = tower_signals a `mappend` tower_signals b 44 | -- Periods are a set 45 | , tower_periods = tower_periods a `union` tower_periods b 46 | } 47 | 48 | towerThreads :: Tower -> [Thread] 49 | towerThreads t = map SignalThread (tower_signals t) ++ 50 | map PeriodThread (tower_periods t) ++ 51 | [ InitThread Init ] 52 | 53 | towerFindMonitorByName :: Unique -> Tower -> Maybe Monitor 54 | towerFindMonitorByName n t = find p (tower_monitors t) 55 | where p m = monitor_name m == n 56 | 57 | instance Pretty Tower where 58 | ppr t = hang 2 $ "Tower program:" 59 | hang 2 ("Monitors:" stack (map ppr (tower_monitors t))) 60 | hang 2 ("SyncChans:" <+/> pprList (tower_syncchans t)) 61 | hang 2 ("Signals:" <+/> pprList (tower_signals t)) 62 | hang 2 ("Periods:" <+/> pprList (tower_periods t)) 63 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/Backend.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | 6 | module Ivory.Tower.Backend where 7 | 8 | import Ivory.Language 9 | import qualified Ivory.Tower.AST as AST 10 | import Ivory.Tower.Types.Emitter 11 | import Ivory.Tower.Types.Unique 12 | 13 | data SomeHandler backend = forall a. SomeHandler (TowerBackendHandler backend a) 14 | 15 | class TowerBackend backend where 16 | -- XXX should probably be type families, not data families, and maybe at the 17 | -- top-level (without relying on the class). 18 | 19 | -- Type correponds to the channel type 20 | data TowerBackendCallback backend :: Area * -> * 21 | data TowerBackendEmitter backend :: * 22 | -- Type correponds to the channel type 23 | data TowerBackendHandler backend :: Area * -> * 24 | data TowerBackendMonitor backend :: * 25 | data TowerBackendOutput backend :: * 26 | 27 | callbackImpl :: IvoryArea a 28 | => backend 29 | -- Callback identifier, used to construct full callback name 30 | -> Unique 31 | -- Implementation 32 | -> (forall s s'. ConstRef s' a -> Ivory (AllocEffects s) ()) 33 | -> TowerBackendCallback backend a 34 | emitterImpl :: (IvoryArea b, IvoryZero b) 35 | => backend 36 | -> AST.Emitter 37 | -> [TowerBackendHandler backend b] 38 | -> (Emitter b, TowerBackendEmitter backend) 39 | handlerImpl :: (IvoryArea a, IvoryZero a) 40 | => backend 41 | -> AST.Handler 42 | -> [TowerBackendEmitter backend] 43 | -> [TowerBackendCallback backend a] 44 | -> TowerBackendHandler backend a 45 | monitorImpl :: backend 46 | -> AST.Monitor 47 | -> [SomeHandler backend] 48 | -- Contains the state variable declarations for the monitor 49 | -> ModuleDef 50 | -> TowerBackendMonitor backend 51 | towerImpl :: backend 52 | -> AST.Tower 53 | -> [TowerBackendMonitor backend] 54 | -> TowerBackendOutput backend 55 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/Coroutine.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | 3 | module Ivory.Tower.Coroutine where 4 | 5 | import Prelude () 6 | import Prelude.Compat 7 | 8 | import Ivory.Language 9 | import Ivory.Tower.Handler 10 | import Ivory.Tower.Monad.Handler 11 | import Ivory.Tower.Monad.Monitor 12 | import Ivory.Tower.Monitor 13 | import Ivory.Tower.Tower 14 | 15 | 16 | -- | Lifts an Ivory coroutine into a set of Tower handlers. Takes the sink of 17 | -- two channels: (1) whether the coroutine should be initialized @chanInit@, and 18 | -- a (2) value to process over the @chan@ channel. The value of @chanInit@ is 19 | -- ignored; whenever a message is received over the channel, the coroutine is 20 | -- reinitialized. Otherwise, values from the @chan@ channel are passed to the 21 | -- coroutine. Example usage: 22 | -- 23 | -- @ 24 | -- coroutineHandler initChan resChan "foo" $ do 25 | -- e <- emitter chan 1 26 | -- return $ CoroutineBody $ \yield -> do 27 | -- ... Ivory code ... 28 | -- @ 29 | coroutineHandler :: (IvoryArea init, IvoryZero init, IvoryArea a, IvoryZero a) 30 | => ChanOutput init 31 | -> ChanOutput a 32 | -> String 33 | -> (forall evt. Handler evt e (CoroutineBody a)) 34 | -> Monitor e () 35 | coroutineHandler chanInit chan name block = do 36 | (doInitChan, readyChan) <- liftTower channel 37 | lastValue <- state "last_value" 38 | 39 | handler readyChan name $ do 40 | coro <- coroutine <$> fmap showUnique handlerName <*> block 41 | liftMonitor $ monitorModuleDef $ coroutineDef coro 42 | callbackV $ \ shouldInit -> coroutineRun coro shouldInit $ constRef lastValue 43 | 44 | handler chanInit (name ++ "_init") $ do 45 | doInit <- emitter doInitChan 1 46 | callback $ const $ emitV doInit true 47 | 48 | handler chan (name ++ "_raw") $ do 49 | doInit <- emitter doInitChan 1 50 | callback $ \ ref -> do 51 | refCopy lastValue ref 52 | emitV doInit false 53 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/Handler.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | 7 | module Ivory.Tower.Handler 8 | ( emitter 9 | , Emitter() 10 | , callback 11 | , callbackV 12 | , emit 13 | , emitV 14 | , Handler() 15 | ) where 16 | 17 | import Ivory.Tower.Backend 18 | import Ivory.Tower.Types.Emitter 19 | import Ivory.Tower.Types.Chan 20 | import Ivory.Tower.Types.Unique 21 | import Ivory.Tower.Monad.Handler 22 | import Ivory.Tower.Monad.Base 23 | 24 | import qualified Ivory.Tower.AST as AST 25 | 26 | import Ivory.Language 27 | 28 | emitter :: (IvoryArea a, IvoryZero a) 29 | => ChanInput a -> Integer -> Handler b e (Emitter a) 30 | emitter (ChanInput chan@(Chan chanast)) bound = handlerName >>= \ nm -> Handler $ do 31 | -- the only things that produce ChanInput will only put ChanSync in it. 32 | let AST.ChanSync syncchan = chanast 33 | n <- freshname $ "emitter_" ++ showUnique nm ++ "_chan_" ++ show (AST.sync_chan_label syncchan) 34 | let ast = AST.emitter n syncchan bound 35 | handlerPutASTEmitter ast 36 | backend <- handlerGetBackend 37 | handlers <- handlerGetHandlers chan 38 | let (e, code) = emitterImpl backend ast handlers 39 | handlerPutCodeEmitter code 40 | return e 41 | 42 | callback :: (IvoryArea a, IvoryZero a) 43 | => (forall s s' . ConstRef s a -> Ivory (AllocEffects s') ()) 44 | -> Handler a e () 45 | callback b = handlerName >>= \ nm -> Handler $ do 46 | u <- freshname $ "callback_" ++ showUnique nm 47 | handlerPutASTCallback u 48 | backend <- handlerGetBackend 49 | handlerPutCodeCallback $ callbackImpl backend u b 50 | 51 | callbackV :: (IvoryArea ('Stored a), IvoryStore a, IvoryZeroVal a) 52 | => (forall s' . a -> Ivory (AllocEffects s') ()) 53 | -> Handler ('Stored a) e () 54 | callbackV b = callback (\bref -> deref bref >>= b) 55 | 56 | emitV :: (IvoryArea ('Stored a), IvoryInit a, IvoryZeroVal a, GetAlloc eff ~ 'Scope s) 57 | => Emitter ('Stored a) -> a -> Ivory eff () 58 | emitV e v = do 59 | l <- local (ival v) 60 | emit e (constRef l) 61 | 62 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/Monad/Base.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | 7 | module Ivory.Tower.Monad.Base 8 | ( Base 9 | , BaseUtils(..) 10 | , runBase 11 | ) where 12 | 13 | import Prelude () 14 | import Prelude.Compat 15 | 16 | import Control.Arrow (first) 17 | import Control.Monad.Fix 18 | import qualified Data.Map as Map 19 | import Ivory.Tower.Types.Unique 20 | import MonadLib 21 | 22 | newtype Base env a = Base 23 | { unBase :: StateT (Map.Map String Integer) (ReaderT env Id) a 24 | } deriving (Functor, Monad, Applicative, MonadFix) 25 | 26 | runBase :: env -> Base env a -> a 27 | runBase env b = runId 28 | $ runReaderT env 29 | $ fmap fst 30 | $ runStateT Map.empty 31 | $ unBase b 32 | 33 | class (Monad (m e), Functor (m e)) => BaseUtils m e where 34 | freshname :: String -> m e Unique 35 | getEnv :: m e e 36 | 37 | instance BaseUtils Base env where 38 | freshname n = Base $ sets $ 39 | first (Unique n . maybe 1 (+ 1)) . Map.insertLookupWithKey (const (+)) n 1 40 | getEnv = Base $ lift $ ask 41 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/Monad/Handler.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | 9 | module Ivory.Tower.Monad.Handler 10 | ( Handler(..) 11 | , Handler' 12 | , handler 13 | , handlerName 14 | , handlerGetBackend 15 | , handlerGetHandlers 16 | , handlerPutASTEmitter 17 | , handlerPutASTCallback 18 | , handlerPutCodeEmitter 19 | , handlerPutCodeCallback 20 | , liftMonitor -- XXX UNSAFE TO USE 21 | -- Source Location 22 | , mkLocation 23 | , setLocation 24 | , withLocation 25 | ) where 26 | 27 | import Prelude () 28 | import Prelude.Compat 29 | 30 | import MonadLib 31 | import Control.Monad.Fix 32 | import Ivory.Tower.Backend 33 | import Ivory.Tower.Types.Chan 34 | import Ivory.Tower.Types.Unique 35 | import Ivory.Tower.Monad.Base 36 | import Ivory.Tower.Monad.Monitor 37 | import qualified Ivory.Tower.AST as AST 38 | 39 | import Ivory.Tower.SrcLoc.Location (SrcLoc(..), Position(..), Range(..)) 40 | 41 | import Ivory.Language 42 | 43 | data PartialHandler = PartialHandler 44 | { partialEmitters :: [AST.Emitter] 45 | , partialCallbacks :: [Unique] 46 | , partialComments :: [AST.Comment] 47 | } 48 | 49 | instance Monoid PartialHandler where 50 | mempty = PartialHandler mempty mempty mempty 51 | mappend a b = PartialHandler 52 | { partialEmitters = partialEmitters a `mappend` partialEmitters b 53 | , partialCallbacks = partialCallbacks a `mappend` partialCallbacks b 54 | , partialComments = partialComments a `mappend` partialComments b 55 | } 56 | 57 | newtype Handler area e a = Handler 58 | { unHandler :: forall backend. TowerBackend backend => Handler' backend area e a 59 | } 60 | -- GHC can't derive these trivial instances because of the RankNType. 61 | 62 | instance Functor (Handler area e) where 63 | fmap f (Handler h) = Handler $ fmap f h 64 | 65 | instance Monad (Handler area e) where 66 | return x = Handler $ return x 67 | Handler x >>= f = Handler $ x >>= (unHandler . f) 68 | 69 | instance Applicative (Handler area e) where 70 | pure = return 71 | (<*>) = ap 72 | 73 | instance MonadFix (Handler area e) where 74 | mfix f = Handler $ mfix (unHandler . f) 75 | 76 | newtype Handler' backend (area :: Area *) e a = Handler' 77 | { unHandler' :: ReaderT Unique 78 | (WriterT (PartialHandler, [TowerBackendEmitter backend], [TowerBackendCallback backend area]) 79 | (Monitor' backend e)) a 80 | } deriving (Functor, Monad, Applicative, MonadFix) 81 | 82 | handler :: (IvoryArea a, IvoryZero a) 83 | => ChanOutput a -> String -> Handler a e () -> Monitor e () 84 | handler (ChanOutput chan@(Chan chanast)) n b = Monitor $ do 85 | u <- freshname n 86 | (r, (part, emitters, callbacks)) <- runWriterT $ runReaderT u $ unHandler' $ unHandler b 87 | 88 | let handlerast = AST.Handler u chanast 89 | (partialEmitters part) (partialCallbacks part) (partialComments part) 90 | 91 | backend <- monitorGetBackend 92 | monitorPutHandler handlerast chan $ handlerImpl backend handlerast emitters callbacks 93 | 94 | return r 95 | 96 | handlerName :: Handler a e Unique 97 | handlerName = Handler $ Handler' ask 98 | 99 | handlerGetBackend :: Handler' backend a e backend 100 | handlerGetBackend = Handler' $ lift $ lift monitorGetBackend 101 | 102 | handlerGetHandlers :: Chan b -> Handler' backend a e [TowerBackendHandler backend b] 103 | handlerGetHandlers chan = Handler' $ lift $ lift $ monitorGetHandlers chan 104 | 105 | handlerPutAST :: PartialHandler -> Handler' backend a e () 106 | handlerPutAST part = Handler' $ put (part, mempty, mempty) 107 | 108 | handlerPutASTEmitter :: AST.Emitter -> Handler' backend a e () 109 | handlerPutASTEmitter a = handlerPutAST $ mempty { partialEmitters = [a] } 110 | 111 | handlerPutASTCallback :: Unique -> Handler' backend a e () 112 | handlerPutASTCallback a = handlerPutAST $ mempty { partialCallbacks = [a] } 113 | 114 | handlerPutCodeCallback :: TowerBackendCallback backend a 115 | -> Handler' backend a e () 116 | handlerPutCodeCallback ms = Handler' $ put (mempty, mempty, [ms]) 117 | 118 | handlerPutCodeEmitter :: TowerBackendEmitter backend 119 | -> Handler' backend a e () 120 | handlerPutCodeEmitter ms = Handler' $ put (mempty, [ms], mempty) 121 | 122 | instance BaseUtils (Handler' backend a) p where 123 | freshname n = Handler' $ lift $ lift $ freshname n 124 | getEnv = Handler' $ lift $ lift getEnv 125 | 126 | instance BaseUtils (Handler a) p where 127 | freshname n = Handler $ freshname n 128 | getEnv = Handler getEnv 129 | 130 | liftMonitor :: Monitor e r -> Handler a e r 131 | liftMonitor a = Handler $ Handler' $ lift $ lift $ unMonitor a 132 | 133 | -------------------------------------------------------------------------------- 134 | -- SrcLoc stuff 135 | 136 | mkLocation :: FilePath -> Int -> Int -> Int -> Int -> SrcLoc 137 | mkLocation file l1 c1 l2 c2 138 | = SrcLoc (Range (Position 0 l1 c1) (Position 0 l2 c2)) (Just file) 139 | 140 | setLocation :: SrcLoc -> Handler a e () 141 | setLocation l = Handler $ handlerPutAST $ mempty { partialComments = [AST.SourcePos l] } 142 | 143 | withLocation :: SrcLoc -> Handler area e a -> Handler area e a 144 | withLocation src h = setLocation src >> h 145 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/Monad/Monitor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | 7 | module Ivory.Tower.Monad.Monitor 8 | ( Monitor(..) 9 | , Monitor' 10 | , monitor 11 | , externalMonitor 12 | , monitorGetBackend 13 | , monitorGetHandlers 14 | , monitorPutHandler 15 | , monitorModuleDef 16 | , liftTower -- XXX UNSAFE TO USE 17 | ) where 18 | 19 | import Prelude () 20 | import Prelude.Compat 21 | 22 | import MonadLib 23 | import Control.Monad.Fix 24 | import Ivory.Tower.Backend 25 | import Ivory.Tower.Monad.Base 26 | import Ivory.Tower.Monad.Tower 27 | import qualified Ivory.Tower.AST as AST 28 | import Ivory.Tower.Types.Chan 29 | 30 | import Ivory.Language 31 | 32 | newtype Monitor e a = Monitor 33 | { unMonitor :: forall backend. TowerBackend backend => Monitor' backend e a 34 | } 35 | -- GHC can't derive these trivial instances because of the RankNType. 36 | 37 | instance Functor (Monitor e) where 38 | fmap f (Monitor h) = Monitor $ fmap f h 39 | 40 | instance Monad (Monitor e) where 41 | return x = Monitor $ return x 42 | Monitor x >>= f = Monitor $ x >>= (unMonitor . f) 43 | 44 | instance Applicative (Monitor e) where 45 | pure = return 46 | (<*>) = ap 47 | 48 | instance MonadFix (Monitor e) where 49 | mfix f = Monitor $ mfix (unMonitor . f) 50 | 51 | newtype Monitor' backend e a = Monitor' 52 | { unMonitor' :: WriterT ([AST.Handler], [SomeHandler backend], ModuleDef) (Tower' backend e) a 53 | } deriving (Functor, Monad, Applicative, MonadFix) 54 | 55 | monitor' :: AST.MonitorExternal -> String -> Monitor e () -> Tower e () 56 | monitor' t n b = Tower $ do 57 | u <- freshname n 58 | ((), (hast, handlers, moddef)) <- runWriterT $ unMonitor' $ unMonitor b 59 | let ast = AST.Monitor u hast t 60 | backend <- towerGetBackend 61 | towerPutMonitor ast $ monitorImpl backend ast handlers moddef 62 | 63 | monitor :: String -> Monitor e () -> Tower e () 64 | monitor = monitor' AST.MonitorDefined 65 | 66 | externalMonitor :: String -> Monitor e () -> Tower e () 67 | externalMonitor = monitor' AST.MonitorExternal 68 | 69 | monitorGetBackend :: Monitor' backend e backend 70 | monitorGetBackend = Monitor' $ lift towerGetBackend 71 | 72 | monitorGetHandlers :: Chan b -> Monitor' backend e [TowerBackendHandler backend b] 73 | monitorGetHandlers chan = Monitor' $ lift $ towerGetHandlers chan 74 | 75 | monitorPutHandler :: AST.Handler -> Chan a -> TowerBackendHandler backend a -> Monitor' backend e () 76 | monitorPutHandler ast chan h = Monitor' $ do 77 | put ([ast], [SomeHandler h], mempty) 78 | lift $ towerPutHandler chan h 79 | 80 | liftTower :: Tower e a -> Monitor e a 81 | liftTower a = Monitor $ Monitor' $ lift $ unTower a 82 | 83 | monitorModuleDef :: ModuleDef -> Monitor e () 84 | monitorModuleDef m = Monitor $ Monitor' $ put (mempty, mempty, m) 85 | 86 | instance BaseUtils (Monitor' backend) e where 87 | freshname n = Monitor' $ lift $ freshname n 88 | getEnv = Monitor' $ lift getEnv 89 | 90 | instance BaseUtils Monitor e where 91 | freshname n = Monitor $ freshname n 92 | getEnv = Monitor getEnv 93 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/Monad/Tower.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | 7 | module Ivory.Tower.Monad.Tower 8 | ( Tower(..) 9 | , Tower' 10 | , runTower 11 | , runTower_ 12 | , towerGetBackend 13 | , towerGetHandlers 14 | , towerNewChannel 15 | , towerPutHandler 16 | , towerPutMonitor 17 | , towerPutDependencies 18 | , towerPutSignalCode 19 | ) where 20 | 21 | import Prelude () 22 | import Prelude.Compat 23 | 24 | import MonadLib 25 | import Control.Monad.Fix 26 | import Ivory.Tower.Backend 27 | import Ivory.Tower.Monad.Base 28 | import Ivory.Tower.Types.Chan 29 | import qualified Ivory.Tower.Types.ChanMap as ChanMap 30 | import Ivory.Tower.Types.Dependencies 31 | import Ivory.Tower.Types.SignalCode 32 | 33 | import qualified Ivory.Tower.AST as AST 34 | 35 | newtype Tower e a = Tower 36 | { unTower :: forall backend. TowerBackend backend => Tower' backend e a 37 | } 38 | -- GHC can't derive these trivial instances because of the RankNType. 39 | 40 | instance Functor (Tower e) where 41 | fmap f (Tower h) = Tower $ fmap f h 42 | 43 | instance Monad (Tower e) where 44 | return x = Tower $ return x 45 | Tower x >>= f = Tower $ x >>= (unTower . f) 46 | 47 | instance Applicative (Tower e) where 48 | pure = return 49 | (<*>) = ap 50 | 51 | instance MonadFix (Tower e) where 52 | mfix f = Tower $ mfix (unTower . f) 53 | 54 | newtype SinkList backend a = SinkList { unSinkList :: [TowerBackendHandler backend a] } 55 | deriving Monoid 56 | 57 | type Sinks backend = ChanMap.ChanMap (SinkList backend) 58 | 59 | data TowerOutput backend = TowerOutput 60 | { output_sinks :: Sinks backend 61 | , output_monitors :: [(AST.Monitor, TowerBackendMonitor backend)] 62 | , output_deps :: Dependencies 63 | , output_sigs :: SignalCode 64 | } 65 | 66 | instance Monoid (TowerOutput backend) where 67 | mempty = TowerOutput 68 | { output_sinks = ChanMap.empty 69 | , output_monitors = mempty 70 | , output_deps = mempty 71 | , output_sigs = mempty 72 | } 73 | mappend a b = TowerOutput 74 | { output_sinks = ChanMap.unionWith mappend (output_sinks a) (output_sinks b) 75 | , output_monitors = output_monitors a `mappend` output_monitors b 76 | , output_deps = output_deps a `mappend` output_deps b 77 | , output_sigs = output_sigs a `mappend` output_sigs b 78 | } 79 | 80 | newtype Tower' backend e a = Tower' 81 | { unTower' :: ReaderT (backend, Sinks backend) (StateT Integer (WriterT (TowerOutput backend) (Base e))) a 82 | } deriving (Functor, Monad, Applicative, MonadFix) 83 | 84 | runTower :: TowerBackend backend 85 | => backend 86 | -> Tower e a 87 | -> e 88 | -> (a, AST.Tower, TowerBackendOutput backend, Dependencies, SignalCode) 89 | runTower backend t e = (a, ast, towerImpl backend ast monitors, output_deps output, output_sigs output) 90 | where 91 | ast = mappend (mempty { AST.tower_monitors = mast }) $ mconcat $ flip map (ChanMap.keys sinks) $ \ key -> 92 | case key of 93 | AST.ChanSync c -> mempty { AST.tower_syncchans = [c] } 94 | AST.ChanSignal c -> mempty { AST.tower_signals = [c] } 95 | AST.ChanPeriod c -> mempty { AST.tower_periods = [c] } 96 | AST.ChanInit _ -> mempty 97 | (mast, monitors) = unzip $ output_monitors output 98 | sinks = output_sinks output 99 | (a, output) = runBase e 100 | $ runWriterT 101 | $ fmap fst 102 | $ runStateT 1 103 | $ runReaderT (backend, sinks) 104 | $ unTower' 105 | $ unTower t 106 | 107 | runTower_ :: TowerBackend backend 108 | => backend 109 | -> Tower e () 110 | -> e 111 | -> (AST.Tower, TowerBackendOutput backend, Dependencies, SignalCode) 112 | runTower_ b t e = 113 | let ((), ast, out, deps, sig) = runTower b t e 114 | in (ast, out, deps, sig) 115 | 116 | instance BaseUtils (Tower' backend) e where 117 | freshname n = Tower' $ lift $ lift $ lift $ freshname n 118 | getEnv = Tower' $ lift $ lift $ lift getEnv 119 | 120 | instance BaseUtils Tower e where 121 | freshname n = Tower $ freshname n 122 | getEnv = Tower getEnv 123 | 124 | towerGetBackend :: Tower' backend e backend 125 | towerGetBackend = Tower' $ asks fst 126 | 127 | towerGetHandlers :: Chan b -> Tower' backend e [TowerBackendHandler backend b] 128 | towerGetHandlers chan = Tower' $ do 129 | sinks <- asks snd 130 | return $ maybe [] unSinkList $ ChanMap.lookup chan sinks 131 | 132 | towerNewChannel :: Tower e Integer 133 | towerNewChannel = Tower $ Tower' $ sets $ \ n -> (n, n + 1) 134 | 135 | towerPutHandler :: Chan a -> TowerBackendHandler backend a -> Tower' backend e () 136 | towerPutHandler chan h = Tower' $ put $ 137 | mempty { output_sinks = ChanMap.singleton chan $ SinkList [h] } 138 | 139 | towerPutMonitor :: AST.Monitor -> TowerBackendMonitor backend -> Tower' backend e () 140 | towerPutMonitor ast m = Tower' $ put $ mempty { output_monitors = [(ast, m)] } 141 | 142 | towerPutDependencies :: Dependencies -> Tower e () 143 | towerPutDependencies d = Tower $ Tower' $ put $ mempty { output_deps = d } 144 | 145 | towerPutSignalCode :: SignalCode -> Tower e () 146 | towerPutSignalCode s = Tower $ Tower' $ put $ mempty { output_sigs = s } 147 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/Monitor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | module Ivory.Tower.Monitor 4 | ( handler 5 | , state 6 | , stateInit 7 | , monitorModuleDef 8 | , Handler() 9 | , Monitor() 10 | ) where 11 | 12 | import Ivory.Tower.Types.Unique 13 | import Ivory.Tower.Monad.Handler 14 | import Ivory.Tower.Monad.Monitor 15 | import Ivory.Tower.Monad.Base 16 | 17 | import Ivory.Language 18 | 19 | state :: (IvoryArea a, IvoryZero a) 20 | => String -> Monitor e (Ref 'Global a) 21 | state n = state' n Nothing 22 | 23 | stateInit :: (IvoryArea a, IvoryZero a) 24 | => String -> Init a -> Monitor e (Ref 'Global a) 25 | stateInit n i = state' n (Just i) 26 | 27 | state' :: (IvoryArea a, IvoryZero a) 28 | => String 29 | -> Maybe (Init a) 30 | -> Monitor e (Ref 'Global a) 31 | state' n i = do 32 | f <- freshname n 33 | let a = area (showUnique f) i 34 | monitorModuleDef $ defMemArea a 35 | return (addrOf a) 36 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/Options.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | 3 | module Ivory.Tower.Options 4 | ( TOpts(..) 5 | , towerGetOpts 6 | , parseOpts 7 | , getOpts 8 | , finalizeOpts 9 | ) where 10 | 11 | import Prelude () 12 | import Prelude.Compat 13 | 14 | import System.Console.GetOpt 15 | (ArgOrder(Permute), OptDescr(..), getOpt', usageInfo) 16 | import System.Exit (exitFailure) 17 | import System.Environment (getArgs) 18 | import qualified Ivory.Compile.C.CmdlineFrontend.Options as C 19 | 20 | data TOpts = TOpts 21 | { topts_outdir :: Maybe FilePath 22 | , topts_help :: Bool 23 | , topts_args :: [String] 24 | , topts_error :: forall a . String -> IO a 25 | } 26 | 27 | towerGetOpts :: IO (C.Opts, TOpts) 28 | towerGetOpts = getArgs >>= getOpts 29 | 30 | finalizeOpts :: TOpts -> IO () 31 | finalizeOpts topts = case topts_args topts of 32 | [] -> case topts_help topts of 33 | True -> topts_error topts "Usage:" 34 | False -> return () 35 | as -> topts_error topts ("Unrecognized arguments:\n" ++ unlines as) 36 | 37 | parseOpts :: [OptDescr (C.OptParser opt)] -> [String] 38 | -> ([String], (Either [String] (opt -> opt))) 39 | parseOpts opts args = 40 | let (fs, ns, us, es) = getOpt' Permute opts args 41 | (C.OptParser errs f) = mconcat fs 42 | unused = ns ++ us 43 | in case errs ++ es of 44 | [] -> (unused, Right f) 45 | e' -> (unused, Left e') 46 | 47 | getOpts :: [String] -> IO (C.Opts, TOpts) 48 | getOpts args = case mkCOpts of 49 | Left es -> err (unlines es) 50 | Right mkc -> do 51 | let copts = mkc C.initialOpts 52 | return (copts, TOpts 53 | { topts_outdir = C.outDir copts 54 | , topts_help = C.help copts 55 | , topts_args = unusedArgs 56 | , topts_error = err 57 | }) 58 | where 59 | (unusedArgs, mkCOpts) = parseOpts C.options args 60 | err s = do 61 | putStrLn s 62 | putStrLn "" 63 | putStrLn "ivory-backend-c options:" 64 | putStrLn $ usageInfo "" C.options 65 | exitFailure 66 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/SrcLoc/Location.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE DeriveFoldable #-} 3 | {-# LANGUAGE DeriveTraversable #-} 4 | 5 | -- 6 | -- Syntax locations. 7 | -- 8 | -- Copyright (C) 2014, Galois, Inc. 9 | -- All rights reserved. 10 | -- 11 | 12 | module Ivory.Tower.SrcLoc.Location where 13 | 14 | import Prelude () 15 | import Prelude.Compat 16 | 17 | import Control.Monad (mplus) 18 | import Data.Function (on) 19 | import Data.List (foldl') 20 | import Data.Maybe (maybeToList) 21 | import Data.Monoid ((<>)) 22 | 23 | -- Located Things -------------------------------------------------------------- 24 | 25 | class HasLocation a where 26 | getLoc :: a -> SrcLoc 27 | stripLoc :: a -> a 28 | 29 | instance HasLocation a => HasLocation [a] where 30 | {-# INLINE getLoc #-} 31 | getLoc = foldMap getLoc 32 | 33 | {-# INLINE stripLoc #-} 34 | stripLoc = fmap stripLoc 35 | 36 | instance (HasLocation a, HasLocation b) => HasLocation (a,b) where 37 | {-# INLINE getLoc #-} 38 | getLoc (a,b) = getLoc a <> getLoc b 39 | 40 | {-# INLINE stripLoc #-} 41 | stripLoc (a,b) = (stripLoc a, stripLoc b) 42 | 43 | instance HasLocation a => HasLocation (Maybe a) where 44 | {-# INLINE getLoc #-} 45 | getLoc = foldMap getLoc 46 | 47 | {-# INLINE stripLoc #-} 48 | stripLoc = fmap stripLoc 49 | 50 | locStart :: HasLocation a => a -> Position 51 | locStart a = srcStart (getLoc a) 52 | 53 | locEnd :: HasLocation a => a -> Position 54 | locEnd a = srcEnd (getLoc a) 55 | 56 | -- | Things that carry a range in the source syntax. 57 | data Located a = Located 58 | { locRange :: !SrcLoc 59 | , locValue :: a 60 | } deriving (Show,Read,Functor,Ord,Eq,Foldable,Traversable) 61 | 62 | instance HasLocation (Located a) where 63 | {-# INLINE getLoc #-} 64 | getLoc = locRange 65 | 66 | {-# INLINE stripLoc #-} 67 | stripLoc l = l { locRange = NoLoc } 68 | 69 | -- | Attach no location information to a value. 70 | noLoc :: a -> Located a 71 | noLoc a = Located 72 | { locRange = NoLoc 73 | , locValue = a 74 | } 75 | 76 | -- | Attach location information to a value. 77 | at :: HasLocation loc => a -> loc -> Located a 78 | at a loc = Located 79 | { locRange = getLoc loc 80 | , locValue = a 81 | } 82 | 83 | -- | `at` helper for binary operators. 84 | atBin :: (HasLocation loc0, HasLocation loc1) 85 | => a -> loc0 -> loc1 -> Located a 86 | atBin a l0 l1 = a `at` (getLoc l0 <> getLoc l1) 87 | 88 | -- | `at` helper for list args. 89 | atList :: a -> [SrcLoc] -> Located a 90 | atList a locs = a `at` mconcat locs 91 | 92 | -- | Strip off location information. 93 | unLoc :: Located a -> a 94 | unLoc = locValue 95 | 96 | -- | Extend the range of a located thing. 97 | extendLoc :: SrcLoc -> Located a -> Located a 98 | extendLoc r loc = loc { locRange = locRange loc `mappend` r } 99 | 100 | -- Source Locations ------------------------------------------------------------ 101 | 102 | -- | Source locations. 103 | type Source = Maybe String 104 | 105 | -- | A range in the program source. 106 | data SrcLoc = NoLoc | SrcLoc !Range Source 107 | deriving (Show,Read,Ord,Eq) 108 | 109 | instance HasLocation SrcLoc where 110 | {-# INLINE getLoc #-} 111 | getLoc = id 112 | 113 | {-# INLINE stripLoc #-} 114 | stripLoc _ = NoLoc 115 | 116 | instance Monoid SrcLoc where 117 | mempty = NoLoc 118 | 119 | -- widen source ranges, and prefer source names from the left 120 | mappend (SrcLoc lr ls) (SrcLoc rr rs) = SrcLoc (mappend lr rr) (mplus ls rs) 121 | mappend NoLoc r = r 122 | mappend l NoLoc = l 123 | 124 | -- | Get info to build a line pragma from a 'SrcLoc'. Returns a value only if 125 | -- there is a valid range. Returns the starting line number. 126 | srcLoclinePragma :: SrcLoc -> Maybe (Int, String) 127 | srcLoclinePragma srcloc = case srcloc of 128 | NoLoc -> Nothing 129 | SrcLoc _ src -> Just ( posLine (srcStart srcloc) 130 | , concat (maybeToList src)) 131 | 132 | srcRange :: SrcLoc -> Range 133 | srcRange loc = case loc of 134 | SrcLoc r _ -> r 135 | NoLoc -> mempty 136 | 137 | -- | Starting Position of a 'SrcLoc'. 138 | srcStart :: SrcLoc -> Position 139 | srcStart loc = case loc of 140 | SrcLoc r _ -> rangeStart r 141 | NoLoc -> zeroPosition 142 | 143 | -- | Ending Position of a 'SrcLoc'. 144 | srcEnd :: SrcLoc -> Position 145 | srcEnd loc = case loc of 146 | SrcLoc r _ -> rangeStart r 147 | NoLoc -> zeroPosition 148 | 149 | 150 | -- Ranges ---------------------------------------------------------------------- 151 | 152 | -- | The region between to source positions. 153 | data Range = Range 154 | { rangeStart :: !Position 155 | , rangeEnd :: !Position 156 | } deriving (Show,Read,Eq,Ord) 157 | 158 | instance Monoid Range where 159 | mempty = Range zeroPosition zeroPosition 160 | 161 | -- widen the range 162 | mappend (Range ls le) (Range rs re) = Range (smallerOf ls rs) (largerOf le re) 163 | 164 | -- Positions ------------------------------------------------------------------- 165 | 166 | -- | Position information within a source. 167 | data Position = Position 168 | { posOff :: !Int 169 | , posLine :: !Int 170 | , posCol :: !Int 171 | } deriving (Show,Read,Eq) 172 | 173 | -- | This only compares offset, assuming that the positions come from the same 174 | -- source. 175 | instance Ord Position where 176 | compare = compare `on` posOff 177 | 178 | -- | Starting position. 179 | zeroPosition :: Position 180 | zeroPosition = Position 181 | { posOff = 0 182 | , posLine = 1 183 | , posCol = 1 184 | } 185 | 186 | -- | Return smaller of the two positions, taking care to not allow the zero 187 | -- position to dominate. 188 | smallerOf :: Position -> Position -> Position 189 | smallerOf l r 190 | | l < r && l /= zeroPosition = l 191 | | otherwise = r 192 | 193 | -- | Return the larger of the two positions. 194 | largerOf :: Position -> Position -> Position 195 | largerOf l r 196 | | l > r = l 197 | | otherwise = r 198 | 199 | -- | Given a character, increment a position. 200 | movePos :: Position -> Char -> Position 201 | movePos (Position off line col) c = 202 | case c of 203 | '\t' -> Position (off+1) line (col+8) 204 | '\n' -> Position (off+1) (line+1) 1 205 | _ -> Position (off+1) line (col+1) 206 | 207 | -- | Move many characters at once. 208 | movesPos :: Position -> String -> Position 209 | movesPos pos = foldl' movePos pos 210 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/SrcLoc/Plugin.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | -- 6 | -- GHC plugin to generate srcloc info. 7 | -- 8 | -- (c) 2014 Galois, Inc. 9 | -- 10 | 11 | module Ivory.Tower.SrcLoc.Plugin (plugin) where 12 | 13 | import DynamicLoading 14 | import GhcPlugins 15 | 16 | import GHC.Plugins.SrcSpan 17 | 18 | plugin :: Plugin 19 | plugin = defaultPlugin { installCoreToDos = install } 20 | 21 | install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] 22 | install opts todos = do 23 | reinitializeGlobals 24 | 25 | hsc_env <- getHscEnv 26 | 27 | Just withLocName <- liftIO $ lookupRdrNameInModuleForPlugins hsc_env hANDLER_MONAD_MODULE wITH_LOC 28 | withLocVar <- lookupId withLocName 29 | 30 | Just mkLocName <- liftIO $ lookupRdrNameInModuleForPlugins hsc_env hANDLER_MONAD_MODULE mK_LOC 31 | mkLocVar <- lookupId mkLocName 32 | 33 | Just handlerName <- liftIO $ lookupRdrNameInModuleForPlugins hsc_env hANDLER_MONAD_MODULE hANDLER 34 | handlerCon <- lookupTyCon handlerName 35 | 36 | let annotate loc expr = mkWithLocExpr handlerCon mkLocVar withLocVar loc expr 37 | let locpass = mkPass annotate killForeignStubs 38 | 39 | return $ (CoreDoPluginPass "Add Locations" locpass) : todos 40 | where 41 | killForeignStubs = "kill-foreign-stubs" `elem` opts 42 | 43 | 44 | -- | Check that the expression is a handler monad type constructor. 45 | isHandlerStmt :: TyCon -> CoreExpr -> Bool 46 | isHandlerStmt handlerM expr@(App _ _) 47 | | Just (tc, _) <- splitTyConApp_maybe $ exprType expr 48 | = tc == handlerM 49 | isHandlerStmt handlerM expr@(Var _) 50 | | Just (tc, _) <- splitTyConApp_maybe $ exprType expr 51 | = tc == handlerM 52 | isHandlerStmt _ _ 53 | = False 54 | 55 | mkWithLocExpr :: TyCon -> Var -> Var -> SrcSpan -> CoreExpr -> CoreM CoreExpr 56 | mkWithLocExpr handlerTyCon mkLocVar withLocVar (RealSrcSpan ss) expr 57 | | isHandlerStmt handlerTyCon expr = do 58 | loc <- mkLocExpr mkLocVar ss 59 | return $ mkCoreApps (Var withLocVar) (tys' ++ [loc, expr]) 60 | where 61 | tys' = map Type tys 62 | (_, tys) = splitAppTys $ exprType expr 63 | 64 | mkWithLocExpr _ _ _ _ expr = return expr 65 | 66 | mkLocExpr :: Var -> RealSrcSpan -> CoreM CoreExpr 67 | mkLocExpr mkLocVar ss = do 68 | df <- getDynFlags 69 | file <- mkStringExprFS $ srcSpanFile ss 70 | return $ mkCoreApps (Var mkLocVar) [ file 71 | , mkIntExprInt df (srcSpanStartLine ss) 72 | , mkIntExprInt df (srcSpanStartCol ss) 73 | , mkIntExprInt df (srcSpanEndLine ss) 74 | , mkIntExprInt df (srcSpanEndCol ss) 75 | ] 76 | 77 | hANDLER_MONAD_MODULE :: ModuleName 78 | hANDLER_MONAD_MODULE = mkModuleName "Ivory.Tower.Monad.Handler" 79 | 80 | wITH_LOC, mK_LOC, hANDLER :: RdrName 81 | wITH_LOC = mkVarUnqual $ fsLit "withLocation" 82 | mK_LOC = mkVarUnqual $ fsLit "mkLocation" 83 | hANDLER = mkRdrQual hANDLER_MONAD_MODULE $ mkTcOcc "Handler" 84 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/Tower.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# LANGUAGE PostfixOperators #-} 5 | 6 | module Ivory.Tower.Tower 7 | ( Tower() 8 | , runTower 9 | , runTower_ 10 | , ChanInput() 11 | , ChanOutput() 12 | , channel 13 | , signal 14 | , signalUnsafe 15 | , Signalable(..) 16 | , module Ivory.Tower.Types.Time 17 | , period 18 | , periodPhase 19 | , systemInit 20 | , Monitor() 21 | , monitor 22 | , externalMonitor 23 | , towerModule 24 | , towerDepends 25 | , towerArtifact 26 | 27 | , getTime 28 | , BaseUtils(..) 29 | , Unique 30 | , showUnique 31 | ) where 32 | 33 | import Prelude () 34 | import Prelude.Compat 35 | 36 | import qualified Data.Map as Map 37 | import Ivory.Tower.Types.Chan 38 | import Ivory.Tower.Types.Dependencies 39 | import Ivory.Tower.Types.SignalCode 40 | import Ivory.Tower.Types.Signalable 41 | import Ivory.Tower.Types.Time 42 | import Ivory.Tower.Types.Unique 43 | 44 | import qualified Ivory.Tower.AST as AST 45 | 46 | import Ivory.Tower.Monad.Base 47 | import Ivory.Tower.Monad.Tower 48 | import Ivory.Tower.Monad.Monitor 49 | 50 | import Ivory.Language 51 | import Ivory.Artifact 52 | import qualified Ivory.Language.Area as I 53 | 54 | channel :: IvoryArea a => Tower e (ChanInput a, ChanOutput a) 55 | channel = do 56 | -- Channels are anonymous so `freshname` is not an appropriate way to 57 | -- give them unique names. Instead, keep a count of the number of 58 | -- channels created in this Tower. 59 | f <- towerNewChannel 60 | let ast = AST.SyncChan f (I.ivoryArea (chanProxy c)) 61 | c = Chan (AST.ChanSync ast) 62 | return (ChanInput c, ChanOutput c) 63 | where 64 | chanProxy :: Chan a -> Proxy a 65 | chanProxy _ = Proxy 66 | 67 | -- Note: signals are no longer tied to be the same type throughout 68 | -- a given Tower. We'd need to add another phantom type to make that 69 | -- work. 70 | signal :: (Time a, Signalable s) 71 | => s -> a -> Tower e (ChanOutput ('Stored ITime)) 72 | signal s t = signalUnsafe s t (return ()) 73 | 74 | signalUnsafe :: (Time a, Signalable s) 75 | => s -> a -> (forall eff . Ivory eff ()) 76 | -> Tower e (ChanOutput ('Stored ITime)) 77 | signalUnsafe s t i = do 78 | towerPutSignalCode $ SignalCode 79 | { signalcode_init = signalInit s 80 | , signalcode_signals = Map.singleton n $ 81 | GeneratedSignal $ \i' -> signalHandler s (i >> i') 82 | } 83 | return (ChanOutput (Chan (AST.ChanSignal ast))) 84 | where 85 | n = signalName s 86 | ast = AST.Signal 87 | { AST.signal_name = n 88 | , AST.signal_deadline = microseconds t 89 | , AST.signal_number = signalNumber s 90 | } 91 | 92 | period :: Time a => a -> Tower e (ChanOutput ('Stored ITime)) 93 | period t = periodPhase t (0`us`) 94 | 95 | periodPhase :: (Time a, Time b) 96 | => a 97 | -> b 98 | -> Tower e (ChanOutput ('Stored ITime)) 99 | periodPhase t ph = do 100 | let ast = AST.Period (microseconds t) perTy (microseconds ph) 101 | return (ChanOutput (Chan (AST.ChanPeriod ast))) 102 | where perTy = I.ivoryArea (Proxy :: I.AProxy ('Stored ITime)) 103 | 104 | systemInit :: ChanOutput ('Stored ITime) 105 | systemInit = ChanOutput (Chan (AST.ChanInit AST.Init)) 106 | 107 | towerModule :: Module -> Tower e () 108 | towerModule m = towerPutDependencies $ mempty { dependencies_modules = [m] } 109 | 110 | towerDepends :: Module -> Tower e () 111 | towerDepends m = towerPutDependencies $ mempty { dependencies_depends = [m] } 112 | 113 | towerArtifact :: Located Artifact -> Tower e () 114 | towerArtifact a = towerPutDependencies $ mempty { dependencies_artifacts = [a] } 115 | 116 | getTime :: Ivory eff ITime 117 | getTime = call getTimeProc 118 | where 119 | -- Must be provided by the code generator: 120 | getTimeProc :: Def('[]':->ITime) 121 | getTimeProc = importProc "tower_get_time" "tower_time.h" 122 | 123 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/Types/Chan.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | 5 | module Ivory.Tower.Types.Chan where 6 | 7 | import qualified Ivory.Tower.AST as AST 8 | import Ivory.Language 9 | 10 | data Chan (a :: Area *) = Chan AST.Chan 11 | deriving (Eq) 12 | 13 | newtype ChanInput (a :: Area *) = ChanInput (Chan a) 14 | deriving (Eq) 15 | 16 | newtype ChanOutput (a :: Area *) = ChanOutput (Chan a) 17 | deriving (Eq) 18 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/Types/ChanMap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | 4 | module Ivory.Tower.Types.ChanMap 5 | ( ChanMap() 6 | , empty 7 | , singleton 8 | , lookup 9 | , unionWith 10 | , keys 11 | ) where 12 | 13 | import qualified Data.Map as Map 14 | import GHC.Exts (Any) 15 | import Ivory.Language 16 | import qualified Ivory.Tower.AST as AST 17 | import Ivory.Tower.Types.Chan 18 | import Prelude hiding (lookup) 19 | import Unsafe.Coerce 20 | 21 | newtype ChanMap (v :: Area * -> *) = ChanMap (Map.Map AST.Chan Any) 22 | 23 | empty :: ChanMap v 24 | empty = ChanMap Map.empty 25 | 26 | singleton :: Chan a -> v a -> ChanMap v 27 | singleton (Chan chan) v = ChanMap $ Map.singleton chan $ unsafeCoerce v 28 | 29 | lookup :: Chan a -> ChanMap v -> Maybe (v a) 30 | lookup (Chan chan) (ChanMap m) = fmap unsafeCoerce $ Map.lookup chan m 31 | 32 | unionWith :: (v a -> v a -> v a) -> ChanMap v -> ChanMap v -> ChanMap v 33 | unionWith f (ChanMap a) (ChanMap b) = ChanMap $ Map.unionWith (liftDyn f) a b 34 | 35 | keys :: ChanMap v -> [AST.Chan] 36 | keys (ChanMap m) = Map.keys m 37 | 38 | liftDyn :: (a -> a -> a) -> Any -> Any -> Any 39 | liftDyn f a b = unsafeCoerce $ f (unsafeCoerce a) (unsafeCoerce b) 40 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/Types/Dependencies.hs: -------------------------------------------------------------------------------- 1 | module Ivory.Tower.Types.Dependencies where 2 | 3 | import Prelude () 4 | import Prelude.Compat 5 | 6 | import Data.List (nub, nubBy) 7 | import Ivory.Artifact 8 | import Ivory.Language 9 | 10 | data Dependencies = Dependencies 11 | { dependencies_modules :: [Module] 12 | , dependencies_depends :: [Module] 13 | , dependencies_artifacts :: [Located Artifact] 14 | } 15 | 16 | instance Monoid Dependencies where 17 | mempty = Dependencies 18 | { dependencies_modules = mempty 19 | , dependencies_depends = mempty 20 | , dependencies_artifacts = mempty 21 | } 22 | mappend a b = Dependencies 23 | { dependencies_modules = nub $ 24 | dependencies_modules a `mappend` dependencies_modules b 25 | , dependencies_depends = nub $ 26 | dependencies_depends a `mappend` dependencies_depends b 27 | , dependencies_artifacts = nubBy mightBeEqLocatedArtifact $ 28 | dependencies_artifacts a `mappend` dependencies_artifacts b 29 | } 30 | 31 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/Types/Emitter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | 5 | module Ivory.Tower.Types.Emitter where 6 | 7 | import Ivory.Language 8 | 9 | newtype Emitter (a :: Area *) = Emitter 10 | { emit :: forall s eff. ConstRef s a -> Ivory eff () 11 | } 12 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/Types/SignalCode.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | 3 | {- | This module is a placeholder until we have backend-specific signal 4 | - support. 5 | -} 6 | module Ivory.Tower.Types.SignalCode where 7 | 8 | import Prelude () 9 | import Prelude.Compat 10 | 11 | import qualified Data.Map as Map 12 | import Ivory.Language 13 | 14 | data SignalCode = SignalCode 15 | { signalcode_signals :: Map.Map String GeneratedSignal 16 | , signalcode_init :: forall eff. Ivory eff () 17 | } 18 | 19 | instance Monoid SignalCode where 20 | mempty = SignalCode 21 | { signalcode_signals = Map.empty 22 | , signalcode_init = return () 23 | } 24 | mappend a b = SignalCode 25 | { signalcode_signals = signalcode_signals a `Map.union` signalcode_signals b 26 | , signalcode_init = signalcode_init a >> signalcode_init b 27 | } 28 | 29 | newtype GeneratedSignal = 30 | GeneratedSignal 31 | { unGeneratedSignal :: (forall s . Ivory (AllocEffects s) ()) -> ModuleDef 32 | -- ^ Unsafe signal continuation. 33 | } 34 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/Types/Signalable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE DefaultSignatures #-} 3 | 4 | module Ivory.Tower.Types.Signalable 5 | ( Signalable(..) 6 | ) where 7 | 8 | import Ivory.Language 9 | 10 | class Signalable s where 11 | signalName :: s -> String 12 | signalHandler :: s -> (forall s' . Ivory (AllocEffects s') ()) -> ModuleDef 13 | 14 | -- | Code to prepare this signal for use, if necessary. The default 15 | -- implementation emits no code. 16 | signalInit :: s -> Ivory eff () 17 | signalInit _ = return () 18 | 19 | -- | On some platforms we need access to an underlying IRQ number for 20 | -- signals that correspond to IRQs. 21 | signalNumber :: s -> Int 22 | default signalNumber :: Enum s => s -> Int 23 | signalNumber = fromEnum 24 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/Types/ThreadCode.hs: -------------------------------------------------------------------------------- 1 | module Ivory.Tower.Types.ThreadCode 2 | ( ThreadCode(..) 3 | ) where 4 | 5 | import Prelude () 6 | import Prelude.Compat 7 | 8 | import Ivory.Language 9 | 10 | data ThreadCode = 11 | ThreadCode 12 | { threadcode_user :: ModuleDef 13 | , threadcode_gen :: ModuleDef 14 | , threadcode_emitter :: ModuleDef 15 | } 16 | 17 | instance Monoid ThreadCode where 18 | mempty = ThreadCode 19 | { threadcode_user = return () 20 | , threadcode_gen = return () 21 | , threadcode_emitter = return () 22 | } 23 | 24 | -- ModuleDef order doesn't matter, but Tower used to concatenate ThreadCode 25 | -- in reverse order, so this does too. It could be swapped if desired. 26 | mappend b a = ThreadCode 27 | { threadcode_user = threadcode_user a >> threadcode_user b 28 | , threadcode_gen = threadcode_gen a >> threadcode_gen b 29 | , threadcode_emitter = threadcode_emitter a >> threadcode_emitter b 30 | } 31 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/Types/Time.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE DataKinds #-} 6 | {-# LANGUAGE CPP #-} 7 | {-# LANGUAGE PostfixOperators #-} 8 | 9 | module Ivory.Tower.Types.Time 10 | ( Time 11 | , Microseconds(..) 12 | , Milliseconds(..) 13 | , toMicroseconds 14 | , toMilliseconds 15 | , microseconds 16 | , us 17 | , ms 18 | 19 | , ITime 20 | , fromIMicroseconds 21 | , fromIMilliseconds 22 | , toIMicroseconds 23 | , toIMilliseconds 24 | , toITime 25 | , prettyTime 26 | ) where 27 | 28 | #if MIN_VERSION_mainland_pretty(0,6,0) 29 | import Text.PrettyPrint.Mainland.Class 30 | #endif 31 | import Text.PrettyPrint.Mainland 32 | 33 | import Ivory.Language 34 | 35 | class Time a where 36 | toMicroseconds :: a -> Integer 37 | 38 | microseconds :: Time a => a -> Microseconds 39 | microseconds = Microseconds . toMicroseconds 40 | 41 | toMilliseconds :: (Time a) => a -> Integer 42 | toMilliseconds t = (toMicroseconds t) `div` 1000 43 | 44 | newtype Microseconds = Microseconds Integer deriving (Eq, Show, Ord) 45 | instance Time Microseconds where 46 | toMicroseconds (Microseconds t) = t 47 | 48 | us :: Integer -> Microseconds 49 | us = Microseconds 50 | 51 | newtype Milliseconds = Milliseconds Integer deriving (Eq, Show, Ord) 52 | instance Time Milliseconds where 53 | toMicroseconds (Milliseconds t) = t * 1000 54 | 55 | ms :: Integer -> Milliseconds 56 | ms = Milliseconds 57 | 58 | newtype ITime = ITime Sint64 59 | deriving ( Num, IvoryType, IvoryVar, IvoryExpr, IvoryEq, IvoryOrd 60 | , IvoryIntegral, IvoryStore, IvoryInit, IvoryZeroVal, Bounded) 61 | 62 | instance SafeCast ITime Sint64 where 63 | 64 | fromIMicroseconds :: (SafeCast a Sint64) => a -> ITime 65 | fromIMicroseconds = ITime . safeCast 66 | 67 | fromIMilliseconds :: (SafeCast a Sint64) => a -> ITime 68 | fromIMilliseconds = ITime . (*1000) . safeCast 69 | 70 | toIMicroseconds :: ITime -> Sint64 71 | toIMicroseconds (ITime t) = t 72 | 73 | toIMilliseconds :: ITime -> Sint64 74 | toIMilliseconds (ITime t) = t `iDiv` 1000 75 | 76 | toITime :: (Time a) => a -> ITime 77 | toITime t = fromIMicroseconds us' 78 | where 79 | us' :: Sint64 80 | us' = fromIntegral (toMicroseconds t) 81 | 82 | prettyTime :: Microseconds -> String 83 | prettyTime m = t 84 | where 85 | us' = toMicroseconds m 86 | t = case us' `mod` 1000 of 87 | 0 -> (show (us' `div` 1000)) ++ "ms" 88 | _ -> (show us') ++ "us" 89 | 90 | instance Pretty Microseconds where 91 | ppr m = text (prettyTime m) 92 | -------------------------------------------------------------------------------- /tower/src/Ivory/Tower/Types/Unique.hs: -------------------------------------------------------------------------------- 1 | module Ivory.Tower.Types.Unique 2 | ( Unique(..) 3 | , showUnique 4 | ) where 5 | 6 | data Unique = 7 | Unique 8 | { unique_name :: String 9 | , unique_fresh :: Integer 10 | } deriving (Eq, Show, Ord) 11 | 12 | showUnique :: Unique -> String 13 | showUnique (Unique n 1) = n 14 | showUnique u = unique_name u ++ "_" ++ show (unique_fresh u) 15 | 16 | -------------------------------------------------------------------------------- /tower/tower.cabal: -------------------------------------------------------------------------------- 1 | name: tower 2 | version: 0.9.0.0 3 | author: Galois, Inc. 4 | maintainer: pat@galois.com 5 | category: Language 6 | build-type: Simple 7 | cabal-version: >= 1.10 8 | license: BSD3 9 | 10 | library 11 | -- Exports 12 | exposed-modules: Ivory.Tower, 13 | 14 | -- Surface syntax: 15 | Ivory.Tower.Coroutine, 16 | Ivory.Tower.Tower, 17 | Ivory.Tower.Monitor, 18 | Ivory.Tower.Handler, 19 | 20 | -- AST 21 | Ivory.Tower.AST, 22 | Ivory.Tower.AST.Comment, 23 | Ivory.Tower.AST.Chan, 24 | Ivory.Tower.AST.Emitter, 25 | Ivory.Tower.AST.Graph, 26 | Ivory.Tower.AST.Handler, 27 | Ivory.Tower.AST.Init, 28 | Ivory.Tower.AST.Monitor, 29 | Ivory.Tower.AST.Period, 30 | Ivory.Tower.AST.Signal, 31 | Ivory.Tower.AST.SyncChan, 32 | Ivory.Tower.AST.Thread, 33 | Ivory.Tower.AST.Tower, 34 | 35 | -- Code generation 36 | Ivory.Tower.Backend, 37 | 38 | -- Compiler 39 | Ivory.Tower.Options, 40 | 41 | -- Monads 42 | Ivory.Tower.Monad.Base, 43 | Ivory.Tower.Monad.Handler, 44 | Ivory.Tower.Monad.Monitor, 45 | Ivory.Tower.Monad.Tower, 46 | 47 | -- Types 48 | Ivory.Tower.Types.Chan, 49 | Ivory.Tower.Types.Dependencies, 50 | Ivory.Tower.Types.Emitter, 51 | Ivory.Tower.Types.SignalCode, 52 | Ivory.Tower.Types.Signalable, 53 | Ivory.Tower.Types.ThreadCode, 54 | Ivory.Tower.Types.Time, 55 | Ivory.Tower.Types.Unique, 56 | 57 | -- SrcLoc 58 | Ivory.Tower.SrcLoc.Location 59 | 60 | other-modules: Ivory.Tower.Types.ChanMap 61 | 62 | build-depends: base >= 4.6, 63 | base-compat >= 0.6, 64 | monadLib, 65 | containers, 66 | ghc-prim, 67 | mainland-pretty >= 0.4.0.0, 68 | text, 69 | filepath, 70 | ivory, 71 | ivory-artifact, 72 | ivory-stdlib, 73 | ivory-backend-c 74 | 75 | hs-source-dirs: src 76 | default-language: Haskell2010 77 | ghc-options: -Wall -fno-warn-orphans 78 | --------------------------------------------------------------------------------