copilot-language 0.1 → 0.2

raw patch · 11 files changed

+487/−207 lines, 11 filesdep ~copilot-corePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: copilot-core

API changes (from Hackage documentation)

Files

• copilot-language.cabal +2/−2
• src/Copilot/Language/Analyze.hs +256/−63
• src/Copilot/Language/Error.hs +1/−1
• src/Copilot/Language/Interpret.hs +58/−61
• src/Copilot/Language/Operators/Cast.hs +0/−2
• src/Copilot/Language/Operators/Constant.hs +37/−0
• src/Copilot/Language/Operators/Extern.hs +77/−13
• src/Copilot/Language/Operators/Integral.hs +2/−2
• src/Copilot/Language/Reify.hs +29/−53
• src/Copilot/Language/Stream.hs +4/−0
• src/System/Mem/StableName/Dynamic/Map.hs +21/−10

@@ -1,6 +1,6 @@ cabal-version:       >=1.10 name:                copilot-language-version:             0.1+version:             0.2 synopsis:            A Haskell-embedded DSL for monitoring hard real-time                      distributed systems. description:         Blah blah blah...@@ -29,7 +29,7 @@     data-reify >= 0.6,     mtl >= 2.0 && < 3,     ghc-prim >= 0.2 && < 0.3,-    copilot-core+    copilot-core >= 0.1   exposed-modules:     Copilot     Copilot.Language

@@ -4,6 +4,7 @@  {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | Copilot specification sanity check. @@ -12,15 +13,20 @@   , analyze   ) where -import Control.Exception (Exception, throw)-import Copilot.Language.Spec import Copilot.Core (DropIdx)+import qualified Copilot.Core as C import Copilot.Language.Stream (Stream (..), FunArg (..))+import Copilot.Language.Spec+import Copilot.Language.Error (badUsage)++import Data.List (groupBy) import Data.IORef import Data.Typeable import System.Mem.StableName.Dynamic-import System.Mem.StableName.Dynamic.Map (Map)+import System.Mem.StableName.Dynamic.Map (Map(..)) import qualified System.Mem.StableName.Dynamic.Map as M+import Control.Monad (when, foldM_, foldM)+import Control.Exception (Exception, throw)  -------------------------------------------------------------------------------- @@ -31,21 +37,39 @@   | DropMaxViolation   | NestedExternFun   | NestedArray+  | TooMuchRecussion+  | DifferentTypes String+  | Redeclared String+  | BadNumberOfArgs String+  | BadFunctionArgType String   deriving Typeable  instance Show AnalyzeException where-  show DropAppliedToNonAppend = "Drop applied to non-append operation!"-  show DropIndexOverflow      = "Drop index overflow!"-  show ReferentialCycle       = "Referential cycle!"-  show DropMaxViolation       = "Maximum drop violation (" ++ +  show DropAppliedToNonAppend = badUsage $  "Drop applied to non-append operation!"+  show DropIndexOverflow      = badUsage $  "Drop index overflow!"+  show ReferentialCycle       = badUsage $  "Referential cycle!"+  show DropMaxViolation       = badUsage $  "Maximum drop violation (" ++                                    show (maxBound :: DropIdx) ++ ")!"-  show NestedExternFun        = -    "Extern function takes an extern function or extern array as an argument!"-  show NestedArray            = -    "Extern array takes an extern function or extern array as an argument!"+  show NestedExternFun        = badUsage $  +    "An external function cannot take another external function or external array as an argument.  Try defining a stream, and using the stream values in the other definition."+  show NestedArray            = badUsage $  +    "An external function cannot take another external function or external array as an argument.  Try defining a stream, and using the stream values in the other definition."+  show TooMuchRecussion       = badUsage $ +    "You have exceeded the limit of " ++ show maxRecursion ++ " recursive calls in a stream definition.  Likely, you have accidently defined a circular stream, such as 'x = x'.  Another possibility is you have defined a a polymorphic function with type constraints that references other streams.  For example,\n\n  nats :: (Typed a, Num a) => Stream a\n  nats = [0] ++ nats + 1\n\nis not allowed.  Make the definition monomorphic, or add a level of indirection, like \n\n  nats :: (Typed a, Num a) => Stream a\n  nats = n\n    where n = [0] ++ nats + 1\n\nFinally, you may have intended to generate a very large expression.  You can try shrinking the expression by using local variables.  It all else fails, you can increase the maximum size of ecursive calls by modifying 'maxRecursion' in copilot-language."+  show (DifferentTypes name) = badUsage $  +    "The external symbol " ++ name ++ " has been declared to have two different types!"+  show (Redeclared name) = badUsage $ +    "The external symbol " ++ name ++ " has been redeclared to be a different symbol (e.g., a variable and an array, or a variable and a funciton symbol, etc.)."+  show (BadNumberOfArgs name) = badUsage $ +    "The function symbol " ++ name ++ " has been redeclared to have different number of arguments."+  show (BadFunctionArgType name) = badUsage $ +    "The funciton symbol " ++ name ++ " has been redeclared to an argument with different types."  instance Exception AnalyzeException +maxRecursion :: Int+maxRecursion = 100000+ --------------------------------------------------------------------------------  type Env = Map ()@@ -53,20 +77,19 @@ --------------------------------------------------------------------------------  analyze :: Spec -> IO ()-analyze spec =-  do-    refStreams <- newIORef M.empty-    mapM_ (analyzeTrigger  refStreams) (triggers  (runSpec spec))-    mapM_ (analyzeObserver refStreams) (observers (runSpec spec))+analyze spec = do+  refStreams <- newIORef M.empty+  mapM_ (analyzeTrigger  refStreams) (triggers  $ runSpec spec)+  mapM_ (analyzeObserver refStreams) (observers $ runSpec spec)+  specExts refStreams spec >>= analyzeExts   --------------------------------------------------------------------------------  analyzeTrigger :: IORef Env -> Trigger -> IO ()-analyzeTrigger refStreams (Trigger _ e0 args) =+analyzeTrigger refStreams (Trigger _ e0 args) =    analyzeExpr refStreams e0 >> mapM_ analyzeTriggerArg args    where-   analyzeTriggerArg :: TriggerArg -> IO ()   analyzeTriggerArg (TriggerArg e) = analyzeExpr refStreams e @@ -84,66 +107,236 @@ --------------------------------------------------------------------------------  analyzeExpr :: IORef Env -> Stream a -> IO ()-analyzeExpr refStreams = go NoExtern M.empty +analyzeExpr refStreams s = do+  b <- mapCheck refStreams+  when b (throw TooMuchRecussion)+  go NoExtern M.empty s    where-   go :: SeenExtern -> Env -> Stream b -> IO ()-  go seenExt nodes e0 =-    do-      dstn <- makeDynStableName e0-      assertNotVisited e0 dstn nodes-      let nodes' = M.insert dstn () nodes-      case e0 of-        Append _ _ e       -> analyzeAppend refStreams dstn e-        Const _            -> return ()-        Drop k e1          -> analyzeDrop (fromIntegral k) e1-        Local e f          -> go seenExt nodes' e >> -                              go seenExt nodes' (f (Var "dummy"))-        Op1 _ e            -> go seenExt nodes' e-        Op2 _ e1 e2        -> go seenExt nodes' e1 >> -                              go seenExt nodes' e2-        Op3 _ e1 e2 e3     -> go seenExt nodes' e1 >> -                              go seenExt nodes' e2 >> -                              go seenExt nodes' e3-        ExternFun _ args   -> case seenExt of -                                NoExtern -> mapM_ (\(FunArg a) -> -                                                      go SeenFun nodes' a) args-                                SeenFun  -> throw NestedExternFun-                                SeenArr  -> throw NestedArray-        ExternArray _ idx  -> case seenExt of -                                NoExtern -> go SeenArr nodes' idx-                                SeenFun  -> throw NestedExternFun-                                SeenArr  -> throw NestedArray-        _                  -> return ()+  go seenExt nodes e0 = do+    dstn <- makeDynStableName e0+    assertNotVisited e0 dstn nodes+    let nodes' = M.insert dstn () nodes+    case e0 of+      Append _ _ e        -> analyzeAppend refStreams dstn e () analyzeExpr+      Const _             -> return ()+      Drop k e1           -> analyzeDrop (fromIntegral k) e1+      Extern _ _          -> return ()+      ExternFun _ args me -> +        checkInterp >> checkArgs+        where+        checkInterp = case me of +                        Nothing -> return ()+                        Just e  -> go seenExt nodes' e+        checkArgs = case seenExt of +                      NoExtern -> mapM_ (\(FunArg a) -> +                                             go SeenFun nodes' a) args+                      SeenFun  -> throw NestedExternFun+                      SeenArr  -> throw NestedArray+      ExternArray _ idx _ _ -> case seenExt of +                                 NoExtern -> go SeenArr nodes' idx+                                 SeenFun  -> throw NestedExternFun+                                 SeenArr  -> throw NestedArray+      Local e f           -> go seenExt nodes' e >> +                             go seenExt nodes' (f (Var "dummy"))+      Var _               -> return ()+      Op1 _ e             -> go seenExt nodes' e+      Op2 _ e1 e2         -> go seenExt nodes' e1 >> +                             go seenExt nodes' e2+      Op3 _ e1 e2 e3      -> go seenExt nodes' e1 >> +                             go seenExt nodes' e2 >> +                             go seenExt nodes' e3 -  assertNotVisited :: Stream a -> DynStableName -> Env -> IO ()-  assertNotVisited (Append _ _ _) _    _     = return ()-  assertNotVisited _              dstn nodes =-    case M.lookup dstn nodes of-      Just () -> throw ReferentialCycle-      Nothing -> return ()+-------------------------------------------------------------------------------- +assertNotVisited :: Stream a -> DynStableName -> Env -> IO ()+assertNotVisited (Append _ _ _) _    _     = return ()+assertNotVisited _              dstn nodes =+  case M.lookup dstn nodes of+    Just () -> throw ReferentialCycle+    Nothing -> return ()+ -------------------------------------------------------------------------------- -analyzeAppend :: IORef Env -> DynStableName -> Stream a -> IO ()-analyzeAppend refStreams dstn e =-  do-    streams <- readIORef refStreams-    case M.lookup dstn streams of-      Just () -> return ()-      Nothing ->-        do-          modifyIORef refStreams $ M.insert dstn ()-          analyzeExpr refStreams e+mapCheck :: IORef Env -> IO Bool+mapCheck refStreams = do+  ref <- readIORef refStreams+  return $ getSize ref > maxRecursion  -------------------------------------------------------------------------------- +analyzeAppend :: +     IORef Env -> DynStableName -> Stream a -> b+  -> (IORef Env -> Stream a -> IO b) -> IO b+analyzeAppend refStreams dstn e b f = do+  streams <- readIORef refStreams+  case M.lookup dstn streams of+    Just () -> return b+    Nothing -> do+      modifyIORef refStreams $ M.insert dstn ()+      f refStreams e++--------------------------------------------------------------------------------+ analyzeDrop :: Int -> Stream a -> IO () analyzeDrop k (Append xs _ _)   | k >= length xs                         = throw DropIndexOverflow   | k > fromIntegral (maxBound :: DropIdx) = throw DropMaxViolation   | otherwise                              = return () analyzeDrop _ _                            = throw DropAppliedToNonAppend+++--------------------------------------------------------------------------------+-- Analyzing external variables.  We check that every reference to an external+-- variable has the same type, and for external functions, they have the same+-- typed arguments.+--------------------------------------------------------------------------------++-- An environment to store external variables, arrays, and functions, so that we+-- can check types in the expression---e.g., if we declare the same external to+-- have two different types.+data ExternEnv = ExternEnv+  { externVarEnv  :: [(String, C.SimpleType)]+  , externArrEnv  :: [(String, C.SimpleType)]+  , externFunEnv  :: [(String, C.SimpleType)] +  , externFunArgs :: [(String, [C.SimpleType])] +  }++--------------------------------------------------------------------------------++-- Make sure external variables, functions, and arrays are correctly typed.++analyzeExts :: ExternEnv -> IO ()+analyzeExts ExternEnv { externVarEnv  = vars+                      , externArrEnv  = arrs+                      , externFunEnv  = funs +                      , externFunArgs = args }+    = do+    -- symbol names redeclared?+    findDups vars arrs+    findDups vars funs+    findDups arrs funs+    -- conflicting types?+    conflictingTypes vars+    conflictingTypes arrs+    conflictingTypes funs+    -- symbol names given different number of args and right types?+    funcArgCheck args+  +  where+  findDups :: [(String, C.SimpleType)] -> [(String, C.SimpleType)] -> IO ()+  findDups ls0 ls1 = mapM_ (\(name,_) -> dup name) ls0+    where+    dup nm = mapM_ ( \(name',_) -> if name' == nm +                                     then throw (Redeclared nm)+                                     else return () +                   ) ls1++  conflictingTypes :: [(String, C.SimpleType)] -> IO ()+  conflictingTypes ls = +    let grps = groupByPred ls in+    mapM_ sameType grps+    where +    sameType :: [(String, C.SimpleType)] -> IO ()+    sameType grp = foldCheck check grp +    check name c0 c1 = if c0 == c1 then return (name,c0) -- a dummy---we+                                                         -- discard the result+                         else throw (DifferentTypes name)++  funcArgCheck :: [(String, [C.SimpleType])] -> IO ()+  funcArgCheck ls = +    let grps = groupByPred ls in+    mapM_ argCheck grps+    where +    argCheck :: [(String, [C.SimpleType])] -> IO ()+    argCheck grp = foldCheck check grp+    check name args0 args1 = +      if length args0 == length args1 +        then if args0 == args1+               then return (name,args0) -- a dummy---we discard the+                                        -- result+               else throw (BadFunctionArgType name)+        else throw (BadNumberOfArgs name) ++  groupByPred :: [(String, a)] -> [[(String, a)]]+  groupByPred = groupBy (\(n0,_) (n1,_) -> n0 == n1)++  foldCheck :: (String -> a -> a -> IO (String, a)) -> [(String, a)] -> IO ()+  foldCheck check grp = +    foldM_ ( \(name, c0) (_, c1) -> check name c0 c1)+           (head grp) -- should be typesafe, since this is from groupBy+           grp++--------------------------------------------------------------------------------++specExts :: IORef Env -> Spec -> IO ExternEnv+specExts refStreams spec = do+  env <- foldM triggerExts+           (ExternEnv [] [] [] []) +           (triggers $ runSpec spec)+  foldM observerExts env (observers $ runSpec spec) ++  where+  observerExts :: ExternEnv -> Observer -> IO ExternEnv+  observerExts env (Observer _ stream) = collectExts refStreams stream env++  triggerExts :: ExternEnv -> Trigger -> IO ExternEnv+  triggerExts env (Trigger _ guard args) = do+    env' <- collectExts refStreams guard env +    foldM (\env'' (TriggerArg arg_) -> collectExts refStreams arg_ env'')+          env' args++collectExts :: C.Typed a => IORef Env -> Stream a -> ExternEnv -> IO ExternEnv+collectExts refStreams stream_ env_ = do+  b <- mapCheck refStreams+  when b (throw TooMuchRecussion)+  go M.empty env_ stream_++  where+  go :: Env -> ExternEnv -> Stream b -> IO ExternEnv+  go nodes env stream = do+    dstn <- makeDynStableName stream+    assertNotVisited stream dstn nodes++    case stream of+      Append _ _ e           -> analyzeAppend refStreams dstn e env +                                  (\refs str -> collectExts refs str env)+      Const _                -> return env+      Drop _ e1              -> go nodes env e1+      Extern name _          -> +        let ext = ( name, getSimpleType stream ) in+        return env { externVarEnv = ext : externVarEnv env }++      ExternFun name args me -> do+        env' <- case me of+                  Nothing -> return env +                  Just e  -> go nodes env e+        env'' <- foldM (\env'' (FunArg arg_) -> go nodes env'' arg_)+                   env' args +        let argTypes = map (\(FunArg arg_) -> getSimpleType arg_) args +        let fun = (name, getSimpleType stream) +        return env'' { externFunEnv  = fun : externFunEnv env''+                     , externFunArgs = (name, argTypes) : externFunArgs env''+                     }++      ExternArray name idx _ _ -> do+        env' <- go nodes env idx+        let arr = ( name, getSimpleType stream )+        return env' { externArrEnv = arr : externArrEnv env' }++      Local e _              -> go nodes env e +      Var _                  -> return env+      Op1 _ e                -> go nodes env e +      Op2 _ e1 e2            -> do env' <- go nodes env e1+                                   go nodes env' e2+      Op3 _ e1 e2 e3         -> do env' <- go nodes env e1  +                                   env'' <- go nodes env' e2 +                                   go nodes env'' e3 ++--------------------------------------------------------------------------------++getSimpleType :: forall a. C.Typed a => Stream a -> C.SimpleType+getSimpleType _ = C.simpleType (C.typeOf :: C.Type a)  --------------------------------------------------------------------------------

@@ -13,4 +13,4 @@     "(remove spaces) or file a bug report on github.com."  badUsage :: String -> a-badUsage msg = error $ "Copilot error: " ++ msg ++ "."+badUsage msg = error $ "Copilot error: " ++ msg

@@ -5,93 +5,90 @@ -- | The interpreter.  module Copilot.Language.Interpret-  ( Input-  , csv+  ( --Input+    csv   , interpret -  , var-  , array-  , func+--  , var+--  , array+--  , func   ) where -import Copilot.Core.Expr (Name)-import Copilot.Core.Type (Typed, typeOf)-import qualified Copilot.Core as C-import Copilot.Core.Interpret (ExtEnv (..))-import Copilot.Core.Type.Dynamic (toDynF)+--import Copilot.Core.Type (Typed, typeOf)+--import Copilot.Core.Interpret (ExtEnv (..))+--import Copilot.Core.Type.Dynamic (toDynF) import qualified Copilot.Core.Interpret as I -import Copilot.Language.Spec (Spec, observer)-import Copilot.Language.Stream (Stream)+import Copilot.Language.Spec (Spec) import Copilot.Language.Reify -import Data.List (foldl')+--import Data.List (foldl')  -------------------------------------------------------------------------------- -data Input where-  -- External variables.-  Var  :: Typed a => String -> [a] -> Input-  -- External arrays (list of lists).-  Arr  :: Typed a => String -> [[a]] -> Input-  -- External functions (streams).-  Func :: Typed a => String -> Stream a -> Input+-- data Input where+--   -- External variables.+--   Var  :: Typed a => String -> [a] -> Input+--   -- External arrays (list of lists).+--   Arr  :: Typed a => String -> [[a]] -> Input+--   -- -- External functions (streams).+--   -- Func :: Typed a => String -> Stream a -> Input -var :: Typed a => String -> [a] -> Input-var = Var+-- var :: Typed a => String -> [a] -> Input+-- var = Var -array :: Typed a => String -> [[a]] -> Input-array = Arr+-- array :: Typed a => String -> [[a]] -> Input+-- array = Arr -func :: Typed a => String -> Stream a -> Input-func = Func+-- func :: Typed a => String -> Stream a -> Input+-- func = Func  -------------------------------------------------------------------------------- -csv :: Integer -> [Input] -> Spec -> IO ()-csv i input_ spec = do+csv :: Integer -> Spec -> IO ()+csv i spec = do   putStrLn "Note: CSV format does not output observers."-  interpret' I.CSV i input_ spec+  interpret' I.CSV i spec  --------------------------------------------------------------------------------  -- | Much slower, but pretty-printed interpreter output.  -interpret :: Integer -> [Input] -> Spec -> IO ()+interpret :: Integer -> Spec -> IO () interpret = interpret' I.Table -interpret' :: I.Format -> Integer -> [Input] -> Spec -> IO ()-interpret' format i inputs spec = do+interpret' :: I.Format -> Integer -> Spec -> IO ()+interpret' format i spec = do   coreSpec <- reify spec-  fexts    <- funcExts-  putStrLn $ I.interpret format (fromIntegral i) (unionExts fexts) coreSpec+--  fexts    <- funcExts+  putStrLn $ I.interpret format (fromIntegral i) coreSpec -  where-  unionExts :: [(Name, C.Spec)] -> ExtEnv-  unionExts fexts = ExtEnv { varEnv  = varEnv varArrExts-                           , arrEnv  = arrEnv varArrExts-                           , funcEnv = fexts-                           }+--  where+--   unionExts :: ExtEnv+--   unionExts = ExtEnv { varEnv  = varEnv varArrExts+--                      , arrEnv  = arrEnv varArrExts+-- --                     , funcEnv = fexts+--                      } -  -- We do the two folds below over the data type separately, since one-  -- component is monadic.-  funcExts :: IO [(Name, C.Spec)]-  funcExts = -    let (names, specs) = unzip $ foldl' envf [] inputs in-    do ss <- sequence specs-       return $ zip names ss-    where-    envf :: [(Name, IO C.Spec)] -> Input -> [(Name, IO C.Spec)]-    envf acc (Func name strm) = -      (name, reify $ observer name strm) : acc-    envf acc _ = acc+  -- -- We do the two folds below over the data type separately, since one+  -- -- component is monadic.+  -- funcExts :: IO [(Name, C.Spec)]+  -- funcExts = +  --   let (names, specs) = unzip $ foldl' envf [] inputs in+  --   do ss <- sequence specs+  --      return $ zip names ss+  --   where+  --   envf :: [(Name, IO C.Spec)] -> Input -> [(Name, IO C.Spec)]+  --   envf acc (Func name strm) = +  --     (name, reify $ observer name strm) : acc+  --   envf acc _ = acc -  varArrExts :: ExtEnv-  varArrExts = foldl' env (ExtEnv [] [] []) inputs-    where -    env :: ExtEnv -> Input -> ExtEnv-    env acc (Var name xs) = -      acc { varEnv = (name, toDynF typeOf xs) : varEnv acc } -    env acc (Arr name xs) = -      acc { arrEnv = (name, map (toDynF typeOf) xs) : arrEnv acc }-    env acc _ = acc+  -- varArrExts :: ExtEnv+  -- varArrExts = foldl' env (ExtEnv [] []) inputs+  --   where +  --   env :: ExtEnv -> Input -> ExtEnv+  --   env acc (Var name xs) = +  --     acc { varEnv = (name, toDynF typeOf xs) : varEnv acc } +  --   env acc (Arr name xs) = +  --     acc { arrEnv = (name, map (toDynF typeOf) xs) : arrEnv acc }+--    env acc _ = acc  --------------------------------------------------------------------------------

@@ -89,8 +89,6 @@  -------------------------------------------------------------------------------- -instance Cast Word32 Word16 where-  cast = castIntegral instance Cast Word32 Word32 where   cast = castIntegral instance Cast Word32 Word64 where

@@ -6,14 +6,51 @@  module Copilot.Language.Operators.Constant   ( constant+  , constB+  , constW8+  , constW16+  , constW32+  , constW64+  , constI8+  , constI16+  , constI32+  , constI64+  , constF+  , constD   ) where  import Copilot.Core (Typed) import Copilot.Language.Stream +import Data.Word+import Data.Int+ --------------------------------------------------------------------------------  constant :: Typed a => a -> Stream a constant = Const  --------------------------------------------------------------------------------++constB   :: Bool -> Stream Bool+constB   = constant+constW8  :: Word8 -> Stream Word8+constW8  = constant +constW16 :: Word16 -> Stream Word16+constW16 = constant+constW32 :: Word32 -> Stream Word32+constW32 = constant+constW64 :: Word64 -> Stream Word64+constW64 = constant+constI8  :: Int8 -> Stream Int8+constI8  = constant+constI16 :: Int16 -> Stream Int16+constI16 = constant+constI32 :: Int32 -> Stream Int32+constI32 = constant+constI64 :: Int64 -> Stream Int64+constI64 = constant+constF   :: Float -> Stream Float+constF   = constant+constD   :: Double -> Stream Double+constD   = constant

@@ -6,6 +6,7 @@  module Copilot.Language.Operators.Extern   ( extern+  , externB   , externW8   , externW16   , externW32@@ -19,6 +20,17 @@   , FunArg   , externFun   , externArray+  , externArrayB+  , externArrayW8+  , externArrayW16+  , externArrayW32+  , externArrayW64+  , externArrayI8+  , externArrayI16+  , externArrayI32+  , externArrayI64+  , externArrayF+  , externArrayD   , funArg   ) where @@ -27,15 +39,18 @@ import Data.Word import Data.Int +type Size = Int+ -------------------------------------------------------------------------------- -extern :: Typed a => String -> Stream a+extern :: Typed a => String -> Maybe [a] -> Stream a extern = Extern -externFun :: Typed a => String -> [FunArg] -> Stream a+externFun :: Typed a => String -> [FunArg] -> Maybe (Stream a) -> Stream a externFun = ExternFun -externArray :: (Typed a, Typed b, Integral a) => String -> Stream a -> Stream b+externArray :: (Typed a, Typed b, Integral a) +            => String -> Stream a -> Size -> Maybe [[b]] -> Stream b externArray = ExternArray  funArg :: Typed a => Stream a -> FunArg@@ -43,23 +58,72 @@  -------------------------------------------------------------------------------- -externW8  :: String -> Stream Word8+externB   :: String -> Maybe [Bool] -> Stream Bool+externB   = extern +externW8  :: String -> Maybe [Word8] -> Stream Word8 externW8  = extern -externW16 :: String -> Stream Word16+externW16 :: String -> Maybe [Word16] -> Stream Word16 externW16 = extern-externW32 :: String -> Stream Word32+externW32 :: String -> Maybe [Word32] -> Stream Word32 externW32 = extern-externW64 :: String -> Stream Word64+externW64 :: String -> Maybe [Word64] -> Stream Word64 externW64 = extern-externI8  :: String -> Stream Int8+externI8  :: String -> Maybe [Int8] -> Stream Int8 externI8  = extern-externI16 :: String -> Stream Int16+externI16 :: String -> Maybe [Int16] -> Stream Int16 externI16 = extern-externI32 :: String -> Stream Int32+externI32 :: String -> Maybe [Int32] -> Stream Int32 externI32 = extern-externI64 :: String -> Stream Int64+externI64 :: String -> Maybe [Int64] -> Stream Int64 externI64 = extern-externF   :: String -> Stream Float+externF   :: String -> Maybe [Float] -> Stream Float externF   = extern-externD   :: String -> Stream Double+externD   :: String -> Maybe [Double] -> Stream Double externD   = extern++--------------------------------------------------------------------------------++externArrayB   :: (Typed a, Integral a) +               => String -> Stream a -> Size +                         -> Maybe [[Bool]] -> Stream Bool+externArrayB   = externArray +externArrayW8  :: (Typed a, Integral a) +               => String -> Stream a -> Size +                         -> Maybe [[Word8]] -> Stream Word8+externArrayW8  = externArray +externArrayW16 :: (Typed a, Integral a)+               => String -> Stream a -> Size +                         -> Maybe [[Word16]] -> Stream Word16+externArrayW16 = externArray+externArrayW32 :: (Typed a, Integral a)+               => String -> Stream a -> Size +                         -> Maybe [[Word32]] -> Stream Word32+externArrayW32 = externArray+externArrayW64 :: (Typed a, Integral a)+               => String -> Stream a -> Size +                         -> Maybe [[Word64]] -> Stream Word64+externArrayW64 = externArray+externArrayI8  :: (Typed a, Integral a)+               => String -> Stream a -> Size +                         -> Maybe [[Int8]] -> Stream Int8+externArrayI8  = externArray+externArrayI16 :: (Typed a, Integral a)+               => String -> Stream a -> Size +                         -> Maybe [[Int16]] -> Stream Int16+externArrayI16 = externArray+externArrayI32 :: (Typed a, Integral a)+               => String -> Stream a -> Size +                         -> Maybe [[Int32]] -> Stream Int32+externArrayI32 = externArray+externArrayI64 :: (Typed a, Integral a)+               => String -> Stream a -> Size +                         -> Maybe [[Int64]] -> Stream Int64+externArrayI64 = externArray+externArrayF   :: (Typed a, Integral a)+               => String -> Stream a -> Size +                         -> Maybe [[Float]] -> Stream Float+externArrayF   = externArray+externArrayD   :: (Typed a, Integral a)+               => String -> Stream a -> Size +                         -> Maybe [[Double]] -> Stream Double+externArrayD   = externArray

@@ -18,12 +18,12 @@  div :: (Typed a, P.Integral a) => Stream a -> Stream a -> Stream a (Const 0) `div` _ = Const 0-_ `div` (Const 0) = Core.badUsage "in div: division by zero"+_ `div` (Const 0) = Core.badUsage "in div: division by zero." x `div` (Const 1) = x x `div` y = Op2 (Core.Div typeOf) x y  mod :: (Typed a, P.Integral a) => Stream a -> Stream a -> Stream a-_         `mod` (Const 0) = Core.badUsage "in mod: division by zero"+_         `mod` (Const 0) = Core.badUsage "in mod: division by zero." (Const 0) `mod` _         = (Const 0) (Const x) `mod` (Const y) = Const (x `P.mod` y) x `mod` y = Op2 (Core.Mod typeOf) x y

@@ -11,23 +11,26 @@   ( reify   ) where -import Copilot.Core (Typed, Type, Id, typeOf, impossible) import qualified Copilot.Core as Core+import Copilot.Core (Typed, Type, Id, typeOf, impossible)+ --import Copilot.Language.Reify.Sharing (makeSharingExplicit) import Copilot.Language.Analyze (analyze) import Copilot.Language.Spec import Copilot.Language.Stream (Stream (..), FunArg (..))-import Data.IORef+ import Prelude hiding (id)+import Data.IORef import System.Mem.StableName.Dynamic import System.Mem.StableName.Dynamic.Map (Map) import qualified System.Mem.StableName.Dynamic.Map as M+import Control.Monad (liftM)  --------------------------------------------------------------------------------  reify :: Spec -> IO Core.Spec reify spec =-  do+  do      analyze spec     let trigs = triggers  $ runSpec spec     let obsvs = observers $ runSpec spec@@ -52,8 +55,7 @@   -> IORef [Core.Stream]   -> Observer   -> IO Core.Observer-mkObserver refMkId refStreams refMap (Observer name e) =-  do +mkObserver refMkId refStreams refMap (Observer name e) = do     w <- mkExpr refMkId refStreams refMap e     return $       Core.Observer@@ -70,8 +72,7 @@   -> IORef [Core.Stream]   -> Trigger   -> IO Core.Trigger-mkTrigger refMkId refStreams refMap (Trigger name guard args) =-  do+mkTrigger refMkId refStreams refMap (Trigger name guard args) = do     w1 <- mkExpr refMkId refStreams refMap guard      args' <- mapM mkTriggerArg args     return $@@ -83,8 +84,7 @@   where    mkTriggerArg :: TriggerArg -> IO Core.UExpr-  mkTriggerArg (TriggerArg e) =-    do+  mkTriggerArg (TriggerArg e) = do       w <- mkExpr refMkId refStreams refMap e       return $ Core.UExpr typeOf w @@ -103,44 +103,32 @@ --  (>>= go) . makeSharingExplicit refMkId    where--  go-    :: Typed a-    => Stream a-    -> IO (Core.Expr a)+  go :: Typed a => Stream a -> IO (Core.Expr a)   go e0 =-     case e0 of        ------------------------------------------------------ -      Append _ _ _ ->--        do s <- mkStream refMkId refStreams refMap e0-           return $ Core.Drop typeOf 0 s+      Append _ _ _ -> do+        s <- mkStream refMkId refStreams refMap e0+        return $ Core.Drop typeOf 0 s        ------------------------------------------------------        Drop k e1 ->-         case e1 of-          Append _ _ _ ->-            do+          Append _ _ _ -> do               s <- mkStream refMkId refStreams refMap e1               return $ Core.Drop typeOf (fromIntegral k) s           _ -> impossible "mkExpr" "copilot-language"        ------------------------------------------------------ -      Const x ->--        return $ Core.Const typeOf x+      Const x -> return $ Core.Const typeOf x        ------------------------------------------------------ -      Local e f ->--        do+      Local e f -> do           id <- mkId refMkId           let cs = "local_" ++ show id           w1 <- go e@@ -149,54 +137,43 @@        ------------------------------------------------------ -      Var cs ->--        return $ Core.Var typeOf cs+      Var cs -> return $ Core.Var typeOf cs        ------------------------------------------------------ -      Extern cs ->--        return $ Core.ExternVar typeOf cs+      Extern cs mXs -> return $ Core.ExternVar typeOf cs mXs        ------------------------------------------------------ -      ExternFun cs args ->--        do+      ExternFun cs args interpExpr -> do           args' <- mapM mkFunArg args-          return $ Core.ExternFun typeOf cs args' Nothing+          w <- case interpExpr of+                 Nothing -> return Nothing+                 Just e  -> liftM Just (go e)+          return $ Core.ExternFun typeOf cs args' w Nothing        ------------------------------------------------------ -      ExternArray cs e ->--        do+      ExternArray cs e size mXs -> do           w <- go e-          return $ Core.ExternArray typeOf typeOf cs w Nothing+          return $ Core.ExternArray typeOf typeOf cs size w mXs Nothing        ------------------------------------------------------ -      Op1 op e ->--        do+      Op1 op e -> do           w <- go e           return $ Core.Op1 op w        ------------------------------------------------------ -      Op2 op e1 e2 ->--        do+      Op2 op e1 e2 -> do           w1 <- go e1           w2 <- go e2           return $ Core.Op2 op w1 w2        ------------------------------------------------------ -      Op3 op e1 e2 e3 ->--        do+      Op3 op e1 e2 e3 -> do           w1 <- go e1           w2 <- go e2           w3 <- go e3@@ -205,8 +182,7 @@       ------------------------------------------------------    mkFunArg :: FunArg -> IO Core.UExpr-  mkFunArg (FunArg e) =-    do+  mkFunArg (FunArg e) = do       w <- mkExpr refMkId refStreams refMap e       return $ Core.UExpr typeOf w 

@@ -40,16 +40,20 @@   Extern     :: Typed a     => String+    -> Maybe [a]     -> Stream a   ExternFun     :: Typed a     => String     -> [FunArg]+    -> Maybe (Stream a)     -> Stream a   ExternArray     :: (Typed a, Typed b, Integral a)     => String     -> Stream a+    -> Int+    -> Maybe [[b]]     -> Stream b   Local     :: (Typed a, Typed b)

@@ -3,7 +3,7 @@ --------------------------------------------------------------------------------  module System.Mem.StableName.Dynamic.Map-    ( Map+    ( Map(..)     , empty     , null     , singleton@@ -25,16 +25,18 @@  import Copilot.Core.Error (impossible) -newtype Map a = Map { getMap :: IntMap [(DynStableName, a)] } +data Map a = Map { getMap  :: IntMap [(DynStableName, a)] +                 , getSize :: Int }   empty :: Map a-empty = Map IntMap.empty+empty = Map IntMap.empty 0  null :: Map a -> Bool-null (Map m) = IntMap.null m+null (Map m _) = IntMap.null m  singleton :: DynStableName -> a -> Map a-singleton k v = Map $ IntMap.singleton (hashDynStableName k) [(k,v)]+singleton k v = +  Map (IntMap.singleton (hashDynStableName k) [(k,v)]) 1  member :: DynStableName -> Map a -> Bool member k m = case lookup k m of@@ -45,15 +47,21 @@ notMember k m = not $ member k m   insert :: DynStableName -> a -> Map a -> Map a-insert k v = Map . IntMap.insertWith (++) (hashDynStableName k) [(k,v)] . getMap-    +insert k v Map { getMap  = mp+               , getSize = sz }+  = Map (IntMap.insertWith (++) (hashDynStableName k) [(k,v)] mp)+        (sz + 1)+ -- | /O(log n)/. Insert with a function for combining the new value and old value. -- @'insertWith' f key value mp@ -- will insert the pair (key, value) into @mp@ if the key does not exist -- in the map. If the key does exist, the function will insert the pair -- @(key, f new_value old_value)@ insertWith :: (a -> a -> a) -> DynStableName -> a -> Map a -> Map a-insertWith f k v = Map . IntMap.insertWith go (hashDynStableName k) [(k,v)] . getMap +insertWith f k v Map { getMap  = mp+                     , getSize = sz } +  = Map (IntMap.insertWith go (hashDynStableName k) [(k,v)] mp)+        (sz + 1)     where          go _ ((k',v'):kvs)              | k == k' = (k', f v v') : kvs@@ -62,7 +70,10 @@  -- | Same as 'insertWith', but with the combining function applied strictly. insertWith' :: (a -> a -> a) -> DynStableName -> a -> Map a -> Map a-insertWith' f k v = Map . IntMap.insertWith go (hashDynStableName k) [(k,v)] . getMap +insertWith' f k v Map { getMap  = mp+                      , getSize = sz } +  = Map (IntMap.insertWith go (hashDynStableName k) [(k,v)] mp)+        (sz + 1)     where          go _ ((k',v'):kvs)              | k == k' = let v'' = f v v' in v'' `seq` (k', v'') : kvs@@ -74,7 +85,7 @@ -- The function will return the corresponding value as a @('Just' value)@ -- or 'Nothing' if the key isn't in the map. lookup :: DynStableName -> Map v -> Maybe v-lookup k (Map m) = do+lookup k (Map m _) = do     pairs <- IntMap.lookup (hashDynStableName k) m     Prelude.lookup k pairs