├── .gitignore ├── LICENSE ├── README.md ├── STLinkUSB ├── LICENSE ├── README.md ├── STLinkUSB.cabal ├── STLinkUSB.nix ├── STM32 │ ├── STLinkUSB.hs │ └── STLinkUSB │ │ ├── Commands.hs │ │ ├── CortexM.hs │ │ ├── Dongle.hs │ │ ├── Env.hs │ │ ├── MemRW.hs │ │ ├── Test.hs │ │ ├── TwoBoards.hs │ │ ├── USBUtils.hs │ │ └── USBXfer.hs ├── Setup.hs └── default.nix ├── STM32-Zombie ├── LICENSE ├── STM32-Zombie.cabal ├── STM32-Zombie.nix ├── Setup.hs ├── cabal.config ├── default.nix └── src │ ├── App │ ├── ADC.hs │ ├── Blink.hs │ ├── DMABuffer.hs │ ├── LCD.hs │ ├── MS5611.hs │ ├── RealTimeClock.hs │ ├── Serial.hs │ ├── Stepper.hs │ ├── TLC5947.hs │ ├── TestLCD.hs │ ├── TimerDMA.hs │ ├── WS1228B.hs │ └── WaveForm.hs │ └── STM32 │ ├── ADC.hs │ ├── API.hs │ ├── DAC.hs │ ├── DMA.hs │ ├── GPIO.hs │ ├── I2C.hs │ ├── MachineInterface.hs │ ├── MachineInterfaceSTLinkUSB.hs │ ├── PWR.hs │ ├── RCC.hs │ ├── RTC.hs │ ├── SPI.hs │ ├── Timer.hs │ ├── USART.hs │ └── Utils.hs ├── STM32F103xx-SVD ├── Device.hs ├── LicenseInfo ├── STM32F103xx-SVD.cabal ├── STM32F103xx-SVD.nix └── Setup.hs ├── SVD2HS ├── Device.hs ├── LICENSE ├── STM32F103xx.svd ├── SVD2HS.cabal ├── SVD2HS.hs └── Setup.hs ├── cabal.project └── misc ├── STLink.png ├── STM32Zombie-MS.tex ├── board1.png ├── board2.png └── board3.jpg /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | \#*\# 3 | dist 4 | dist-* 5 | cabal-dev 6 | *.o 7 | *.hi 8 | *.chi 9 | *.chs.h 10 | *.dyn_o 11 | *.dyn_hi 12 | .hpc 13 | .hsenv 14 | .cabal-sandbox/ 15 | cabal.sandbox.config 16 | *.prof 17 | *.aux 18 | *.hp 19 | *.eventlog 20 | .stack-work/ 21 | cabal.project.local 22 | .HTF/ 23 | .ghc.environment.* 24 | _darcs/ -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) Marc Fontaine 2015-2017 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 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 2. Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | 3. Neither the name of the author nor the names of his contributors 14 | may be used to endorse or promote products derived from this software 15 | without specific prior written permission. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' AND 18 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 20 | ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 21 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 23 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 24 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 25 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 26 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 27 | SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # STM32Fxxx micro-controller hacking in Haskell 2 | 3 | ## STM32-Zombie 4 | 5 | The STM32-Zombie library turns a STM32 microcontroller 6 | into a powerful Haskell-hackable hardware interface. 7 | It gives the user full control of the STM32Fxxx hardware peripherals 8 | without the need to write any c-code, without cross-compiler tool chain 9 | and even without any particular microcontroller firmware. 10 | The library is called STM-32 Zombie because it halts the brain, 11 | i.e. the ARM CPU of the controller board and instead uses the on-cip-debugging 12 | features of the controller. The boards run like a Zombie without using 13 | its own brain. 14 | 15 | ## Compatible Hardware 16 | I have tested the library with the following hardware: 17 | 18 | * ST-Link USB dongle (Google for "ST-Link V2 stlink mini STM8STM32 STLINK simulator") 19 | 20 | ![ST-Link USB dongle](https://i.imgur.com/Y4iEvVt.jpg) 21 | 22 | * A STM32F103 breakout board (Google for " "STM32F103C8T6 ARM STM32 Minimum System Development Board Module") 23 | 24 | ![STM32F103C8T6 board](https://imgur.com/Xb4mOFa.jpg) 25 | ![STM32F103C8T6 board](https://imgur.com/qMCp6au.jpg) 26 | 27 | The USB dongle as well as the breakout boards are available in China starting 28 | at about US$2. 29 | The cheap ST-link clones and the breakout boards work well but the US$2 30 | ST-Link clones provide no electrical isolation to protect your PC or Laptop. 31 | Experimenting with Hardware is a lot of fun until you let the magic smoke out. 32 | A ST-LINK/V2-ISOL programmer, that guaranties electrical isolation 33 | and full protection of the PC, is very affordable and may be a good investing. 34 | 35 | ## How it Works 36 | One end of ST-Link dongle plugs into the PC USB port the other end is the so called 37 | SWD (single wire debug) interface. 38 | The SWD interface, which also provides electrical power, is connected to the 39 | STM32F103 breakout with 4 jumper wires. 40 | As most breakout boards come with a LED, this is all that is needed to run the 41 | App.Blink example. 42 | Via the SWD interface the PC can read and write the controller CPU 43 | address space and access the memory-mapped hardware registers. 44 | 45 | ## API 46 | The STM32-Zombie library is modeled after the STMicroelectronics 47 | STM32F10x firmware library which provides a low level interface to the 48 | controller hardware. 49 | This API is suitable for bare metal hardware hacking but also allows to build 50 | higher level interfaces. 51 | 52 | ## Examples and features 53 | The STM32Fxxx controllers feature a wide variety of powerful and flexible 54 | hardware peripherals like GPIO port, serial, SPI, I2C interfaces 55 | and 12bit-ADC converters and USB ports. 56 | The killer feature is, that they also include a flexible DMA controller 57 | that can be uses in combination with the peripherals. 58 | This makes it possible to build hard-real-time applications that work 59 | completely independent from the controller CPU. 60 | Examples are ADC sampling and high sampling rate and with precise timing, 61 | high frequency sampling of digital inputs or generation of high frequency 62 | digital output patterns. 63 | 64 | The library does not cover all of the STM32 hardware. 65 | I add support for something when I need it in a particular project. 66 | (For example I have not tried the USB features of the boards, 67 | which seems to be very interesting project) 68 | 69 | The examples are in the App module hierarchy. 70 | 71 | ### App.Blink 72 | Blink a LED. 73 | ### App.ADC 74 | Buffered ADC converters with DMA transfer. 75 | ### App.DMABuffer 76 | An example for a serial ports with DMA transfer. 77 | ### App.TestLCD 78 | An LCD driver. 79 | This is the original code from the hArduino library 80 | with some very small adaptions. 81 | ### App.WS1228B 82 | A driver for nice colorful RGB LED strips. 83 | (Uses SPI and DMA) 84 | ### App.Serial 85 | Hello world example for serial ports. 86 | 87 | ## Todo 88 | 89 | ## Packages 90 | ### STM32-Zombie 91 | [![Hackage](https://img.shields.io/hackage/v/STM32-Zombie.svg)](http://hackage.haskell.org/package/STM32-Zombie) 92 | 93 | ### STLinkUSB 94 | [![Hackage](https://img.shields.io/hackage/v/STLinkUSB.svg)](http://hackage.haskell.org/package/STLinkUSB) 95 | 96 | The STLinkUSB package contains a Haskell driver for ST-Link USB dongles. 97 | The library is based on information from the openocd library. 98 | The STM32-Zombie package only uses a small subset of the ST-Link features 99 | and only these features of ST-Link protocol are really tested and included 100 | in STLinkUSB. (There is some extra but untested code). 101 | 102 | ### STM32F103xx-SVD 103 | [![Hackage](https://img.shields.io/hackage/v/STM32F103xx-SVD.svg)](http://hackage.haskell.org/package/STM32F103xx-SVD) 104 | 105 | This package contains names and definitions for STM32F103 peripherals, 106 | registers, addresses and the bits of the hardware registers. 107 | It is generated from STM32F103xx.svd. 108 | 109 | ### SVD2HS 110 | [![Hackage](https://img.shields.io/hackage/v/SVD2HS.svg)](http://hackage.haskell.org/package/SVD2HS) 111 | 112 | The compiler that translates a file called STM32F103xx.svd to a set of 113 | Haskell data types and lookup tables. -------------------------------------------------------------------------------- /STLinkUSB/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) Marc Fontaine 2015-2017 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 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 2. Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | 3. Neither the name of the author nor the names of his contributors 14 | may be used to endorse or promote products derived from this software 15 | without specific prior written permission. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' AND 18 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 20 | ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 21 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 23 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 24 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 25 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 26 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 27 | SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /STLinkUSB/README.md: -------------------------------------------------------------------------------- 1 | # STLinkUSB 2 | 3 | ![ST-Link USB dongle](https://i.imgur.com/Y4iEvVt.jpg) 4 | 5 | This package contains a Haskell driver for ST-Link USB dongles. 6 | My use case for this driver is the STM32-Zombie library. 7 | The STM32-Zombie library turns a STM32 micro-controller 8 | into a powerful Haskell-hackable hardware interface. 9 | The library is a based on information from the openocd library. 10 | 11 | ## [Haddock documentation](http://hackage.haskell.org/package/STLinkUSB) 12 | -------------------------------------------------------------------------------- /STLinkUSB/STLinkUSB.cabal: -------------------------------------------------------------------------------- 1 | Name: STLinkUSB 2 | Version: 0.1.2 3 | Category: Hardware, STM32, Microcontroller, Embedded 4 | License-File: LICENSE 5 | Synopsis: STLink USB interface in Haskell 6 | Description: This package contains a Haskell driver for ST-Link USB dongles. 7 | My use case for this driver is the STM32-Zombie library. 8 | The STM32-Zombie library turns a STM32 micro-controller 9 | into a powerful Haskell-hackable hardware interface. 10 | The library is a based on information from the openocd library. 11 | 12 | License: BSD3 13 | Author: 2015-2020 Marc Fontaine 14 | Maintainer: 2015-2020 Marc Fontaine 15 | Stability: Experimental 16 | Tested-With: GHC ==8.6.5 || ==8.4.4 || ==8.2.2 17 | Build-Type: Simple 18 | Cabal-Version: >= 1.24 19 | Homepage: https://github.com/MarcFontaine/stm32hs 20 | Extra-Source-Files: README.md 21 | 22 | Source-Repository head 23 | type: git 24 | location: git://github.com/MarcFontaine/stm32hs.git 25 | 26 | library 27 | default-language : Haskell2010 28 | ghc-options : -Wall 29 | Build-depends : base >= 4.9 && < 5 30 | , bytestring >= 0.10 && < 0.11 31 | , usb >= 1.3 && < 1.4 32 | , vector >= 0.12 && < 0.13 33 | , binary >= 0.8 && < 0.9 34 | , transformers >= 0.5 && < 0.6 35 | Exposed-modules: STM32.STLinkUSB 36 | , STM32.STLinkUSB.Commands 37 | , STM32.STLinkUSB.Env 38 | , STM32.STLinkUSB.USBXfer 39 | , STM32.STLinkUSB.MemRW 40 | , STM32.STLinkUSB.Dongle 41 | , STM32.STLinkUSB.Test 42 | , STM32.STLinkUSB.CortexM 43 | , STM32.STLinkUSB.USBUtils 44 | , STM32.STLinkUSB.TwoBoards 45 | -------------------------------------------------------------------------------- /STLinkUSB/STLinkUSB.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, binary, bytestring, stdenv, transformers, usb 2 | , vector 3 | }: 4 | mkDerivation { 5 | pname = "STLinkUSB"; 6 | version = "0.1.2"; 7 | src = ./.; 8 | libraryHaskellDepends = [ 9 | base binary bytestring transformers usb vector 10 | ]; 11 | homepage = "https://github.com/MarcFontaine/stm32hs"; 12 | description = "STLink USB interface in Haskell"; 13 | license = stdenv.lib.licenses.bsd3; 14 | } 15 | -------------------------------------------------------------------------------- /STLinkUSB/STM32/STLinkUSB.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | ---------------------------------------------------------------------------- 3 | -- | 4 | -- Module : STM32.STLinkUSB 5 | -- Copyright : (c) Marc Fontaine 2017 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Marc.Fontaine@gmx.de 9 | -- Stability : experimental 10 | -- Portability : GHC-only 11 | -- 12 | -- This module exports a small driver for the STLink dongles. 13 | -- The focus of this API is on reading and writing 14 | -- to the memory of and attached STM32 controller. 15 | -- The STM32 architecture use memory mapped IO registers to program 16 | -- IO ports a hardware peripherals. 17 | -- Therefor a STLink dongle with an attached STM32 board in combination with this 18 | -- library makes a nice Haskell-controlled IO extension board. 19 | 20 | 21 | module STM32.STLinkUSB 22 | ( 23 | test 24 | ,STLT 25 | ,STL 26 | ,STLinkEnv 27 | ,runSTLink 28 | ,initDongle 29 | ,resetHalt 30 | ,writeDebugReg 31 | ,writeMem8 32 | ,writeMem32 33 | ,readMem8 34 | ,readMem32 35 | ,LogLevel 36 | ,Logger 37 | ,xfer 38 | ) 39 | where 40 | import STM32.STLinkUSB.Env 41 | import STM32.STLinkUSB.USBXfer 42 | import STM32.STLinkUSB.MemRW 43 | import STM32.STLinkUSB.Dongle 44 | import STM32.STLinkUSB.Test 45 | import STM32.STLinkUSB.CortexM 46 | -------------------------------------------------------------------------------- /STLinkUSB/STM32/STLinkUSB/Commands.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | ---------------------------------------------------------------------------- 3 | -- | 4 | -- Module : STM32.Commands 5 | -- Copyright : (c) Marc Fontaine 2017 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : Marc.Fontaine@gmx.de 9 | -- Stability : experimental 10 | -- Portability : GHC-only 11 | -- 12 | -- The bits, bytes and constants of the STLink protocoll. 13 | -- The constants have been looked up a corresponding driver that is 14 | -- part of the openocd library. 15 | -- Some parts have been added for completeness (but have not been tested so far). 16 | module STM32.STLinkUSB.Commands 17 | where 18 | import qualified Data.ByteString as BS 19 | import qualified Data.ByteString.Lazy as BSL (toStrict) 20 | import Data.Binary 21 | import Data.Binary.Put 22 | import Data.Binary.Get 23 | import Data.Bits 24 | 25 | data Version = Version { 26 | stlink :: Word16 27 | ,jtag :: Word16 28 | ,swim :: Word16 29 | } deriving Show 30 | 31 | instance Binary Version where 32 | put _ = error "Version put not implemented" 33 | get = do 34 | v <- getWord16be 35 | let 36 | stlink = (v `shiftR` 12) .&. 0x0f 37 | jtag = (v `shiftR` 6) .&. 0x3f 38 | swim = v .&. 0x3f 39 | return $ Version {..} 40 | 41 | -- | APIV1 is NOT supported ! Todo remove old APIV1 stuff. 42 | -- | todo 43 | data API = APIV1 | APIV2 44 | deriving (Show,Eq) 45 | 46 | type Addr = Word32 47 | data DebugCmd 48 | = ENTER_JTAG 49 | | GETSTATUS 50 | | FORCEDEBUG 51 | | READMEM_32BIT Addr Word16 52 | | WRITEMEM_32BIT Addr Word16 53 | | RUNCORE 54 | | STEPCORE 55 | | READMEM_8BIT Addr Word16 56 | | WRITEMEM_8BIT Addr Word16 57 | | APIV1_CLEARFP 58 | | APIV1_SETWATCHPOINT 59 | | ENTER_SWD 60 | | EXIT 61 | | READCOREID 62 | | APIV1_SETFP 63 | | ENTER API 64 | | APIV2_READ_IDCODES 65 | | RESETSYS API 66 | | READREG API 67 | | WRITEREG API 68 | | WRITEDEBUGREG API Addr Word32 69 | | APIV2_READDEBUGREG Addr 70 | | READALLREGS API 71 | | GETLASTRWSTATUS 72 | | APIV2_DRIVE_NRST 73 | | APIV2_START_TRACE_RX Word16 Word32 74 | | APIV2_STOP_TRACE_RX 75 | | APIV2_GET_TRACE_NB 76 | | APIV2_SWD_SET_FREQ 77 | | APIV2_DRIVE_NRST_LOW 78 | | APIV2_DRIVE_NRST_HIGH 79 | | APIV2_DRIVE_NRST_PULSE 80 | deriving (Show,Eq) 81 | 82 | instance Binary DebugCmd where 83 | get = error "no Binary get for debugCMD" 84 | put cmd = case cmd of 85 | ENTER_JTAG -> putWord8 0x00 86 | GETSTATUS -> putWord8 0x01 87 | FORCEDEBUG -> putWord8 0x02 88 | READALLREGS APIV1 -> putWord8 0x04 89 | READALLREGS APIV2 -> putWord8 0x3A 90 | READREG APIV1 -> putWord8 0x05 91 | READREG APIV2 -> putWord8 0x33 92 | WRITEREG APIV1 -> putWord8 0x06 93 | WRITEREG APIV2 -> putWord8 0x34 94 | READMEM_32BIT addr len 95 | -> putWord8 0x07 >> putWord32le addr >> putWord16le len 96 | WRITEMEM_32BIT addr len 97 | -> putWord8 0x08 >> putWord32le addr >> putWord16le len 98 | RUNCORE -> putWord8 0x09 99 | STEPCORE -> putWord8 0x0a 100 | APIV1_SETFP -> putWord8 0x0b 101 | READMEM_8BIT addr len 102 | -> putWord8 0x0c >> putWord32le addr >> putWord16le len 103 | WRITEMEM_8BIT addr len 104 | -> putWord8 0x0d >> putWord32le addr >> putWord16le len 105 | APIV1_CLEARFP -> putWord8 0x0e 106 | APIV1_SETWATCHPOINT -> putWord8 0x10 107 | ENTER_SWD -> putWord8 0xa3 108 | (ENTER APIV1) -> putWord8 0x20 109 | EXIT -> putWord8 0x21 110 | READCOREID -> putWord8 0x22 111 | ENTER APIV2 -> putWord8 0x30 112 | APIV2_READ_IDCODES -> putWord8 0x31 113 | (RESETSYS APIV2) -> putWord8 0x32 114 | (RESETSYS APIV1) -> putWord8 0x03 115 | (WRITEDEBUGREG APIV1 w1 w2) 116 | -> putWord8 0x0f >> putWord32le w1 >> putWord32le w2 117 | (WRITEDEBUGREG APIV2 w1 w2) 118 | -> putWord8 0x35 >> putWord32le w1 >> putWord32le w2 119 | APIV2_READDEBUGREG w -> putWord8 0x36 >> putWord32le w 120 | GETLASTRWSTATUS -> putWord8 0x3B 121 | APIV2_DRIVE_NRST -> putWord8 0x3C 122 | APIV2_START_TRACE_RX size speed 123 | -> putWord8 0x40 >> putWord16le size >> putWord32le speed 124 | APIV2_STOP_TRACE_RX -> putWord8 0x41 125 | APIV2_GET_TRACE_NB -> putWord8 0x42 126 | APIV2_SWD_SET_FREQ -> putWord8 0x43 127 | APIV2_DRIVE_NRST_LOW -> putWord8 0x00 128 | APIV2_DRIVE_NRST_HIGH -> putWord8 0x01 129 | APIV2_DRIVE_NRST_PULSE -> putWord8 0x02 130 | 131 | data Cmd 132 | = GET_VERSION 133 | | DEBUG_COMMAND DebugCmd 134 | | DEBUG_COMMANDs [DebugCmd] 135 | | DFU_COMMAND_EXIT 136 | | SWIM_COMMAND SWIM_Cmd 137 | | GET_CURRENT_MODE 138 | | GET_TARGET_VOLTAGE 139 | deriving Show 140 | 141 | data SWIM_Cmd = SWIM_ENTER | SWIM_EXIT 142 | deriving Show 143 | 144 | instance Binary Cmd where 145 | get = error "no Binary get for debugCMD" 146 | put cmd = case cmd of 147 | GET_VERSION -> putWord8 0xF1 148 | DEBUG_COMMAND c -> putWord8 0xF2 >> put c 149 | DEBUG_COMMANDs l 150 | -> putWord8 0xF2 >> mapM_ put l 151 | DFU_COMMAND_EXIT -> putWord8 0xF3 >> putWord8 0x07 152 | (SWIM_COMMAND SWIM_ENTER) -> putWord8 0xF4 >> putWord8 0x00 153 | (SWIM_COMMAND SWIM_EXIT) -> putWord8 0xF4 >> putWord8 0x01 154 | GET_CURRENT_MODE -> putWord8 0xF5 155 | GET_TARGET_VOLTAGE -> putWord8 0xF7 156 | 157 | cmdToByteString :: Cmd -> BS.ByteString 158 | cmdToByteString cmd 159 | = BS.take 16 $ BSL.toStrict $ runPut (put cmd >> padding) 160 | where 161 | padding = putWord64le 0 >> putWord64le 0 162 | 163 | data DevMode 164 | = DEV_DFU_MODE 165 | | DEV_MASS_MODE 166 | | DEV_DEBUG_MODE 167 | | DEV_SWIM_MODE 168 | | DEV_BOOTLOADER_MODE 169 | deriving (Show,Eq,Ord,Enum) 170 | 171 | data Status 172 | = DEBUG_ERR_OK 173 | | DEBUG_ERR_FAULT 174 | | SWD_AP_WAIT 175 | | SWD_AP_FAULT 176 | | SWD_AP_ERROR 177 | | SWD_AP_PARITY_ERROR 178 | | JTAG_WRITE_ERROR 179 | | JTAG_WRITE_VERIF_ERROR 180 | | SWD_DP_WAIT 181 | | SWD_DP_FAULT 182 | | SWD_DP_ERROR 183 | | SWD_DP_PARITY_ERROR 184 | | SWD_AP_WDATA_ERROR 185 | | SWD_AP_STICKY_ERROR 186 | | SWD_AP_STICKYORUN_ERROR 187 | | UnknownStatus Word8 188 | deriving (Show,Eq,Ord) 189 | 190 | toStatus :: Word8 -> Status 191 | toStatus w = case w of 192 | 0x80 -> DEBUG_ERR_OK 193 | 0x81 -> DEBUG_ERR_FAULT 194 | 0x10 -> SWD_AP_WAIT 195 | 0x11 -> SWD_AP_FAULT 196 | 0x12 -> SWD_AP_ERROR 197 | 0x13 -> SWD_AP_PARITY_ERROR 198 | 0x0c -> JTAG_WRITE_ERROR 199 | 0x0d -> JTAG_WRITE_VERIF_ERROR 200 | 0x14 -> SWD_DP_WAIT 201 | 0x15 -> SWD_DP_FAULT 202 | 0x16 -> SWD_DP_ERROR 203 | 0x17 -> SWD_DP_PARITY_ERROR 204 | 0x18 -> SWD_AP_WDATA_ERROR 205 | 0x19 -> SWD_AP_STICKY_ERROR 206 | 0x1a -> SWD_AP_STICKYORUN_ERROR 207 | other -> UnknownStatus other 208 | -------------------------------------------------------------------------------- /STLinkUSB/STM32/STLinkUSB/CortexM.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : STM32.STLinkUSB.CortexM 3 | -- Copyright : (c) Marc Fontaine 2017 4 | -- License : BSD3 5 | -- 6 | -- Maintainer : Marc.Fontaine@gmx.de 7 | -- Stability : experimental 8 | -- Portability : GHC-only 9 | -- 10 | -- Starting and stopping the attached CPU 11 | 12 | module STM32.STLinkUSB.CortexM 13 | where 14 | 15 | import Data.Word 16 | import Data.Bits 17 | import qualified Data.ByteString as BS 18 | import Control.Monad 19 | 20 | import STM32.STLinkUSB.Commands 21 | import STM32.STLinkUSB.Dongle 22 | import STM32.STLinkUSB.Env 23 | import STM32.STLinkUSB.USBXfer 24 | import STM32.STLinkUSB.MemRW 25 | 26 | halt :: STL () 27 | halt = do 28 | debugSTL Info "halting CPU" 29 | api <- asksDongleAPI 30 | case api of 31 | APIV2 -> writeDebugReg _DCB_DHCSR (_DBGKEY .|. _C_HALT .|. _C_DEBUGEN) 32 | APIV1 -> void $ xfer (DEBUG_COMMAND FORCEDEBUG) 33 | 34 | {-- TODO: does this work ? 35 | -- The intended application is to use the micro controller as an IO extension 36 | -- board and write to the hardware register over the SWD interface. 37 | -- It is essential that the micro controller cpu does not interfere, 38 | -- i.e. it is halted. 39 | -- (fancy stuff could be possible by running a custom micro controller firmware) 40 | -} 41 | resetHalt :: STL () 42 | resetHalt = halt >> reset 43 | 44 | run :: STL () 45 | run = do 46 | debugSTL Info "starting CPU" 47 | api <- asksDongleAPI 48 | case api of 49 | APIV2 -> writeDebugReg _DCB_DHCSR (_DBGKEY .|. _C_DEBUGEN) 50 | APIV1 -> void $ xfer (DEBUG_COMMAND RUNCORE) 51 | 52 | readCpuID :: STL BS.ByteString 53 | readCpuID = do 54 | debugSTL Info ("trying to read CPU ID") 55 | cpuID <- readMem32 _CPUID 4 56 | debugSTL Info ("CPU ID : " ++ (show $ BS.unpack cpuID)) 57 | return cpuID 58 | 59 | _CPUID :: Word32 60 | _CPUID = 0xE000ED00 61 | 62 | _DCB_DHCSR :: Word32 63 | _DCB_DCRSR :: Word32 64 | _DCB_DCRDR :: Word32 65 | _DCB_DEMCR :: Word32 66 | 67 | _DCB_DHCSR = 0xE000EDF0 68 | _DCB_DCRSR = 0xE000EDF4 69 | _DCB_DCRDR = 0xE000EDF8 70 | _DCB_DEMCR = 0xE000EDFC 71 | 72 | _DBGKEY :: Word32 73 | _DBGKEY = 0xA05F0000 74 | 75 | _C_DEBUGEN :: Word32 76 | _C_DEBUGEN = 1 77 | _C_HALT :: Word32 78 | _C_HALT = 2 79 | -------------------------------------------------------------------------------- /STLinkUSB/STM32/STLinkUSB/Dongle.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : STM32.STLinkUSB.Dongle 4 | -- Copyright : (c) Marc Fontaine 2017 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Marc.Fontaine@gmx.de 8 | -- Stability : experimental 9 | -- Portability : GHC-only 10 | -- 11 | -- Functions for initializing, reseting and mode-change of the STLink dongle. 12 | 13 | {-# LANGUAGE RankNTypes #-} 14 | module STM32.STLinkUSB.Dongle 15 | where 16 | import Control.Monad 17 | import qualified Data.ByteString as BS 18 | import qualified Data.ByteString.Lazy as BSL (fromStrict) 19 | import Data.Binary 20 | import Data.Binary.Get 21 | import Control.Monad.Trans.Reader 22 | import Control.Monad.IO.Class 23 | import System.USB (Status(..)) 24 | 25 | import STM32.STLinkUSB.Commands 26 | import STM32.STLinkUSB.Env 27 | import STM32.STLinkUSB.USBXfer 28 | 29 | -- | Init the dongle and set debug mode. 30 | -- A Haskell translation of the same function in the openocd library. 31 | 32 | initDongle :: STL () 33 | initDongle = do 34 | debugSTL Debug "starting initDongle" 35 | v <- readVersion 36 | debugSTL Info ("dongle version : " ++ show v) 37 | devMode <- readCurrentMode 38 | case devMode of 39 | DEV_DFU_MODE -> modeLeave MODE_DFU 40 | DEV_DEBUG_MODE -> modeLeave MODE_DEBUG_SWD 41 | DEV_SWIM_MODE -> modeLeave MODE_DEBUG_SWIM 42 | _ -> return () 43 | _nMode <- readCurrentMode 44 | when (_nMode /= DEV_DFU_MODE) $ do 45 | voltage <- readVoltage 46 | debugSTL Info ("dongle voltage : " ++ show voltage) 47 | debugSTL Info "entering SWD Mode // connection to controller" 48 | modeEnter MODE_DEBUG_SWD 49 | newMode <- readCurrentMode 50 | when (newMode /= DEV_DEBUG_MODE) $ do 51 | let err = ("cannot set dongle mode DEV_DEBUG_MODE. Mode is : "++ show newMode) 52 | debugSTL Error err 53 | error err 54 | return () 55 | 56 | reset :: STL () 57 | reset = do 58 | debugSTL Info "resetting dongle" 59 | api <- asks dongleAPI 60 | void $ xferRetry (DEBUG_COMMAND $ RESETSYS api) 61 | 62 | readVersion :: STL Version 63 | readVersion = do 64 | debugSTL Debug "reading dongle version" 65 | msg <- xfer GET_VERSION 66 | return $ decode $ BSL.fromStrict msg 67 | 68 | readVoltage :: STL Float 69 | readVoltage = do 70 | debugSTL Debug "reading dongle voltage" 71 | msg <- xfer GET_TARGET_VOLTAGE 72 | let (a,b) = runGet ((,) <$> getWord32le <*> getWord32le) $ BSL.fromStrict msg 73 | return $ 74 | 2.4 * (realToFrac b) / (realToFrac a) 75 | 76 | readCurrentMode :: STL DevMode 77 | readCurrentMode = do 78 | debugSTL Debug "reading dongle mode" 79 | msg <- xfer GET_CURRENT_MODE 80 | let mode = toEnum $ fromIntegral $ BS.head msg 81 | debugSTL Debug $ "dongle mode : " ++ show mode 82 | return mode 83 | 84 | data Mode 85 | = MODE_DFU 86 | | MODE_MASS 87 | | MODE_DEBUG_JTAG 88 | | MODE_DEBUG_SWD 89 | | MODE_DEBUG_SWIM 90 | deriving (Show,Eq,Ord,Enum) 91 | 92 | modeEnter :: Mode ->STL () 93 | modeEnter mode = do 94 | api <- asks dongleAPI 95 | case mode of 96 | MODE_DEBUG_JTAG -> void $ xferRetry $ DEBUG_COMMANDs [ ENTER api , ENTER_JTAG ] 97 | MODE_DEBUG_SWD -> void $ xferRetry $ DEBUG_COMMANDs [ ENTER api , ENTER_SWD ] 98 | MODE_DEBUG_SWIM -> void $ xferRetry $ SWIM_COMMAND SWIM_ENTER 99 | MODE_DFU -> return () 100 | MODE_MASS -> return () 101 | 102 | modeLeave :: Mode -> STL () 103 | modeLeave mode = do 104 | case mode of 105 | MODE_DEBUG_JTAG -> xferCheck $ DEBUG_COMMAND EXIT 106 | MODE_DEBUG_SWD -> xferCheck $ DEBUG_COMMAND EXIT 107 | MODE_DEBUG_SWIM -> xferCheck $ SWIM_COMMAND SWIM_EXIT 108 | MODE_DFU -> xferCheck $ DFU_COMMAND_EXIT 109 | _ -> return () 110 | where 111 | xferCheck cmd = do 112 | (_ret,err) <- xferStatus cmd 113 | case err of 114 | Right TimedOut -> return () -- this is what happens : timeout 115 | Right Completed -> return () -- this case was not seen 116 | Left usbExcept -> do 117 | let msg = "leaveMode : USB exception : " ++ show usbExcept 118 | debugSTL Error msg 119 | error msg 120 | 121 | writeDebugReg :: Word32 -> Word32 -> STL() 122 | writeDebugReg addr val = do 123 | api <- asks dongleAPI 124 | void $ xfer (DEBUG_COMMAND $ WRITEDEBUGREG api addr val) 125 | 126 | dumpTrace :: STL () 127 | dumpTrace = forever $ do 128 | (msg,err) <- xferReadTrace 129 | liftIO $ print ("trace: ",err,msg) 130 | 131 | -------------------------------------------------------------------------------- /STLinkUSB/STM32/STLinkUSB/Env.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : STM32.STLinkUSB.Env 4 | -- Copyright : (c) Marc Fontaine 2017 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Marc.Fontaine@gmx.de 8 | -- Stability : experimental 9 | -- Portability : GHC-only 10 | -- 11 | -- The STLT Monad is just a reader transformer of STLinkEnv. 12 | 13 | 14 | {-# LANGUAGE RecordWildCards #-} 15 | {-# LANGUAGE RankNTypes #-} 16 | 17 | module STM32.STLinkUSB.Env 18 | where 19 | 20 | import System.USB 21 | import Control.Monad.Trans.Reader 22 | import Control.Monad.IO.Class 23 | 24 | import STM32.STLinkUSB.USBUtils 25 | import STM32.STLinkUSB.Commands (API(..)) 26 | 27 | type STLT m a = ReaderT STLinkEnv m a 28 | type STL a = forall m. MonadIO m => ReaderT STLinkEnv m a 29 | 30 | runSTLink :: STLT IO a -> IO a 31 | runSTLink = runSTLink' defaultDebugLogger . runReaderT 32 | 33 | runSTLink_verbose :: STLT IO a -> IO a 34 | runSTLink_verbose = runSTLink' verboseDebugLogger . runReaderT 35 | 36 | runSTLink' :: Logger -> (STLinkEnv -> IO a) -> IO a 37 | runSTLink' logger action = do 38 | usb <- findDefaultEndpoints 39 | runSTLinkWith logger usb action 40 | 41 | runSTLinkWith :: 42 | Logger 43 | -> (Ctx, Device, EndpointAddress, EndpointAddress, EndpointAddress) 44 | -> (STLinkEnv -> IO a) 45 | -> IO a 46 | runSTLinkWith 47 | debugLogger 48 | (usbCtx, device, rxEndpoint, txEndpoint, traceEndpoint) 49 | action 50 | = withUSB device $ \deviceHandle -> (action STLinkEnv {..}) 51 | where 52 | dongleAPI = APIV2 53 | 54 | data STLinkEnv = STLinkEnv { 55 | usbCtx :: Ctx 56 | ,rxEndpoint :: EndpointAddress 57 | ,txEndpoint :: EndpointAddress 58 | ,traceEndpoint :: EndpointAddress 59 | ,deviceHandle :: DeviceHandle 60 | ,dongleAPI :: API 61 | ,debugLogger :: Logger 62 | } 63 | 64 | asksDongleAPI :: STL API 65 | asksDongleAPI = asks dongleAPI 66 | 67 | data LogLevel = Debug | Info | Warn | Error deriving (Show,Eq,Ord) 68 | type Logger = LogLevel -> String -> IO () 69 | 70 | debugSTL :: LogLevel -> String -> STL () 71 | debugSTL ll msg = do 72 | logger <- asks debugLogger 73 | liftIO $ logger ll msg 74 | 75 | defaultDebugLogger :: Logger 76 | defaultDebugLogger logLevel msg = case logLevel of 77 | Debug -> return () 78 | Info -> return () 79 | _ -> putStrLn (show logLevel ++ " : " ++ msg ) 80 | 81 | verboseDebugLogger :: Logger 82 | verboseDebugLogger logLevel msg 83 | = putStrLn (show logLevel ++ " : " ++ msg ) 84 | -------------------------------------------------------------------------------- /STLinkUSB/STM32/STLinkUSB/MemRW.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : STM32.STLinkUSB.MemRW 4 | -- Copyright : (c) Marc Fontaine 2017 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Marc.Fontaine@gmx.de 8 | -- Stability : experimental 9 | -- Portability : GHC-only 10 | -- 11 | -- Read and Write to the memory of an attached STM32 controller. 12 | 13 | {-# LANGUAGE RankNTypes #-} 14 | module STM32.STLinkUSB.MemRW 15 | where 16 | import Control.Monad 17 | import qualified Data.ByteString as BS 18 | import Data.Binary 19 | import Control.Monad.Trans.Reader 20 | 21 | import STM32.STLinkUSB.Commands 22 | import STM32.STLinkUSB.Env 23 | import STM32.STLinkUSB.USBXfer 24 | 25 | checkRWStatus :: STL () 26 | checkRWStatus = do 27 | api <- asks dongleAPI 28 | case api of 29 | APIV1 -> return () 30 | APIV2 -> do 31 | msg <- xfer (DEBUG_COMMAND GETLASTRWSTATUS) 32 | let dongleStatus = toStatus $ BS.head msg 33 | if (dongleStatus == DEBUG_ERR_OK) 34 | then return () 35 | else do 36 | let err = show ("checkRWStatus", dongleStatus) 37 | debugSTL Error err 38 | error err 39 | 40 | maxTransferBlocksize :: Word16 41 | maxTransferBlocksize = 64 42 | 43 | newtype TransferBlock 44 | = TransferBlock {_unTransferBlock :: BS.ByteString} deriving Show 45 | 46 | unsafeToTransferBlock :: BS.ByteString -> TransferBlock 47 | unsafeToTransferBlock bs 48 | = if len <= fromIntegral maxTransferBlocksize 49 | then TransferBlock bs 50 | else error msg 51 | where 52 | msg = "unsafeToTransferBlock :" ++ show len ++ "> maxTransferBlockSize" 53 | len = BS.length bs 54 | 55 | newtype TransferLen = TransferLen {_unTransferLen :: Word16} deriving Show 56 | 57 | unsafeToTransferLen :: Word16 -> TransferLen 58 | unsafeToTransferLen len 59 | = if len <= maxTransferBlocksize 60 | then TransferLen len 61 | else error msg 62 | where 63 | msg = "unsafeToTransferLen :" ++ show len ++ "> maxTransferBlocksize" 64 | 65 | writeMem8' :: Addr -> TransferBlock -> STL () 66 | writeMem8' addr (TransferBlock block) = do 67 | void $ xferBulkWrite (DEBUG_COMMAND $ WRITEMEM_8BIT addr len) block 68 | checkRWStatus 69 | where 70 | len = fromIntegral $ BS.length block 71 | 72 | writeMem32' :: Addr -> TransferBlock -> STL () 73 | writeMem32' addr (TransferBlock block) = do 74 | void $ xferBulkWrite (DEBUG_COMMAND $ WRITEMEM_32BIT addr len) block 75 | checkRWStatus 76 | where 77 | len = fromIntegral $ BS.length block 78 | 79 | readMem8' :: Addr -> TransferLen -> STL BS.ByteString 80 | readMem8' addr (TransferLen len) = do 81 | bs <- xfer (DEBUG_COMMAND $ READMEM_8BIT addr len) 82 | checkRWStatus 83 | return bs 84 | 85 | readMem32' :: Addr -> TransferLen -> STL BS.ByteString 86 | readMem32' addr (TransferLen len) = do 87 | bs <- xfer (DEBUG_COMMAND $ READMEM_32BIT addr len) 88 | checkRWStatus 89 | return bs 90 | 91 | writeMem8 :: Addr -> BS.ByteString -> STL () 92 | writeMem8 = writeChunks writeMem8' 93 | 94 | writeMem32 :: Addr -> BS.ByteString -> STL () 95 | writeMem32 = writeChunks writeMem32' 96 | 97 | writeChunks 98 | :: (Addr -> TransferBlock -> STL () ) -> Addr -> BS.ByteString -> STL () 99 | writeChunks action addr bs 100 | = forM_ (chunkBS addr bs) $ uncurry action 101 | 102 | 103 | chunkBS :: Addr -> BS.ByteString -> [(Addr,TransferBlock)] 104 | chunkBS addr bs 105 | = if BS.length bs <= chunkSize 106 | then [h] 107 | else h : (chunkBS (addr + fromIntegral chunkSize) 108 | (BS.drop chunkSize bs)) 109 | where 110 | h = (addr, unsafeToTransferBlock $ BS.take chunkSize bs) 111 | chunkSize = fromIntegral maxTransferBlocksize 112 | 113 | chunkAddr :: Addr -> Int -> [(Addr,TransferLen)] 114 | chunkAddr addr len 115 | = if len <= chunkSize 116 | then [h] 117 | else h : (chunkAddr (addr + fromIntegral chunkSize) 118 | (len - chunkSize)) 119 | where 120 | h = (addr, unsafeToTransferLen 121 | (min (fromIntegral len) (fromIntegral maxTransferBlocksize))) 122 | chunkSize = fromIntegral maxTransferBlocksize 123 | 124 | readChunks 125 | :: (Addr -> TransferLen -> STL BS.ByteString ) 126 | -> Addr -> Int -> STL BS.ByteString 127 | readChunks action addr len 128 | = liftM BS.concat $ forM (chunkAddr addr len) $ uncurry action 129 | 130 | readMem8 :: Addr -> Int -> STL BS.ByteString 131 | readMem8 = readChunks readMem8' 132 | 133 | readMem32 :: Addr -> Int -> STL BS.ByteString 134 | readMem32 = readChunks readMem32' 135 | -------------------------------------------------------------------------------- /STLinkUSB/STM32/STLinkUSB/Test.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : STM32.STLinkUSB.Test 4 | -- Copyright : (c) Marc Fontaine 2017 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Marc.Fontaine@gmx.de 8 | -- Stability : experimental 9 | -- Portability : GHC-only 10 | -- 11 | -- Test the connetion to the STLink dongle 12 | -- and read the CPU ID of the attached controller. 13 | 14 | {-# LANGUAGE RankNTypes #-} 15 | module STM32.STLinkUSB.Test 16 | where 17 | 18 | import STM32.STLinkUSB.Env 19 | import STM32.STLinkUSB.Dongle 20 | import STM32.STLinkUSB.CortexM 21 | 22 | -- | Test the dongle and connection to the board. 23 | -- This test fails if no board is attached 24 | test :: IO () 25 | test = runSTLink_verbose $ do 26 | initDongle 27 | _<-readCpuID 28 | return () 29 | -------------------------------------------------------------------------------- /STLinkUSB/STM32/STLinkUSB/TwoBoards.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : STM32.STLinkUSB.TwoBoards 4 | -- Copyright : (c) Marc Fontaine 2017 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Marc.Fontaine@gmx.de 8 | -- Stability : experimental 9 | -- Portability : GHC-only 10 | -- 11 | -- Using two Boards/Dongles in parallel. 12 | 13 | {-# LANGUAGE RecordWildCards #-} 14 | {-# LANGUAGE RankNTypes #-} 15 | 16 | module STM32.STLinkUSB.TwoBoards 17 | where 18 | 19 | import System.USB 20 | import Control.Monad.Trans.Reader 21 | import Control.Monad.IO.Class 22 | 23 | import STM32.STLinkUSB.USBUtils 24 | import STM32.STLinkUSB.Env 25 | import STM32.STLinkUSB.Commands 26 | import STM32.STLinkUSB.Dongle 27 | import STM32.STLinkUSB.CortexM 28 | 29 | type STLTT m a = ReaderT (STLinkEnv,STLinkEnv) m a 30 | 31 | runSTLinkAB :: STLTT IO a -> IO a 32 | runSTLinkAB 33 | = runSTLinkAB' (defaultDebugLogger, defaultDebugLogger) 34 | . runReaderT 35 | 36 | runSTLinkAB_verbose :: STLTT IO a -> IO a 37 | runSTLinkAB_verbose 38 | = runSTLinkAB' (verboseDebugLogger, verboseDebugLogger) 39 | . runReaderT 40 | 41 | runSTLinkAB' :: 42 | (Logger,Logger) 43 | -> ((STLinkEnv,STLinkEnv) -> IO a) 44 | -> IO a 45 | runSTLinkAB' (loggerA,loggerB) action = do 46 | ctx <- newCtx 47 | setDebug ctx PrintWarnings 48 | list <- findUSBDevices ctx defaultSTLProductID 49 | let (deviceA,deviceB) = case list of 50 | [] -> error "no STLink dongle found" 51 | [_] -> error "just one STLink dongle found" 52 | [a,b] -> (a,b) 53 | (_:_:_:_) -> error "more two one STLink dongle found" 54 | (_,_,rxA,txA,traceA) <- findEndpoints ctx deviceA 55 | (_,_,rxB,txB,traceB) <- findEndpoints ctx deviceB 56 | let 57 | preEnvA handleA = STLinkEnv { 58 | usbCtx = ctx 59 | ,rxEndpoint = rxA 60 | ,txEndpoint = txA 61 | ,traceEndpoint = traceA 62 | ,deviceHandle = handleA 63 | ,dongleAPI = APIV2 64 | ,debugLogger = taggedLogger "A" loggerA 65 | } 66 | preEnvB handleB = STLinkEnv { 67 | usbCtx = ctx 68 | ,rxEndpoint = rxB 69 | ,txEndpoint = txB 70 | ,traceEndpoint = traceB 71 | ,deviceHandle = handleB 72 | ,dongleAPI = APIV2 73 | ,debugLogger = taggedLogger "B" loggerB 74 | } 75 | runSTLinkWithAB (deviceA,deviceB) (preEnvA,preEnvB) action 76 | 77 | runSTLinkWithAB :: 78 | (Device, Device) 79 | -> ((DeviceHandle -> STLinkEnv), (DeviceHandle -> STLinkEnv)) 80 | -> ((STLinkEnv, STLinkEnv) -> IO a) 81 | -> IO a 82 | runSTLinkWithAB (deviceA, deviceB) (preEnvA, preEnvB) action 83 | = withUSB deviceA $ \deviceHandleA -> 84 | withUSB deviceB $ \deviceHandleB -> 85 | (action (preEnvA deviceHandleA, preEnvB deviceHandleB)) 86 | 87 | taggedLogger :: String -> Logger -> Logger 88 | taggedLogger tag logger loglevel msg 89 | = logger loglevel (tag++":"++msg) 90 | 91 | 92 | boardA :: STLT IO a -> STLTT IO a 93 | boardA action = do 94 | env <- asks fst 95 | liftIO $ (runReaderT action) env 96 | 97 | boardB :: STLT IO a -> STLTT IO a 98 | boardB action = do 99 | env <- asks snd 100 | liftIO $ (runReaderT action) env 101 | 102 | testTwoBoards :: IO () 103 | testTwoBoards = runSTLinkAB_verbose $ do 104 | boardA $ initDongle 105 | _<-boardA $ readCpuID 106 | boardB $ initDongle 107 | -------------------------------------------------------------------------------- /STLinkUSB/STM32/STLinkUSB/USBUtils.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : STM32.STLinkUSB.USBUtils 4 | -- Copyright : (c) Marc Fontaine 2017 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Marc.Fontaine@gmx.de 8 | -- Stability : experimental 9 | -- Portability : GHC-only 10 | -- 11 | -- This module contains low-level functions for initializing the USB connection. 12 | -- In most setups 'STM32.STLinkUSB.Env.runSTLink' does all the work 13 | -- and there is no need to include this module. 14 | 15 | module STM32.STLinkUSB.USBUtils 16 | where 17 | import qualified Data.Vector as Vector 18 | import System.USB 19 | import Control.Monad 20 | 21 | findDefaultEndpoints 22 | :: IO (Ctx, Device, EndpointAddress, EndpointAddress, EndpointAddress) 23 | findDefaultEndpoints = do 24 | ctx <- newCtx 25 | setDebug ctx PrintWarnings 26 | list <- findUSBDevices ctx defaultSTLProductID 27 | let device = case list of 28 | [x] -> x 29 | [] -> error "no STLink dongle found" 30 | (_:_:_) -> error "more than one STLink dongle found" 31 | 32 | findEndpoints ctx device 33 | 34 | findUSBDevices :: 35 | Ctx -> ProductId -> IO [Device] 36 | findUSBDevices ctx stlProductID = do 37 | devices <- fmap Vector.toList $ getDevices ctx 38 | flip filterM devices $ \ device -> do 39 | descr <- getDeviceDesc device 40 | return (deviceProductId descr == stlProductID) 41 | 42 | defaultSTLProductID :: ProductId 43 | defaultSTLProductID = 0x3748 44 | 45 | findEndpoints :: 46 | Ctx -> Device 47 | -> IO (Ctx, Device, EndpointAddress, EndpointAddress, EndpointAddress) 48 | findEndpoints ctx device = do 49 | config <- getConfigDesc device 0 50 | let 51 | endPoints = interfaceEndpoints 52 | $ Vector.head $ Vector.head $ configInterfaces config 53 | rxEndpoint = endpointAddress $ endPoints Vector.! 0 54 | txEndpoint = endpointAddress $ endPoints Vector.! 1 55 | traceEndpoint = endpointAddress $ endPoints Vector.! 2 56 | return (ctx, device, rxEndpoint, txEndpoint, traceEndpoint) 57 | 58 | withUSB :: Device -> (DeviceHandle -> IO a) -> IO a 59 | withUSB device action 60 | = withDeviceHandle device $ 61 | \deviceHandle -> withDetachedKernelDriver deviceHandle 0 62 | $ action deviceHandle 63 | 64 | usbReadTimeout :: Int 65 | usbReadTimeout = 1000 66 | 67 | usbWriteTimeout :: Int 68 | usbWriteTimeout = 100 69 | -------------------------------------------------------------------------------- /STLinkUSB/STM32/STLinkUSB/USBXfer.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : STM32.STLinkUSB.USBXfer 4 | -- Copyright : (c) Marc Fontaine 2017 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Marc.Fontaine@gmx.de 8 | -- Stability : experimental 9 | -- Portability : GHC-only 10 | -- This module contains low-level functions for USB data transfers. 11 | -- Don't use theses functions directly, the prefered API is the MemRW module. 12 | 13 | {-# LANGUAGE RecordWildCards #-} 14 | {-# LANGUAGE RankNTypes #-} 15 | module STM32.STLinkUSB.USBXfer 16 | where 17 | 18 | import System.USB 19 | import Control.Monad.Trans.Reader 20 | import Control.Monad.IO.Class 21 | import Control.Concurrent (threadDelay) 22 | import Control.Exception (catch) 23 | 24 | import qualified Data.ByteString as BS 25 | 26 | import STM32.STLinkUSB.Commands 27 | import STM32.STLinkUSB.Env 28 | import STM32.STLinkUSB.USBUtils 29 | 30 | data XferStatus 31 | = XferOK 32 | | XferRetry 33 | | XferDongleError 34 | | XferUSBError (Either USBException System.USB.Status) 35 | deriving (Show,Eq) 36 | 37 | writeBulkSTL :: Cmd -> STL (Size, System.USB.Status) 38 | writeBulkSTL cmd 39 | = ReaderT $ \STLinkEnv {..} -> liftIO 40 | $ writeBulk deviceHandle txEndpoint (cmdToByteString cmd) usbWriteTimeout 41 | 42 | readBulkSTL :: STL (BS.ByteString, Either USBException System.USB.Status) 43 | readBulkSTL = ReaderT $ \STLinkEnv {..} -> do 44 | let readAction = do 45 | (r,s) <- readBulk deviceHandle rxEndpoint 64 usbReadTimeout 46 | return (r,Right s) 47 | liftIO $ catch readAction handler 48 | where 49 | handler e = return (BS.empty,Left e) 50 | 51 | xferStatus :: Cmd -> STL (BS.ByteString, Either USBException System.USB.Status) 52 | xferStatus cmd = do 53 | debugSTL Debug $ show ("xferStatus write :",cmd) 54 | writeResult <- writeBulkSTL cmd 55 | debugSTL Debug $ show ("xferStatus writeResult :",cmd,writeResult) 56 | (retMsg,retStatus) <- readBulkSTL 57 | debugSTL Debug $ show ("xferStatus readResult : ",retStatus,BS.unpack retMsg) 58 | return (retMsg,retStatus) 59 | 60 | xferBulkWrite :: Cmd -> BS.ByteString -> STL () 61 | xferBulkWrite cmd block = do 62 | writeResult1 <- writeBulkSTL cmd 63 | debugSTL Debug $ show ("xferBulkWrite : ",cmd,writeResult1) 64 | writeResult2 <- ReaderT $ \STLinkEnv {..} -> do 65 | liftIO $ writeBulk deviceHandle txEndpoint block usbWriteTimeout 66 | debugSTL Debug $ show ("xferBulkWrite result : ",writeResult2) 67 | 68 | xfer :: Cmd -> STL BS.ByteString 69 | xfer cmd = do 70 | (ret,err) <- xferStatus cmd 71 | case err of 72 | Right Completed -> return ret 73 | Right TimedOut -> do 74 | let msg = "xfer (" ++ show cmd ++ ") : timeout" 75 | debugSTL Error msg 76 | error msg 77 | Left usbExcept -> do 78 | let msg = "xfer : USB exception : " ++ show usbExcept 79 | debugSTL Error msg 80 | error msg 81 | 82 | -- todo xferRetry is expected to fail 83 | -- it should not throw an exception but return an error 84 | xferRetry :: Cmd -> STL BS.ByteString 85 | xferRetry cmd = loop 8 10000 86 | where 87 | exit :: Show x => x -> STL BS.ByteString 88 | exit x = do 89 | debugSTL Error (show x) 90 | error $ show x 91 | 92 | loop :: Int -> Int -> STL BS.ByteString 93 | loop 0 _ = exit ("xferRetry giving up after retry:", cmd) 94 | loop n d = do 95 | (msg,usbStatus) <- xferStatus cmd 96 | case usbStatus of 97 | Left err -> exit ("xferRetry usb error ",err) -- todo 98 | Right Completed -> case toStatus $ BS.head msg of 99 | SWD_AP_WAIT -> retry 100 | SWD_DP_WAIT -> retry 101 | DEBUG_ERR_OK -> return msg 102 | dongleStatus -> exit ("xferRetry dongle error ",dongleStatus) 103 | Right other -> exit ("xferRetry usb error ",other) 104 | where 105 | retry = do 106 | debugSTL Warn ("xferRetry retry after delay ("++ show cmd ++")") 107 | liftIO $ threadDelay d 108 | loop (n-1) (d*2) 109 | 110 | xferReadTrace :: STL (BS.ByteString, Either USBException System.USB.Status) 111 | xferReadTrace = do 112 | debugSTL Debug $ show "xferReadTrace" 113 | (retMsg,retStatus) <- readBulkSTL 114 | debugSTL Debug $ show ("xferReadTrace return : ",retStatus,BS.unpack retMsg) 115 | return (retMsg,retStatus) 116 | -------------------------------------------------------------------------------- /STLinkUSB/Setup.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | import Distribution.Simple 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /STLinkUSB/default.nix: -------------------------------------------------------------------------------- 1 | { compiler ? "ghc865" 2 | , haddock ? false 3 | , test ? false 4 | , benchmarks ? false 5 | , pkgs ? import {} 6 | }: 7 | with builtins; 8 | let 9 | 10 | lib = pkgs.haskell.lib; 11 | callPackage = pkgs.haskell.packages.${compiler}.callPackage; 12 | 13 | doHaddock = if haddock 14 | then lib.doHaddock 15 | else lib.dontHaddock; 16 | doTest = if test 17 | then lib.doCheck 18 | else lib.dontCheck; 19 | doBench = if benchmarks 20 | then lib.doBenchmark 21 | else pkgs.lib.id; 22 | in 23 | { 24 | stlinkusb=doHaddock(doTest(doBench( callPackage ./STLinkUSB.nix {} ))); 25 | } 26 | -------------------------------------------------------------------------------- /STM32-Zombie/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) Marc Fontaine 2015-2017 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 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 2. Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | 3. Neither the name of the author nor the names of his contributors 14 | may be used to endorse or promote products derived from this software 15 | without specific prior written permission. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' AND 18 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 20 | ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 21 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 23 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 24 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 25 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 26 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 27 | SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /STM32-Zombie/STM32-Zombie.cabal: -------------------------------------------------------------------------------- 1 | Name: STM32-Zombie 2 | Version: 0.2.0.1 3 | Category: STM32, Hardware, Microcontroller, Embedded 4 | License-File: LICENSE 5 | Synopsis: control a STM32F103 microcontroller 6 | Description: 7 | The STM32-Zombie library turns a STM32F103 board into a 8 | powerful Haskell hackable IO adapter. 9 | Features are GPIO pins, serial ports, SPI ports, DMA ADC, timers,.. 10 | The library is modeled after the STMicroelectronics 11 | STM32F10x Firmware Library but does not rely on any c-code or 12 | cross-compilation 13 | STM32-Zombie has a low-level interface, which 14 | allows one to control many details of the micro controller hardware 15 | and can also be used to build higher level abstraction. 16 | See the "App.Blink" module 17 | and the [github page](https://github.com/MarcFontaine/stm32hs) 18 | 19 | Copyright: 2015-2020 Marc Fontaine 20 | Maintainer: Marc Fontaine 21 | License: BSD3 22 | Stability: Experimental 23 | Tested-With: GHC ==8.6.5 || ==8.4.4 || ==8.2.2 24 | Author: Marc Fontaine 25 | Build-Type: Simple 26 | Cabal-Version: >= 1.24 27 | 28 | Source-Repository head 29 | type: git 30 | location: git://github.com/MarcFontaine/stm32hs 31 | 32 | library 33 | default-language : Haskell2010 34 | ghc-options : -Wall 35 | build-depends : base >= 4 && < 5 36 | , bytestring 37 | , transformers 38 | , containers 39 | , binary 40 | , STM32F103xx-SVD <0.2 41 | , STLinkUSB <0.2 42 | 43 | hs-source-dirs: src 44 | exposed-modules: 45 | STM32.API 46 | , STM32.MachineInterfaceSTLinkUSB 47 | , STM32.MachineInterface 48 | , STM32.Utils 49 | , STM32.GPIO 50 | , STM32.USART 51 | , STM32.RTC 52 | , STM32.RCC 53 | , STM32.PWR 54 | , STM32.DMA 55 | , STM32.ADC 56 | , STM32.SPI 57 | , STM32.I2C 58 | , STM32.DAC 59 | , STM32.Timer 60 | , App.Blink 61 | , App.Serial 62 | , App.ADC 63 | , App.TimerDMA 64 | , App.RealTimeClock 65 | , App.Stepper 66 | , App.LCD 67 | , App.TestLCD 68 | , App.DMABuffer 69 | , App.WS1228B 70 | , App.TLC5947 71 | -------------------------------------------------------------------------------- /STM32-Zombie/STM32-Zombie.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, binary, bytestring, containers, stdenv 2 | , STLinkUSB, STM32F103xx-SVD, transformers 3 | }: 4 | mkDerivation { 5 | pname = "STM32-Zombie"; 6 | version = "0.2.0.1"; 7 | src = ./.; 8 | libraryHaskellDepends = [ 9 | base binary bytestring containers STLinkUSB STM32F103xx-SVD 10 | transformers 11 | ]; 12 | description = "control a STM32F103 microcontroller"; 13 | license = stdenv.lib.licenses.bsd3; 14 | } 15 | -------------------------------------------------------------------------------- /STM32-Zombie/Setup.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | import Distribution.Simple 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /STM32-Zombie/cabal.config: -------------------------------------------------------------------------------- 1 | allow-newer: True -------------------------------------------------------------------------------- /STM32-Zombie/default.nix: -------------------------------------------------------------------------------- 1 | { compiler ? "ghc865" 2 | , haddock ? false 3 | , test ? false 4 | , benchmarks ? false 5 | , pkgs ? import {} 6 | }: 7 | with builtins; 8 | let 9 | 10 | lib = pkgs.haskell.lib; 11 | callPackage = pkgs.haskell.packages.${compiler}.callPackage; 12 | 13 | doHaddock = if haddock 14 | then lib.doHaddock 15 | else lib.dontHaddock; 16 | doTest = if test 17 | then lib.doCheck 18 | else lib.dontCheck; 19 | doBench = if benchmarks 20 | then lib.doBenchmark 21 | else pkgs.lib.id; 22 | in 23 | { 24 | STM32-Zombie=doHaddock(doTest(doBench( callPackage ./STM32-Zombie.nix {} ))); 25 | } 26 | -------------------------------------------------------------------------------- /STM32-Zombie/src/App/ADC.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : App.ADC 4 | -- Copyright : (c) Marc Fontaine 2017 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Marc.Fontaine@gmx.de 8 | -- Stability : experimental 9 | -- Portability : GHC-only 10 | -- 11 | -- This module shows an example for using the analog digital converter. 12 | -- The ADC of the STM32 works best in combination with DMA transfers. 13 | -- This example turns the STM32 into a small digital storage oscilloscope. 14 | -- Thanks to DMA transfers, one can sample with precise timings 15 | -- and sampling rate is not limited by the speed of the Haskell code. 16 | 17 | module App.ADC 18 | where 19 | import Control.Monad 20 | import Control.Monad.IO.Class 21 | 22 | import STM32.API 23 | import STM32.DMA as DMA 24 | import STM32.GPIO as GPIO 25 | import STM32.ADC as ADC 26 | 27 | import qualified Data.ByteString.Lazy as BSL (fromStrict) 28 | import Data.Binary 29 | import Data.Binary.Get 30 | 31 | 32 | -- this is buggy the channels get mixed up from time to time 33 | -- maybe DMA out of sync 34 | adc3channel :: IO () 35 | adc3channel = runMI $ do 36 | initMI 37 | resetHalt 38 | setDefaultClocks 39 | 40 | peripheralClockOn GPIOA 41 | GPIO.pinMode (GPIOA,Pin_1) InputAnalog 42 | GPIO.pinMode (GPIOA,Pin_3) InputAnalog 43 | GPIO.pinMode (GPIOA,Pin_5) InputAnalog 44 | 45 | let overSampling :: Num x => x 46 | overSampling = 8 47 | bufferSize :: Num x => x 48 | bufferSize = overSampling * 2 *3 49 | dmaCount = overSampling *3 50 | let dmaBuffer = 0x20001000 51 | dmaConfig = DMA.Config { 52 | _BufferSize = dmaCount 53 | ,_Direction = PeripheralSRC 54 | ,_MemoryBaseAddr = dmaBuffer 55 | ,_MemoryDataSize = HalfWord 56 | ,_MemoryInc = True 57 | ,DMA._Mode = Circular 58 | ,_PeripheralBaseAddr = regToAddr ADC1 DR 59 | ,_PeripheralDataSize = HalfWord 60 | ,_PeripheralInc = False 61 | ,_Priority = High 62 | } 63 | 64 | peripheralClockOn DMA1 65 | DMA.deInit DMA1_Channel1 66 | DMA.init DMA1_Channel1 dmaConfig 67 | DMA.enable DMA1_Channel1 68 | 69 | let adcConfig = ADC.Config { 70 | ADC._Mode = Independent 71 | ,_ScanConvMode = True 72 | ,_ContinuousConvMode = True 73 | ,_ExternalTrigConv = ExternalTrigConv_None 74 | ,_DataAlign = AlignRight 75 | ,_NbrOfChannel = 3 76 | } 77 | peripheralClockOn ADC1 78 | ADC.init ADC1 adcConfig 79 | 80 | ADC.regularChannelConfig ADC1 Channel_1 1 SampleTime_71Cycles5 81 | ADC.regularChannelConfig ADC1 Channel_3 2 SampleTime_71Cycles5 82 | ADC.regularChannelConfig ADC1 Channel_5 3 SampleTime_71Cycles5 83 | 84 | ADC.dmaCmd ADC1 True 85 | ADC.cmd ADC1 True 86 | -- todo : implement calibration 87 | ADC.softwareStartConvCmd ADC1 True 88 | 89 | forever $ do 90 | buffer <- readMem8 dmaBuffer bufferSize 91 | let 92 | vals :: [(Word16,Word16,Word16)] 93 | vals = runGet 94 | ( replicateM overSampling 95 | ((,,) <$> getWord16le <*> getWord16le <*> getWord16le) 96 | ) 97 | (BSL.fromStrict buffer) 98 | average sel = (fromIntegral $ sum $ map sel vals) * 100 `div` overSampling 99 | w1 :: Int 100 | w1 = average (\(x,_,_) -> x) 101 | w2 :: Int 102 | w2 = average (\(_,x,_) -> x) 103 | w3 :: Int 104 | w3 = average (\(_,_,x) -> x) 105 | {- 106 | when some input pin is connect to a poti while some 107 | neighboring inputs are left floating 108 | the floating ones do not "float" randomely 109 | floating inputs are pulled by the poti 110 | -} 111 | print' (w1,w2,w3) 112 | delay 100000 113 | 114 | -- | Periodically sample a block of data and write it to a file. 115 | -- In combination with a wave-form viewer that can detect file updates, 116 | -- this works as a poor mans' digital storage oscilloscope. 117 | sampleBlock :: FilePath -> IO () 118 | sampleBlock filename = runMI $ do 119 | initMI 120 | resetHalt 121 | setDefaultClocks 122 | 123 | peripheralClockOn GPIOA 124 | GPIO.pinMode (GPIOA,Pin_1) InputAnalog 125 | 126 | let samples :: Num x => x 127 | samples = 1000 128 | bufferSize :: Num x => x 129 | bufferSize = samples *2 130 | let dmaBuffer = 0x20001000 131 | dmaConfig = DMA.Config { 132 | _BufferSize = samples 133 | ,_Direction = PeripheralSRC 134 | ,_MemoryBaseAddr = dmaBuffer 135 | ,_MemoryDataSize = HalfWord 136 | ,_MemoryInc = True 137 | ,DMA._Mode = Circular 138 | ,_PeripheralBaseAddr = regToAddr ADC1 DR 139 | ,_PeripheralDataSize = HalfWord 140 | ,_PeripheralInc = False 141 | ,_Priority = High 142 | } 143 | 144 | peripheralClockOn DMA1 145 | DMA.deInit DMA1_Channel1 146 | DMA.init DMA1_Channel1 dmaConfig 147 | DMA.enable DMA1_Channel1 148 | 149 | let adcConfig = ADC.Config { 150 | ADC._Mode = Independent 151 | ,_ScanConvMode = True 152 | ,_ContinuousConvMode = True 153 | ,_ExternalTrigConv = ExternalTrigConv_None 154 | ,_DataAlign = AlignRight 155 | ,_NbrOfChannel = 1 156 | } 157 | peripheralClockOn ADC1 158 | ADC.init ADC1 adcConfig 159 | 160 | ADC.regularChannelConfig ADC1 Channel_1 1 SampleTime_239Cycles5 161 | -- ADC.regularChannelConfig ADC1 Channel_3 2 SampleTime_71Cycles5 162 | -- ADC.regularChannelConfig ADC1 Channel_5 3 SampleTime_71Cycles5 163 | 164 | ADC.dmaCmd ADC1 True 165 | ADC.cmd ADC1 True 166 | -- todo : implement calibration 167 | ADC.softwareStartConvCmd ADC1 True 168 | 169 | liftIO $ putStrLn "sampling" 170 | delay 1000000 171 | liftIO $ putStrLn "sampling OK" 172 | buffer <- readMem8 dmaBuffer bufferSize 173 | let 174 | vals :: [(Int,Word16)] 175 | vals = zip [0..] $ runGet (replicateM samples $ 176 | (getWord16le) 177 | ) 178 | $ BSL.fromStrict buffer 179 | out = concat $ map (\(idx,val) -> (show idx ++"," ++ show val ++ "\n")) vals 180 | liftIO $ writeFile filename out 181 | 182 | -------------------------------------------------------------------------------- /STM32-Zombie/src/App/Blink.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : App.Blink 4 | -- Copyright : (c) Marc Fontaine 2017 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Marc.Fontaine@gmx.de 8 | -- Stability : experimental 9 | -- Portability : GHC-only 10 | -- 11 | -- The HelloWorld of microcontroller programming: A blinking LED. 12 | 13 | module App.Blink 14 | where 15 | import Control.Monad 16 | 17 | import STM32.API 18 | import STM32.GPIO as GPIO 19 | 20 | blink :: IO () 21 | blink = runMI $ blinkLED (GPIOC,Pin_13) 22 | 23 | blinkLED :: Wire -> MI () 24 | blinkLED led = do 25 | initMI 26 | resetHalt 27 | let (port,_) = led 28 | peripheralClockOn port 29 | pinMode led $ GPOutPushPull MHz_2 30 | forever $ do 31 | pinHigh led 32 | delay 500000 33 | pinLow led 34 | delay 500000 35 | -------------------------------------------------------------------------------- /STM32-Zombie/src/App/DMABuffer.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : App.DMABuffer 4 | -- Copyright : (c) Marc Fontaine 2017 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Marc.Fontaine@gmx.de 8 | -- Stability : experimental 9 | -- Portability : GHC-only 10 | -- 11 | -- In this example, the controller reads chars from the USART 12 | -- and writes them to a RAM buffer using DMA. 13 | 14 | {-# LANGUAGE OverloadedStrings #-} 15 | module App.DMABuffer 16 | where 17 | import Control.Monad 18 | import Control.Monad.IO.Class 19 | 20 | import STM32.API 21 | import qualified STM32.USART as USART 22 | import STM32.DMA as DMA 23 | import STM32.GPIO as GPIO 24 | import qualified Data.ByteString as BS 25 | import Data.ByteString.Char8 as BSC (putStrLn) 26 | import qualified Data.ByteString.Lazy as BSL (fromStrict) 27 | import Data.Binary 28 | import Data.Binary.Get 29 | import Data.Char (chr,isPrint) 30 | 31 | 32 | -- | Initialize the Hardware and keep polling the DMA Buffer. 33 | -- This function loops for ever. 34 | -- Though after the buffer is full nothing interesting happens. 35 | readCommDMA :: IO () 36 | readCommDMA = runMI $ do 37 | initMI 38 | resetHalt 39 | setDefaultClocks 40 | USART.deInit USART1 41 | peripheralClockOn USART1 42 | peripheralClockOn GPIOA 43 | peripheralClockOn AFIO 44 | 45 | GPIO.pinMode (GPIOA,Pin_9) (AlternateOutPushPull MHz_2) 46 | GPIO.pinMode (GPIOA,Pin_10) InputPullUp 47 | 48 | USART.enable USART1 49 | USART.init USART1 USART.defaultConfig 50 | bitSet USART1 CR1_RE 51 | 52 | let dmaBuffer = 0x20001000 53 | dmaConfig = DMA.Config { 54 | _BufferSize = 16 55 | ,_Direction = PeripheralSRC 56 | ,_MemoryBaseAddr = dmaBuffer 57 | ,_MemoryDataSize = Byte 58 | ,_MemoryInc = True 59 | ,DMA._Mode = Normal 60 | ,_PeripheralBaseAddr = regToAddr USART1 DR 61 | ,_PeripheralDataSize = Byte 62 | ,_PeripheralInc = False 63 | ,_Priority = Low 64 | } 65 | 66 | peripheralClockOn DMA1 67 | bitSet USART1 CR3_DMAR 68 | DMA.deInit DMA1_Channel5 69 | DMA.disable DMA1_Channel5 70 | DMA.init DMA1_Channel5 dmaConfig 71 | DMA.enable DMA1_Channel5 72 | bitSet USART1 CR3_DMAR 73 | writeMem8 dmaBuffer "XXXXXXXXXXXXXXXX" 74 | forever $ do 75 | buffer <- readMem8 dmaBuffer 16 76 | liftIO $ BSC.putStrLn buffer 77 | delay 500000 78 | 79 | 80 | -- | Initialize the Hardware and keep polling the DMA Buffer. 81 | -- 'uartRingBuffer' uses a ring buffer that wraps over when filled up. 82 | -- The DMA controller is configured to read Bytes (8 Bit) from the UART 83 | -- and write half words (16 Bit) to then RAM. This means 84 | -- it transfers a char and clears out the next byte to flag that this position 85 | -- in the buffer has been written. 86 | 87 | 88 | uartRingBuffer :: IO () 89 | uartRingBuffer = runMI $ do 90 | initMI 91 | resetHalt 92 | setDefaultClocks 93 | USART.deInit USART1 94 | peripheralClockOn USART1 95 | peripheralClockOn GPIOA 96 | peripheralClockOn AFIO 97 | 98 | GPIO.pinMode (GPIOA,Pin_9) (AlternateOutPushPull MHz_2) 99 | GPIO.pinMode (GPIOA,Pin_10) InputPullUp 100 | 101 | USART.enable USART1 102 | USART.init USART1 USART.defaultConfig 103 | bitSet USART1 CR1_RE 104 | 105 | let 106 | entries :: Num a => a 107 | entries = 20 108 | bufferSize :: Num a => a 109 | bufferSize = 2 * entries 110 | let dmaBuffer = 0x20001000 111 | dmaConfig = DMA.Config { 112 | _BufferSize = entries 113 | ,_Direction = PeripheralSRC 114 | ,_MemoryBaseAddr = dmaBuffer 115 | ,_MemoryDataSize = HalfWord 116 | ,_MemoryInc = True 117 | ,DMA._Mode = Circular 118 | ,_PeripheralBaseAddr = regToAddr USART1 DR 119 | ,_PeripheralDataSize = Byte 120 | ,_PeripheralInc = False 121 | ,_Priority = Low 122 | } 123 | 124 | peripheralClockOn DMA1 125 | bitSet USART1 CR3_DMAR 126 | DMA.deInit DMA1_Channel5 127 | DMA.disable DMA1_Channel5 128 | DMA.init DMA1_Channel5 dmaConfig 129 | DMA.enable DMA1_Channel5 130 | bitSet USART1 CR3_DMAR 131 | forever $ do 132 | buffer <- readMem8 dmaBuffer bufferSize 133 | writeMem8 dmaBuffer $ BS.replicate bufferSize 1 134 | let slots = runGet (replicateM entries parseSlot) 135 | $ BSL.fromStrict buffer 136 | 137 | liftIO $ print (map fst slots,map (\(_,x) -> if x then 'X' else ' ') slots) 138 | delay 500000 139 | 140 | parseSlot :: Get (Char, Bool) 141 | parseSlot =do 142 | c <- fmap (chr .fromIntegral) getWord8 143 | f <- getWord8 144 | return (if isPrint c then c else ' ', f==0) 145 | -------------------------------------------------------------------------------- /STM32-Zombie/src/App/LCD.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : App.LCD 4 | -- License : BSD3 5 | -- 6 | -- Stability : experimental 7 | -- Portability : GHC-only 8 | -- 9 | -- The LCD module has been copied from 10 | -- System.Hardware.Arduino.Parts.LCD in the hArduino package. 11 | -- The original Author of this code is Levent Erkok. 12 | -- There have been some minor adaption for STM32. 13 | 14 | {-# LANGUAGE NamedFieldPuns #-} 15 | module App.LCD( 16 | -- * LCD types and registration 17 | LCD, LCDController(..), lcdRegister 18 | -- * Writing text on the LCD 19 | , lcdClear, lcdWrite 20 | -- * Moving the cursor 21 | , lcdHome, lcdSetCursor 22 | -- * Scrolling 23 | , lcdAutoScrollOn, lcdAutoScrollOff 24 | , lcdScrollDisplayLeft, lcdScrollDisplayRight 25 | -- * Display properties 26 | , lcdLeftToRight, lcdRightToLeft 27 | , lcdBlinkOn, lcdBlinkOff 28 | , lcdCursorOn, lcdCursorOff 29 | , lcdDisplayOn, lcdDisplayOff 30 | -- * Accessing internal symbols, 31 | , LCDSymbol, lcdInternalSymbol, lcdWriteSymbol 32 | -- Creating custom symbols 33 | , lcdCreateSymbol 34 | -- * Misc helpers 35 | , lcdFlash 36 | ) where 37 | 38 | import Control.Concurrent (threadDelay) 39 | import Control.Concurrent (MVar,modifyMVar,newMVar) 40 | import Control.Monad (when) 41 | import Control.Monad.IO.Class (liftIO) 42 | import Data.Bits (testBit, (.|.), (.&.), setBit, clearBit, shiftL, bit) 43 | import Data.Char (ord, isSpace) 44 | import Data.Maybe (fromMaybe) 45 | import Data.Word (Word8) 46 | 47 | import STM32.MachineInterface 48 | import STM32.GPIO as GPIO 49 | 50 | debug :: String -> MI () 51 | debug = liftIO . putStrLn 52 | delay :: Int -> MI () 53 | delay = liftIO . threadDelay 54 | digitalWrite :: Wire -> Bool -> MI () 55 | digitalWrite = GPIO.pinOut 56 | 57 | data LCD = LCD { 58 | _controller :: LCDController 59 | ,_state :: MVar LCDData 60 | } 61 | 62 | -- | Hitachi LCD controller: See: . 63 | -- We model only the 4-bit variant, with RS and EN lines only. (The most common Arduino usage.) 64 | -- The data sheet can be seen at: . 65 | data LCDController = Hitachi44780 { 66 | lcdRS :: Wire -- ^ Hitachi pin @ 4@: Register-select 67 | , lcdEN :: Wire -- ^ Hitachi pin @ 6@: Enable 68 | , lcdD4 :: Wire -- ^ Hitachi pin @11@: Data line @4@ 69 | , lcdD5 :: Wire -- ^ Hitachi pin @12@: Data line @5@ 70 | , lcdD6 :: Wire -- ^ Hitachi pin @13@: Data line @6@ 71 | , lcdD7 :: Wire -- ^ Hitachi pin @14@: Data line @7@ 72 | , lcdRows :: Int -- ^ Number of rows (typically 1 or 2, upto 4) 73 | , lcdCols :: Int -- ^ Number of cols (typically 16 or 20, upto 40) 74 | , dotMode5x10 :: Bool -- ^ Set to True if 5x10 dots are used 75 | } 76 | deriving Show 77 | 78 | -- | State of the LCD, a mere 8-bit word for the Hitachi 79 | data LCDData = LCDData { 80 | lcdDisplayMode :: Word8 -- ^ Display mode (left/right/scrolling etc.) 81 | , lcdDisplayControl :: Word8 -- ^ Display control (blink on/off, display on/off etc.) 82 | , lcdGlyphCount :: Word8 -- ^ Count of custom created glyphs (typically at most 8) 83 | , lcdController :: LCDController -- ^ Actual controller 84 | } 85 | --------------------------------------------------------------------------------------- 86 | -- Low level interface, not available to the user 87 | --------------------------------------------------------------------------------------- 88 | 89 | -- | Commands understood by Hitachi 90 | data Cmd = LCD_INITIALIZE 91 | | LCD_INITIALIZE_END 92 | | LCD_FUNCTIONSET 93 | | LCD_DISPLAYCONTROL Word8 94 | | LCD_CLEARDISPLAY 95 | | LCD_ENTRYMODESET Word8 96 | | LCD_RETURNHOME 97 | | LCD_SETDDRAMADDR Word8 98 | | LCD_CURSORSHIFT Word8 99 | | LCD_SETCGRAMADDR Word8 100 | 101 | -- | Convert a command to a data-word 102 | getCmdVal :: LCDController -> Cmd -> Word8 103 | getCmdVal Hitachi44780{lcdRows, dotMode5x10} = get 104 | where multiLine -- bit 3 105 | | lcdRows > 1 = 0x08 :: Word8 106 | | True = 0x00 :: Word8 107 | dotMode -- bit 2 108 | | dotMode5x10 = 0x04 :: Word8 109 | | True = 0x00 :: Word8 110 | displayFunction = multiLine .|. dotMode 111 | get LCD_INITIALIZE = 0x33 112 | get LCD_INITIALIZE_END = 0x32 113 | get LCD_FUNCTIONSET = 0x20 .|. displayFunction 114 | get (LCD_DISPLAYCONTROL w) = 0x08 .|. w 115 | get LCD_CLEARDISPLAY = 0x01 116 | get (LCD_ENTRYMODESET w) = 0x04 .|. w 117 | get LCD_RETURNHOME = 0x02 118 | get (LCD_SETDDRAMADDR w) = 0x80 .|. w 119 | get (LCD_CURSORSHIFT w) = 0x10 .|. 0x08 .|. w -- NB. LCD_DISPLAYMOVE (0x08) hard coded here 120 | get (LCD_SETCGRAMADDR w) = 0x40 .|. w `shiftL` 3 121 | 122 | -- | Initialize the LCD. Follows the data sheet , 123 | -- page 46; figure 24. 124 | initLCD :: LCD -> LCDController -> MI () 125 | initLCD lcd c@Hitachi44780{lcdRS, lcdEN, lcdD4, lcdD5, lcdD6, lcdD7} = do 126 | debug "Starting the LCD initialization sequence" 127 | mapM_ (\w -> GPIO.pinMode w $ GPOutPushPull MHz_2) 128 | [lcdRS, lcdEN, lcdD4, lcdD5, lcdD6, lcdD7] 129 | -- Wait for 50ms, data-sheet says at least 40ms for 2.7V version, so be safe 130 | delay 50 131 | sendCmd c LCD_INITIALIZE 132 | delay 5 133 | sendCmd c LCD_INITIALIZE_END 134 | sendCmd c LCD_FUNCTIONSET 135 | lcdCursorOff lcd 136 | lcdBlinkOff lcd 137 | lcdLeftToRight lcd 138 | lcdAutoScrollOff lcd 139 | lcdHome lcd 140 | lcdClear lcd 141 | lcdDisplayOn lcd 142 | 143 | -- | Get the controller associated with the LCD 144 | getController :: LCD -> MI LCDController 145 | getController lcd = return $ _controller lcd 146 | 147 | -- | Send a command to the LCD controller 148 | sendCmd :: LCDController -> Cmd -> MI () 149 | sendCmd c = transmit False c . getCmdVal c 150 | 151 | -- | Send 4-bit data to the LCD controller 152 | sendData :: LCDController -> Word8 -> MI () 153 | sendData lcd n = do debug $ "Transmitting LCD data: " ++ show n 154 | transmit True lcd n 155 | 156 | -- | By controlling the enable-pin, indicate to the controller that 157 | -- the data is ready for it to process. 158 | pulseEnable :: LCDController -> MI () 159 | pulseEnable Hitachi44780{lcdEN} = do 160 | debug "Sending LCD pulseEnable" 161 | digitalWrite lcdEN False 162 | delay 1 163 | digitalWrite lcdEN True 164 | delay 1 165 | digitalWrite lcdEN False 166 | delay 1 167 | 168 | -- | Transmit data down to the LCD 169 | transmit :: Bool -> LCDController -> Word8 -> MI () 170 | transmit mode c@Hitachi44780{lcdRS, lcdEN, lcdD4, lcdD5, lcdD6, lcdD7} val = do 171 | digitalWrite lcdRS mode 172 | digitalWrite lcdEN False 173 | let [b7, b6, b5, b4, b3, b2, b1, b0] = [val `testBit` i | i <- [7, 6 .. 0]] 174 | -- Send down the first 4 bits 175 | digitalWrite lcdD4 b4 176 | digitalWrite lcdD5 b5 177 | digitalWrite lcdD6 b6 178 | digitalWrite lcdD7 b7 179 | pulseEnable c 180 | -- Send down the remaining batch 181 | digitalWrite lcdD4 b0 182 | digitalWrite lcdD5 b1 183 | digitalWrite lcdD6 b2 184 | digitalWrite lcdD7 b3 185 | pulseEnable c 186 | 187 | -- | Helper function to simplify library programming, not exposed to the user. 188 | withLCD :: LCD -> String -> (LCDController -> MI a) -> MI a 189 | withLCD lcd what action = do 190 | debug what 191 | c <- getController lcd 192 | action c 193 | 194 | --------------------------------------------------------------------------------------- 195 | -- High level interface, exposed to the user 196 | --------------------------------------------------------------------------------------- 197 | 198 | -- | Register an LCD controller. When registration is complete, the LCD will be initialized so that: 199 | -- 200 | -- * Set display ON (Use 'lcdDisplayOn' / 'lcdDisplayOff' to change.) 201 | -- 202 | -- * Set cursor OFF (Use 'lcdCursorOn' / 'lcdCursorOff' to change.) 203 | -- 204 | -- * Set blink OFF (Use 'lcdBlinkOn' / 'lcdBlinkOff' to change.) 205 | -- 206 | -- * Clear display (Use 'lcdClear' to clear, 'lcdWrite' to display text.) 207 | -- 208 | -- * Set entry mode left to write (Use 'lcdLeftToRight' / 'lcdRightToLeft' to control.) 209 | -- 210 | -- * Set autoscrolling OFF (Use 'lcdAutoScrollOff' / 'lcdAutoScrollOn' to control.) 211 | -- 212 | -- * Put the cursor into home position (Use 'lcdSetCursor' or 'lcdHome' to move around.) 213 | lcdRegister :: LCDController -> MI LCD 214 | lcdRegister controller = do 215 | let 216 | ld = LCDData { lcdDisplayMode = 0 217 | , lcdDisplayControl = 0 218 | , lcdGlyphCount = 0 219 | , lcdController = controller 220 | } 221 | ref <- liftIO $ newMVar ld 222 | let lcd = LCD {_controller=controller,_state=ref} 223 | case controller of 224 | Hitachi44780{} -> initLCD lcd controller 225 | return lcd 226 | 227 | -- | Write a string on the LCD at the current cursor position 228 | lcdWrite :: LCD -> String -> MI () 229 | lcdWrite lcd m = withLCD lcd ("Writing " ++ show m ++ " to LCD") $ \c -> mapM_ (sendData c) m' 230 | where m' = map (\ch -> fromIntegral (ord ch) .&. 0xFF) m 231 | 232 | -- | Clear the LCD 233 | lcdClear :: LCD -> MI () 234 | lcdClear lcd = withLCD lcd "Sending clearLCD" $ \c -> 235 | do sendCmd c LCD_CLEARDISPLAY 236 | delay 2 -- give some time to make sure LCD is really cleared 237 | 238 | -- | Send the cursor to home position 239 | lcdHome :: LCD -> MI () 240 | lcdHome lcd = withLCD lcd "Sending the cursor home" $ \c -> 241 | do sendCmd c LCD_RETURNHOME 242 | delay 2 243 | 244 | -- | Set the cursor location. The pair of arguments is the new column and row numbers 245 | -- respectively: 246 | -- 247 | -- * The first value is the column, the second is the row. (This is counter-intuitive, but 248 | -- is in line with what the standard Arduino programmers do, so we follow the same convention.) 249 | -- 250 | -- * Counting starts at 0 (both for column and row no) 251 | -- 252 | -- * If the new location is out-of-bounds of your LCD, we will put it the cursor to the closest 253 | -- possible location on the LCD. 254 | lcdSetCursor :: LCD -> (Int, Int) -> MI () 255 | lcdSetCursor lcd (givenCol, givenRow) = withLCD lcd ("Sending the cursor to Row: " ++ show givenRow ++ " Col: " ++ show givenCol) set 256 | where set c@Hitachi44780{lcdRows, lcdCols} = sendCmd c (LCD_SETDDRAMADDR offset) 257 | where align :: Int -> Int -> Word8 258 | align i m 259 | | i < 0 = 0 260 | | i >= m = fromIntegral $ m-1 261 | | True = fromIntegral i 262 | col = align givenCol lcdCols 263 | row = align givenRow lcdRows 264 | -- The magic row-offsets come from various web sources 265 | -- I don't follow the logic in these numbers, but it seems to work 266 | rowOffsets = [(0, 0), (1, 0x40), (2, 0x14), (3, 0x54)] 267 | offset = col + fromMaybe 0x54 (row `lookup` rowOffsets) 268 | 269 | -- | Scroll the display to the left by 1 character. Project idea: Using a tilt sensor, scroll the contents of the display 270 | -- left/right depending on the tilt. 271 | lcdScrollDisplayLeft :: LCD -> MI () 272 | lcdScrollDisplayLeft lcd = withLCD lcd "Scrolling display to the left by 1" $ \c -> sendCmd c (LCD_CURSORSHIFT lcdMoveLeft) 273 | where lcdMoveLeft = 0x00 274 | 275 | -- | Scroll the display to the right by 1 character 276 | lcdScrollDisplayRight :: LCD -> MI () 277 | lcdScrollDisplayRight lcd = withLCD lcd "Scrolling display to the right by 1" $ \c -> sendCmd c (LCD_CURSORSHIFT lcdMoveRight) 278 | where lcdMoveRight = 0x04 279 | 280 | -- | Display characteristics helper, set the new control/mode and send 281 | -- appropriate commands if anything changed 282 | updateDisplayData :: String -> (Word8 -> Word8, Word8 -> Word8) -> LCD -> MI () 283 | updateDisplayData what (f, g) lcd = do 284 | debug what 285 | ( LCDData {lcdDisplayControl = oldC, lcdDisplayMode = oldM} 286 | , LCDData {lcdDisplayControl = newC, lcdDisplayMode = newM, lcdController = c}) 287 | <- liftIO $ modifyMVar (_state lcd) $ 288 | \ld@LCDData{lcdDisplayControl, lcdDisplayMode} -> do 289 | let ld' = ld { lcdDisplayControl = f lcdDisplayControl 290 | , lcdDisplayMode = g lcdDisplayMode 291 | } 292 | return (ld',(ld,ld')) 293 | when (oldC /= newC) $ sendCmd c (LCD_DISPLAYCONTROL newC) 294 | when (oldM /= newM) $ sendCmd c (LCD_ENTRYMODESET newM) 295 | 296 | -- | Update the display control word 297 | updateDisplayControl :: String -> (Word8 -> Word8) -> LCD -> MI () 298 | updateDisplayControl what f = updateDisplayData what (f, id) 299 | 300 | -- | Update the display mode word 301 | updateDisplayMode :: String -> (Word8 -> Word8) -> LCD -> MI () 302 | updateDisplayMode what g = updateDisplayData what (id, g) 303 | 304 | -- | Various control masks for the Hitachi44780 305 | data Hitachi44780Mask = LCD_BLINKON -- ^ bit @0@ Controls whether cursor blinks 306 | | LCD_CURSORON -- ^ bit @1@ Controls whether cursor is on 307 | | LCD_DISPLAYON -- ^ bit @2@ Controls whether display is on 308 | | LCD_ENTRYSHIFTINCREMENT -- ^ bit @0@ Controls left/right scroll 309 | | LCD_ENTRYLEFT -- ^ bit @1@ Controls left/right entry mode 310 | 311 | -- | Convert the mask value to the bit no 312 | maskBit :: Hitachi44780Mask -> Int 313 | maskBit LCD_BLINKON = 0 314 | maskBit LCD_CURSORON = 1 315 | maskBit LCD_DISPLAYON = 2 316 | maskBit LCD_ENTRYSHIFTINCREMENT = 0 317 | maskBit LCD_ENTRYLEFT = 1 318 | 319 | -- | Clear by the mask 320 | clearMask :: Hitachi44780Mask -> Word8 -> Word8 321 | clearMask m w = w `clearBit` maskBit m 322 | 323 | -- | Set by the mask 324 | setMask :: Hitachi44780Mask -> Word8 -> Word8 325 | setMask m w = w `setBit` maskBit m 326 | 327 | -- | Do not blink the cursor 328 | lcdBlinkOff :: LCD -> MI () 329 | lcdBlinkOff = updateDisplayControl "Turning blinking off" (clearMask LCD_BLINKON) 330 | 331 | -- | Blink the cursor 332 | lcdBlinkOn :: LCD -> MI () 333 | lcdBlinkOn = updateDisplayControl "Turning blinking on" (setMask LCD_BLINKON) 334 | 335 | -- | Hide the cursor. Note that a blinking cursor cannot be hidden, you must first 336 | -- turn off blinking. 337 | lcdCursorOff :: LCD -> MI () 338 | lcdCursorOff = updateDisplayControl "Not showing the cursor" (clearMask LCD_CURSORON) 339 | 340 | -- | Show the cursor 341 | lcdCursorOn :: LCD -> MI () 342 | lcdCursorOn = updateDisplayControl "Showing the cursor" (setMask LCD_CURSORON) 343 | 344 | -- | Turn the display off. Note that turning the display off does not mean you are 345 | -- powering it down. It simply means that the characters will not be shown until 346 | -- you turn it back on using 'lcdDisplayOn'. (Also, the contents will /not/ be 347 | -- forgotten when you call this function.) Therefore, this function is useful 348 | -- for temporarily hiding the display contents. 349 | lcdDisplayOff :: LCD -> MI () 350 | lcdDisplayOff = updateDisplayControl "Turning display off" (clearMask LCD_DISPLAYON) 351 | 352 | -- | Turn the display on 353 | lcdDisplayOn :: LCD -> MI () 354 | lcdDisplayOn = updateDisplayControl "Turning display on" (setMask LCD_DISPLAYON) 355 | 356 | -- | Set writing direction: Left to Right 357 | lcdLeftToRight :: LCD -> MI () 358 | lcdLeftToRight = updateDisplayMode "Setting left-to-right entry mode" (setMask LCD_ENTRYLEFT) 359 | 360 | -- | Set writing direction: Right to Left 361 | lcdRightToLeft :: LCD -> MI () 362 | lcdRightToLeft = updateDisplayMode "Setting right-to-left entry mode" (clearMask LCD_ENTRYLEFT) 363 | 364 | -- | Turn on auto-scrolling. In the context of the Hitachi44780 controller, this means that 365 | -- each time a letter is added, all the text is moved one space to the left. This can be 366 | -- confusing at first: It does /not/ mean that your strings will continuously scroll: 367 | -- It just means that if you write a string whose length exceeds the column-count 368 | -- of your LCD, then you'll see the tail-end of it. (Of course, this will create a scrolling 369 | -- effect as the string is being printed character by character.) 370 | -- 371 | -- Having said that, it is easy to program a scrolling string program: Simply write your string 372 | -- by calling 'lcdWrite', and then use the 'lcdScrollDisplayLeft' and 'lcdScrollDisplayRight' functions 373 | -- with appropriate delays to simulate the scrolling. 374 | lcdAutoScrollOn :: LCD -> MI () 375 | lcdAutoScrollOn = updateDisplayMode "Setting auto-scroll ON" (setMask LCD_ENTRYSHIFTINCREMENT) 376 | 377 | -- | Turn off auto-scrolling. See the comments for 'lcdAutoScrollOn' for details. When turned 378 | -- off (which is the default), you will /not/ see the characters at the end of your strings that 379 | -- do not fit into the display. 380 | lcdAutoScrollOff :: LCD -> MI () 381 | lcdAutoScrollOff = updateDisplayMode "Setting auto-scroll OFF" (clearMask LCD_ENTRYSHIFTINCREMENT) 382 | 383 | -- | Flash contents of the LCD screen 384 | lcdFlash :: LCD 385 | -> Int -- ^ Flash count 386 | -> Int -- ^ Delay amount (in milli-seconds) 387 | -> MI () 388 | lcdFlash lcd n d = sequence_ $ concat $ replicate n [lcdDisplayOff lcd, delay d, lcdDisplayOn lcd, delay d] 389 | 390 | -- | An abstract symbol type for user created symbols 391 | newtype LCDSymbol = LCDSymbol Word8 392 | 393 | -- | Create a custom symbol for later display. Note that controllers 394 | -- have limited capability for such symbols, typically storing no more 395 | -- than 8. The behavior is undefined if you create more symbols than your 396 | -- LCD can handle. 397 | -- 398 | -- The input is a simple description of the glyph, as a list of precisely 8 399 | -- strings, each of which must have 5 characters. Any space character is 400 | -- interpreted as a empty pixel, any non-space is a full pixel, corresponding 401 | -- to the pixel in the 5x8 characters we have on the LCD. For instance, here's 402 | -- a happy-face glyph you can use: 403 | -- 404 | -- > 405 | -- > [ " " 406 | -- > , "@ @" 407 | -- > , " " 408 | -- > , " " 409 | -- > , "@ @" 410 | -- > , " @@@ " 411 | -- > , " " 412 | -- > , " " 413 | -- > ] 414 | -- > 415 | lcdCreateSymbol :: LCD -> [String] -> MI LCDSymbol 416 | lcdCreateSymbol lcd glyph 417 | | length glyph /= 8 || any (/= 5) (map length glyph) 418 | = error "hArduino: lcdCreateSymbol: Invalid glyph description: must be 8x5!" 419 | | True 420 | = do (i, c) <- liftIO $ modifyMVar (_state lcd) $ 421 | \ld@LCDData{lcdGlyphCount, lcdController} -> do 422 | let ld' = ld { lcdGlyphCount = lcdGlyphCount + 1 } 423 | return (ld', (lcdGlyphCount, lcdController)) 424 | sendCmd c (LCD_SETCGRAMADDR i) 425 | let cvt :: String -> Word8 426 | cvt s = foldr (.|.) 0 [bit p | (ch, p) <- zip (reverse s) [0..], not (isSpace ch)] 427 | mapM_ (sendData c . cvt) glyph 428 | return $ LCDSymbol i 429 | 430 | -- | Display a user created symbol on the LCD. (See 'lcdCreateSymbol' for details.) 431 | lcdWriteSymbol :: LCD -> LCDSymbol -> MI () 432 | lcdWriteSymbol lcd (LCDSymbol i) = withLCD lcd ("Writing custom symbol " ++ show i ++ " to LCD") $ \c -> sendData c i 433 | 434 | -- | Access an internally stored symbol, one that is not available via its ASCII equivalent. See 435 | -- the Hitachi datasheet for possible values: , Table 4 on page 17. 436 | -- 437 | -- For instance, to access the symbol right-arrow: 438 | -- 439 | -- * Locate it in the above table: Right-arrow is at the second-to-last row, 7th character from left. 440 | -- 441 | -- * Check the upper/higher bits as specified in the table: For Right-arrow, upper bits are @0111@ and the 442 | -- lower bits are @1110@; which gives us the code @01111110@, or @0x7E@. 443 | -- 444 | -- * So, right-arrow can be accessed by symbol code 'lcdInternalSymbol' @0x7E@, which will give us a 'LCDSymbol' value 445 | -- that can be passed to the 'lcdWriteSymbol' function. The code would look like this: @lcdWriteSymbol lcd (lcdInternalSymbol 0x7E)@. 446 | lcdInternalSymbol :: Word8 -> LCDSymbol 447 | lcdInternalSymbol = LCDSymbol 448 | -------------------------------------------------------------------------------- /STM32-Zombie/src/App/MS5611.hs: -------------------------------------------------------------------------------- 1 | {-- todo work in progress I2C not implemented yet -} 2 | module App.MS5611 3 | where 4 | 5 | import Control.Monad 6 | import Control.Monad.IO.Class 7 | 8 | import STM32.I2C as I2C 9 | import qualified STM32.RTC as RTC 10 | import qualified STM32.RCC as RCC 11 | import qualified STM32.GPIO as GPIO 12 | import Device 13 | import STM32.MachineInterface 14 | import STM32.Utils 15 | 16 | barometer :: IO () 17 | barometer = runMI $ do 18 | initMI 19 | resetHalt 20 | RTC.getCounter >>= print' 21 | 22 | let led = (GPIOB,GPIO.Pin_15) 23 | RCC.peripheralClockOn GPIOB 24 | GPIO.pinMode led $ GPIO.GPOutPushPull GPIO.Mhz_2 25 | replicateM_ 3 $ do 26 | GPIO.pinHigh led 27 | delay 500000 28 | GPIO.pinLow led 29 | delay 500000 30 | 31 | 32 | -------------------------------------------------------------------------------- /STM32-Zombie/src/App/RealTimeClock.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : App.RealTimeClock 4 | -- License : BSD3 5 | -- 6 | -- Stability : experimental 7 | -- Portability : GHC-only 8 | -- 9 | -- Read the real time clock. 10 | -- This only works if the controller has a battery installed 11 | -- and the RTC has been initialized. 12 | 13 | module App.RealTimeClock 14 | where 15 | 16 | import STM32.API 17 | import qualified STM32.RTC as RTC 18 | 19 | printRTC :: IO () 20 | printRTC = runMI $ do 21 | initMI 22 | resetHalt 23 | RTC.getCounter >>=print' 24 | -------------------------------------------------------------------------------- /STM32-Zombie/src/App/Serial.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : App.Serial 4 | -- Copyright : (c) Marc Fontaine 2017 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Marc.Fontaine@gmx.de 8 | -- Stability : experimental 9 | -- Portability : GHC-only 10 | -- 11 | -- Serial port output. 12 | -- 13 | 14 | module App.Serial 15 | where 16 | import Control.Monad 17 | 18 | import STM32.API 19 | import qualified STM32.USART as USART 20 | import STM32.DMA as DMA 21 | 22 | import Data.ByteString.Char8 as BS (pack) 23 | 24 | -- | Send some chars one after the other 25 | sendComm :: IO () 26 | sendComm 27 | = runMI $ sendComm_Port USART.stm32F103_UartPort1 USART.defaultConfig 28 | 29 | sendComm_Port :: USART.UartPort -> USART.Config -> MI () 30 | sendComm_Port port config = do 31 | initMI 32 | resetHalt 33 | setDefaultClocks 34 | USART.configure port config 35 | forever $ do 36 | forM_ [65..90] $ USART.sendWord8 $ USART._UartPeripheral port 37 | delay 500000 38 | 39 | -- | Send a block chars using DMA. 40 | sendCommDMA :: IO () 41 | sendCommDMA 42 | = runMI $ sendCommDMA_Port USART.stm32F103_UartPort1 USART.defaultConfig 43 | 44 | -- only works for USART.stm32F103_UartPort1 at the moment 45 | sendCommDMA_Port :: USART.UartPort -> USART.Config -> MI () 46 | sendCommDMA_Port port config = do 47 | initMI 48 | resetHalt 49 | setDefaultClocks 50 | USART.configure port config 51 | 52 | let dmaBuffer = 0x20001000 53 | dmaConfig = DMA.Config { 54 | _BufferSize = 16 55 | ,_Direction = PeripheralDST 56 | ,_MemoryBaseAddr = dmaBuffer 57 | ,_MemoryDataSize = Byte 58 | ,_MemoryInc = True 59 | ,DMA._Mode = Normal 60 | ,_PeripheralBaseAddr = regToAddr USART1 DR 61 | ,_PeripheralDataSize = Byte 62 | ,_PeripheralInc = False 63 | ,_Priority = Low 64 | } 65 | 66 | peripheralClockOn DMA1 67 | bitSet USART1 CR3_DMAT 68 | DMA.deInit DMA1_Channel4 69 | writeMem8 dmaBuffer $ BS.pack "abcdefghABCD123\n" 70 | 71 | forever $ do 72 | DMA.disable DMA1_Channel4 73 | DMA.init DMA1_Channel4 dmaConfig 74 | DMA.enable DMA1_Channel4 75 | delay 500000 76 | 77 | -------------------------------------------------------------------------------- /STM32-Zombie/src/App/Stepper.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : App.Stepper 4 | -- Copyright : (c) Marc Fontaine 2017 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Marc.Fontaine@gmx.de 8 | -- Stability : experimental 9 | -- Portability : GHC-only 10 | -- 11 | -- Stepper motor control. (GPIO bit-banging) 12 | -- This example uses bit-banging to toggle two GPIO pins. 13 | -- It does not show a special STM32 feature. 14 | -- (But I just wanted to test a stepper motor) 15 | 16 | module App.Stepper 17 | where 18 | import Control.Monad 19 | 20 | import STM32.API 21 | import STM32.GPIO as GPIO 22 | 23 | data Direction = CW | CCW deriving (Show,Eq) 24 | 25 | -- | Rotatet the stepper motor a number of steps clock wise or conter clock wise. 26 | runStepper:: Direction -> Int -> IO () 27 | runStepper = runStepperDelay 25000 28 | 29 | runStepperDelay :: Int -> Direction -> Int -> IO () 30 | runStepperDelay pause dir steps = runMI $ do 31 | let 32 | port = GPIOB 33 | dirWire = (port,Pin_2) 34 | stepWire = (port,Pin_1) 35 | initMI 36 | resetHalt 37 | peripheralClockOn port 38 | pinMode dirWire $ GPOutPushPull MHz_2 39 | pinMode stepWire $ GPOutPushPull MHz_2 40 | case dir of 41 | CW -> pinHigh dirWire 42 | CCW -> pinLow dirWire 43 | replicateM_ steps $ do 44 | delay pause 45 | pinHigh stepWire 46 | delay pause 47 | pinLow stepWire 48 | -------------------------------------------------------------------------------- /STM32-Zombie/src/App/TLC5947.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : App.TLC5947 4 | -- Copyright : (c) Marc Fontaine 2019 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Marc.Fontaine@gmx.de 8 | -- Stability : experimental 9 | -- Portability : GHC-only 10 | -- 11 | -- LED animation using a TLC5947 controller chip (bit-banging based) . 12 | -- TODO: Add DMA/SPI based implementation. 13 | 14 | module App.TLC5947 15 | where 16 | import Prelude hiding (sin) 17 | import Control.Monad 18 | import Data.Bits 19 | import Data.List 20 | 21 | import STM32.API 22 | import STM32.GPIO as GPIO 23 | 24 | main :: IO () 25 | main = animateBitBang 26 | 27 | -- Wiring of the CircuitHup Haskell logo PCB. 28 | blank :: Wire 29 | xlat :: Wire 30 | sin :: Wire 31 | sclk :: Wire 32 | blank = (GPIOB, Pin_7) 33 | xlat = (GPIOB, Pin_6) 34 | sin = (GPIOB, Pin_5) 35 | sclk = (GPIOB, Pin_3) 36 | 37 | ledsOff :: IO () 38 | ledsOff = runMI $ do 39 | initMI 40 | resetHalt 41 | let (port,_) = blank 42 | peripheralClockOn port 43 | pinMode blank $ GPOutPushPull MHz_2 44 | pinHigh blank 45 | 46 | animateBitBang :: IO () 47 | animateBitBang = runMI $ do 48 | initMI 49 | resetHalt 50 | let (port,_) = blank 51 | peripheralClockOn port 52 | pinMode blank $ GPOutPushPull MHz_2 53 | pinMode xlat $ GPOutPushPull MHz_2 54 | pinMode sclk $ GPOutPushPull MHz_2 55 | pinMode sin $ GPOutPushPull MHz_2 56 | pinLow blank 57 | forever $ do 58 | forM_ animation $ \leds -> do 59 | forM_ leds shiftInCurrent 60 | togglePin xlat 61 | 62 | animation :: [[Word16]] 63 | animation = take 24 $ map (take 24) $ tails $ cycle (map ((*) (4096 `div` 23)) [0..23]) 64 | 65 | togglePin :: Wire -> MI () 66 | togglePin w = do 67 | pinHigh w 68 | pinLow w 69 | 70 | shiftInCurrent :: Word16 -> MI () 71 | shiftInCurrent i 72 | = forM_ [11,10..0] $ \b -> do 73 | if testBit i b then pinHigh sin else pinLow sin 74 | togglePin sclk 75 | -------------------------------------------------------------------------------- /STM32-Zombie/src/App/TestLCD.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : App.LCDDemo 4 | -- License : BSD3 5 | -- 6 | -- Stability : experimental 7 | -- Portability : GHC-only 8 | -- 9 | -- The LCDDemo module has been copied from 10 | -- System.Hardware.Arduino.Parts.TestLCD in the hArduino package. 11 | -- The original Author of this code is Levent Erkok. 12 | -- There have been some minor adaption for STM32. 13 | 14 | module App.TestLCD 15 | where 16 | import App.LCD 17 | 18 | import STM32.API 19 | import STM32.GPIO as GPIO 20 | import Control.Monad.IO.Class 21 | import Data.Char (isSpace) 22 | 23 | 24 | port :: Peripheral 25 | port = GPIOB 26 | 27 | hitachi :: LCDController 28 | hitachi = Hitachi44780 { 29 | lcdRS = (port,GPIO.Pin_10) 30 | , lcdEN = (port,GPIO.Pin_2) 31 | , lcdD4 = (port,GPIO.Pin_13) 32 | , lcdD5 = (port,GPIO.Pin_14) 33 | , lcdD6 = (port,GPIO.Pin_11) 34 | , lcdD7 = (port,GPIO.Pin_12) 35 | , lcdRows = 2 36 | , lcdCols = 16 37 | , dotMode5x10 = True 38 | } 39 | 40 | -- | The happy glyph. See 'lcdCreateSymbol' for details on how to create new ones. 41 | happy :: [String] 42 | happy = [ " " 43 | , "@ @" 44 | , " " 45 | , " " 46 | , "@ @" 47 | , " @@@ " 48 | , " " 49 | , " " 50 | ] 51 | 52 | -- | The sad glyph. See 'lcdCreateSymbol' for details on how to create new ones. 53 | sad :: [String] 54 | sad = [ " " 55 | , "@ @" 56 | , " " 57 | , " " 58 | , " " 59 | , " @@@ " 60 | , "@ @" 61 | , " " 62 | ] 63 | 64 | -- | Access the LCD connected to Arduino, making it show messages 65 | -- we read from the user and demonstrate other LCD control features offered 66 | -- by hArduino. 67 | lcdDemo :: IO () 68 | lcdDemo = runMI $ do 69 | initMI 70 | resetHalt 71 | peripheralClockOn port 72 | lcd <- lcdRegister hitachi 73 | happySymbol <- lcdCreateSymbol lcd happy 74 | sadSymbol <- lcdCreateSymbol lcd sad 75 | lcdHome lcd 76 | liftIO $ do putStrLn "Hitachi controller demo.." 77 | putStrLn "" 78 | putStrLn "Looking for an example? Try the following sequence:" 79 | putStrLn " cursor 5 0" 80 | putStrLn " happy" 81 | putStrLn " write _" 82 | putStrLn " happy" 83 | putStrLn " flash 5" 84 | putStrLn "" 85 | putStrLn "Type ? to see all available commands." 86 | let repl = do liftIO $ putStr "LCD> " 87 | m <- liftIO getLine 88 | case words m of 89 | [] -> repl 90 | ["quit"] -> return () 91 | (cmd:_) -> case cmd `lookup` commands of 92 | Nothing -> do liftIO $ putStrLn $ "Unknown command '" ++ cmd ++ "', type ? for help." 93 | repl 94 | Just (_, _, c) -> do c lcd (dropWhile isSpace (drop (length cmd) m)) (happySymbol, sadSymbol) 95 | repl 96 | repl 97 | where help = liftIO $ do let (cmds, args, hlps) = unzip3 $ ("quit", "", "Quit the demo") : [(c, a, h) | (c, (a, h, _)) <- commands] 98 | clen = 1 + maximum (map length cmds) 99 | alen = 8 + maximum (map length args) 100 | pad l s = take l (s ++ repeat ' ') 101 | line (c, a, h) = putStrLn $ pad clen c ++ pad alen a ++ h 102 | mapM_ line $ zip3 cmds args hlps 103 | arg0 f _ [] _ = f 104 | arg0 _ _ a _ = liftIO $ putStrLn $ "Unexpected arguments: " ++ show a 105 | arg1 f lcd [] _ = f lcd 106 | arg1 _ _ a _ = liftIO $ putStrLn $ "Unexpected arguments: " ++ show a 107 | arg2 f lcd a _ = f lcd a 108 | arg3 = id 109 | grabNums n a f = case [v | [(v, "")] <- map reads (words a)] of 110 | vs | length vs /= n -> liftIO $ putStrLn $ "Need " ++ show n ++ " numeric parameter" ++ if n == 1 then "." else "s." 111 | vs -> f vs 112 | symbol isHappy lcd _ (h, s) = lcdWriteSymbol lcd (if isHappy then h else s) 113 | cursor lcd a = grabNums 2 a (\[col, row] -> lcdSetCursor lcd (col, row)) 114 | flash lcd a = grabNums 1 a (\[n] -> lcdFlash lcd n 500) 115 | code lcd a = grabNums 1 a (\[n] -> do lcdClear lcd 116 | lcdHome lcd 117 | lcdWriteSymbol lcd (lcdInternalSymbol n) 118 | lcdWrite lcd $ " (Code: " ++ show n ++ ")") 119 | scroll toLeft lcd a = grabNums 1 a (\[n] -> do let scr | toLeft = lcdScrollDisplayLeft 120 | | True = lcdScrollDisplayRight 121 | sequence_ $ concat $ replicate n [scr lcd, delay 500]) 122 | commands = [ ("?", ("", "Display this help message", arg0 help)) 123 | , ("clear", ("", "Clear the LCD screen", arg1 lcdClear)) 124 | , ("write", ("string", "Write to the LCD", arg2 lcdWrite)) 125 | , ("home", ("", "Move cursor to home", arg1 lcdHome)) 126 | , ("cursor", ("col row", "Move cursor to col row", arg2 cursor)) 127 | , ("scrollOff", ("", "Turn off auto-scroll", arg1 lcdAutoScrollOff)) 128 | , ("scrollOn", ("", "Turn on auto-scroll", arg1 lcdAutoScrollOn)) 129 | , ("scrollLeft", ("n", "Scroll left by n chars", arg2 (scroll True))) 130 | , ("scrollRight", ("n", "Scroll right by n char", arg2 (scroll False))) 131 | , ("leftToRight", ("", "Set left to right direction", arg1 lcdLeftToRight)) 132 | , ("rightToLeft", ("", "Set left to right direction", arg1 lcdRightToLeft)) 133 | , ("blinkOn", ("", "Set blinking ON", arg1 lcdBlinkOn)) 134 | , ("blinkOff", ("", "Set blinking ON", arg1 lcdBlinkOff)) 135 | , ("cursorOn", ("", "Display the cursor", arg1 lcdCursorOn)) 136 | , ("cursorOff", ("", "Do not display the cursor", arg1 lcdCursorOff)) 137 | , ("displayOn", ("", "Turn the display on", arg1 lcdDisplayOn)) 138 | , ("displayOff", ("", "Turn the display off", arg1 lcdDisplayOff)) 139 | , ("flash", ("n", "Flash the display n times", arg2 flash)) 140 | , ("happy", ("", "Draw a smiling face", arg3 (symbol True))) 141 | , ("sad", ("", "Draw a sad face", arg3 (symbol False))) 142 | , ("code", ("n", "Write symbol with code n", arg2 code)) 143 | ] 144 | -------------------------------------------------------------------------------- /STM32-Zombie/src/App/TimerDMA.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : App.TimerDMA 4 | -- Copyright : (c) Marc Fontaine 2017 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Marc.Fontaine@gmx.de 8 | -- Stability : experimental 9 | -- Portability : GHC-only 10 | -- 11 | -- This example show the combination of hardware timers with hardware DMA. 12 | -- Timer 4 triggers DMA1_Channel7 and the DMA writes data to the USART. 13 | -- Instead of the USART its also possible to write to any other peripheral. 14 | -- Applications are wave-form-generation or hard-real-time control. 15 | 16 | module App.TimerDMA 17 | where 18 | import Control.Monad 19 | 20 | import STM32.API 21 | import qualified STM32.USART as USART 22 | import STM32.DMA as DMA 23 | import STM32.Timer as Timer 24 | 25 | import Data.ByteString.Char8 as BS (pack) 26 | 27 | sendCommTimer :: IO () 28 | sendCommTimer 29 | = runMI $ sendCommTimer_Port USART.stm32F103_UartPort1 USART.defaultConfig 30 | 31 | -- only works for USART.stm32F103_UartPort1 at the moment 32 | sendCommTimer_Port :: USART.UartPort -> USART.Config -> MI () 33 | sendCommTimer_Port port config = do 34 | initMI 35 | resetHalt 36 | USART.configure port config 37 | 38 | let dmaBuffer = 0x20001000 39 | dmaConfig = DMA.Config { 40 | _BufferSize = 16 41 | ,_Direction = PeripheralDST 42 | ,_MemoryBaseAddr = dmaBuffer 43 | ,_MemoryDataSize = Byte 44 | ,_MemoryInc = True 45 | ,DMA._Mode = Circular 46 | ,_PeripheralBaseAddr = regToAddr USART1 DR 47 | ,_PeripheralDataSize = Byte 48 | ,_PeripheralInc = False 49 | ,_Priority = Low 50 | } 51 | 52 | peripheralClockOn DMA1 53 | peripheralClockOn TIM4 54 | DMA.deInit DMA1_Channel7 55 | writeMem8 dmaBuffer $ BS.pack "abcdefghABCD123\n" 56 | 57 | DMA.disable DMA1_Channel7 58 | DMA.init DMA1_Channel7 dmaConfig 59 | DMA.enable DMA1_Channel7 60 | 61 | let timeBase = TimeBase { 62 | _Prescaler = 7200 -- 72 Mhz clock _Period counts in 0.1 ms 63 | ,_CounterMode = Down 64 | ,_Period = 10000 -- 1s 65 | ,_ClockDevision = CKD_DIV1 66 | ,_RepetitionCounter =0 67 | } 68 | 69 | Timer.deInit TIM4 70 | Timer.timeBaseInit TIM4 timeBase 71 | bitReset TIM4 CR1_URS 72 | bitSet TIM4 DIER_UDE 73 | bitSet TIM4 CR1_CEN 74 | -------------------------------------------------------------------------------- /STM32-Zombie/src/App/WS1228B.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : App.WS1228B 4 | -- Copyright : (c) Marc Fontaine 2017 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Marc.Fontaine@gmx.de 8 | -- Stability : experimental 9 | -- Portability : GHC-only 10 | -- 11 | -- The popular WS1228B module consists of a RGB LED and an included LED controller. 12 | -- Many WS1228B modules can be chained up to build LED strips 13 | -- for colorful decorations, mood lights etc. 14 | -- For proper operation the WS1228B requires fast and accurate timing. 15 | -- The example works with combination of SPI and DMA. 16 | -- With the SPI port it is possible to shift out a raw bit-stream. 17 | -- (i.e. play a one-bit sampled wave-form). 18 | -- (This is not possible with the USART because the USART would add start and stop bits) 19 | 20 | module App.WS1228B 21 | where 22 | 23 | import STM32.API as API 24 | import STM32.GPIO as GPIO 25 | import STM32.SPI as SPI 26 | import STM32.DMA as DMA 27 | 28 | import qualified Data.ByteString as BS 29 | -- import Control.Monad 30 | import Data.List (tails) 31 | 32 | data RGB = RGB Word8 Word8 Word8 33 | deriving (Read,Show,Eq,Ord) 34 | 35 | -- | show some color pattern 36 | testLEDs :: IO () 37 | testLEDs = sendLEDs [red,green,blue,black,white] 38 | 39 | -- | turn off the first 30 LEDs (== set the color to black) 40 | ledsOff30 :: IO () 41 | ledsOff30 = sendLEDs $ replicate 30 black 42 | 43 | -- | set the LED strip to a list of colors. 44 | sendLEDs :: [RGB] -> IO () 45 | sendLEDs colors = runMI $ do 46 | initSPI 47 | sendSPI $ encodeRGBLine colors 48 | 49 | black :: RGB 50 | black = RGB 0x00 0x00 0x00 51 | 52 | white :: RGB 53 | white = RGB 0xff 0xff 0xff 54 | 55 | red :: RGB 56 | red = RGB 0xff 0x00 0x00 57 | 58 | green :: RGB 59 | green = RGB 0x00 0xff 0x00 60 | 61 | blue :: RGB 62 | blue = RGB 0x00 0x00 0xff 63 | 64 | -- | The WS1228B protocoll. 65 | -- translate a list of colors to the transmission bits. 66 | encodeRGBLine :: [RGB] -> BS.ByteString 67 | encodeRGBLine l = BS.concat (resetCode : map encodeRGB l) 68 | 69 | resetCode :: BS.ByteString 70 | resetCode = BS.pack $ replicate 20 0x00 71 | 72 | encodeRGB :: RGB -> BS.ByteString 73 | encodeRGB (RGB r g b) 74 | = BS.pack [g3,g2,g1,r3,r2,r1,b3,b2,b1] 75 | where 76 | (r3,r2,r1) = lineCodeWord8 r 77 | (g3,g2,g1) = lineCodeWord8 g 78 | (b3,b2,b1) = lineCodeWord8 b 79 | 80 | -- | Encode an Word8 according to the WS1228B line code. 81 | -- Each data bit is extended to a three bit line code. 82 | lineCodeWord8 :: Word8 -> (Word8,Word8,Word8) 83 | lineCodeWord8 b = (c1,c2,c3) 84 | where 85 | c1 = fromIntegral ((mix32 `shiftR` 16) .&. 0xff) 86 | c2 = fromIntegral ((mix32 `shiftR` 8) .&. 0xff) 87 | c3 = fromIntegral (mix32 .&. 0xff) 88 | mix32 :: Word32 89 | mix32 = worker 7 0 90 | worker (-1) accum = accum 91 | worker n accum = worker (n -1) ((accum `shiftL` 3) .|. bitCode) 92 | where bitCode = if b `testBit` n then 6 else 4 93 | 94 | 95 | {- 96 | spi_nss :: Wire 97 | spi_nss =(GPIOB,Pin_12) 98 | spi_sck :: Wire 99 | spi_sck =(GPIOB,Pin_13) 100 | spi_miso :: Wire 101 | spi_miso=(GPIOB,Pin_14) 102 | -} 103 | led :: Wire 104 | --led = (GPIOC,Pin_13) 105 | led = (GPIOA,Pin_12) 106 | 107 | spi_mosi :: Wire 108 | spi_mosi=(GPIOB,Pin_15) 109 | 110 | spiConfig :: SPI.Config 111 | spiConfig = SPI.Config { 112 | _direction = One_Line_Tx 113 | , _mode = Master 114 | , _dataSize = Eight 115 | , _CPOL = SPI.Low 116 | , _CPHA = OneEdge 117 | , _NSS = Soft 118 | , _baudRatePrescaler = Prescaler_16 119 | , _firstBit = MSB 120 | , _CRCPolynomial = 7 121 | } 122 | 123 | 124 | initSPI :: MI () 125 | initSPI = do 126 | initMI 127 | API.resetHalt 128 | setDefaultClocks 129 | SPI.deInit SPI2 130 | peripheralClockOn GPIOB 131 | peripheralClockOn GPIOC 132 | peripheralClockOn SPI2 133 | pinMode led $ GPOutPushPull MHz_2 134 | pinMode spi_mosi $ GPIO.AlternateOutPushPull MHz_2 135 | SPI.init SPI2 spiConfig 136 | bitSet SPI2 CR2_TXDMAEN 137 | 138 | SPI.enable SPI2 139 | 140 | sendSPI :: BS.ByteString -> MI () 141 | sendSPI bs = do 142 | let len = BS.length bs 143 | dmaBuffer = 0x20001000 144 | dmaConfig = DMA.Config { 145 | _BufferSize = fromIntegral $ len 146 | ,_Direction = PeripheralDST 147 | ,_MemoryBaseAddr = dmaBuffer 148 | ,_MemoryDataSize = Byte 149 | ,_MemoryInc = True 150 | ,DMA._Mode = Normal 151 | ,_PeripheralBaseAddr = regToAddr SPI2 DR 152 | ,_PeripheralDataSize = Byte 153 | ,_PeripheralInc = False 154 | ,_Priority = DMA.High 155 | } 156 | writeMem8 dmaBuffer bs 157 | 158 | peripheralClockOn DMA1 159 | DMA.deInit DMA1_Channel5 160 | 161 | DMA.disable DMA1_Channel5 162 | DMA.init DMA1_Channel5 dmaConfig 163 | DMA.enable DMA1_Channel5 164 | 165 | return () 166 | 167 | -- | Animate a LED strip and show some wave-like lighting pattern. 168 | testWave :: IO () 169 | testWave = runMI $ do 170 | initSPI 171 | let 172 | st = 2*pi/10 173 | loop t = do 174 | let colors = [RGB (redIntensity $ wave t st i) 175 | (redIntensity $ wave (-t*0.5) st i) 0 176 | | i <- [0..15]] 177 | sendSPI $ encodeRGBLine colors 178 | delay 1000 179 | loop $ t + 0.1 180 | loop 0 181 | 182 | wave :: Double -> Double -> Int -> Double 183 | wave t st i = (sin (t+st* fromIntegral i) +1) /2 184 | 185 | redIntensity :: Double -> Word8 186 | redIntensity d = 187 | if d >0.4 then floor (d*5) 188 | else 0 189 | 190 | -- this leaks memory !! 191 | testPattern :: IO () 192 | testPattern = runMI $ loop config 193 | where 194 | loop :: [([RGB], Int, Bool)] -> MI () 195 | loop conf = do 196 | let 197 | (p, d, dir) = head conf 198 | p2 = (\x -> if dir then x else reverse x) $ take 15 p 199 | pe = reverse p2 ++ p2 200 | sendSPI $ encodeRGBLine pe 201 | delay d 202 | loop $ tail conf 203 | 204 | config :: [([RGB], Int, Bool)] 205 | config = zip3 (tails pat) speed rev 206 | 207 | pat = cycle [red, red, red, green, green, blue, blue, blue, black, black, black ,black, black] 208 | speed = cycle ((reverse ramp ++ (replicate 300 acc) ++ ramp) ++ reverse (reverse ramp ++ (replicate 300 acc) ++ ramp)) 209 | ramp = [acc, acc+acc..400000] 210 | acc = 10000 211 | rev = cycle $ replicate 100 True ++ replicate 100 False 212 | 213 | -------------------------------------------------------------------------------- /STM32-Zombie/src/App/WaveForm.hs: -------------------------------------------------------------------------------- 1 | {- work in progress -} 2 | 3 | module App.WaveForm 4 | where 5 | 6 | import STM32.MachineInterface 7 | import STM32.Utils 8 | import STM32.GPIO as GPIO 9 | 10 | -- type Signal = array Word8 (Maybe Bool) 11 | -- type WaveForm = [(Pin,Signal)] 12 | 13 | -------------------------------------------------------------------------------- /STM32-Zombie/src/STM32/ADC.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : STM32.APP 4 | -- Copyright : (c) Marc Fontaine 2017 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Marc.Fontaine@gmx.de 8 | -- Stability : experimental 9 | -- Portability : GHC-only 10 | -- 11 | -- Analog Digital Converter 12 | {-# LANGUAGE OverloadedStrings #-} 13 | module STM32.ADC 14 | where 15 | 16 | import Device 17 | import STM32.MachineInterface 18 | import STM32.Utils 19 | import Data.Word 20 | import qualified STM32.RCC as RCC 21 | import Data.Bits 22 | 23 | deInit :: Peripheral -> MI () 24 | deInit = RCC.peripheralResetToggle 25 | 26 | data Config = Config 27 | { 28 | _Mode :: Mode 29 | ,_ScanConvMode :: Bool 30 | ,_ContinuousConvMode :: Bool 31 | ,_ExternalTrigConv :: ExternalTrigConv 32 | ,_DataAlign :: DataAlign 33 | ,_NbrOfChannel :: Word32 34 | } deriving Show 35 | 36 | data Mode 37 | = Independent 38 | | RegInjecSimult 39 | | RegSimult_AlterTrig 40 | | InjecSimult_FastInterl 41 | | InjecSimult_SlowInterl 42 | | InjecSimult 43 | | RegSimult 44 | | FastInterl 45 | | SlowInterl 46 | | AlterTrig 47 | deriving (Show) 48 | 49 | instance RegisterField Mode where 50 | toBits m = case m of 51 | Independent -> "0000" 52 | RegInjecSimult -> "0001" 53 | RegSimult_AlterTrig -> "0010" 54 | InjecSimult_FastInterl -> "0011" 55 | InjecSimult_SlowInterl -> "0100" 56 | InjecSimult -> "0101" 57 | RegSimult -> "0110" 58 | FastInterl -> "0111" 59 | SlowInterl -> "1000" 60 | AlterTrig -> "1001" 61 | toField = const CR1_DUALMOD 62 | 63 | data ExternalTrigConv 64 | = ExternalTrigConv_T1_CC1 65 | | ExternalTrigConv_T1_CC2 66 | | ExternalTrigConv_T1_CC3 67 | | ExternalTrigConv_T2_CC2 68 | | ExternalTrigConv_T3_TRGO 69 | | ExternalTrigConv_T4_CC4 70 | | ExternalTrigConv_Ext_IT11_TIM8_TRGO 71 | | ExternalTrigConv_None 72 | | ExternalTrigConv_T3_CC1 73 | | ExternalTrigConv_T2_CC3 74 | | ExternalTrigConv_T8_CC1 75 | | ExternalTrigConv_T8_TRGO 76 | | ExternalTrigConv_T5_CC1 77 | | ExternalTrigConv_T5_CC3 78 | deriving Show 79 | 80 | instance RegisterField ExternalTrigConv where 81 | toBits x = case x of 82 | ExternalTrigConv_T1_CC1 -> "000" 83 | ExternalTrigConv_T1_CC2 -> "001" 84 | ExternalTrigConv_T1_CC3 -> "010" 85 | ExternalTrigConv_T2_CC2 -> "011" 86 | ExternalTrigConv_T3_TRGO -> "100" 87 | ExternalTrigConv_T4_CC4 -> "101" 88 | ExternalTrigConv_Ext_IT11_TIM8_TRGO -> "110" 89 | ExternalTrigConv_None -> "111" 90 | ExternalTrigConv_T3_CC1 -> "000" 91 | ExternalTrigConv_T2_CC3 -> "001" 92 | ExternalTrigConv_T8_CC1 -> "011" 93 | ExternalTrigConv_T8_TRGO -> "100" 94 | ExternalTrigConv_T5_CC1 -> "101" 95 | ExternalTrigConv_T5_CC3 -> "110" 96 | toField = const CR2_EXTSEL 97 | 98 | data DataAlign = AlignRight | AlignLeft 99 | deriving Show 100 | 101 | instance ToBit DataAlign where 102 | toBit AlignRight = False 103 | toBit AlignLeft = True 104 | 105 | 106 | data Channel 107 | = Channel_0 | Channel_1 | Channel_2 | Channel_3 | Channel_4 | Channel_5 108 | | Channel_6 | Channel_7 | Channel_8 | Channel_9 | Channel_10 | Channel_11 109 | | Channel_12 | Channel_13 | Channel_14 | Channel_15 | Channel_16 | Channel_17 110 | deriving Show 111 | 112 | data SampleTime 113 | = SampleTime_1Cycles5 114 | | SampleTime_7Cycles5 115 | | SampleTime_13Cycles5 116 | | SampleTime_28Cycles5 117 | | SampleTime_41Cycles5 118 | | SampleTime_55Cycles5 119 | | SampleTime_71Cycles5 120 | | SampleTime_239Cycles5 121 | deriving Show 122 | 123 | instance ToBitField SampleTime where 124 | toBitField s = case s of 125 | SampleTime_1Cycles5 -> "000" 126 | SampleTime_7Cycles5 -> "001" 127 | SampleTime_13Cycles5 -> "010" 128 | SampleTime_28Cycles5 -> "011" 129 | SampleTime_41Cycles5 -> "100" 130 | SampleTime_55Cycles5 -> "101" 131 | SampleTime_71Cycles5 -> "110" 132 | SampleTime_239Cycles5 -> "111" 133 | 134 | data ExternalTrigInjecConv 135 | = ExternalTrigInjecConv_T1_TRGO 136 | | ExternalTrigInjecConv_T1_CC4 137 | | ExternalTrigInjecConv_T2_TRGO 138 | | ExternalTrigInjecConv_T2_CC1 139 | | ExternalTrigInjecConv_T3_CC4 140 | | ExternalTrigInjecConv_T4_TRGO 141 | | ExternalTrigInjecConv_Ext_IT15_TIM8_CC4 142 | | ExternalTrigInjecConv_None 143 | | ExternalTrigInjecConv_T4_CC3 144 | | ExternalTrigInjecConv_T8_CC2 145 | | ExternalTrigInjecConv_T8_CC4 146 | | ExternalTrigInjecConv_T5_TRGO 147 | | ExternalTrigInjecConv_T5_CC4 148 | deriving Show 149 | 150 | instance ToBitField ExternalTrigInjecConv where 151 | toBitField e = case e of 152 | ExternalTrigInjecConv_T1_TRGO -> "000" 153 | ExternalTrigInjecConv_T1_CC4 -> "001" 154 | ExternalTrigInjecConv_T2_TRGO -> "010" 155 | ExternalTrigInjecConv_T2_CC1 -> "011" 156 | ExternalTrigInjecConv_T3_CC4 -> "100" 157 | ExternalTrigInjecConv_T4_TRGO -> "101" 158 | ExternalTrigInjecConv_Ext_IT15_TIM8_CC4 -> "110" 159 | ExternalTrigInjecConv_None -> "111" 160 | ExternalTrigInjecConv_T4_CC3 -> "010" 161 | ExternalTrigInjecConv_T8_CC2 -> "011" 162 | ExternalTrigInjecConv_T8_CC4 -> "100" 163 | ExternalTrigInjecConv_T5_TRGO -> "101" 164 | ExternalTrigInjecConv_T5_CC4 -> "110" 165 | 166 | data InjectedChannel 167 | = InjectedChannel_1 168 | | InjectedChannel_2 169 | | InjectedChannel_3 170 | | InjectedChannel_4 171 | deriving Show 172 | 173 | data AnalogWatchdog 174 | = AnalogWatchdog_SingleRegEnable 175 | | AnalogWatchdog_SingleInjecEnable 176 | | AnalogWatchdog_SingleRegOrInjecEnable 177 | | AnalogWatchdog_AllRegEnable 178 | | AnalogWatchdog_AllInjecEnable 179 | | AnalogWatchdog_AllRegAllInjecEnable 180 | | AnalogWatchdog_None 181 | deriving Show 182 | 183 | init :: Peripheral -> Config -> MI () 184 | init p conf = do 185 | fieldWrite p $ _Mode conf 186 | bitWrite p CR1_SCAN $ _ScanConvMode conf 187 | 188 | bitWrite p CR2_ALIGN $ _DataAlign conf 189 | fieldWrite p $ _ExternalTrigConv conf 190 | bitWrite p CR2_CONT $ _ContinuousConvMode conf 191 | 192 | pokeReg p SQR1 ((_NbrOfChannel conf -1) `shiftL` 20) 193 | 194 | channelToSMP :: Channel -> Field 195 | channelToSMP ch = case ch of 196 | Channel_0 -> SMPR2_SMP0 197 | Channel_1 -> SMPR2_SMP1 198 | Channel_2 -> SMPR2_SMP2 199 | Channel_3 -> SMPR2_SMP3 200 | Channel_4 -> SMPR2_SMP4 201 | Channel_5 -> SMPR2_SMP5 202 | Channel_6 -> SMPR2_SMP6 203 | Channel_7 -> SMPR2_SMP7 204 | Channel_8 -> SMPR2_SMP8 205 | Channel_9 -> SMPR2_SMP9 206 | Channel_10 -> SMPR1_SMP10 207 | Channel_11 -> SMPR1_SMP11 208 | Channel_12 -> SMPR1_SMP12 209 | Channel_13 -> SMPR1_SMP13 210 | Channel_14 -> SMPR1_SMP14 211 | Channel_15 -> SMPR1_SMP15 212 | Channel_16 -> SMPR1_SMP16 213 | Channel_17 -> SMPR1_SMP17 214 | 215 | channelToSQBits :: Channel -> BitField 216 | channelToSQBits ch = case ch of 217 | Channel_0 -> "00000" 218 | Channel_1 -> "00001" 219 | Channel_2 -> "00010" 220 | Channel_3 -> "00011" 221 | Channel_4 -> "00100" 222 | Channel_5 -> "00101" 223 | Channel_6 -> "00110" 224 | Channel_7 -> "00111" 225 | Channel_8 -> "01000" 226 | Channel_9 -> "01001" 227 | Channel_10 -> "01010" 228 | Channel_11 -> "01011" 229 | Channel_12 -> "01100" 230 | Channel_13 -> "01101" 231 | Channel_14 -> "01110" 232 | Channel_15 -> "01111" 233 | Channel_16 -> "10000" 234 | Channel_17 -> "10001" 235 | 236 | rankToSQ :: Word8 -> Field 237 | rankToSQ r = case r of 238 | 1 -> SQR3_SQ1 239 | 2 -> SQR3_SQ2 240 | 3 -> SQR3_SQ3 241 | 4 -> SQR3_SQ4 242 | 5 -> SQR3_SQ5 243 | 6 -> SQR3_SQ6 244 | 7 -> SQR2_SQ7 245 | 8 -> SQR2_SQ8 246 | 9 -> SQR2_SQ9 247 | 10 -> SQR2_SQ10 248 | 11 -> SQR2_SQ11 249 | 12 -> SQR2_SQ12 250 | 13 -> SQR1_SQ13 251 | 14 -> SQR1_SQ14 252 | 15 -> SQR1_SQ15 253 | 16 -> SQR1_SQ16 254 | _ -> error "ADC.hs rankToSQ" 255 | 256 | regularChannelConfig :: Peripheral -> Channel -> Word8 -> SampleTime -> MI () 257 | regularChannelConfig p channel rank sampleTime = do 258 | regFieldWrite p (channelToSMP channel) sampleTime 259 | regFieldWrite p (rankToSQ rank) (channelToSQBits channel) 260 | 261 | dmaCmd :: Peripheral -> Bool -> MI () 262 | dmaCmd p rs = case p of 263 | ADC1 -> bitWrite ADC1 CR2_DMA rs 264 | ADC2 -> error "dmaCMD: ADC2 no DMA available" 265 | ADC3 -> bitWrite ADC3 CR2_DMA rs 266 | _ -> error "dmaCMD" 267 | 268 | cmd :: Peripheral -> Bool -> MI () 269 | cmd p rs = bitWrite p CR2_ADON rs 270 | 271 | softwareStartConvCmd :: Peripheral -> Bool -> MI () 272 | softwareStartConvCmd p rs = do 273 | bitWrite p CR2_EXTTRIG rs 274 | bitWrite p CR2_SWSTART rs 275 | -------------------------------------------------------------------------------- /STM32-Zombie/src/STM32/API.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : STM32.API 4 | -- Copyright : (c) Marc Fontaine 2017 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Marc.Fontaine@gmx.de 8 | -- Stability : experimental 9 | -- Portability : GHC-only 10 | -- 11 | -- The general part of the API. 12 | -- The module for the peripheral (GPIO, USART,ADC,..) has to be imported separately. 13 | 14 | module STM32.API 15 | ( 16 | module STM32.MachineInterface 17 | , module STLinkUSB 18 | , module STM32.RCC 19 | , module Data.Word 20 | , module Data.Bits 21 | , module Device 22 | , module STM32.Utils 23 | ) 24 | 25 | where 26 | import Data.Word 27 | import Data.Bits 28 | 29 | import Device 30 | import STM32.MachineInterface 31 | import STM32.Utils 32 | import STM32.STLinkUSB as STLinkUSB hiding (resetHalt) 33 | import STM32.RCC (setDefaultClocks , peripheralClockOn 34 | , peripheralClockOff, peripheralResetToggle) 35 | 36 | -------------------------------------------------------------------------------- /STM32-Zombie/src/STM32/DAC.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : STM32.DAC 4 | -- Copyright : (c) Marc Fontaine 2017 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Marc.Fontaine@gmx.de 8 | -- Stability : experimental 9 | -- Portability : GHC-only 10 | -- 11 | -- Digital Analog Converters. 12 | -- This is untested. 13 | -- The cheap STM32F103C8T6 boards don't have a built-in DAC. 14 | {-# LANGUAGE OverloadedStrings #-} 15 | module STM32.DAC 16 | where 17 | 18 | import Data.Word 19 | import Data.Bits 20 | import Device 21 | import STM32.MachineInterface 22 | import STM32.Utils 23 | 24 | import qualified STM32.RCC as RCC (peripheralResetToggle) 25 | 26 | data Config = Config { 27 | _trigger :: Maybe Trigger 28 | ,_waveGeneration :: Maybe Wave 29 | ,_LFSRUnmask_TriangleAmplitude :: Either TriangleAmplitude LFSRUnmask 30 | ,_outputBuffer :: Bool 31 | } deriving (Show,Eq) 32 | 33 | defaultConfig :: Config 34 | defaultConfig = Config { 35 | _trigger = Nothing 36 | ,_waveGeneration = Nothing 37 | ,_LFSRUnmask_TriangleAmplitude = Right Bit0 38 | ,_outputBuffer = True 39 | } 40 | 41 | data Trigger 42 | = T6_TRGO | T8_TRGO | T7_TRGO 43 | | T5_TRGO | T2_TRGO | T4_TRGO | Ext_IT9 | Software 44 | deriving (Show,Eq) 45 | 46 | instance ToBitField Trigger where 47 | toBitField t = case t of 48 | T6_TRGO -> "000" 49 | T8_TRGO -> "001" 50 | T7_TRGO -> "010" 51 | T5_TRGO -> "011" 52 | T2_TRGO -> "100" 53 | T4_TRGO -> "101" 54 | Ext_IT9 -> "110" 55 | Software -> "111" 56 | 57 | data Wave = Noise | Triangle 58 | deriving (Show,Eq) 59 | 60 | data TriangleAmplitude 61 | = Amplitude_1 | Amplitude_3 | Amplitude_7 | Amplitude_15 62 | | Amplitude_31 | Amplitude_63 63 | | Amplitude_127 | Amplitude_255 | Amplitude_511 | Amplitude_1023 64 | | Amplitude_2047 | Amplitude_4095 65 | deriving (Show,Eq) 66 | 67 | instance ToBitField TriangleAmplitude where 68 | toBitField t = case t of 69 | Amplitude_1 -> "0000" 70 | Amplitude_3 -> "0001" 71 | Amplitude_7 -> "0010" 72 | Amplitude_15 -> "0011" 73 | Amplitude_31 -> "0100" 74 | Amplitude_63 -> "0101" 75 | Amplitude_127 -> "0110" 76 | Amplitude_255 -> "0111" 77 | Amplitude_511 -> "1000" 78 | Amplitude_1023 -> "1001" 79 | Amplitude_2047 -> "1010" 80 | Amplitude_4095 -> "1011" 81 | 82 | data LFSRUnmask 83 | = Bit0 | Bits1 | Bits2 | Bits3 | Bits4 | Bits5 | Bits6 | Bits7 84 | | Bits8 | Bits9 | Bits10 | Bits11 85 | deriving (Show,Eq) 86 | 87 | instance ToBitField LFSRUnmask where 88 | toBitField t = case t of 89 | Bit0 -> "0000" 90 | Bits1 -> "0001" 91 | Bits2 -> "0010" 92 | Bits3 -> "0011" 93 | Bits4 -> "0100" 94 | Bits5 -> "0101" 95 | Bits6 -> "0110" 96 | Bits7 -> "0111" 97 | Bits8 -> "1000" 98 | Bits9 -> "1001" 99 | Bits10 -> "1010" 100 | Bits11 -> "1011" 101 | 102 | data Channel = Channel_1 | Channel_2 deriving (Show,Eq) 103 | 104 | data Align = Align_12b_R | Align_12b_L | Align_8b_R deriving (Show,Eq) 105 | 106 | deInit :: MI () 107 | deInit = RCC.peripheralResetToggle DAC 108 | 109 | init :: Channel -> Config -> MI () 110 | init channel config = do 111 | let (tsel,wave,mamp,boff) = case channel of 112 | Channel_1 -> (CR_TSEL1,CR_WAVE1,CR_MAMP1,CR_BOFF1) 113 | Channel_2 -> (CR_TSEL2,CR_WAVE2,CR_MAMP2,CR_BOFF2) 114 | 115 | regFieldWrite DAC tsel $ case _trigger config of 116 | Nothing -> "000" 117 | Just t -> toBitField t 118 | 119 | regFieldWrite DAC wave $ case _waveGeneration config of 120 | Nothing -> BitField [False,False] 121 | Just Noise -> BitField [False,True] 122 | Just Triangle -> BitField [True,False] 123 | 124 | regFieldWrite DAC mamp $ case _LFSRUnmask_TriangleAmplitude config of 125 | Right t -> toBitField t 126 | Left t -> toBitField t 127 | 128 | bitWrite DAC boff $ not $ _outputBuffer config 129 | 130 | cmd :: Channel -> Bool -> MI () 131 | cmd Channel_1 rs = bitWrite DAC CR_EN1 rs 132 | cmd Channel_2 rs = bitWrite DAC CR_EN2 rs 133 | 134 | enable :: Channel -> MI () 135 | enable c = cmd c True 136 | 137 | disable :: Channel -> MI () 138 | disable c = cmd c False 139 | 140 | dmaCmd :: Channel -> Bool -> MI () 141 | dmaCmd Channel_1 rs = bitWrite DAC CR_DMAEN1 rs 142 | dmaCmd Channel_2 rs = bitWrite DAC CR_DMAEN2 rs 143 | 144 | 145 | enableDMA :: Channel -> MI () 146 | enableDMA c = dmaCmd c True 147 | 148 | disableDMA :: Channel -> MI () 149 | disableDMA c = dmaCmd c False 150 | 151 | softwareTriggerCmd :: Channel -> Bool -> MI () 152 | softwareTriggerCmd Channel_1 rs = bitWrite DAC SWTRIGR_SWTRIG1 rs 153 | softwareTriggerCmd Channel_2 rs = bitWrite DAC SWTRIGR_SWTRIG2 rs 154 | 155 | enableSoftwareTrigger :: Channel -> MI () 156 | enableSoftwareTrigger c = softwareTriggerCmd c True 157 | 158 | disableSoftwareTrigger :: Channel -> MI () 159 | disableSoftwareTrigger c = softwareTriggerCmd c False 160 | 161 | dualSoftwareTriggerCmd :: Bool -> MI () 162 | dualSoftwareTriggerCmd rs = do 163 | softwareTriggerCmd Channel_1 rs 164 | softwareTriggerCmd Channel_2 rs 165 | 166 | enableDualSoftwareTrigger :: MI () 167 | enableDualSoftwareTrigger = dualSoftwareTriggerCmd True 168 | 169 | disableDualSoftwareTrigger :: MI () 170 | disableDualSoftwareTrigger = dualSoftwareTriggerCmd False 171 | 172 | waveGenerationCmd :: Channel -> (Maybe Wave) -> MI () 173 | waveGenerationCmd ch wave = regFieldWrite DAC register bits 174 | where 175 | register = case ch of 176 | Channel_1 -> CR_WAVE1 177 | Channel_2 -> CR_WAVE2 178 | bits :: BitField 179 | bits = case wave of 180 | Nothing -> "00" 181 | (Just Noise) -> "01" 182 | (Just Triangle)-> "10" 183 | 184 | disableWaveGeneration :: Channel -> MI () 185 | disableWaveGeneration ch = waveGenerationCmd ch Nothing 186 | 187 | setChannel1Data :: Align -> Word16 -> MI () 188 | setChannel1Data align w = pokeReg DAC reg $ fromIntegral w 189 | where 190 | reg = case align of 191 | Align_12b_R -> DHR12R1 192 | Align_12b_L -> DHR12L1 193 | Align_8b_R -> DHR8R1 194 | 195 | setChannel2Data :: Align -> Word16 -> MI () 196 | setChannel2Data align w = pokeReg DAC reg $ fromIntegral w 197 | where 198 | reg = case align of 199 | Align_12b_R -> DHR12R2 200 | Align_12b_L -> DHR12L2 201 | Align_8b_R -> DHR8R2 202 | 203 | setDualChannelData :: Align -> Word16 -> Word16 -> MI () 204 | setDualChannelData align w1 w2 205 | = pokeReg DAC reg $ (fromIntegral w1) .|. (byteSwap32 $ fromIntegral w2) 206 | where 207 | reg = case align of 208 | Align_12b_R -> DHR12RD 209 | Align_12b_L -> DHR12LD 210 | Align_8b_R -> DHR8RD 211 | 212 | getDataOutputValue :: Channel -> MI (Word16) 213 | getDataOutputValue Channel_1 = fmap fromIntegral $ peekReg DAC DOR1 214 | getDataOutputValue Channel_2 = fmap fromIntegral $ peekReg DAC DOR2 215 | 216 | setChannel1 :: Word16 -> MI () 217 | setChannel1 = setChannel1Data Align_12b_R 218 | 219 | setChannel2 :: Word16 -> MI () 220 | setChannel2 = setChannel2Data Align_12b_R 221 | 222 | setDualChannel :: Word16 -> Word16 -> MI () 223 | setDualChannel = setDualChannelData Align_12b_R 224 | -------------------------------------------------------------------------------- /STM32-Zombie/src/STM32/DMA.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : STM32.DMA 4 | -- Copyright : (c) Marc Fontaine 2017 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Marc.Fontaine@gmx.de 8 | -- Stability : experimental 9 | -- Portability : GHC-only 10 | -- 11 | -- 12 | -- The direct memory access (DMA) 13 | -- controller is one of the coolest features of STM32Fxxx 14 | -- micro controllers. 15 | -- For example, one can sample signals at a fast and precise 16 | -- sampling rate or generate wave-form patterns using DMA transfers. 17 | -- DMA transfers run completely independent and in parallel 18 | -- from the CPU or the Haskell code. 19 | 20 | {-# LANGUAGE NoMonomorphismRestriction #-} 21 | module STM32.DMA 22 | where 23 | 24 | import Device 25 | import STM32.MachineInterface 26 | import STM32.Utils 27 | 28 | import Data.Word 29 | 30 | data Channel 31 | = DMA1_Channel1 32 | | DMA1_Channel2 33 | | DMA1_Channel3 34 | | DMA1_Channel4 35 | | DMA1_Channel5 36 | | DMA1_Channel6 37 | | DMA1_Channel7 38 | | DMA2_Channel1 39 | | DMA2_Channel2 40 | | DMA2_Channel3 41 | | DMA2_Channel4 42 | | DMA2_Channel5 43 | deriving Show 44 | 45 | channelToPeripheral :: Channel -> Peripheral 46 | channelToPeripheral ch = case ch of 47 | DMA1_Channel1 -> DMA1 48 | DMA1_Channel2 -> DMA1 49 | DMA1_Channel3 -> DMA1 50 | DMA1_Channel4 -> DMA1 51 | DMA1_Channel5 -> DMA1 52 | DMA1_Channel6 -> DMA1 53 | DMA1_Channel7 -> DMA1 54 | DMA2_Channel1 -> DMA2 55 | DMA2_Channel2 -> DMA2 56 | DMA2_Channel3 -> DMA2 57 | DMA2_Channel4 -> DMA2 58 | DMA2_Channel5 -> DMA2 59 | 60 | channelToCCR :: Channel -> Register 61 | channelToCCR ch = case ch of 62 | DMA1_Channel1 -> CCR1 63 | DMA1_Channel2 -> CCR2 64 | DMA1_Channel3 -> CCR3 65 | DMA1_Channel4 -> CCR4 66 | DMA1_Channel5 -> CCR5 67 | DMA1_Channel6 -> CCR6 68 | DMA1_Channel7 -> CCR7 69 | DMA2_Channel1 -> CCR1 70 | DMA2_Channel2 -> CCR2 71 | DMA2_Channel3 -> CCR3 72 | DMA2_Channel4 -> CCR4 73 | DMA2_Channel5 -> CCR5 74 | 75 | channelToCNDTR :: Channel -> Register 76 | channelToCNDTR ch = case ch of 77 | DMA1_Channel1 -> CNDTR1 78 | DMA1_Channel2 -> CNDTR2 79 | DMA1_Channel3 -> CNDTR3 80 | DMA1_Channel4 -> CNDTR4 81 | DMA1_Channel5 -> CNDTR5 82 | DMA1_Channel6 -> CNDTR6 83 | DMA1_Channel7 -> CNDTR7 84 | DMA2_Channel1 -> CNDTR1 85 | DMA2_Channel2 -> CNDTR2 86 | DMA2_Channel3 -> CNDTR3 87 | DMA2_Channel4 -> CNDTR4 88 | DMA2_Channel5 -> CNDTR5 89 | 90 | channelToCPAR :: Channel -> Register 91 | channelToCPAR ch = case ch of 92 | DMA1_Channel1 -> CPAR1 93 | DMA1_Channel2 -> CPAR2 94 | DMA1_Channel3 -> CPAR3 95 | DMA1_Channel4 -> CPAR4 96 | DMA1_Channel5 -> CPAR5 97 | DMA1_Channel6 -> CPAR6 98 | DMA1_Channel7 -> CPAR7 99 | DMA2_Channel1 -> CPAR1 100 | DMA2_Channel2 -> CPAR2 101 | DMA2_Channel3 -> CPAR3 102 | DMA2_Channel4 -> CPAR4 103 | DMA2_Channel5 -> CPAR5 104 | 105 | channelToCMAR :: Channel -> Register 106 | channelToCMAR ch = case ch of 107 | DMA1_Channel1 -> CMAR1 108 | DMA1_Channel2 -> CMAR2 109 | DMA1_Channel3 -> CMAR3 110 | DMA1_Channel4 -> CMAR4 111 | DMA1_Channel5 -> CMAR5 112 | DMA1_Channel6 -> CMAR6 113 | DMA1_Channel7 -> CMAR7 114 | DMA2_Channel1 -> CMAR1 115 | DMA2_Channel2 -> CMAR2 116 | DMA2_Channel3 -> CMAR3 117 | DMA2_Channel4 -> CMAR4 118 | DMA2_Channel5 -> CMAR5 119 | 120 | data Config = Config { 121 | _BufferSize :: Word16 --number of entries 122 | ,_Direction :: Direction 123 | ,_MemoryBaseAddr :: Word32 124 | ,_MemoryDataSize :: DataSize 125 | ,_MemoryInc :: Bool 126 | ,_Mode :: Mode 127 | ,_PeripheralBaseAddr :: Word32 128 | ,_PeripheralDataSize :: DataSize 129 | ,_PeripheralInc :: Bool 130 | ,_Priority :: Priority 131 | } deriving Show 132 | 133 | data Direction 134 | = PeripheralDST | PeripheralSRC | Mem2Mem 135 | deriving Show 136 | 137 | data Priority 138 | = VeryHigh | High | Medium | Low 139 | deriving Show 140 | 141 | {- 142 | instance ToBitField Priority where 143 | toBitField p = case p of 144 | -} 145 | 146 | data DataSize 147 | = Byte | HalfWord | Word 148 | deriving Show 149 | 150 | data Mode 151 | = Circular | Normal 152 | deriving Show 153 | 154 | instance ToBit Mode where 155 | toBit Normal = False 156 | toBit Circular = True 157 | 158 | 159 | writeCCRxOffset :: ToBit b => Int -> Channel -> Field -> b -> MI() 160 | writeCCRxOffset offset channel field rs 161 | = bitWriteRaw rs 162 | (regToAddr (channelToPeripheral channel) $ channelToCCR channel ) 163 | (offset + fieldBitOffset field) 164 | 165 | init :: Channel -> Config -> MI () 166 | init channel config = do 167 | let 168 | peri = channelToPeripheral channel 169 | writeCCRx = writeCCRxOffset 0 channel 170 | writeCCRxH = writeCCRxOffset 1 channel 171 | writeCCRxL = writeCCRx 172 | 173 | poke = pokeReg peri 174 | cndtr = channelToCNDTR channel 175 | cpar = channelToCPAR channel 176 | cmar = channelToCMAR channel 177 | 178 | writeCCRx CCR1_DIR $ case _Direction config of 179 | PeripheralSRC -> False 180 | Mem2Mem -> True 181 | PeripheralDST -> True 182 | 183 | writeCCRx CCR1_CIRC $ _Mode config 184 | writeCCRx CCR1_PINC $ _PeripheralInc config 185 | writeCCRx CCR1_MINC $ _MemoryInc config 186 | 187 | let (psizeH,psizeL) = case _PeripheralDataSize config of 188 | Byte -> (False,False) 189 | HalfWord -> (False, True) 190 | Word -> (True ,False) 191 | writeCCRxL CCR1_PSIZE psizeL 192 | writeCCRxH CCR1_PSIZE psizeH 193 | 194 | let (msizeH,msizeL) = case _MemoryDataSize config of 195 | Byte -> (False,False) 196 | HalfWord -> (False, True) 197 | Word -> (True ,False) 198 | writeCCRxL CCR1_MSIZE msizeL 199 | writeCCRxH CCR1_MSIZE msizeH 200 | 201 | let (prioH,prioL) = case _Priority config of 202 | Low -> (False,False) 203 | Medium -> (False, True) 204 | High -> (True ,False) 205 | VeryHigh -> (True ,True ) 206 | writeCCRxL CCR1_PL prioL 207 | writeCCRxH CCR1_PL prioH 208 | 209 | writeCCRx CCR1_MEM2MEM $ case _Direction config of 210 | Mem2Mem -> True 211 | PeripheralSRC -> False 212 | PeripheralDST -> False 213 | 214 | poke cndtr $ fromIntegral $ _BufferSize config 215 | poke cpar $ _PeripheralBaseAddr config 216 | poke cmar $ _MemoryBaseAddr config 217 | 218 | cmd :: Channel -> Bool -> MI () 219 | cmd c rs 220 | = writeCCRxOffset 0 c CCR1_EN rs 221 | 222 | enable :: Channel -> MI () 223 | enable c = cmd c True 224 | 225 | disable :: Channel -> MI () 226 | disable c = cmd c False 227 | 228 | deInit :: Channel -> MI() 229 | deInit channel = do 230 | let poke = pokeReg $ channelToPeripheral channel 231 | 232 | disable channel 233 | poke (channelToCCR channel) 0 234 | poke (channelToCNDTR channel) 0 235 | poke (channelToCPAR channel) 0 236 | poke (channelToCMAR channel) 0 237 | -------------------------------------------------------------------------------- /STM32-Zombie/src/STM32/GPIO.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : STM32.GPIO 4 | -- Copyright : (c) Marc Fontaine 2017 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Marc.Fontaine@gmx.de 8 | -- Stability : experimental 9 | -- Portability : GHC-only 10 | -- 11 | -- General Purpose Input Output 12 | {-# LANGUAGE OverloadedStrings #-} 13 | module STM32.GPIO 14 | where 15 | 16 | import Device 17 | import STM32.MachineInterface 18 | import STM32.Utils 19 | 20 | data Pin 21 | = Pin_0 | Pin_1 | Pin_2 | Pin_3 | Pin_4 | Pin_5 | Pin_6 | Pin_7 | Pin_8 22 | | Pin_9 | Pin_10 | Pin_11 | Pin_12 | Pin_13 | Pin_14 | Pin_15 23 | deriving (Show,Ord,Eq,Enum) 24 | 25 | type Wire = (Peripheral,Pin) 26 | 27 | pinOut :: Wire -> Bool -> MI () 28 | pinOut (p,pin) rs = case rs of 29 | True -> bitSet p $ bsFromPin pin 30 | False -> bitSet p $ brFromPin pin 31 | 32 | pinHigh :: Wire -> MI () 33 | pinHigh w = pinOut w True 34 | 35 | pinLow :: Wire -> MI () 36 | pinLow w = pinOut w False 37 | 38 | data Speed 39 | = MHz_10 40 | | MHz_2 41 | | MHz_50 42 | deriving (Eq,Ord,Show) 43 | 44 | instance ToBitField Speed where 45 | toBitField s = case s of 46 | MHz_10 -> "01" 47 | MHz_2 -> "10" 48 | MHz_50 -> "11" 49 | 50 | data PinMode 51 | = GPOutPushPull Speed 52 | | GPOutOpenDrain Speed 53 | | AlternateOutPushPull Speed 54 | | AlternateOutOpenDrain Speed 55 | | InputAnalog 56 | | InputFloating 57 | | InputPullDown 58 | | InputPullUp 59 | deriving (Eq,Ord,Show) 60 | 61 | pinMode :: Wire -> PinMode -> MI () 62 | pinMode (p,n) m = do 63 | regFieldWrite p (cnfFromPin n) $ case m of 64 | GPOutPushPull _ -> "00" 65 | GPOutOpenDrain _ -> "01" 66 | AlternateOutPushPull _ -> "10" 67 | AlternateOutOpenDrain _ -> "11" 68 | InputAnalog -> "00" 69 | InputFloating -> "01" 70 | InputPullDown -> "10" 71 | InputPullUp -> ("10" :: BitField) 72 | 73 | regFieldWrite p (modeFromPin n) $ case m of 74 | GPOutPushPull s -> toBitField s 75 | GPOutOpenDrain s -> toBitField s 76 | AlternateOutPushPull s -> toBitField s 77 | AlternateOutOpenDrain s -> toBitField s 78 | InputAnalog -> "00" 79 | InputFloating -> "00" 80 | InputPullDown -> "00" 81 | InputPullUp -> "00" 82 | case m of 83 | InputPullDown -> pinLow (p,n) 84 | InputPullUp -> pinHigh (p,n) 85 | _ -> return () 86 | 87 | cnfFromPin :: Pin -> Field 88 | cnfFromPin p = cnf 89 | where 90 | (cnf,_,_,_) = pinToFields p 91 | 92 | modeFromPin :: Pin -> Field 93 | modeFromPin p = m 94 | where 95 | (_,m,_,_) = pinToFields p 96 | 97 | bsFromPin :: Pin -> Field 98 | bsFromPin p = bs 99 | where 100 | (_,_,bs,_) = pinToFields p 101 | 102 | brFromPin :: Pin -> Field 103 | brFromPin p = br 104 | where 105 | (_,_,_,br) = pinToFields p 106 | 107 | pinToFields :: Pin -> (Field,Field,Field,Field) 108 | pinToFields p = case p of 109 | Pin_0 -> ( CRL_CNF0 , CRL_MODE0 , BSRR_BS0 , BSRR_BR0 ) 110 | Pin_1 -> ( CRL_CNF1 , CRL_MODE1 , BSRR_BS1 , BSRR_BR1 ) 111 | Pin_2 -> ( CRL_CNF2 , CRL_MODE2 , BSRR_BS2 , BSRR_BR2 ) 112 | Pin_3 -> ( CRL_CNF3 , CRL_MODE3 , BSRR_BS3 , BSRR_BR3 ) 113 | Pin_4 -> ( CRL_CNF4 , CRL_MODE4 , BSRR_BS4 , BSRR_BR4 ) 114 | Pin_5 -> ( CRL_CNF5 , CRL_MODE5 , BSRR_BS5 , BSRR_BR5 ) 115 | Pin_6 -> ( CRL_CNF6 , CRL_MODE6 , BSRR_BS6 , BSRR_BR6 ) 116 | Pin_7 -> ( CRL_CNF7 , CRL_MODE7 , BSRR_BS7 , BSRR_BR7 ) 117 | Pin_8 -> ( CRH_CNF8 , CRH_MODE8 , BSRR_BS8 , BSRR_BR8 ) 118 | Pin_9 -> ( CRH_CNF9 , CRH_MODE9 , BSRR_BS9 , BSRR_BR9 ) 119 | Pin_10 -> ( CRH_CNF10 , CRH_MODE10 ,BSRR_BS10 ,BSRR_BR10 ) 120 | Pin_11 -> ( CRH_CNF11 , CRH_MODE11 ,BSRR_BS11 ,BSRR_BR11 ) 121 | Pin_12 -> ( CRH_CNF12 , CRH_MODE12 ,BSRR_BS12 ,BSRR_BR12 ) 122 | Pin_13 -> ( CRH_CNF13 , CRH_MODE13 ,BSRR_BS13 ,BSRR_BR13 ) 123 | Pin_14 -> ( CRH_CNF14 , CRH_MODE14 ,BSRR_BS14 ,BSRR_BR14 ) 124 | Pin_15 -> ( CRH_CNF15 , CRH_MODE15 ,BSRR_BS15 ,BSRR_BR15 ) 125 | -------------------------------------------------------------------------------- /STM32-Zombie/src/STM32/I2C.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : STM32.GPIO 4 | -- Copyright : (c) Marc Fontaine 2017 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Marc.Fontaine@gmx.de 8 | -- Stability : experimental 9 | -- Portability : GHC-only 10 | -- 11 | -- Untested // Work in progress 12 | {-# LANGUAGE OverloadedStrings #-} 13 | module STM32.I2C 14 | where 15 | 16 | import Device 17 | import STM32.MachineInterface 18 | import STM32.Utils 19 | import qualified STM32.RCC as RCC 20 | 21 | import Control.Monad 22 | import Data.Word 23 | import Data.Bits 24 | 25 | data Config = Config { 26 | _mode :: Mode 27 | , _dutyCycle :: DutyCycle 28 | , _ownAddress1 :: Word16 29 | , _ack :: Bool 30 | , _acknowledgedAddress :: AcknowledgedAddress 31 | , _clocks :: Clocks 32 | } deriving Show 33 | 34 | 35 | defaultConfig :: Config 36 | defaultConfig = Config { 37 | _mode = I2C 38 | , _dutyCycle = DutyCycle_2 39 | , _ownAddress1 = 0 40 | , _ack = False 41 | , _acknowledgedAddress = SevenBit 42 | , _clocks = defaultClocks 43 | } 44 | 45 | data Mode = I2C | SMBusDevice | SMBusHost deriving Show 46 | data DutyCycle = DutyCycle_16_9 | DutyCycle_2 deriving Show 47 | data Direction = Transmitter | Receiver deriving Show 48 | data AcknowledgedAddress = SevenBit | TenBit deriving Show 49 | 50 | data Clocks = Clocks { 51 | _freq :: Word32 52 | ,_ccr :: Word32 53 | ,_trise :: Word32 54 | } deriving Show 55 | 56 | defaultClocks :: Clocks 57 | defaultClocks = Clocks {_freq = 36,_ccr=0,_trise=0} 58 | 59 | deInit :: Peripheral -> MI () 60 | deInit = RCC.peripheralResetToggle 61 | 62 | init :: Peripheral -> Config -> MI () 63 | init p conf = do 64 | cr2 <- peekReg p CR2 65 | pokeReg p CR2 $ ((cr2 .&. 0xffffffe00) .|. (fromIntegral $ _freq $ _clocks conf)) 66 | 67 | disable p 68 | pokeReg p TRISE $ _trise $ _clocks conf 69 | pokeReg p CCR $ _ccr $ _clocks conf 70 | enable p 71 | let write field rs = bitWrite p field rs 72 | 73 | write CR1_SMBUS $ case _mode conf of 74 | I2C -> False 75 | SMBusDevice -> True 76 | SMBusHost -> True 77 | 78 | write CR1_SMBTYPE $ case _mode conf of 79 | I2C -> False 80 | SMBusDevice -> False 81 | SMBusHost -> True 82 | 83 | write CR1_ACK $ _ack conf 84 | 85 | oar1 <- peekReg p OAR1 86 | pokeReg p OAR1 87 | ( (oar1 .&. 0x000003ff) 88 | .|. 0x00004000 89 | .|. (fromIntegral $ _ownAddress1 conf) 90 | .|. (case _acknowledgedAddress conf of 91 | SevenBit -> 0 92 | TenBit -> 0x00008000 93 | ) 94 | ) 95 | 96 | enable :: Peripheral -> MI () 97 | enable p = bitSet p CR1_PE 98 | 99 | disable :: Peripheral -> MI () 100 | disable p = bitReset p CR1_PE 101 | -------------------------------------------------------------------------------- /STM32-Zombie/src/STM32/MachineInterface.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : STM32.MachineInterface 4 | -- Copyright : (c) Marc Fontaine 2017 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Marc.Fontaine@gmx.de 8 | -- Stability : experimental 9 | -- Portability : GHC-only 10 | -- 11 | -- At the moment, there is just one implementation for the MachineInterface 12 | -- namely STM32.MachineInterfaceSTLinkUSB. 13 | -- All direct communication with the micro controller runs through this API. 14 | -- 15 | 16 | module STM32.MachineInterface 17 | ( 18 | MI 19 | ,runMI 20 | ,initMI 21 | ,resetHalt 22 | ,peek_w16 23 | ,poke_w16 24 | ,peek_w32 25 | ,poke_w32 26 | ) 27 | where 28 | import STM32.MachineInterfaceSTLinkUSB 29 | 30 | -------------------------------------------------------------------------------- /STM32-Zombie/src/STM32/MachineInterfaceSTLinkUSB.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : STM32.MachineInterfaceSTLinkUSB 4 | -- Copyright : (c) Marc Fontaine 2017 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Marc.Fontaine@gmx.de 8 | -- Stability : experimental 9 | -- Portability : GHC-only 10 | -- 11 | -- STM32.MachineInterfaceSTLinkUSB is the (internal) 12 | -- API for communication with the STM32Fxxx boards 13 | -- All communication runs through these function. 14 | -- The main driver for ST-Link USB dongles is in the STLinkUSB package. 15 | -- This module contains some small wrappers for functions from STM32.STLinkUSB. 16 | -- 17 | 18 | module STM32.MachineInterfaceSTLinkUSB 19 | ( 20 | MI 21 | ,runMI 22 | ,initMI 23 | ,STM32.MachineInterfaceSTLinkUSB.resetHalt 24 | ,peek_w16 -- check if supported by hardware if not remove 25 | ,poke_w16 -- if i remember right hardware implements poke_w16 as 2 poke_w8 26 | -- that is very bad if used on the bitbang region 27 | ,peek_w32 28 | ,poke_w32 29 | {- 30 | ,MachineInterfaceSTLinkUSB.writeMem8 31 | ,MachineInterfaceSTLinkUSB.writeMem32 32 | ,MachineInterfaceSTLinkUSB.readMem8 33 | ,MachineInterfaceSTLinkUSB.readMem32 34 | -} 35 | ) 36 | 37 | where 38 | 39 | import STM32.STLinkUSB 40 | 41 | import Data.Word 42 | import qualified Data.ByteString as BS 43 | import qualified Data.ByteString.Lazy as BSL (toStrict,fromStrict) 44 | 45 | import Data.Binary 46 | import Data.Binary.Put 47 | import Data.Binary.Get 48 | 49 | type Addr = Word32 50 | type MI a = STLT IO a 51 | 52 | runMI :: MI a -> IO a 53 | runMI = runSTLink 54 | 55 | initMI :: MI () 56 | initMI = initDongle 57 | 58 | resetHalt :: MI () 59 | resetHalt = STM32.STLinkUSB.resetHalt 60 | 61 | peek_w16 :: Addr -> MI Word16 62 | peek_w16 addr = do 63 | bs <- STM32.STLinkUSB.readMem8 addr 2 64 | return $ runGet getWord16le $ BSL.fromStrict bs 65 | 66 | peek_w32 :: Addr -> MI Word32 67 | peek_w32 addr = do 68 | bs <- STM32.STLinkUSB.readMem32 addr 4 69 | return $ runGet getWord32le $ BSL.fromStrict bs 70 | 71 | poke_w16 :: Addr -> Word16 -> MI () 72 | poke_w16 addr val 73 | = STM32.STLinkUSB.writeMem8 addr $ BSL.toStrict $ runPut $ putWord16le val 74 | 75 | poke_w32 :: Addr -> Word32 -> MI () 76 | poke_w32 addr val 77 | = STM32.STLinkUSB.writeMem32 addr $ BSL.toStrict $ runPut $ putWord32le val 78 | 79 | writeMem8 :: Addr -> BS.ByteString -> MI () 80 | writeMem8 = STM32.STLinkUSB.writeMem8 81 | 82 | writeMem32 :: Addr -> BS.ByteString -> MI () 83 | writeMem32 = STM32.STLinkUSB.writeMem32 84 | 85 | readMem8 :: Addr -> Int -> MI BS.ByteString 86 | readMem8 = STM32.STLinkUSB.readMem8 87 | 88 | readMem32 :: Addr -> Int -> MI BS.ByteString 89 | readMem32 = STM32.STLinkUSB.readMem32 90 | -------------------------------------------------------------------------------- /STM32-Zombie/src/STM32/PWR.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : STM32.PWR 4 | -- Copyright : (c) Marc Fontaine 2017 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Marc.Fontaine@gmx.de 8 | -- Stability : experimental 9 | -- Portability : GHC-only 10 | 11 | {-# LANGUAGE OverloadedStrings #-} 12 | module STM32.PWR 13 | where 14 | 15 | import Device 16 | import STM32.MachineInterface 17 | import STM32.Utils 18 | import qualified STM32.RCC as RCC 19 | 20 | data PVDLevel = U_2V2 | U_2V3 | U_2V4 | U_2V5 | U_2V6 | U_2V7 | U_2V8 | U_2V9 21 | deriving (Show,Eq) 22 | 23 | instance RegisterField PVDLevel where 24 | toBits b = case b of 25 | U_2V2 -> "000" 26 | U_2V3 -> "001" 27 | U_2V4 -> "010" 28 | U_2V5 -> "011" 29 | U_2V6 -> "100" 30 | U_2V7 -> "101" 31 | U_2V8 -> "110" 32 | U_2V9 -> "111" 33 | toField = const CR_PLS 34 | 35 | data Flag = WU | SB | PVDO 36 | deriving (Show,Eq) 37 | 38 | deInit :: MI () 39 | deInit = RCC.peripheralResetToggle PWR 40 | 41 | backupAccessCmd :: Bool -> MI () 42 | backupAccessCmd = bitWrite PWR CR_DBP 43 | 44 | pvdCmd :: Bool -> MI () 45 | pvdCmd = bitWrite PWR CR_PVDE 46 | 47 | pvdLevelConfig :: PVDLevel -> MI () 48 | pvdLevelConfig = fieldWrite PWR 49 | 50 | wakeUpPinCmd :: Bool -> MI () 51 | wakeUpPinCmd = bitWrite PWR CSR_EWUP 52 | 53 | getFlagStatus :: Flag -> MI Bool 54 | getFlagStatus = error "todo" 55 | 56 | 57 | clearFlag :: Flag -> MI () 58 | clearFlag flag = bitSet PWR $ case flag of 59 | WU -> CR_CWUF 60 | SB -> CR_CSBF 61 | PVDO -> CR_PVDE 62 | -------------------------------------------------------------------------------- /STM32-Zombie/src/STM32/RCC.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : STM32.RCC 4 | -- Copyright : (c) Marc Fontaine 2017 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Marc.Fontaine@gmx.de 8 | -- Stability : experimental 9 | -- Portability : GHC-only 10 | -- 11 | -- Clock control and 12 | -- resetting parts of the hardware. 13 | 14 | {-# LANGUAGE OverloadedStrings #-} 15 | module STM32.RCC 16 | where 17 | 18 | import Device 19 | import STM32.MachineInterface 20 | import STM32.Utils 21 | 22 | deInit :: MI () 23 | deInit = do 24 | bitSet RCC CR_HSION 25 | andReg RCC CFGR 0xF8FF0000 26 | 27 | bitReset RCC CR_HSEON 28 | bitReset RCC CR_CSSON 29 | bitReset RCC CR_PLLON 30 | 31 | bitReset RCC CR_HSEBYP 32 | 33 | andReg RCC CFGR 0xFF80FFFF 34 | pokeReg RCC CIR 0 35 | 36 | set_HSE_OFF :: MI () 37 | set_HSE_OFF = do 38 | bitReset RCC CR_HSEON 39 | bitReset RCC CR_HSEBYP 40 | 41 | set_HSE_ON :: MI () 42 | set_HSE_ON = do 43 | set_HSE_OFF 44 | bitSet RCC CR_HSEON 45 | 46 | set_HSE_Bypass :: MI () 47 | set_HSE_Bypass = do 48 | set_HSE_ON 49 | bitSet RCC CR_HSEBYP 50 | 51 | 52 | peripheralClockOn :: Peripheral -> MI () 53 | peripheralClockOn = peripheralClock True 54 | 55 | peripheralClockOff :: Peripheral -> MI () 56 | peripheralClockOff = peripheralClock False 57 | 58 | peripheralClock :: Bool -> Peripheral -> MI () 59 | peripheralClock rs p = bitWrite RCC (peripheralClockField p) rs 60 | 61 | peripheralClockField :: Peripheral -> Field 62 | peripheralClockField p = case p of 63 | I2C1 -> APB1ENR_I2C1EN 64 | SPI3 -> APB1ENR_SPI3EN 65 | TIM2 -> APB1ENR_TIM2EN 66 | TIM5 -> APB1ENR_TIM6EN 67 | USART2 -> APB1ENR_USART2EN 68 | BKP -> APB1ENR_BKPEN 69 | I2C2 -> APB1ENR_I2C2EN 70 | TIM12 -> APB1ENR_TIM12EN 71 | TIM3 -> APB1ENR_TIM3EN 72 | TIM7 -> APB1ENR_TIM7EN 73 | USART3 -> APB1ENR_USART3EN 74 | CAN -> APB1ENR_CANEN 75 | PWR -> APB1ENR_PWREN 76 | TIM13 -> APB1ENR_TIM13EN 77 | TIM4 -> APB1ENR_TIM4EN 78 | UART4 -> APB1ENR_UART4EN 79 | USB -> APB1ENR_USBEN 80 | DAC -> APB1ENR_DACEN 81 | SPI2 -> APB1ENR_SPI2EN 82 | TIM14 -> APB1ENR_TIM14EN 83 | TIM5 -> APB1ENR_TIM5EN 84 | UART5 -> APB1ENR_UART5EN 85 | WWDG -> APB1ENR_WWDGEN 86 | 87 | GPIOA -> APB2ENR_IOPAEN 88 | GPIOB -> APB2ENR_IOPBEN 89 | GPIOC -> APB2ENR_IOPCEN 90 | GPIOD -> APB2ENR_IOPDEN 91 | GPIOE -> APB2ENR_IOPEEN 92 | GPIOF -> APB2ENR_IOPFEN 93 | GPIOG -> APB2ENR_IOPGEN 94 | ADC1 -> APB2ENR_ADC1EN 95 | ADC2 -> APB2ENR_ADC2EN 96 | ADC3 -> APB2ENR_ADC3EN 97 | SPI1 -> APB2ENR_SPI1EN 98 | TIM1 -> APB2ENR_TIM1EN 99 | TIM8 -> APB2ENR_TIM8EN 100 | TIM9 -> APB2ENR_TIM9EN 101 | TIM10 -> APB2ENR_TIM10EN 102 | TIM11 -> APB2ENR_TIM11EN 103 | USART1 -> APB2ENR_USART1EN 104 | AFIO -> APB2ENR_AFIOEN 105 | DMA1 -> AHBENR_DMA1EN 106 | DMA2 -> AHBENR_DMA2EN 107 | SDIO -> AHBENR_SDIOEN 108 | CRC -> AHBENR_CRCEN 109 | FSMC -> AHBENR_FSMCEN 110 | 111 | peripheralReset :: Bool -> Peripheral -> MI () 112 | peripheralReset rs p = bitWrite RCC (peripheralResetField p) rs 113 | 114 | peripheralResetToggle :: Peripheral -> MI () 115 | peripheralResetToggle p = do 116 | peripheralReset True p 117 | peripheralReset False p 118 | 119 | peripheralResetField :: Peripheral -> Field 120 | peripheralResetField p = case p of 121 | AFIO -> APB2RSTR_AFIORST 122 | GPIOD -> APB2RSTR_IOPDRST 123 | SPI1 -> APB2RSTR_SPI1RST 124 | TIM8 -> APB2RSTR_TIM8RST 125 | ADC1 -> APB2RSTR_ADC1RST 126 | GPIOA -> APB2RSTR_IOPARST 127 | GPIOE -> APB2RSTR_IOPERST 128 | TIM10 -> APB2RSTR_TIM10RST 129 | TIM9 -> APB2RSTR_TIM9RST 130 | ADC2 -> APB2RSTR_ADC2RST 131 | GPIOB -> APB2RSTR_IOPBRST 132 | GPIOF -> APB2RSTR_IOPFRST 133 | TIM11 -> APB2RSTR_TIM11RST 134 | USART1 -> APB2RSTR_USART1RST 135 | ADC3 -> APB2RSTR_ADC3RST 136 | GPIOC -> APB2RSTR_IOPCRST 137 | GPIOG -> APB2RSTR_IOPGRST 138 | TIM1 -> APB2RSTR_TIM1RST 139 | BKP -> APB1RSTR_BKPRST 140 | I2C2 -> APB1RSTR_I2C2RST 141 | TIM12 -> APB1RSTR_TIM12RST 142 | TIM3 -> APB1RSTR_TIM3RST 143 | TIM7 -> APB1RSTR_TIM7RST 144 | USART3 -> APB1RSTR_USART3RST 145 | CAN -> APB1RSTR_CANRST 146 | PWR -> APB1RSTR_PWRRST 147 | TIM13 -> APB1RSTR_TIM13RST 148 | TIM4 -> APB1RSTR_TIM4RST 149 | UART4 -> APB1RSTR_UART4RST 150 | USB -> APB1RSTR_USBRST 151 | DAC -> APB1RSTR_DACRST 152 | SPI2 -> APB1RSTR_SPI2RST 153 | TIM14 -> APB1RSTR_TIM14RST 154 | TIM5 -> APB1RSTR_TIM5RST 155 | UART5 -> APB1RSTR_UART5RST 156 | WWDG -> APB1RSTR_WWDGRST 157 | I2C1 -> APB1RSTR_I2C1RST 158 | SPI3 -> APB1RSTR_SPI3RST 159 | TIM2 -> APB1RSTR_TIM2RST 160 | TIM6 -> APB1RSTR_TIM6RST 161 | USART2 -> APB1RSTR_USART2RST 162 | 163 | data SYSCLK_Div 164 | = SYSCLK_Div1 | SYSCLK_Div2 | SYSCLK_Div4 | SYSCLK_Div8 165 | | SYSCLK_Div16 | SYSCLK_Div64 | SYSCLK_Div128 166 | | SYSCLK_Div256 | SYSCLK_Div512 deriving (Show,Eq) 167 | 168 | instance RegisterField SYSCLK_Div where 169 | toBits d = case d of 170 | SYSCLK_Div1 -> "0000" 171 | SYSCLK_Div2 -> "1000" 172 | SYSCLK_Div4 -> "1001" 173 | SYSCLK_Div8 -> "1010" 174 | SYSCLK_Div16 -> "1011" 175 | SYSCLK_Div64 -> "1100" 176 | SYSCLK_Div128 -> "1101" 177 | SYSCLK_Div256 -> "1110" 178 | SYSCLK_Div512 -> "1111" 179 | toField = const CFGR_HPRE 180 | 181 | hCLKConfig :: SYSCLK_Div -> MI() 182 | hCLKConfig = fieldWrite RCC 183 | 184 | data HCLK_Div 185 | = HCLK_Div1 | HCLK_Div2 | HCLK_Div4 | HCLK_Div8 | HCLK_Div16 186 | deriving Show 187 | 188 | instance ToBitField HCLK_Div where 189 | toBitField d = case d of 190 | HCLK_Div1 -> "000" 191 | HCLK_Div2 -> "100" 192 | HCLK_Div4 -> "101" 193 | HCLK_Div8 -> "110" 194 | HCLK_Div16 -> "111" 195 | 196 | 197 | pCLK1Config :: HCLK_Div -> MI() 198 | pCLK1Config = regFieldWrite RCC CFGR_PPRE1 199 | 200 | pCLK2Config :: HCLK_Div -> MI() 201 | pCLK2Config = regFieldWrite RCC CFGR_PPRE2 202 | 203 | data PLLSource 204 | = PLLSource_HSI_Div2 | PLLSource_HSE_Div1 | PLLSource_HSE_Div2 205 | deriving Show 206 | 207 | data PLLMul 208 | = PLLMul4 | PLLMul5 | PLLMul6 | PLLMul7 | PLLMul8 | PLLMul9 | PLLMul65 209 | deriving Show 210 | 211 | instance RegisterField PLLMul where 212 | toBits m = case m of 213 | PLLMul4 -> "0010" 214 | PLLMul5 -> "0011" 215 | PLLMul6 -> "0100" 216 | PLLMul7 -> "0101" 217 | PLLMul8 -> "0110" 218 | PLLMul9 -> "0111" 219 | PLLMul65 -> "1101" 220 | toField = const CFGR_PLLMUL 221 | 222 | pllConfig :: PLLSource -> PLLMul -> MI () 223 | pllConfig source mult = do 224 | let set f = bitWrite RCC f 225 | set CFGR_PLLXTPRE $ case source of 226 | PLLSource_HSE_Div1 -> False 227 | PLLSource_HSE_Div2 -> True 228 | PLLSource_HSI_Div2 -> True 229 | 230 | set CFGR_PLLSRC $ case source of 231 | PLLSource_HSI_Div2 -> False 232 | PLLSource_HSE_Div1 -> True 233 | PLLSource_HSE_Div2 -> True 234 | 235 | fieldWrite RCC mult 236 | 237 | data SYSCLKSource 238 | = SYSCLKSource_HSI 239 | | SYSCLKSource_HSE 240 | | SYSCLKSource_PLLCLK 241 | 242 | instance RegisterField SYSCLKSource where 243 | toBits s = case s of 244 | SYSCLKSource_HSI -> "00" 245 | SYSCLKSource_HSE -> "01" 246 | SYSCLKSource_PLLCLK -> "10" 247 | toField = const CFGR_SW 248 | 249 | sysCLKConfig :: SYSCLKSource -> MI() 250 | sysCLKConfig = fieldWrite RCC 251 | 252 | pllCmd :: Bool -> MI () 253 | pllCmd rs = bitWrite RCC CR_PLLON rs 254 | 255 | pllCmdEnable :: MI () 256 | pllCmdEnable = pllCmd True 257 | 258 | setDefaultClocks :: MI() 259 | setDefaultClocks = do 260 | deInit 261 | set_HSE_ON 262 | 263 | hCLKConfig SYSCLK_Div1 264 | pCLK2Config HCLK_Div1 265 | pCLK1Config HCLK_Div2 266 | 267 | pllConfig PLLSource_HSE_Div1 PLLMul9 268 | pllCmdEnable 269 | sysCLKConfig SYSCLKSource_PLLCLK 270 | 271 | 272 | data LSE = LSE_OFF | LSE_ON | LSE_Bypass 273 | deriving (Show,Eq) 274 | 275 | lseConfig :: LSE -> MI () 276 | lseConfig lse = do 277 | andReg RCC BDCR 0xffffff00 -- stmlib uses u8-access here ? 278 | case lse of 279 | LSE_OFF -> return () 280 | LSE_ON -> bitSet RCC BDCR_LSEON 281 | LSE_Bypass -> bitSet RCC BDCR_LSEON >> bitSet RCC BDCR_LSEBYP 282 | 283 | data RtcClockSource = LSE | LSI | HSE_Div128 284 | deriving (Show,Eq) 285 | 286 | instance RegisterField RtcClockSource where 287 | toBits d = case d of 288 | LSE -> "01" 289 | LSI -> "10" 290 | HSE_Div128 -> "11" 291 | toField = const BDCR_RTCSEL 292 | 293 | rtcClockConfig :: RtcClockSource -> MI () 294 | rtcClockConfig = fieldWrite RCC 295 | 296 | rtcClkCmd :: Bool -> MI () 297 | rtcClkCmd = bitWrite RCC BDCR_RTCEN 298 | -------------------------------------------------------------------------------- /STM32-Zombie/src/STM32/RTC.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : STM32.RTC 4 | -- Copyright : (c) Marc Fontaine 2017 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Marc.Fontaine@gmx.de 8 | -- Stability : experimental 9 | -- Portability : GHC-only 10 | -- 11 | -- The real time clock. 12 | 13 | module STM32.RTC 14 | where 15 | 16 | import Data.Word 17 | import Data.Bits 18 | import Device 19 | import STM32.MachineInterface 20 | import STM32.Utils 21 | import qualified STM32.PWR as PWR 22 | import qualified STM32.RCC as RCC 23 | 24 | getCounter :: MI Word32 25 | getCounter = peekLHReg RTC (CNTL,CNTH) 26 | 27 | exitConfigMode :: MI () 28 | exitConfigMode = bitReset RTC CRL_CNF 29 | 30 | enterConfigMode :: MI () 31 | enterConfigMode = bitSet RTC CRL_CNF 32 | 33 | inConfigMode :: MI x -> MI x 34 | inConfigMode action = do 35 | enterConfigMode 36 | r <- action 37 | exitConfigMode 38 | return r 39 | 40 | setCounter :: Word32 -> MI () 41 | setCounter n = inConfigMode $ pokeLHReg RTC (CNTL,CNTH) n 42 | 43 | addJustCounter :: Word32 -> MI () 44 | addJustCounter offset = do 45 | t <- getCounter 46 | setCounter $ t + offset 47 | 48 | 49 | -- | Setup the batterie powered real-time-clock. 50 | -- The board should have a backup battery and a low speed external crystal. 51 | setupLSE_RTC :: Word32 -> MI () 52 | setupLSE_RTC epoch = do 53 | RCC.peripheralClockOn BKP 54 | RCC.peripheralClockOn PWR 55 | PWR.backupAccessCmd True 56 | 57 | RCC.peripheralResetToggle BKP -- BKP_DeInit(); todo : BKP-module 58 | RCC.lseConfig RCC.LSE_ON 59 | 60 | {- /* Wait till LSE is ready */ 61 | while (RCC_GetFlagStatus(RCC_FLAG_LSERDY) == RESET) 62 | {} 63 | -} 64 | 65 | delay 100000 66 | RCC.rtcClockConfig RCC.LSE 67 | RCC.rtcClkCmd True 68 | 69 | {- 70 | /* Wait for RTC registers synchronization */ 71 | RTC_WaitForSynchro(); 72 | 73 | /* Wait until last write operation on RTC registers has finished */ 74 | RTC_WaitForLastTask(); 75 | -} 76 | delay 100000 77 | setPrescaler 32767 78 | delay 100000 79 | setCounter epoch -- didnt work?? 80 | 81 | setPrescaler :: Word32 -> MI () 82 | setPrescaler n 83 | = inConfigMode $ pokeLHReg RTC (PRLL,PRLH) (n .&. 0x000fffff) 84 | -------------------------------------------------------------------------------- /STM32-Zombie/src/STM32/SPI.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : STM32.SPI 4 | -- Copyright : (c) Marc Fontaine 2017 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Marc.Fontaine@gmx.de 8 | -- Stability : experimental 9 | -- Portability : GHC-only 10 | -- 11 | -- The SPI peripheral. 12 | 13 | {-# LANGUAGE OverloadedStrings #-} 14 | module STM32.SPI 15 | where 16 | 17 | import Device 18 | import STM32.MachineInterface 19 | import STM32.Utils 20 | import qualified STM32.RCC as RCC 21 | 22 | import Control.Monad 23 | import Data.Word 24 | 25 | data Config = Config { 26 | _direction :: Direction 27 | , _mode :: Mode 28 | , _dataSize :: DataSize 29 | , _CPOL :: ClockPolarity 30 | , _CPHA :: ClockPhase 31 | , _NSS :: SlaveSelect 32 | , _baudRatePrescaler :: BaudPrescaler 33 | , _firstBit :: FirstBit 34 | , _CRCPolynomial :: Word16 35 | } deriving Show 36 | 37 | defaultConfig :: Config 38 | defaultConfig = Config { 39 | _direction = Two_Lines_FullDuplex 40 | , _mode = Slave 41 | , _dataSize = Eight 42 | , _CPOL = Low 43 | , _CPHA = OneEdge 44 | , _NSS = Hard 45 | , _baudRatePrescaler = Prescaler_2 46 | , _firstBit = MSB 47 | , _CRCPolynomial = 7 48 | } 49 | 50 | data Direction = 51 | Two_Lines_FullDuplex -- ((u16)0x0000) 52 | | Two_Lines_RxOnly -- ((u16)0x0400) 53 | | One_Line_Rx -- ((u16)0x8000) 54 | | One_Line_Tx -- ((u16)0xC000) 55 | deriving (Show) 56 | 57 | data Mode = Master | Slave deriving Show 58 | data DataSize = Eight | Sixteen deriving Show 59 | data ClockPolarity = Low | High deriving Show 60 | data ClockPhase = OneEdge | TwoEdge deriving Show 61 | data SlaveSelect = Soft | Hard deriving Show 62 | data BaudPrescaler = 63 | Prescaler_2 64 | | Prescaler_4 65 | | Prescaler_8 66 | | Prescaler_16 67 | | Prescaler_32 68 | | Prescaler_64 69 | | Prescaler_128 70 | | Prescaler_256 71 | deriving Show 72 | 73 | instance RegisterField BaudPrescaler where 74 | toBits b = case b of 75 | Prescaler_2 -> "000" 76 | Prescaler_4 -> "001" 77 | Prescaler_8 -> "010" 78 | Prescaler_16 -> "011" 79 | Prescaler_32 -> "100" 80 | Prescaler_64 -> "101" 81 | Prescaler_128 -> "110" 82 | Prescaler_256 -> "111" 83 | toField = const CR1_BR 84 | 85 | data FirstBit = MSB | LSB deriving Show 86 | 87 | deInit :: Peripheral -> MI () 88 | deInit = RCC.peripheralResetToggle 89 | 90 | init :: Peripheral -> Config -> MI () 91 | init p conf = do 92 | let write field rs = bitWrite p field rs 93 | 94 | write CR1_MSTR $ case _mode conf of 95 | Slave -> False 96 | Master -> True 97 | 98 | write CR1_SSI $ case _mode conf of 99 | Slave -> False 100 | Master -> True 101 | 102 | write CR1_DFF $ case _dataSize conf of 103 | Eight -> False 104 | Sixteen -> True 105 | 106 | write CR1_CPOL $ case _CPOL conf of 107 | Low -> False 108 | High -> True 109 | 110 | write CR1_CPHA $ case _CPHA conf of 111 | OneEdge -> False 112 | TwoEdge -> True 113 | 114 | write CR1_SSM $ case _NSS conf of 115 | Hard -> False 116 | Soft -> True 117 | 118 | fieldWrite p $ _baudRatePrescaler conf 119 | 120 | write CR1_LSBFIRST $ case _firstBit conf of 121 | MSB -> False 122 | LSB -> True 123 | 124 | pokeReg p CRCPR $ fromIntegral $ _CRCPolynomial conf 125 | 126 | enable :: Peripheral -> MI () 127 | enable p = bitSet p CR1_SPE 128 | 129 | disable :: Peripheral -> MI () 130 | disable p = bitReset p CR1_SPE 131 | 132 | sendData8 :: Peripheral -> Word8 -> MI () 133 | sendData8 p b = pokeReg p DR $ fromIntegral b 134 | 135 | sendData :: Peripheral -> Word16 -> MI () 136 | sendData p b = pokeReg p DR $ fromIntegral b 137 | 138 | receiveData8 :: Peripheral -> MI Word8 139 | receiveData8 p = fmap fromIntegral $ peekReg p DR 140 | 141 | receiveData :: Peripheral -> MI Word16 142 | receiveData p = fmap fromIntegral $ peekReg p DR 143 | 144 | ssOutputCmd :: Peripheral -> Bool -> MI () 145 | ssOutputCmd p = bitWrite p CR2_SSOE 146 | -------------------------------------------------------------------------------- /STM32-Zombie/src/STM32/Timer.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : STM32.Timer 4 | -- Copyright : (c) Marc Fontaine 2017 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Marc.Fontaine@gmx.de 8 | -- Stability : experimental 9 | -- Portability : GHC-only 10 | -- 11 | -- Timer 12 | 13 | {-# LANGUAGE OverloadedStrings,NoMonomorphismRestriction #-} 14 | module STM32.Timer 15 | where 16 | 17 | import Device 18 | import STM32.MachineInterface 19 | import STM32.Utils 20 | import qualified STM32.RCC as RCC 21 | 22 | import Data.Word 23 | 24 | data TimeBase = TimeBase { 25 | _Prescaler :: Word16 26 | ,_CounterMode :: CounterMode 27 | ,_Period :: Word16 28 | ,_ClockDevision :: ClockDevision 29 | ,_RepetitionCounter :: Word8 30 | } deriving Show 31 | 32 | data CounterMode 33 | = Up 34 | | Down 35 | | CenterAligned1 36 | | CenterAligned2 37 | | CenterAligned3 38 | deriving Show 39 | 40 | data ClockDevision = CKD_DIV1 | CKD_DIV2 | CKD_DIV4 41 | deriving Show 42 | 43 | instance RegisterField ClockDevision where 44 | toBits b = case b of 45 | CKD_DIV1 -> "00" 46 | CKD_DIV2 -> "01" 47 | CKD_DIV4 -> "10" 48 | toField = const CR1_CKD 49 | 50 | deInit :: Peripheral -> MI () 51 | deInit = RCC.peripheralResetToggle 52 | 53 | timeBaseInit :: Peripheral -> TimeBase -> MI () 54 | timeBaseInit p conf = do 55 | fieldWrite p $ _ClockDevision conf 56 | let 57 | mode :: BitField 58 | mode = case _CounterMode conf of 59 | Up -> "00" 60 | Down -> "00" 61 | CenterAligned1 -> "01" 62 | CenterAligned2 -> "10" 63 | CenterAligned3 -> "11" 64 | regFieldWrite p CR1_CMS mode 65 | 66 | bitWrite p CR1_DIR $ case _CounterMode conf of 67 | Up -> False 68 | Down -> True 69 | _ -> True 70 | pokeReg p ARR $ fromIntegral $ _Period conf 71 | pokeReg p PSC $ fromIntegral $ _Prescaler conf 72 | bitSet p EGR_UG -- generate and update-event 73 | if ( p==TIM1 || p== TIM8) 74 | then pokeReg p RCR $ fromIntegral $ _RepetitionCounter conf 75 | else return () 76 | -------------------------------------------------------------------------------- /STM32-Zombie/src/STM32/USART.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : STM32.USART 4 | -- Copyright : (c) Marc Fontaine 2017 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Marc.Fontaine@gmx.de 8 | -- Stability : experimental 9 | -- Portability : GHC-only 10 | -- 11 | -- USART (Serial Port) 12 | 13 | {-# LANGUAGE OverloadedStrings, RecordWildCards #-} 14 | module STM32.USART 15 | where 16 | 17 | import Device 18 | import STM32.MachineInterface 19 | import STM32.Utils 20 | import STM32.GPIO as GPIO 21 | import qualified STM32.RCC as RCC 22 | 23 | import Control.Monad 24 | import Data.Word 25 | 26 | data Config = Config { 27 | _baudRate :: BaudRate 28 | , _wordLength :: WordLength 29 | , _stopBits :: StopBits 30 | , _parity :: Parity 31 | , _mode :: Mode 32 | , _hardwareFlowControl :: HardwareFlowControl 33 | } deriving (Show) 34 | 35 | {- 36 | Only USART1 is clocked with PCLK2 (72 MHz Max). Other USARTs are clocked with 37 | PCLK1 (36 MHz Max). 38 | 39 | todo :: fix the baudrate stuff-- 40 | baudrate depends on clock 41 | 42 | -} 43 | 44 | 45 | defaultConfig :: Config 46 | defaultConfig = Config { 47 | _baudRate = BaudRateRegisterValue 625 -- 115200 @ 72Mhz 48 | , _wordLength = Eight 49 | , _stopBits = One 50 | , _parity = No 51 | , _mode = RxTx 52 | , _hardwareFlowControl = None 53 | } 54 | 55 | data WordLength = Eight | Nine deriving Show 56 | instance ToBit WordLength where 57 | toBit Eight = False 58 | toBit Nine = True 59 | 60 | data StopBits = Zero5 | One | One5 | Two deriving Show 61 | instance RegisterField StopBits where 62 | toBits b = case b of 63 | One -> "00" 64 | Zero5 -> "01" 65 | Two -> "10" 66 | One5 -> "11" 67 | toField = const CR2_STOP 68 | 69 | data Parity = No | Even | Odd deriving Show 70 | data Mode = Rx | Tx | RxTx deriving Show 71 | data HardwareFlowControl = None | RTS | CTS | RTS_CTS | NA deriving (Eq,Show) 72 | data BaudRate = BaudRateRegisterValue {getBRR :: Word16} deriving Show 73 | 74 | deInit :: Peripheral -> MI () 75 | deInit = RCC.peripheralResetToggle 76 | 77 | init :: Peripheral -> Config -> MI () 78 | init p conf = do 79 | let write field rs = bitWrite p field rs 80 | 81 | fieldWrite p $ _stopBits conf 82 | 83 | write CR1_PCE $ case _parity conf of 84 | No -> False 85 | Even -> False 86 | Odd -> True 87 | 88 | write CR1_PS $ case _parity conf of 89 | Even -> False 90 | _ -> True 91 | 92 | write CR1_M $ _wordLength conf 93 | 94 | write CR1_TE $ case _mode conf of 95 | Tx -> True 96 | Rx -> False 97 | RxTx -> True 98 | 99 | write CR1_RE $ case _mode conf of 100 | Tx -> False 101 | Rx -> True 102 | RxTx -> True 103 | 104 | when (_hardwareFlowControl conf /= NA) $ do 105 | write CR3_RTSE $ case _hardwareFlowControl conf of 106 | RTS -> True 107 | RTS_CTS -> True 108 | _ -> False 109 | write CR3_CTSE $ case _hardwareFlowControl conf of 110 | CTS -> True 111 | RTS_CTS -> True 112 | _ -> False 113 | 114 | pokeReg p BRR $ fromIntegral $ getBRR $ _baudRate conf 115 | 116 | sendWord8 :: Peripheral -> Word8 -> MI () 117 | sendWord8 p b = pokeReg p DR $ fromIntegral b 118 | 119 | enable :: Peripheral -> MI () 120 | enable p = bitSet p CR1_UE 121 | 122 | disable :: Peripheral -> MI () 123 | disable p = bitReset p CR1_UE 124 | 125 | data UartPort = UartPort { 126 | _UartPeripheral :: Peripheral 127 | ,_UartTXWire :: GPIO.Wire 128 | ,_UartRXWire :: GPIO.Wire 129 | ,_UartIsAlternativeMapping :: Bool 130 | } 131 | 132 | stm32F103_UartPort1 :: UartPort 133 | stm32F103_UartPort1 = UartPort { 134 | _UartPeripheral = USART1 135 | ,_UartTXWire = (GPIOA,Pin_9) 136 | ,_UartRXWire = (GPIOA,Pin_10) 137 | ,_UartIsAlternativeMapping = False 138 | } 139 | 140 | stm32F103_UartPort2 :: UartPort 141 | stm32F103_UartPort2 = UartPort { 142 | _UartPeripheral = USART2 143 | ,_UartTXWire = (GPIOA,Pin_2) 144 | ,_UartRXWire = (GPIOA,Pin_3) 145 | ,_UartIsAlternativeMapping = False 146 | } 147 | 148 | stm32F103_UartPort3 :: UartPort 149 | stm32F103_UartPort3 = UartPort { 150 | _UartPeripheral = USART3 151 | ,_UartTXWire = (GPIOB,Pin_10) 152 | ,_UartRXWire = (GPIOB,Pin_11) 153 | ,_UartIsAlternativeMapping = False 154 | } 155 | 156 | 157 | configure :: UartPort -> Config -> MI () 158 | configure UartPort {..} config = do 159 | STM32.USART.deInit _UartPeripheral 160 | RCC.peripheralClockOn _UartPeripheral 161 | RCC.peripheralClockOn $ fst _UartRXWire 162 | RCC.peripheralClockOn AFIO 163 | 164 | GPIO.pinMode _UartTXWire (AlternateOutPushPull MHz_2) 165 | GPIO.pinMode _UartRXWire InputFloating 166 | 167 | STM32.USART.enable _UartPeripheral 168 | STM32.USART.init _UartPeripheral config 169 | -------------------------------------------------------------------------------- /STM32-Zombie/src/STM32/Utils.hs: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------------------- 2 | -- | 3 | -- Module : STM32.Utils 4 | -- Copyright : (c) Marc Fontaine 2017 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : Marc.Fontaine@gmx.de 8 | -- Stability : experimental 9 | -- Portability : GHC-only 10 | -- 11 | -- Utility functions for hardware register access. 12 | 13 | {-# LANGUAGE FlexibleInstances #-} 14 | module STM32.Utils 15 | where 16 | import STM32.MachineInterface 17 | import Data.Word 18 | import Data.Bits 19 | import Data.String 20 | import Control.Monad 21 | import Control.Monad.IO.Class 22 | import Control.Concurrent (threadDelay) 23 | import Device 24 | 25 | delay :: Int -> MI () 26 | delay = liftIO . threadDelay 27 | 28 | regToAddr :: Peripheral -> Register -> Word32 29 | regToAddr p r = peripheralBase p + registerOffset p r 30 | 31 | fieldToAddr :: Peripheral -> Field -> Word32 32 | fieldToAddr p f = regToAddr p $ fieldToRegister f 33 | 34 | peekReg :: Peripheral -> Register -> MI Word32 35 | peekReg p r = peek_w32 $ regToAddr p r 36 | 37 | -- ? do we have any 32 bit registers? 38 | pokeReg :: Peripheral -> Register -> Word32 -> MI () 39 | pokeReg p r = poke_w32 $ regToAddr p r 40 | 41 | andReg :: Peripheral -> Register -> Word32 -> MI () 42 | andReg p r w = do 43 | tmp <- peekReg p r 44 | pokeReg p r $ tmp .&. w 45 | 46 | orReg :: Peripheral -> Register -> Word32 -> MI () 47 | orReg p r w = do 48 | tmp <- peekReg p r 49 | pokeReg p r $ tmp .|. w 50 | 51 | 52 | peekLHReg :: Peripheral -> (Register,Register) -> MI Word32 53 | peekLHReg p (l,h) 54 | = fromLH <$> peekReg p l <*> peekReg p h 55 | 56 | pokeLHReg :: Peripheral -> (Register,Register) -> Word32 -> MI () 57 | pokeLHReg p (l,h) val = do 58 | pokeReg p l (val .&. 0xffff) 59 | pokeReg p h (val `shiftR` 16) 60 | 61 | 62 | fromLH :: Word32 -> Word32 -> Word32 63 | fromLH l h = (h `shiftL` 16) .|. (l .&. 0xffff) 64 | 65 | print':: Show x => x -> MI () 66 | print' = liftIO . print 67 | 68 | bitSet :: Peripheral -> Field -> MI () 69 | bitSet p f = bitWrite p f True 70 | 71 | bitReset :: Peripheral -> Field -> MI () 72 | bitReset p f = bitWrite p f False 73 | 74 | class ToBit a where 75 | toBit :: a -> Bool 76 | 77 | instance ToBit Bool where toBit = id 78 | 79 | bitWrite :: ToBit b => Peripheral -> Field -> b -> MI () 80 | bitWrite p f rs = do 81 | when (fieldBitWidth f /= 1) $ error "bitSet: fieldWidth not 1" 82 | bitWriteRaw rs 83 | (fieldToAddr p f) 84 | (fieldBitOffset f) 85 | 86 | class RegisterField f where 87 | toBits :: f -> BitField 88 | toField :: f -> Field 89 | 90 | class ToBitField f where 91 | toBitField :: f -> BitField 92 | 93 | instance ToBitField [Bool] where toBitField = BitField 94 | instance ToBitField BitField where toBitField = id 95 | newtype BitField = BitField {unBitField :: [Bool]} 96 | 97 | instance IsString BitField 98 | where fromString = BitField . toBList 99 | 100 | toBList :: String -> [Bool] 101 | toBList = reverse . map toB 102 | where 103 | toB '0' = False 104 | toB '1' = True 105 | toB _ = error "toBList: no binary" 106 | 107 | fieldWrite :: RegisterField f => Peripheral -> f -> MI () 108 | fieldWrite p regField 109 | = regFieldWrite p (toField regField) (toBits regField) 110 | 111 | regFieldWrite :: ToBitField f => Peripheral -> Field -> f -> MI () 112 | regFieldWrite p f bits' = do 113 | let bits= unBitField $ toBitField bits' 114 | when (fieldBitWidth f /= length bits) 115 | $ error "fieldWrite: fieldWidth does not match argument" 116 | fieldWriteRaw 117 | (fieldToAddr p f) 118 | (enumFrom $ fieldBitOffset f) 119 | bits 120 | 121 | fieldWriteRaw :: Word32 -> [Int] -> [Bool] -> MI () 122 | fieldWriteRaw addr offsets bits 123 | = zipWithM_ (\o b -> bitWriteRaw b addr o) offsets bits 124 | 125 | bitWriteRaw :: ToBit b => b -> Word32 -> Int -> MI () 126 | bitWriteRaw rs addr bitNum = do 127 | bbAddr <- case toBidBand addr bitNum of 128 | Just r -> return r 129 | Nothing -> error "todo: bitWrite implement none bitband" 130 | case toBit rs of 131 | True -> poke_w32 bbAddr 1 132 | False -> poke_w32 bbAddr 0 133 | 134 | bitWrite_alt :: Bool -> Peripheral -> Field -> MI () 135 | bitWrite_alt rs p f = do 136 | let 137 | r = fieldToRegister f 138 | bitNum = fieldBitOffset f 139 | old <- peekReg p r 140 | let new = case rs of 141 | True -> old .|. (1 `shiftL` bitNum) 142 | False -> old .&.(0xfffffffe `shiftL` bitNum) 143 | pokeReg p r new 144 | 145 | 146 | toBidBand :: Word32 -> Int -> Maybe Word32 147 | toBidBand addr bitNum = case addr of 148 | _ | 0x20000000 <= addr && addr <= 0x200FFFFF 149 | -> Just $ (bit_word_offset $ addr - 0x20000000) + 0x22000000 150 | _ | 0x40000000 <= addr && addr <= 0x400FFFFF 151 | -> Just $ (bit_word_offset $ addr - 0x40000000) + 0x42000000 152 | _ -> Nothing 153 | where 154 | bit_word_offset byte = byte*32 + (fromIntegral bitNum) * 4 155 | -------------------------------------------------------------------------------- /STM32F103xx-SVD/LicenseInfo: -------------------------------------------------------------------------------- 1 | The tables in this package are generated from STM32F103xx.svd. 2 | 3 | 4 | Copyright (c) Marc Fontaine 2015-2017 5 | 6 | All rights reserved. 7 | 8 | Redistribution and use in source and binary forms, with or without 9 | modification, are permitted provided that the following conditions 10 | are met: 11 | 1. Redistributions of source code must retain the above copyright 12 | notice, this list of conditions and the following disclaimer. 13 | 2. Redistributions in binary form must reproduce the above copyright 14 | notice, this list of conditions and the following disclaimer in the 15 | documentation and/or other materials provided with the distribution. 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 COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' AND 21 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 23 | ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 24 | FOR 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, STRICT 28 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 29 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 30 | SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /STM32F103xx-SVD/STM32F103xx-SVD.cabal: -------------------------------------------------------------------------------- 1 | Name: STM32F103xx-SVD 2 | Version: 0.1 3 | Category: STM32, Hardware, Microcontroller, Embedded 4 | License-File: LicenseInfo 5 | Synopsis: Definition for peripherals, registers and Fields 6 | from STM32F103xx.svd 7 | Description: Definition for peripherals, registers and Fields 8 | from STM32F103xx.svv. 9 | This package contains tables, that have been generated from the 10 | corresponding svd file. Do not edit. 11 | License: BSD3 12 | Author: Marc Fontaine 13 | Maintainer: Marc Fontaine 14 | Stability: Experimental 15 | Tested-With: GHC ==8.6.5 || ==8.4.4 || ==8.2.2 16 | Build-Type: Simple 17 | Cabal-Version: >= 1.24 18 | 19 | Source-Repository head 20 | type: git 21 | location: git://github.com/MarcFontaine/stm32hs 22 | 23 | 24 | library 25 | default-language : Haskell2010 26 | ghc-options : -Wall 27 | Build-depends : base >= 4 && < 5 28 | Exposed-modules: Device 29 | -------------------------------------------------------------------------------- /STM32F103xx-SVD/STM32F103xx-SVD.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, stdenv }: 2 | mkDerivation { 3 | pname = "STM32F103xx-SVD"; 4 | version = "0.1"; 5 | src = ./.; 6 | libraryHaskellDepends = [ base ]; 7 | description = "Definition for peripherals, registers and Fields from STM32F103xx.svd"; 8 | license = stdenv.lib.licenses.bsd3; 9 | } 10 | -------------------------------------------------------------------------------- /STM32F103xx-SVD/Setup.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | import Distribution.Simple 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /SVD2HS/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) Marc Fontaine 2015-2017 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 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 2. Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | 3. Neither the name of the author nor the names of his contributors 14 | may be used to endorse or promote products derived from this software 15 | without specific prior written permission. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' AND 18 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 20 | ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 21 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 23 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 24 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 25 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 26 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 27 | SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /SVD2HS/SVD2HS.cabal: -------------------------------------------------------------------------------- 1 | Name: SVD2HS 2 | Version: 0.1.2 3 | Category: STM32, Hardware, Microcontroller, SVD, Embedded 4 | License-File: LICENSE 5 | Synopsis: Translate a SVD of a micro controller to Haskell tables 6 | Description: Translate a SVD description of a micro controller to Haskell tables 7 | 8 | Copyright: 2015-2020 Marc Fontaine 9 | Maintainer: Marc Fontaine 10 | License: BSD3 11 | Stability: Experimental 12 | Tested-With: GHC ==8.6.5 || ==8.4.4 || ==8.2.2 13 | Author: Marc Fontaine 14 | Build-Type: Simple 15 | Cabal-Version: >= 1.24 16 | Extra-Source-Files: STM32F103xx.svd 17 | 18 | Source-Repository head 19 | type: git 20 | location: git://github.com/MarcFontaine/stm32hs 21 | 22 | library 23 | default-language : Haskell2010 24 | ghc-options : -Wall 25 | Build-depends : base >= 4 && < 5 26 | , xml-lens >= 0.1 && < 0.2 27 | , xml-conduit >= 1.7 && < 1.8 28 | , pretty >=1.1 && < 1.2 29 | , text >=1.2 && < 1.3 30 | , containers >=0.5 && < 0.7 31 | Exposed-modules: SVD2HS 32 | -------------------------------------------------------------------------------- /SVD2HS/SVD2HS.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-dodgy-imports #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE NoMonomorphismRestriction #-} 4 | module SVD2HS 5 | where 6 | import Prelude hiding ((<>)) 7 | import Text.XML.Lens hiding (text) 8 | import qualified Data.Text as Text 9 | import Data.Text (Text) 10 | import qualified Text.XML.Lens as TXL 11 | import Text.XML(readFile,def) 12 | import Text.PrettyPrint 13 | import Data.Set (Set) 14 | import qualified Data.Set as Set 15 | import qualified Data.Map as Map 16 | 17 | selectPeripheral :: 18 | Applicative f => (Element -> f Element) -> Document -> f Document 19 | 20 | selectPeripheral = root 21 | . el "device" 22 | ./ el "peripherals" 23 | ./ el "peripheral" 24 | 25 | selectPeripheralName :: Applicative f => Over (->) f Document Document Text Text 26 | selectPeripheralName = selectPeripheral ./ el "name" . TXL.text 27 | 28 | selectRegister :: Applicative f => Over (->) f Document Document Element Element 29 | selectRegister = selectPeripheral ./ el "registers" ./ el "register" 30 | 31 | selectRegisterName :: Applicative f => Over (->) f Document Document Text Text 32 | selectRegisterName = selectRegister ./ el "name" . TXL.text 33 | 34 | selectField :: Applicative f => Over (->) f Document Document Element Element 35 | selectField = selectRegister ./ el "fields" ./ el "field" 36 | 37 | selectFieldName :: Applicative f => Over (->) f Document Document Text Text 38 | selectFieldName = selectField ./ el "name" . TXL.text 39 | 40 | svdFile :: FilePath 41 | svdFile ="STM32F103xx.svd" 42 | 43 | main :: IO () 44 | main = do 45 | svd <- Text.XML.readFile def svdFile 46 | Prelude.writeFile "Device.hs" $ svd2hs svd 47 | 48 | svd2hs :: Document -> String 49 | svd2hs svd = render hsModule 50 | where 51 | fieldTable = (Map.fromList 52 | $ map (\(register,field,offset,width) 53 | -> ((register,field),(offset,width))) 54 | $ concat 55 | $ svd ^.. selectRegister 56 | . to collectFields) 57 | 58 | hsModule = vcat [ 59 | text "-- Generated from"<+> text svdFile 60 | ,text "module Device" 61 | ,text "where" 62 | ,text "import Data.Word (Word32)" 63 | ,blankLine 64 | 65 | ,dataType 66 | "Peripheral" 67 | (Set.fromList $ svd ^.. selectPeripheralName) 68 | ,blankLine 69 | 70 | ,dataType 71 | "Register" 72 | (Set.fromList $ svd ^.. selectRegisterName) 73 | ,blankLine 74 | 75 | ,dataType 76 | "Field" 77 | (Set.fromList 78 | $ map (\(r,f) -> Text.concat [r,"_",f]) 79 | $ Map.keys fieldTable) 80 | 81 | ,blankLine 82 | 83 | ,text "peripheralBase :: Peripheral -> Word32" 84 | ,funTable 85 | "peripheralBase" 86 | (svd ^.. selectPeripheral . to foldBaseAddress) 87 | ,blankLine 88 | 89 | ,text "registerOffset :: Peripheral -> Register -> Word32" 90 | ,funTable 91 | "registerOffset" 92 | (concat $ svd ^.. selectPeripheral . to foldRegisterOffset) 93 | ,text "--derived peripherals" 94 | ,funTable 95 | "registerOffset" 96 | (svd ^.. selectPeripheral . attributeSatisfies "derivedFrom" (const True) 97 | . to derivedPeripheral) 98 | ,text "--catch all" 99 | ,text "registerOffset p r = error $ show (\"undefined registerOffset\",p ,r)" ,blankLine 100 | 101 | ,text "fieldToRegister :: Field -> Register" 102 | ,funTable 103 | "fieldToRegister" 104 | (map (\(reg,field) 105 | -> (textText $ Text.concat [reg , "_" , field],textText reg)) 106 | $ Map.keys fieldTable) 107 | ,blankLine 108 | 109 | ,text "fieldBitOffset :: Field -> Int" 110 | ,funTable 111 | "fieldBitOffset" 112 | (map (\((reg,field),(offset,_)) 113 | -> (textText $ Text.concat [reg , "_" , field],textText offset)) 114 | $ Map.assocs fieldTable) 115 | ,blankLine 116 | 117 | ,text "fieldBitWidth :: Field -> Int" 118 | ,funTable 119 | "fieldBitWidth" 120 | (map (\((reg,field),(_,width)) 121 | -> (textText $ Text.concat [reg , "_" , field],textText width)) 122 | $ Map.assocs fieldTable) 123 | 124 | ] 125 | 126 | blankLine :: Doc 127 | blankLine = text "" 128 | 129 | foldBaseAddress :: Element -> (Doc, Doc) 130 | foldBaseAddress x 131 | = (sel "peripheral" "name" x, sel "peripheral" "baseAddress" x) 132 | 133 | derivedPeripheral :: Element -> (Doc,Doc) 134 | derivedPeripheral p 135 | = (sel "peripheral" "name" p <+> text "reg" 136 | ,text "registerOffset" 137 | <+> (head $ p ^.. el "peripheral" . attr "derivedFrom" . to textText) 138 | <+> text "reg" 139 | ) 140 | 141 | 142 | foldRegisterOffset :: Element -> [(Doc, Doc)] 143 | foldRegisterOffset p 144 | = p ^.. el "peripheral" ./ el "registers" ./ el "register" . to fo 145 | where 146 | peri = sel "peripheral" "name" p 147 | fo x= (peri <+> sel "register" "name" x, 148 | sel "register" "addressOffset" x) 149 | 150 | sel :: Name -> Name -> Element -> Doc 151 | sel n c p 152 | = textText $ selText n c p 153 | 154 | selText :: Name -> Name -> Element -> Text 155 | selText n c p 156 | = head $ p ^.. el n ./ el c . TXL.text 157 | 158 | collectFields :: Element -> [(Text, Text, Text, Text)] 159 | collectFields r 160 | = r ^.. el "register" ./ el "fields" ./ el "field" . to fo 161 | where 162 | register = selText "register" "name" r 163 | fo x =(register 164 | ,selText "field" "name" x 165 | ,selText "field" "bitOffset" x 166 | ,selText "field" "bitWidth" x) 167 | 168 | 169 | textText :: Data.Text.Text -> Doc 170 | textText = text . Text.unpack 171 | 172 | dataType :: String -> Set Text -> Doc 173 | dataType typeName constructors = vcat [ 174 | text "data" <+> text typeName 175 | ,nest 4 $ vcat $ zipWith (<>) seps $ map textText $ Set.toList $ constructors 176 | ,nest 4 $ text "deriving (Show,Eq,Ord)" 177 | ] 178 | where 179 | seps = text "=" : (repeat $ text "|") 180 | 181 | funTable :: String -> [(Doc,Doc)] -> Doc 182 | funTable funName assocs 183 | = vcat $ map mkCase assocs 184 | where 185 | mkCase (patterns, value) = hsep [ 186 | text funName 187 | ,patterns 188 | ,equals 189 | ,value 190 | ] 191 | -------------------------------------------------------------------------------- /SVD2HS/Setup.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | import Distribution.Simple 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | STLinkUSB 3 | STM32F103xx-SVD 4 | STM32-Zombie 5 | SVD2HS -------------------------------------------------------------------------------- /misc/STLink.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/MarcFontaine/stm32hs/402a27046357891430cd86c2e48b88b0ef116dad/misc/STLink.png -------------------------------------------------------------------------------- /misc/STM32Zombie-MS.tex: -------------------------------------------------------------------------------- 1 | % STM32Zombie-MS.tex 2 | \begin{hcarentry}[new]{STM32-Zombie} 3 | \report{Marc Fontaine}%11/17 4 | \status{active} 5 | \makeheader 6 | 7 | %** 8 | %*ignore 9 | \begin{center} 10 | \includegraphics[width=.6\columnwidth]{html/board3.jpg} 11 | \end{center} 12 | %*endignore 13 | 14 | The {\em STM32-Zombie} project turns a \texttt{STM32Fxxx} micro controller 15 | into a Haskell programmable and flexible IO peripheral of your PC. The 16 | \texttt{STM32Fxxx} micro controller family features a variety of powerful 17 | \texttt{IO} peripherals like \texttt{GPIO} ports, \texttt{USART}, 18 | \texttt{SPI}, \texttt{I2C}, \texttt{USB}, \texttt{ADC}, timers, real time 19 | clock, etc.\, and {\em STM32-Zombie} allows a Haskell program to control the 20 | complete set of built-in micro controller peripherals. 21 | 22 | The project is called {\em STM32-Zombie} because it shuts down the controllers 23 | brain (the \texttt{ARM} \texttt{CPU}) and turns it into a remote controlled 24 | zombie. It works without any c-code, cross-compiler tool-chain, or firmware. 25 | The \texttt{STM32Fxxx} peripherals use memory mapped control registers and the 26 | on-chip-debugging interface of the controller allows Haskell to access all of 27 | the controllers address space and registers. With help of the \texttt{DMA} 28 | controller even hard-real-time applications, like high-frequency sampling or 29 | generating of high-frequency output patterns, are possible. 30 | 31 | Minimal hardware requirements, for trying out this project, are a mini 32 | \texttt{STM32F103} breakout board and a \texttt{STLink V2 USB dongle 33 | simulator}. Both parts are available for less then \$2 each. My test setup are 34 | mini \texttt{STM32F103} breakout boards. I have not tested the library with 35 | other members of the \texttt{STM32Fxxx} family but the library is probably a 36 | good starting point for work on other \texttt{STM32Fxxx} controllers. 37 | 38 | The cabal package contains examples for LED blinking, serial port, SPI, 39 | high-frequency ADC sampling, control of \texttt{WS1228B RGB LED} strips, and 40 | more. 41 | 42 | The library uses the naming conventions of the {\em ST-Microelectronics 43 | STM32F10x Firmware Library} and provides a mid-level abstraction of the 44 | hardware. 45 | 46 | While access to all of the peripherals is possible, the abstraction layer is 47 | still work-in-progress and does not cover all of the peripherals yet. 48 | 49 | Comments, suggestions, experience reports, and patches are welcome. The 50 | project is open to any kind of contribution. 51 | 52 | \FurtherReading 53 | {\small 54 | \begin{compactitem} 55 | \item\url{https://github.com/MarcFontaine/stm32hs} 56 | \item\url{http://hackage.haskell.org/package/STM32-Zombie} 57 | \end{compactitem} 58 | } 59 | \end{hcarentry} 60 | -------------------------------------------------------------------------------- /misc/board1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/MarcFontaine/stm32hs/402a27046357891430cd86c2e48b88b0ef116dad/misc/board1.png -------------------------------------------------------------------------------- /misc/board2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/MarcFontaine/stm32hs/402a27046357891430cd86c2e48b88b0ef116dad/misc/board2.png -------------------------------------------------------------------------------- /misc/board3.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/MarcFontaine/stm32hs/402a27046357891430cd86c2e48b88b0ef116dad/misc/board3.jpg --------------------------------------------------------------------------------