diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) Chris Hodapp 2015-2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/ion.cabal b/ion.cabal new file mode 100644 --- /dev/null +++ b/ion.cabal @@ -0,0 +1,67 @@ +-- Initial ion.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ + +name: ion +version: 1.0.0.0 +synopsis: EDSL for concurrent, realtime, embedded programming on top of Ivory +description: + Ion is a Haskell EDSL for concurrent, realtime, embedded programming. + It interfaces with the Ivory EDSL, , to perform + code generation. It supports similar scheduling functionality to Atom + (), and also accomodates + asynchronous programming with continuation-passing style. + + Be forewarned that Ion is still heavily experimental. For some + further explanation, see the write-up at HaskellEmbedded, + . +license: BSD3 +license-file: LICENSE + +author: Chris Hodapp +maintainer: Hodapp87@gmail.com +stability: experimental +homepage: https://haskellembedded.github.io/ +-- copyright: +category: Language, Embedded +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/HaskellEmbedded/ion + +library + exposed-modules: Ivory.Language.Ion + , Ivory.Language.Ion.Base + , Ivory.Language.Ion.Code + , Ivory.Language.Ion.CPS + , Ivory.Language.Ion.Operators + , Ivory.Language.Ion.Schedule + , Ivory.Language.Ion.Util + -- other-modules: + -- other-extensions: + build-depends: base >=4.6 && <5 + , containers + , ivory >= 0.1.0.0 + , ivory-backend-c + , mtl + hs-source-dirs: src + default-language: Haskell2010 + +executable ion_example + main-is: Ivory/Language/Ion/Examples/Example.hs + --ghc-options: -threaded -rtsopts -with-rtsopts=-N + other-modules: Ivory.Language.Ion.Base + , Ivory.Language.Ion.Code + , Ivory.Language.Ion.CPS + , Ivory.Language.Ion.Operators + , Ivory.Language.Ion.Schedule + , Ivory.Language.Ion.Util + build-depends: base + , containers + , ivory + , ivory-backend-c + , mtl + hs-source-dirs: src + default-language: Haskell2010 diff --git a/src/Ivory/Language/Ion.hs b/src/Ivory/Language/Ion.hs new file mode 100644 --- /dev/null +++ b/src/Ivory/Language/Ion.hs @@ -0,0 +1,181 @@ +{- | +Module: Ion +Description: Top-level Ion module +Copyright: (c) 2015 Chris Hodapp + +Ion is a Haskell EDSL for concurrent, realtime, embedded programming. +It performs compile-time scheduling, and produces scheduling code +with constant memory usage and deterministic execution (i.e. no +possibility for divergence). + +It interfaces with another, more powerful EDSL, , to perform code generation. Ivory is responsible for all the +code generation to perform the scheduling. One may also embed general +Ivory effects in an Ion spec with few restrictions, however, it does +very little to enforce constant memory usage or deterministic code +here. + +Ion generates scheduling code which must be called at regular clock +ticks (i.e. from a timer interrupt). The interval of these clock +ticks establishes the *base rate* of the system. All scheduled events +in the system take place relative to this base rate, defined in terms +of 'period' (interval of repetition) and 'phase' (position within that +interval). + +This functionality is expressed in the 'Ion' monad - in large part to +allow composition and modularity in expressing tightly-scheduled +functionality. In addition, it has functions like 'newProc' and +'newArea' which define uniquely-named C functions and globals. The +purpose of these is to allow that same compositional when working with +Ivory definitions that are parametrized and may be instantiated +multiple times. + +For instance, when dealing with functions that return via asynchronous +callbacks or interrupts - a common thing on embedded systems - one +must generally work in continuation-passing style. This simplifies +the process of creating a reusable pattern for a use-case like: + +1. Transmit instruction @I@ over SPI. Wait to receive 2 bytes. +2. In a callback: Check that result for being an error condition. If +an error, call error handler function @E@. If successful, transmit +instruction @I2@ and wait to receive 2 bytes. +3. In a callback: Check for error and call @E@ if needed. If successful, +combine result into some composite value, and call success handler @S@ +with that value. + +and then parametrizing this whole definition over instructions @I@ and +@I2@, error handler @E@, and success handler @S@. This definition +then could be parametrized over multiple different instructions, and +all of these chained together (e.g. via @(=<<)@) to create a larger +sequence of calls passing control via CPS. + +Ion was heavily inspired by another EDSL, +. It started as an Atom +re-implementation which had other backends, rather than generating C +code directly (as Atom does). However, Ion has diverged somewhat, and +still does not have many things from Atom, such as synchronous +variable access, run-time checks on execution time, various +compile-time sanity checks, traces, or most of its standard library. + +To-do items: + + * Continue writing documentation and examples! + * Get some unit tests for things that I am prone to breaking. + * It *still* does not handle 'minimum' phase. + * This could use a way to 'invert' a phase, and run at every phase but +the ones noted. + * I need to convert over the 'schedule' function in Scheduling.hs in Atom. + * Atom treats everything within a node as happening at the same time, and I +do not handle this yet, though I rather should. This may be complicated - I +may either need to process the Ivory effect to look at variable references, or +perhaps add certain features to the monad. + * Atom had a way to express things like rising or falling edges, and +debouncing. How possible is this to express? + * Right now one can only pass variables to an Ion by way of a Ref or some +derivative, and those must then be dereferenced inside of an 'ivoryEff' call. +Is this okay? Should we make this more flexible somehow? (I feel like Atom +did it similarly, with V & E.) + * Pretty-printing the schedule itself (as Atom does) would probably be a +good idea. + * Consider the case where one puts a condition on a node, and that node +has many sub-nodes across various delays. Now, suppose that that condition +becomes false somewhere in the middle of those delays. Is the entire node +blocked from taking effect, or does it partially take effect? When is the +condition considered as being evaluated? Right now it is evaluated at every +single sub-node that inherits it. I consider this to be a violation of how +Ion should operate - synchronously and atomically. + * Could 'ivoryEff' meaningfully return a value to 'Ion' rather than ()? + * Would it be possible to make a CFG for the continuation-passing style +arrangements? (Might Ivory have to handle this?) + * Runtime check: Schedule function being called twice in one clock tick. + * Runtime check: Schedule function never called in a clock tick. + * Runtime check: Schedule function hasn't returned yet when next clock +tick occurs (i.e. schedule function takes too long). + * Runtime check: Compute percent utilization, time-wise, in schedule +function. + * Compile-time check: Same period and phase occupied. (Atom would throw +a compile-time error when this happened.) + +-} + +module Ivory.Language.Ion ( + -- * Base types + Base.Ion + , CPS.IonCont + + -- * Code generation + , Code.IonExports(..) + , Code.ionDef + + -- * Operators + + -- ** Compositional + -- | These functions all have @'Ion' a -> 'Ion' a@ (or similar) at the + -- end of their type, and that is because they are meant to be + -- nested by function composition. For instance: + -- + -- @ + -- 'ion' "top_level" $ do + -- 'ion' "sub_spec" $ 'period' 100 $ do + -- 'ion' "phase0" $ 'phase' 0 $ do + -- -- Everything here inherits period 100, phase 0, and + -- -- a new path "top_level.sub_spec.phase0". + -- 'phase' 20 $ 'phase' '30' $ do + -- -- Everything here inherits period 100, and phase 30 + -- 'phase' 40 $ 'cond' (return true) $ do + -- -- Everything here inherits period 100, phase 40, and + -- -- a (rather vacuous) condition + -- 'disable' $ 'phase' 50 $ do + -- -- This is all disabled. + -- @ + -- + -- Note that more inner bindings override outer ones in the case + -- of 'phase', 'delay', 'period', and 'subPeriod'. Applications + -- of 'cond' combine with each other as a logical @and@. + -- Applications of 'disable' are idempotent. + , Operators.ion + , Operators.phase + , Operators.delay + , Operators.period + , Operators.subPeriod + , Operators.cond + , Operators.disable + + -- ** Memory & Procedures + , Operators.newName + , Operators.newProc + , Operators.newProcP + , Operators.area' + , Operators.areaP' + , Operators.newArea + , Operators.newAreaP + + -- ** Effects + , Operators.ivoryEff + + -- ** Utilities + , Operators.timer + , Operators.startTimer + , Operators.stopTimer + , Operators.getPhase + , Operators.adapt_0_1 + , Operators.adapt_1_0 + , Operators.adapt_0_2 + , Operators.adapt_2_0 + , Operators.adapt_0_3 + , Operators.adapt_3_0 + , Operators.adapt_0_4 + , Operators.adapt_4_0 + , Operators.adapt_0_5 + -- Yes, the 'utilities' aren't in module Util. Whatever. + + -- ** CPS + , CPS.accum + + ) where + +import qualified Ivory.Language.Ion.Base as Base +import qualified Ivory.Language.Ion.Code as Code +import qualified Ivory.Language.Ion.CPS as CPS +import qualified Ivory.Language.Ion.Operators as Operators +import qualified Ivory.Language.Ion.Util as Util diff --git a/src/Ivory/Language/Ion/Base.hs b/src/Ivory/Language/Ion/Base.hs new file mode 100644 --- /dev/null +++ b/src/Ivory/Language/Ion/Base.hs @@ -0,0 +1,97 @@ +{- | +Module: Base +Description: Base Ion types +Copyright: (c) 2015 Chris Hodapp + +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} + +module Ivory.Language.Ion.Base where + +import Control.Exception +import Control.Monad.State hiding ( forever ) +import Data.Typeable + +import qualified Ivory.Language as IL +import Ivory.Language +import qualified Ivory.Language.Monad as ILM + +-- | This wraps 'Ion' with the ability to create unique C identifier names. +type Ion = State IonDef + +data IonDef = IonDef { ionId :: String -- ^ Unique ID (used as base name) + , ionNum :: Int -- ^ Next unused number + , ionDefs :: IL.ModuleDef -- ^ Ivory definitions + -- that the specifications produce + , ionCtxt :: Schedule -- ^ The 'inherited' context + , ionSched :: [Schedule] -- ^ A flat list of + -- schedule items generated along the way. + } + +defaultIonDef = IonDef { ionId = "" + , ionNum = 0 + , ionDefs = return () + , ionCtxt = defaultSchedule + , ionSched = [] + } + +-- | A scheduled action. Phase and period here are absolute, and there are no +-- child nodes. +data Schedule = + Schedule { schedId :: Integer -- ^ A unique ID for this action + , schedName :: String -- ^ Name (without any disambiguation applied) + , schedPath :: [String] -- ^ A list of names giving the trail that + -- produced this schedule + , schedPhase :: Integer -- ^ The (absolute & exact) phase of this + -- action + , schedPeriod :: Integer -- ^ The period of this action + , schedAction :: [IvoryAction ()] -- ^ The Ivory effects for this + -- action + , schedCond :: [IvoryAction IL.IBool] -- ^ Ivory effects which all + -- must return 'true' for anything in 'schedAction' + -- to execute + } + deriving (Show) + +defaultSchedule = Schedule { schedId = 0 + , schedName = "root" + , schedPath = [] + , schedPhase = 0 + , schedPeriod = 1 + , schedAction = [] + , schedCond = [] + } + +-- | The type of Ivory action that an 'IonNode' can support. Note that this +-- purposely forbids breaking, returning, and allocating. +type IvoryAction = IL.Ivory IL.NoEffects + +instance Show (IvoryAction a) where + show iv = "Ivory NoEffects () [" ++ show block ++ "]" + where (_, block) = + ILM.runIvory $ ILM.noReturn $ ILM.noBreak $ ILM.noAlloc iv + +data PhaseContext = Absolute -- ^ Phase is relative to the first tick + -- within a period + | Relative -- ^ Phase is relative to the last phase + -- used + deriving (Show) + +data PhaseType = Min -- ^ Minimum phase (i.e. at this phase, or any + -- later point) + | Exact -- ^ Exactly this phase + deriving (Show) + +data IonException = InvalidCName [String] String Int -- ^ Path, C name, and + -- index at which it is invalid + | PhaseExceedsPeriod [String] Integer Integer -- ^ Path, + -- phase, period + | PhaseIsNegative [String] Integer -- ^ Path, phase + | PeriodMustBePositive [String] Integer -- ^ Path, period + deriving (Show, Typeable) + +instance Exception IonException diff --git a/src/Ivory/Language/Ion/CPS.hs b/src/Ivory/Language/Ion/CPS.hs new file mode 100644 --- /dev/null +++ b/src/Ivory/Language/Ion/CPS.hs @@ -0,0 +1,90 @@ +{- | +Module: CPS +Description: Ion types for continuations & continuation-passing style +Copyright: (c) 2015 Chris Hodapp + +-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} + +module Ivory.Language.Ion.CPS where + +import Ivory.Language + +import Ivory.Language.Ion.Base +import Ivory.Language.Ion.Operators + +-- | This wraps a pattern of functions calling each other in +-- continuation-passing style. The intent is that the returned entry +-- function (which takes arguments 'a') causes the supplied +-- continuation function to be called (passing arguments 'b'). +-- +-- This is a common pattern for asynchronous calls, for instance, in +-- which the callback or interrupt calls the continuation function. +-- +-- Multiple calls of this sort can be composed with '(=<<)' (and with +-- @RecursiveDo@ and 'mdo') to chain them in the order in which they +-- would proceed. +-- +-- For instance, in @start <- call1 =<< call2 =<< call3 final@, +-- @start@ contains the entry function to @call1@, whose continuation +-- is set to the entry function of @call2@, whose continuation in turn +-- is set to the entry function of @call3@, whose continuation is +-- 'final'. Note that chaining these with '(>>=)' is possible too, +-- but the order is somewhat reversed from what is logical - hence, +-- 'mdo' often being sensible here. +type IonCont a b = Def (b ':-> ()) -- ^ Continuation function + -> Ion (Def (a ':-> ())) -- ^ Entry function + +-- | 'Lift' a Haskell function up into an 'IonCont'. +lift :: (IvoryType a, IvoryVar a, IvoryType b, IvoryVar b) => + (a -> b) -> IonCont '[a] '[b] +lift f cont = newProc $ \a -> body $ call_ cont $ f a + +-- | 'Accumulate' an argument into a continuation function. +-- Specifically: Given an 'IonCont' taking some argument in its entry +-- function, generate another 'IonCont' with the same type of entry +-- function, but whose continuation function contains another argument +-- (which will receive the same value of that argument). +-- +-- Note that every use of this requires a static variable of type 'a'. +-- Also, this implementation does not protect against the continuation +-- function being called without the entry function; if this occurs, +-- the continuation will contain old values of 'a' from earlier +-- invocations, or possibly a zero value. +-- +-- TODO: Right now this handles only converting single-argument to +-- double-argument. I intend to modify this to work similarly to +-- 'call' and 'callAux' in Ivory. +accum :: (IvoryType a, IvoryVar a, IvoryStore a, IvoryZeroVal a, + IvoryType b, IvoryVar b) => + IonCont '[] '[b] -> IonCont '[a] (a ': '[b]) +accum f_ab cont = do + -- Temporary variable to hold 'a' while waiting to be called back: + tempA <- newArea Nothing + + -- Generate a new continuation which calls the continuation with the + -- temporary 'a' value: + cont2 <- newProc $ \b -> body $ do + a <- deref tempA + call_ cont a b + + -- 'entry2' is the entry function using 'cont2' as the continuation: + entry2 <- f_ab cont2 + + -- And finally, the new entry function: + entry <- newProc $ \a -> body $ do + store tempA a + call_ entry2 + + return entry + +-- Another function that will be much more difficult to implement: +join :: (a -> b -> c) -> IonCont t '[a] -> IonCont t '[b] -> IonCont t '[c] +join _ _ _ = undefined + +-- This would implement a 'join point' of sorts. The returned IonCont +-- would not call its own continuation until the other two continuations +-- (those of the first two IonCont arguments) have been called. The entry +-- function should call that of both of the arguments. diff --git a/src/Ivory/Language/Ion/Code.hs b/src/Ivory/Language/Ion/Code.hs new file mode 100644 --- /dev/null +++ b/src/Ivory/Language/Ion/Code.hs @@ -0,0 +1,175 @@ +{- | +Module: Code +Description: Ivory code generation from Ion specifications +Copyright: (c) 2015 Chris Hodapp + +This contains functionality for converting the 'Ion' type to Ivory constructs. + +Known issues: + + * One must depend on the Ivory module that makes use of the +definitions from 'ionDef' in order to reference a variable declared +with 'area''. + * It can be really inefficient to require a separate counter for +every distinct phase within a period. Why not reuse variables here +when it's within the same period, and rather than starting at the +phase, counting down, and checking for zero, instead starting just one +variable at 0, counting up, checking for each individual phase? + +-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Ivory.Language.Ion.Code where + +import Control.Exception +import Control.Monad.State hiding ( forever ) + +import qualified Ivory.Compile.C.CmdlineFrontend as IC +import Ivory.Language +import Ivory.Language.MemArea ( memSym ) +import Ivory.Language.Monad ( emit ) +import qualified Ivory.Language.Syntax.AST as AST +import qualified Ivory.Language.Syntax.Names as N +import qualified Ivory.Language.Syntax.Type as Ty + +import Ivory.Language.Ion.Base +import Ivory.Language.Ion.Schedule +import Ivory.Language.Ion.Util + +-- | Concrete exports from an 'Ion' +data IonExports a = IonExports + { ionEntry :: Def ('[] ':-> ()) + , ionModule :: ModuleDef + , ionValue :: a + } +-- FIXME: Figure out why I must have 'ModuleDef' and a value twice. +-- I'm basically just exporting an 'Ion' (but one that semantically is +-- different) plus an entry procedure. + +-- | Helper function to generate code from an 'Ion' and run the Ivory +-- compiler on it (or else output an exception message). While I +-- don't yet know any reason why it needs to, this also returns +-- whatever value the 'Ion' returns. +ionCompile :: IC.Opts -- ^ Options for 'IC.runCompiler' + -> String -- ^ Name for schedule function and module + -> Ion a -- ^ Spec + -> IO a +ionCompile opts name spec = do + let exps = ionDef name spec + mod = package name $ ionModule exps + catch + (IC.runCompiler [mod] [] opts) + $ \e -> putStrLn ("Exception: " ++ show (e :: IonException)) + return $ ionValue exps + +-- | Produce exports from the given 'Ion' specs. +ionDef :: String -- ^ Name for schedule function + -> Ion a -- ^ Ion specification + -> IonExports a +ionDef name s = IonExports { ionEntry = entryProc + , ionModule = mod + , ionValue = a + } + where -- FIXME: 'defaultIonDef' should probably not be hard-coded. + -- i0 :: Ion (a, SeqState) + (a, def) = runState s $ defaultIonDef { ionId = name } + mod = do ionDefs def + incl entryProc + mapM_ incl schedFns + mapM_ counterDef nodes + nodes = flatten def + -- FIXME: This shouldn't just be taking the head node, and we should + -- probably also not hard-code defaultSchedule. + -- The entry procedure for running the schedule: + entryProc :: Def ('[] ':-> ()) + entryProc = proc name $ body $ do + let nodeComment (sch, _) = + comment $ "Path: " ++ (foldl1 (\s acc -> (s ++ "." ++ acc)) $ + schedPath sch) + comment "Auto-generated schedule entry procedure from Ion & Ivory" + mapM_ (\t -> nodeComment t >> entryEff t) $ zip nodes schedFns + -- FIXME: Disambiguate the name of this procedure + schedFns :: [Def ('[] ':-> ())] + schedFns = map mkSchedFn nodes + id' sch = "_" ++ (show $ schedId sch) + -- The name of the counter symbol: + counterSym sch = "counter_" ++ schedName sch ++ id' sch + -- The ModuleDef of the counter's MemArea: + counterDef sch = + let areaDef :: forall a . + (IvoryType a, IvoryInit a, IvoryZeroVal a, Num a) => + Proxy a -> ModuleDef + areaDef _ = defMemArea $ area (counterSym sch) $ Just $ ival $ + ((fromIntegral $ schedPhase sch) :: a) + in case (fitWordType $ schedPeriod sch) of + (Ty.TyWord Ty.Word8) -> areaDef (Proxy :: Proxy Uint8) + (Ty.TyWord Ty.Word16) -> areaDef (Proxy :: Proxy Uint16) + (Ty.TyWord Ty.Word32) -> areaDef (Proxy :: Proxy Uint32) + (Ty.TyWord Ty.Word64) -> areaDef (Proxy :: Proxy Uint64) + -- FIXME: Is there a cleaner way to do the above? + -- FIXME: I think this introduces problems when phase proceeds + -- period, and phase exceeds a Word8. + -- The Ivory procedure for some schedule item: + mkSchedFn sch = proc ("ion_" ++ schedName sch ++ id' sch) $ body $ do + noReturn $ noBreak $ noAlloc $ getIvory sch + -- The Ivory effect for invoking a given schedule item: + entryEff (sch, schFn) = emit $ + AST.IfTE counterZero [callSched, reset] [decr] + where ty = fitWordType $ schedPeriod sch + -- Counter variable: + var = AST.ExpSym $ counterSym sch + -- Pointer to it (because AST.Store assumes a reference): + var' = AST.ExpAddrOfGlobal $ counterSym sch + -- Predicate, true if counter equals zero: + counterZero = AST.ExpOp (AST.ExpEq ty) + [var, AST.ExpLit $ AST.LitInteger 0] + -- True case (counter = 0): + callSched = AST.Call Ty.TyVoid Nothing + (AST.NameSym $ procName schFn) [] + -- FIXME: I need to add a condition to 'callSched' + -- which checks any conditions on 'sch', and move + -- those conditions out of 'getIvory'. I still need + -- to find a way of evaluating this condition only at + -- the proper time. I may have to look at how Atom + -- did this. The problem is that all of the calls to + -- sub-nodes are flattened in this function, and each + -- call must be handled separately. + -- I also must be mindful that I do not evaluate the Ivory + -- effect vastly more times than necessary. + reset = AST.Store ty var' $ AST.ExpLit $ + AST.LitInteger $ fromIntegral (schedPeriod sch - 1) + -- False case: + decr = AST.Store ty var' $ + (AST.ExpOp AST.ExpSub + [var, AST.ExpLit $ AST.LitInteger 1]) +-- This perhaps should be seen as an analogue of 'writeC' in Code.hs in Atom. + +-- | Produce an Ivory effect from a 'Schedule'. +getIvory :: (eff ~ NoEffects) => Schedule -> Ivory eff () +-- Originally: +-- (GetBreaks eff ~ NoBreak, GetReturn eff ~ NoReturn, GetAlloc eff ~ NoAlloc) +getIvory i0 = do + comment "Auto-generated schedule procedure from Ion & Ivory" + comment $ "Path: " ++ (foldl1 (\s acc -> (s ++ "." ++ acc)) $ schedPath i0) + comment $ "Phase: " ++ (show $ schedPhase i0) + comment $ "Period: " ++ (show $ schedPeriod i0) + let actions = sequence_ $ schedAction i0 + case schedCond i0 of + -- If no conditions, apply actions directly: + [] -> do comment "Action has no conditions" + actions + -- Otherwise, evaluate & logical AND them all: + condEffs -> do + comment $ "Action has " ++ (show $ length condEffs) ++ " conditions:" + conds <- sequence condEffs + ifte_ (foldr1 (.&&) conds) + actions + $ return () + -- FIXME: Short-circuit evaluation might be helpful here. We don't need + -- to evaluate any other condition as soon as one has failed. + -- This might be inefficient for other reasons too - we re-evaluate the + -- same condition in every single sub-node. + -- FIXME: Can we evaluate Ivory constants at code generation time and + -- just fully enable/disable the node then? diff --git a/src/Ivory/Language/Ion/Examples/Example.hs b/src/Ivory/Language/Ion/Examples/Example.hs new file mode 100644 --- /dev/null +++ b/src/Ivory/Language/Ion/Examples/Example.hs @@ -0,0 +1,276 @@ +{- | +Module: Example +Description: Example Ion modules & code generation +Copyright: (c) 2015 Chris Hodapp + +-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE TypeOperators #-} + +module Main where + +import Data.Word + +import Ivory.Language +import Ivory.Compile.C.CmdlineFrontend + +import Ivory.Language.Ion.Base +import Ivory.Language.Ion.Code +import Ivory.Language.Ion.Operators + +main :: IO () +main = do + let ivoryOpts = initialOpts { scErrors = False + , srcLocs = True + , outDir = Nothing + } + ionCompile ivoryOpts "simpleSchedule" simpleSchedule + ionCompile ivoryOpts "timer" exampleTimer + ionCompile ivoryOpts "exampleChain" exampleChain + ionCompile ivoryOpts "giant_ugly_test" test + return () + +printf :: Def ('[IString] :-> Sint32) +printf = importProc "printf" "stdio.h" + +-- void foo(int16_t) +foo :: Def ('[] :-> ()) +foo = importProc "foo" "something.h" + +-- void bar(int32_t) +bar :: Def ('[] :-> ()) +bar = importProc "bar" "something.h" + +-- uint16_t get_value(int32_t) +get_value :: Def ('[] :-> Uint16) +get_value = importProc "get_value" "something.h" + +-- bool get_flag(void) +get_flag :: Def ('[] :-> IBool) +get_flag = importProc "get_flag" "something.h" + +simpleSchedule :: Ion () +simpleSchedule = ion "schedule" $ do + + period 100 $ do + variousPhases + + cond ((>? 10) <$> call get_value) $ do + ivoryEff $ comment "get_value() > 10" + cond (call get_flag) $ do + ivoryEff $ comment "get_value() > 10 && get_flag()" + +variousPhases :: Ion () +variousPhases = do + phase 1 $ ivoryEff $ do + comment "period 100, phase 1" + call_ foo + phase 10 $ ion "optional_tag" $ ivoryEff $ do + comment "period 100, phase 10" + call_ bar + disable $ phase 20 $ ivoryEff $ do + comment "shouldn't even appear in code" + call_ foo + call_ bar + delay 50 $ do + p <- getSched + ivoryEff $ do + comment "Should be phase 100 + 50" + comment ("Reported sched: " ++ show p) + delay 10 $ ion "moreDelay" $ do + p <- getSched + ivoryEff $ do + comment "Should be phase 100 + 50 + 10" + comment ("Reported sched: " ++ show p) + phase 1 $ do + ivoryEff $ comment "Should override to phase 1" + period 1000 $ do + ivoryEff $ comment "Should override all other period" + +-- This returns its own entry procedure (init). The schedule procedure +-- must be called at regular intervals for the timer to function. +exampleTimer :: Ion (Def ('[] ':-> ())) +exampleTimer = ion "timer" $ mdo + -- Note the use of 'mdo' so that we can define things in a more + -- logical order. + + -- Timer is initialized with a Uint16; procedure called at + -- expiration is fixed at compile-time: + timer1 <- period 1 $ timer (Proxy :: Proxy Uint16) expire + + -- Initialization procedure: + init <- newProc $ body $ do + -- Trigger the timer for 1000 ticks: + startTimer timer1 1000 + + expire <- newProc $ body $ do + call_ printf "Timer expired!\r\n" + + return init + +-- | This is an example of chaining together a variety of calls and +-- async callbacks in continuation-passing style. +exampleChain :: Ion (Def ('[] ':-> ())) +exampleChain = mdo + let error :: Def ('[Uint32] :-> ()) + error = importProc "assert_error" "foo.h" + + -- Chain together four calls with different values. The final + -- call is the 'success' function. + init <- exampleSend 0x1234 error =<< + adapt_0_1 =<< exampleSend 0x2345 error =<< + adapt_0_1 =<< exampleSend 0x3456 error =<< + adapt_0_1 =<< exampleSend 0x4567 error success + -- adapt_0_1 is required to match the success callback (which takes a + -- single Uint16) with the entry function of 'exampleSend' (which takes no + -- arguments). + + success <- newProc $ \_ -> body $ do + call_ printf "All calls succeeded!\r\n" + + return init + +-- | This definition accepts a payload to transmit, an error callback, +-- and a success callback; it returns the entry function which +-- transmits that value, awaits the async call, and if the result is +-- correct, calls the success callback. If any of these steps go +-- wrong, it calls the error handler with an error code, and proceeds +-- no further. +exampleSend :: Word16 -- ^ Payload value (or something like that) + -> Def ('[Uint32] ':-> ()) -- ^ Error callback + -> Def ('[Uint16] ':-> ()) -- ^ Success callback + -> Ion (Def ('[] ':-> ())) +exampleSend payload err succ = mdo + -- Make up a hypothetical function which takes a Uint16 payload to + -- transmit, and a function pointer to a callback. It returns a + -- Uint32 that is an error code. The function pointer itself takes + -- a Uint16 which is the value received, and returns nothing. + let transmit_async :: Def ('[Uint16, ProcPtr ('[Uint16] :-> ())] :-> Uint32) + transmit_async = importProc "transmit_async" "foo.h" + + write <- newProc $ body $ do + comment $ "Transmit value: " ++ show payload + -- Tell transmit_async to transmit this, and call us back at 'recv' + -- (which we define after): + errCode <- call transmit_async (fromIntegral payload) $ procPtr recv + -- Check for a nonzero error code: + ifte_ (errCode /=? 0) + (call_ err errCode) + $ return () + + recv <- newProc $ \value -> body $ do + -- Say that hypothetically we should have received the same value + -- back, so check this first: + ifte_ (value /=? fromIntegral payload) + -- If a mismatch, then call the error handler with some code: + (call_ err 0x12345678) + -- Otherwise, call the success handler: + $ call_ succ value + + return write + +-- Problems with this spec should be fixed but it's good to have +-- around as an example: +leakageBug :: Ion () +leakageBug = ion "leakageBug" $ do + period 200 $ do + expr <- newProc $ body $ retVoid + initTimer <- period 1 $ timer (Proxy :: Proxy Uint16) expr + ion "otherstuff" $ ivoryEff $ do + comment "Should be period 200 (inherited)" + +-- Likewise, problems with this spec should be fixed but it's good to +-- have around as an example: +lostAttribBug :: Ion () +lostAttribBug = period 200 $ ion "lostAttribBug" $ do + phase 100 $ ion "moreStuff" $ do + p <- getSched + ivoryEff $ do + comment "Phase 100" + comment ("Reported sched: " ++ show p) + delay 3 $ do + p <- getSched + ivoryEff $ do + comment "Should be phase 103" + comment ("Reported sched: " ++ show p) + delay 10 $ ion "moreDelay" $ do + p <- getSched + ivoryEff $ do + comment "Should be phase 113" + comment ("Reported sched: " ++ show p) + +baz :: Ion () +baz = ion "extBaz1" $ phase 10 $ do + ivoryEff $ comment "should be phase 10" + phase 20 $ ivoryEff $ comment "should be phase 20" + +baz2 :: Ion () +baz2 = phase 10 $ ion "extBaz2" $ do + ivoryEff $ comment "should be phase 10" + +delayTest :: Ion () +delayTest = ion "delayTest" $ period 100 $ do + ivoryEff $ comment "should be phase 0" + delay 10 $ ion "named" $ ivoryEff $ comment "delay 10 #1" + delay 10 $ ivoryEff $ comment "delay 10 #2" + delay 10 $ ivoryEff $ comment "delay 10 #3" + ion "delayTest2" $ do + delay 20 $ ivoryEff $ comment "should have inherited delay" + +-- | The below does nothing useful, but is left here because it served +-- to illuminate many pesky bugs in Ion. +test :: Ion () +test = ion "Foo" $ do + + test <- areaP' (Proxy :: Proxy (Stored Uint16)) "testMem" Nothing + + leakageBug + + lostAttribBug + + period 20 $ do + ivoryEff $ comment "period 20a" + ivoryEff $ comment "period 20b" + ivoryEff $ comment "period 20c" + ivoryEff $ comment "period 20d" + period 30 $ ivoryEff $ comment "period 30 overwriting 20" + + period 1 $ disable $ do + ivoryEff $ comment "shouldn't appear in code" + period 30 $ ivoryEff $ comment "also shouldn't appear in code" + undefined + + -- Period 1: + ion "Bar" $ do + ivoryEff $ comment "Foo.Bar" + ivoryEff $ comment "Foo.Bar 2" + + ion "Baz" $ period 1500 $ do + ivoryEff $ comment "Foo.Baz period 15" + ivoryEff $ comment "Foo.Baz period 15b" + + period 75 $ do + baz + baz2 + + -- FIXME: delayTest improperly inherits phase 10 from baz2. + period 100 $ do + delayTest + + disable $ ion "disabled" $ period 60000 $ do + ivoryEff $ comment "Should be disabled" + + cond (return false) $ ion "condTest" $ do + ivoryEff $ comment "Conditional test" + ion "condTest1" $ ivoryEff $ comment "Conditional test sub 1" + ion "condTest2" $ ivoryEff $ comment "Conditional test sub 2" + ion "condTest3" $ ivoryEff $ comment "Conditional test sub 3" + cond (return true) $ ion "twoConds" $ do + ivoryEff $ comment "Two conditions" + ion "condTest4" $ ivoryEff $ comment "Also two conditions" + + + cond (return true) $ ion "condTest2" $ do + ivoryEff $ comment "Should have just one condition" diff --git a/src/Ivory/Language/Ion/Operators.hs b/src/Ivory/Language/Ion/Operators.hs new file mode 100644 --- /dev/null +++ b/src/Ivory/Language/Ion/Operators.hs @@ -0,0 +1,315 @@ +{- | +Module: Operators +Description: Operators used in creating Ion specifications +Copyright: (c) 2015 Chris Hodapp + +-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Ivory.Language.Ion.Operators where + +import Control.Applicative ( (<$>) ) +import Control.Exception +import Control.Monad +import Control.Monad.State hiding ( forever ) + +import qualified Ivory.Language as IL +import qualified Ivory.Language.Monad as ILM +import Ivory.Language.Proc ( Def(..), Proc(..), IvoryCall_, + IvoryProcDef ) + +import Ivory.Language.Ion.Base +import Ivory.Language.Ion.Schedule +import Ivory.Language.Ion.Util + +-- | Transform a sub-node according to a function which transforms +-- 'Schedule' items, and then collect the state from it. +addAction :: (Schedule -> Schedule) -> Ion a -> Ion a +addAction fn sub = do + start <- get + -- 'Run' the sub-node, passing in a minimal starting state (except + -- for the unique ID & name): + let temp = IonDef + { ionId = ionId start + , ionNum = ionNum start + , ionCtxt = fn $ ionCtxt start + -- FIXME: How much is ionCtxt needed, considering + -- that we copy it? + , ionDefs = return () + , ionSched = [fn $ ionCtxt start] + } + (a, def) = runState sub temp + -- Collect some of the state that the sub-node produced: + put $ start { ionNum = ionNum def + , ionDefs = ionDefs start >> ionDefs def + -- , ionTree = ionTree start ++ [Tree.Node act $ ionTree def] + , ionSched = ionSched start ++ ionSched def + } + return a + +getSched :: Ion Schedule +getSched = ionCtxt <$> get + +getPhase :: Ion Integer +getPhase = schedPhase <$> ionCtxt <$> get + +-- | Specify a name of a sub-node, returning the parent. This node +-- name is used in the paths to the node and in some C identifiers in +-- the generated C code; its purpose is mainly diagnostic and to help +-- the C code be more comprehensible. +ion :: String -- ^ Name + -> Ion a -- ^ Sub-node + -> Ion a +ion name = addAction setName + where setName sch = case checkCName name of + Just i -> throw $ InvalidCName (schedPath sch) name i + Nothing -> sch { schedName = name + , schedPath = schedPath sch ++ [name] + } + +phaseSet :: Integral i => i -> Schedule -> Schedule +phaseSet ph sch = if (ph' >= schedPeriod sch) + then throw $ + PhaseExceedsPeriod (schedPath sch) ph' (schedPeriod sch) + else sch { schedPhase = ph' } + where ph' = fromIntegral ph + +-- | Specify a relative, minimum delay for a sub-node - i.e. a minimum +-- offset past the phase that is inherited. For instance, in the +-- example, +-- +-- @ +-- 'phase' 20 $ do +-- 'phase' 40 $ foo +-- 'delay' 2 $ bar +-- 'delay' 2 $ baz +-- @ +-- +-- @foo@ and @bar@ both run at a (minimum) phase of 22, because the +-- entire @do@ block inherits that minimum phase. +delay :: Integral i => + i -- ^ Relative phase + -> Ion a -- ^ Sub-node + -> Ion a +delay ph = addAction setDelay + where setDelay sch = phaseSet (schedPhase sch + fromIntegral ph) sch + +-- | Specify a minimum phase for a sub-node - that is, the earliest +-- tick within a period that the sub-node should be scheduled at. +-- Phase must be non-negative, and lower than the period. +phase :: Integral i => + i -- ^ Phase + -> Ion a -- ^ Sub-node + -> Ion a +phase ph = addAction (phaseSet ph) + +-- | Specify a period for a sub-node - that is, the interval, in +-- ticks, at which the sub-node is scheduled to repeat. Period must +-- be positive; a period of 1 indicates that the sub-node executes at +-- every single clock tick. +period :: Integral i => + i -- ^ Period + -> Ion a -- ^ Sub-node + -> Ion a +period p = addAction setPeriod + where p' = fromIntegral p + setPeriod sch = if (p' <= 0) + then throw $ PeriodMustBePositive (schedPath sch) p' + else sch { schedPeriod = p' } + +-- | Specify a sub-period for a sub-node - that is, the factor by +-- which to multiply the inherited period. A factor of 2, for +-- instance, would execute the sub-node half as often as its parent. +subPeriod :: Integral i => + i -- ^ Factor by which to multiply period (must be positive) + -> Ion a -- ^ Sub-node + -> Ion a +subPeriod f = addAction divPeriod + where divPeriod sch = let p = schedPeriod sch * fromIntegral f + in if (p <= 0) + then throw $ PeriodMustBePositive (schedPath sch) p + else sch { schedPeriod = p } + +-- | Ignore a sub-node completely. This is intended to mask off some +-- part of a spec while still leaving it present for compilation. +-- Note that this disables only the scheduled effects of a node, and +-- so it has no effect on things like 'newProc'. +disable :: Ion a -> Ion () +disable _ = return () +-- FIXME: Explain this better. 'disable' and 'cond' only apply to certain +-- things. + +-- | Make a sub-node's execution conditional; if the given Ivory effect +-- returns 'true' (as evaluated at the inherited phase and period), +-- then this sub-node is active, and otherwise is not. Multiple +-- conditions may accumulate, in which case they combine with a +-- logical @and@ (i.e. all of them must be true for the node to be active). +cond :: IvoryAction IL.IBool -> Ion a -> Ion a +cond pred = addAction setCond + where setCond sch = sch { schedCond = pred : schedCond sch } + +-- | Attach an Ivory effect to an 'Ion'. This effect will execute at +-- the inherited phase and period of the node. +ivoryEff :: IvoryAction () -> Ion () +ivoryEff iv = addAction addEff $ return () + where addEff sch = sch { schedAction = schedAction sch ++ [iv] } + +-- | Return a unique name. +newName :: Ion String +newName = do state <- get + let num' = ionNum state + put $ state { ionNum = num' + 1 } + return $ ionId state ++ "_" ++ show num' + +-- | Allocate a 'IL.MemArea' for this 'Ion', returning a reference to it. +-- If the initial value fails to specify the type of this, then an +-- external signature may be needed (or instead 'areaP''). If access +-- to this variable is needed outside of the 'Ion' monad, retrieve the +-- reference from an 'Ion' with the 'ionRef' function. +-- The 'ModuleDef' for this will be generated automatically. +area' :: (IL.IvoryArea area, IL.IvoryZero area) => + String -- ^ Name of variable + -> Maybe (IL.Init area) -- ^ Initial value (or 'Nothing') + -> Ion (IL.Ref IL.Global area) +area' name init = do + let mem = IL.area name init + state <- get + put $ state { ionDefs = ionDefs state >> IL.defMemArea mem } + return $ IL.addrOf mem + +-- | Same as 'area'', but with an initial 'IL.Proxy' to disambiguate +-- the area type. +areaP' :: (IL.IvoryArea area, IL.IvoryZero area) => + IL.Proxy area -- ^ Proxy (to disambiguate type) + -> String -- ^ Name of variable + -> Maybe (IL.Init area) -- ^ Initial value (or 'Nothing') + -> Ion (IL.Ref IL.Global area) +areaP' _ = area' + +-- | This is 'area'', but using 'Ion' to create a unique name. +-- (The purpose for this is to help with composing an 'Ion' or +-- instantiating one multiple times.) +newArea :: (IL.IvoryArea area, IL.IvoryZero area) => + Maybe (IL.Init area) -> Ion (IL.Ref IL.Global area) +newArea init = mkArea =<< newName + where mkArea name = area' name init + +-- | This is 'areaP'', but using 'Ion' to create a unique name. +newAreaP :: (IL.IvoryArea area, IL.IvoryZero area) => + IL.Proxy area -> Maybe (IL.Init area) -> + Ion (IL.Ref IL.Global area) +newAreaP _ = newArea + +-- | This is like Ivory 'proc', but using 'Ion' to give the +-- procedure a unique name. +newProc :: (IvoryProcDef proc impl) => impl -> Ion (Def proc) +newProc impl = do + name <- newName + state <- get + let fn sym = IL.proc sym impl + put $ state { ionDefs = ionDefs state >> (IL.incl $ fn name) } + return $ fn name + +-- | 'newProc' with an initial 'Proxy' to disambiguate the procedure type +newProcP :: (IvoryProcDef proc impl) => + IL.Proxy (Def proc) -> impl -> Ion (Def proc) +newProcP _ = newProc + +-- | All the @adapt_X_Y@ functions adapt an Ivory procedure which +-- takes @X@ arguments and returns nothing, into an Ivory procedure +-- which takes @Y@ arguments. If @X@ > @Y@ then zero is passed for +-- the argument(s); if @Y@ < @X@ then the additional arguments are +-- ignored. The generated procedure is automatically included as part +-- of the 'Ion' spec. The main point of this is to simplify the +-- chaining together of Ivory procedures. +adapt_0_1 :: (IL.IvoryType a, IL.IvoryVar a) => + Def ('[] ':-> ()) -> Ion (Def ('[a] ':-> ())) +adapt_0_1 fn0 = newProc $ \_ -> IL.body $ IL.call_ fn0 + +adapt_1_0 :: (Num a, IL.IvoryType a, IL.IvoryVar a) => + Def ('[a] ':-> ()) -> Ion (Def ('[] ':-> ())) +adapt_1_0 fn0 = newProc $ IL.body $ IL.call_ fn0 0 + +adapt_0_2 :: (IL.IvoryType a, IL.IvoryVar a, IL.IvoryType b, IL.IvoryVar b) => + Def ('[] ':-> ()) -> Ion (Def ('[a,b] ':-> ())) +adapt_0_2 fn0 = newProc $ \_ _ -> IL.body $ IL.call_ fn0 + +adapt_2_0 :: (Num a, IL.IvoryType a, IL.IvoryVar a, Num b, IL.IvoryType b, + IL.IvoryVar b) => + Def ('[a, b] ':-> ()) -> Ion (Def ('[] ':-> ())) +adapt_2_0 fn0 = newProc $ IL.body $ IL.call_ fn0 0 0 + +adapt_0_3 :: (IL.IvoryType a, IL.IvoryVar a, IL.IvoryType b, IL.IvoryVar b, + IL.IvoryType c, IL.IvoryVar c) => + Def ('[] ':-> ()) -> Ion (Def ('[a,b,c] ':-> ())) +adapt_0_3 fn0 = newProc $ \_ _ _ -> IL.body $ IL.call_ fn0 + +adapt_3_0 :: (Num a, IL.IvoryType a, IL.IvoryVar a, Num b, IL.IvoryType b, + IL.IvoryVar b, Num c, IL.IvoryType c, IL.IvoryVar c) => + Def ('[a, b, c] ':-> ()) -> Ion (Def ('[] ':-> ())) +adapt_3_0 fn0 = newProc $ IL.body $ IL.call_ fn0 0 0 0 + +adapt_0_4 :: (IL.IvoryType a, IL.IvoryVar a, IL.IvoryType b, IL.IvoryVar b, + IL.IvoryType c, IL.IvoryVar c, IL.IvoryType d, IL.IvoryVar d) => + Def ('[] ':-> ()) -> Ion (Def ('[a,b,c,d] ':-> ())) +adapt_0_4 fn0 = newProc $ \_ _ _ _ -> IL.body $ IL.call_ fn0 + +adapt_4_0 :: (Num a, IL.IvoryType a, IL.IvoryVar a, Num b, IL.IvoryType b, + IL.IvoryVar b, Num c, IL.IvoryType c, IL.IvoryVar c, Num d, + IL.IvoryType d, IL.IvoryVar d) => + Def ('[a, b, c, d] ':-> ()) -> Ion (Def ('[] ':-> ())) +adapt_4_0 fn0 = newProc $ IL.body $ IL.call_ fn0 0 0 0 0 + +adapt_0_5 :: (IL.IvoryType a, IL.IvoryVar a, IL.IvoryType b, IL.IvoryVar b, + IL.IvoryType c, IL.IvoryVar c, IL.IvoryType d, IL.IvoryVar d, + IL.IvoryType e, IL.IvoryVar e) => + Def ('[] ':-> ()) -> Ion (Def ('[a,b,c,d,e] ':-> ())) +adapt_0_5 fn0 = newProc $ \_ _ _ _ _ -> IL.body $ IL.call_ fn0 + +-- FIXME: I am almost certain that a better way exists than what I did +-- above - perhaps using typeclasses and mimicking what Ivory did to +-- define the functions. + +-- | Create a timer resource. The returned 'Ion' still must be called +-- at regular intervals (e.g. by including it in a larger Ion spec +-- that is already active). See 'startTimer' and 'stopTimer' to +-- actually activate this timer. +timer :: (a ~ 'IL.Stored t, Num t, IL.IvoryStore t, IL.IvoryInit t, + IL.IvoryEq t, IL.IvoryOrd t, IL.IvoryArea a, IL.IvoryZero a) => + IL.Proxy t -- ^ Proxy to resolve timer type + -> Def ('[] ':-> ()) -- ^ Timer expiration procedure + -> Ion (IL.Ref IL.Global (IL.Stored t)) +timer _ expFn = do + name <- newName + + ion name $ do + var <- area' name $ Just $ IL.ival 0 + + ion "decr" $ ivoryEff $ do + val <- IL.deref var + IL.ifte_ (val IL.==? 0) (return ()) -- Do nothing if already 0 + -- Otherwise, decrement + $ do let val' = val - 1 + IL.store var (val') + -- If it transitions to 0, then call the expiration proc + IL.ifte_ (val' IL.>? 0) (return ()) $ IL.call_ expFn + + return var +-- FIXME: If the timer expiration procedure is to be fixed at +-- compile-time, maybe I should also just allow Ivory effects. This +-- might make for lighter code and drop the need to make a new +-- function as a handler. + +-- | Begin counting a timer down by the given number of ticks. +startTimer :: (Num t, IL.IvoryStore t, IL.IvoryZeroVal t) => + IL.Ref IL.Global (IL.Stored t) -- ^ Timer from 'timer' + -> Integer -- ^ Countdown time + -> ILM.Ivory eff () +startTimer ref n = IL.store ref $ fromInteger n +-- FIXME: Will this even work right in usage? Think of whether or not +-- the variable will be in scope. Must these be in the same module? + +-- | Stop a timer from running. +stopTimer ref = startTimer ref 0 diff --git a/src/Ivory/Language/Ion/Schedule.hs b/src/Ivory/Language/Ion/Schedule.hs new file mode 100644 --- /dev/null +++ b/src/Ivory/Language/Ion/Schedule.hs @@ -0,0 +1,27 @@ +{- | +Module: Schedule +Description: Types and functions for flattened schedule +Copyright: (c) 2015 Chris Hodapp + +-} +module Ivory.Language.Ion.Schedule where + +import qualified Ivory.Language as IL + +import Ivory.Language.Ion.Base +import Ivory.Language.Ion.Util + +-- | Produce a flat list of scheduled actions. +flatten :: IonDef -> [Schedule] +flatten i = uniqueIds 0 $ prune $ ionSched i + -- join $ map (flattenTree defaultSchedule) $ ionTree i + +-- | Prune any schedule item that has no Ivory actions. +prune :: [Schedule] -> [Schedule] +prune = filter (not . null . schedAction) + +-- | Assign unique IDs to the list of schedule items, starting from the given +-- ID. +uniqueIds :: Integer -> [Schedule] -> [Schedule] +uniqueIds _ [] = [] +uniqueIds n (x:xs) = (x { schedId = n }) : uniqueIds (n + 1) xs diff --git a/src/Ivory/Language/Ion/Util.hs b/src/Ivory/Language/Ion/Util.hs new file mode 100644 --- /dev/null +++ b/src/Ivory/Language/Ion/Util.hs @@ -0,0 +1,51 @@ +{- | +Module: Util +Description: Utility functions used throughout Ion +Copyright: (c) 2015 Chris Hodapp + +-} +module Ivory.Language.Ion.Util where + +import Data.Char ( isAlpha, isDigit ) + +import Ivory.Language +import Ivory.Language.Proc ( Def(..), IvoryCall_ ) +import qualified Ivory.Language.Syntax.AST as AST +import qualified Ivory.Language.Syntax.Type as Ty + +-- | Return the symbol name of an Ivory procedure +procName :: Def proc -> String +procName def = case def of + DefProc p -> AST.procSym p + DefImport i -> AST.importSym i + +-- | Return the Ivory unsigned int type (in its AST) that the given 'Integer' +-- would require (i.e. any value from 0 to 255 returns a 'Ty.Word8'; values +-- beyond that but less than 65535 require a 'Ty.Word16'; and so on.) +-- The given integer must be non-negative. +fitWordType :: Integer -> Ty.Type +fitWordType i = + if (i < 0) + then error ("fitWordType: Integer " ++ show i ++ " is negative.") + else + if (i < 2^8) then Ty.TyWord Ty.Word8 + else + if (i < 2^16) then Ty.TyWord Ty.Word16 + else + if (i < 2^32) then Ty.TyWord Ty.Word32 + else + if (i < 2^64) then Ty.TyWord Ty.Word64 + else error ("fitWordType: Integer " ++ show i ++ " is too large.") + +-- | Checks the given string for being a valid C identifier. If it is, then +-- it returns 'Nothing', and otherwise 'Just' and the string index of the +-- character which renders it invalid. +checkCName :: String -> Maybe Int +checkCName [] = Just 0 -- empty identifier is not allowed +checkCName str = check str 0 + where check :: String -> Int -> Maybe Int + check [] _ = Nothing + check (c:cs) i = if (isAlpha c || '_' == c || (i > 0 && isDigit c)) + then check cs (i + 1) + else Just i +