imperative-edsl 0.5 → 0.6

raw patch · 22 files changed

+1157/−706 lines, 22 filesdep +data-default-classdep +filepathdep +randomdep −open-typerepdep ~language-c-quotedep ~microlens-mtldep ~operational-alacartePVP ok

version bump matches the API change (PVP)

Dependencies added: data-default-class, filepath, random, stm

Dependencies removed: open-typerep

Dependency ranges changed: language-c-quote, microlens-mtl, operational-alacarte, syntactic

API changes (from Hackage documentation)

Files

• LICENSE +4/−2
• examples/C.hs +0/−35
• examples/Concurrent.hs +46/−9
• imperative-edsl.cabal +16/−18
• src/Control/Chan.hs +70/−0
• src/Language/C/Monad.hs +74/−81
• src/Language/Embedded/Backend/C.hs +80/−64
• src/Language/Embedded/Backend/C/Expression.hs +21/−43
• src/Language/Embedded/CExp.hs +41/−79
• src/Language/Embedded/Concurrent.hs +152/−38
• src/Language/Embedded/Concurrent/Backend/C.hs +51/−19
• src/Language/Embedded/Concurrent/CMD.hs +153/−65
• src/Language/Embedded/Expression.hs +16/−11
• src/Language/Embedded/Imperative.hs +1/−1
• src/Language/Embedded/Imperative/Args.hs +18/−10
• src/Language/Embedded/Imperative/Backend/C.hs +93/−65
• src/Language/Embedded/Imperative/CMD.hs +138/−87
• src/Language/Embedded/Imperative/Frontend.hs +43/−30
• src/Language/Embedded/Imperative/Frontend/General.hs +1/−1
• src/Language/Embedded/Signature.hs +5/−5
• tests/CExp.hs +0/−4
• tests/Imperative.hs +134/−39

@@ -1,4 +1,6 @@-Copyright (c) 2015-2016, Anders Persson, Emil Axelsson, Markus Aronsson+Copyright (c) 2016 Emil Axelsson, Anton Ekblad, Máté Karácsony+Copyright (c) 2015 Anders Persson, Anton Ekblad, Emil Axelsson,+                   Markus Aronsson, Josef Svenningsson  All rights reserved. @@ -13,7 +15,7 @@       disclaimer in the documentation and/or other materials provided       with the distribution. -    * Neither the name of Anders Persson, Emil Axelsson, Markus Aronsson nor the names of other+    * Neither the names of the copyright holders nor the names of other       contributors may be used to endorse or promote products derived       from this software without specific prior written permission. 

@@ -1,35 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TypeOperators #-}--module C where--import Prelude hiding (break)--import Language.C.Quote.C-import Language.Embedded.Imperative-import Language.Embedded.Concurrent-import Language.Embedded.Backend.C-import Language.Embedded.CExp--type L =-  C_CMD CExp :+:-  FileCMD CExp---- | Define a function in another module and call it.-multiModule :: Program L ()-multiModule = do-  addInclude "<stdlib.h>"-  addExternProc "func_in_other" []-  inModule "other" $ do-    addDefinition [cedecl|-      void func_in_other(void) {-        puts("Hello from the other module!");-      } |]-    addInclude "<stdio.h>"-  callProc "func_in_other" []--------------------------------------------testAll = do-    icompileAll multiModule

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-}  module Concurrent where@@ -18,14 +19,15 @@   ThreadCMD :+:   ChanCMD :+:   ControlCMD :+:-  FileCMD+  FileCMD :+:+  ArrCMD  type Prog = Program CMD (Param2 CExp CType)  -- | Deadlocks due to channel becoming full. deadlock :: Prog () deadlock = do-  c <- newChan 1+  c <- newChan (1 :: CExp Word32)   t <- fork $ readChan c >>= printf "%d\n"   writeChan c (1 :: CExp Int32)   writeChan c 2@@ -36,8 +38,8 @@ --   happen in separate threads. mapFile :: (CExp Float -> CExp Float) -> FilePath -> Prog () mapFile f i = do-  c1 <- newCloseableChan 5-  c2 <- newCloseableChan 5+  c1 <- newCloseableChan (5 :: CExp Word32)+  c2 <- newCloseableChan (5 :: CExp Word32)   fi <- fopen i ReadMode    t1 <- fork $ do@@ -49,12 +51,20 @@         (closeChan c2 >> break)    t2 <- fork $ do-    while (lastChanReadOK c2) $ do-      readChan c2 >>= printf "%f\n"+    while (return true) $ do+      x <- readChan c2+      readOK <- lastChanReadOK c2+      iff readOK+        (printf "%f\n" x)+        (break)    t3 <- fork $ do     while (not_ <$> feof fi) $ do-      fget fi >>= void . writeChan c1+      x <- fget fi+      eof <- feof fi+      iff eof+        (break)+        (void $ writeChan c1 x)     fclose fi     closeChan c1   waitThread t2@@ -77,13 +87,40 @@   printf "The thread is dead, long live the thread! %d\n" (0 :: CExp Int32)  +-- | Primitive channel operations.+chanOps :: Prog ()+chanOps = do+  c <- newCloseableChan (2 :: CExp Word32)+  writeChan c (1337 :: CExp Int32)+  writeChan c 42+  a <- readChan c+  b <- readChan c+  printf "%d %d\n" a b +  sent :: Arr Int8 Int32 <- initArr [ 12, 34 ]+  writeChanBuf c (0 :: CExp Int8) 2 sent+  received <- newArr (2 :: CExp Int8)+  readChanBuf c (0 :: CExp Int8) 2 received+  a <- getArr 0 received+  b <- getArr 1 received+  printf "%d %d\n" a b++  writeChan' c (67 :: CExp Word8)+  r :: CExp Word8 <- readChan' c+  printf "%d\n" r+  closeChan c+++ ----------------------------------------  testAll = do     tag "waiting" >> compareCompiled' opts waiting (runIO waiting) ""     tag "suicide" >> compareCompiled' opts suicide (runIO suicide) ""+    tag "chanOps" >> compareCompiled' opts chanOps (runIO chanOps) ""   where     tag str = putStrLn $ "---------------- examples/Concurrent.hs/" ++ str ++ "\n"-    opts = defaultExtCompilerOpts {externalFlagsPost = ["-lpthread"]}-+    opts = def+         { externalFlagsPre  = ["-Iinclude", "csrc/chan.c"]+         , externalFlagsPost = ["-lpthread"]+         }

@@ -1,5 +1,5 @@ name:                imperative-edsl-version:             0.5+version:             0.6 synopsis:            Deep embedding of imperative programs with code generation description:         Deep embedding of imperative programs with code generation.                      .@@ -13,7 +13,9 @@ license-file:        LICENSE author:              Anders Persson, Emil Axelsson, Markus Aronsson maintainer:          emax@chalmers.se-copyright:           Copyright (c) 2015-2016, Anders Persson, Emil Axelsson, Markus Aronsson+copyright:           Copyright (c) 2016 Anton Ekblad, Emil Axelsson, Máté Karácsony+                     Copyright (c) 2015 Anders Persson, Anton Ekblad, Emil Axelsson,+                                        Markus Aronsson, Josef Svenningsson homepage:            https://github.com/emilaxelsson/imperative-edsl bug-reports:         https://github.com/emilaxelsson/imperative-edsl/issues category:            Language@@ -28,10 +30,6 @@   type:     git   location: git@github.com:emilaxelsson/imperative-edsl.git -Flag old-syntactic-  Description: Use syntactic < 2-  Default:     False- library   exposed-modules:     Control.Monads@@ -55,6 +53,7 @@     Language.Embedded.Imperative.Backend.C     Language.Embedded.Concurrent.Backend.C       -- No need to export these since only the instances are interesting+    Control.Chan    default-language: Haskell2010 @@ -90,29 +89,24 @@     array,     base >=4 && <5,     containers,+    data-default-class,     deepseq,     directory,     exception-transformers,     ghc-prim,-    language-c-quote >= 0.11 && < 0.12,+    language-c-quote >= 0.11.5 && < 0.12,     mainland-pretty >= 0.4 && < 0.5,     microlens >= 0.3.0.0,-    microlens-mtl,+    microlens-mtl >= 0.1.8,     microlens-th,     mtl,     process,-    operational-alacarte >= 0.2,+    operational-alacarte >= 0.3,     BoundedChan,     srcloc,-    time >= 1.5.0.1--  if flag(old-syntactic)-    build-depends:-      syntactic < 2-  else-    build-depends:-      open-typerep >= 0.4,-      syntactic >= 3.2+    syntactic >= 3.2,+    time >= 1.5.0.1,+    stm >= 2.4 && < 2.5    hs-source-dirs: src @@ -127,7 +121,11 @@    build-depends:     base,+    directory,+    filepath,     imperative-edsl,+    process,+    random,     syntactic,     tasty-quickcheck,     tasty-th

@@ -0,0 +1,70 @@+-- | Multi-element channels, for the Haskell interpretation of+--   'Language.Embedded.Concurrent'.+module Control.Chan where+import Control.Concurrent.STM++data ChanState = Open | Closed+  deriving Eq++newtype Chan a = Chan {unChan :: TVar (ChanGuts a)}++data ChanGuts a = ChanGuts+  { chanBuf        :: [a]+  , chanBufLen     :: Int+  , chanBound      :: Int+  , chanState      :: ChanState+  , chanLastReadOK :: Bool+  }++newChan :: Int -> IO (Chan a)+newChan len = fmap Chan . atomically . newTVar $ ChanGuts+  { chanBuf = []+  , chanBufLen = 0+  , chanBound = len+  , chanState = Open+  , chanLastReadOK = True+  }++readChan :: Chan a -> Int -> IO [a]+readChan (Chan chan) len = atomically $ do+  ch <- readTVar chan+  case chanState ch of+    Open -> do+      check (chanBufLen ch >= len)+      readAndUpdate ch True+    Closed+      | chanBufLen ch < len -> do+        return []+      | otherwise -> do+        readAndUpdate ch False+  where+    readAndUpdate ch success = do+      let (out, rest) = splitAt len (chanBuf ch)+      writeTVar chan $ ch+        { chanBuf = rest+        , chanBufLen = chanBufLen ch - len+        , chanLastReadOK = success+        }+      return out++writeChan :: Chan a -> [a] -> IO Bool+writeChan (Chan chan) xs = atomically $ do+  let len = length xs+  ch <- readTVar chan+  case chanState ch of+    Open -> do+      check (chanBound ch - chanBufLen ch >= len)+      writeTVar chan $ ch+        { chanBuf = chanBuf ch ++ xs+        , chanBufLen = chanBufLen ch + len+        }+      return True+    Closed -> do+      return False++closeChan :: Chan a -> IO ()+closeChan (Chan chan) = atomically $ do+  modifyTVar chan (\c -> c {chanState = Closed})++lastReadOK :: Chan a -> IO Bool+lastReadOK = fmap chanLastReadOK . atomically . readTVar . unChan

@@ -1,52 +1,4 @@--- Copyright (c) 2009-2010---         The President and Fellows of Harvard College.------ 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 University nor the names of its contributors---    may be used to endorse or promote products derived from this software---    without specific prior written permission.------ THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY AND CONTRIBUTORS ``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 UNIVERSITY 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.---- Copyright (c) 2011-2012, Geoffrey Mainland--- 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.------ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "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 COPYRIGHT HOLDER 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.+-- Copyright (c) 2016 and after, see package copyright  -- Copyright (c) 2015, Anders Persson --@@ -79,6 +31,56 @@ -- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- Copyright (c) 2011-2012, Geoffrey Mainland+-- 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.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "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 COPYRIGHT HOLDER 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.++-- Copyright (c) 2009-2010+--         The President and Fellows of Harvard College.+--+-- 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 University nor the names of its contributors+--    may be used to endorse or promote products derived from this software+--    without specific prior written permission.+--+-- THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY AND CONTRIBUTORS ``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 UNIVERSITY 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.+ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-}@@ -92,7 +94,6 @@ module Language.C.Monad   where -import Lens.Micro import Lens.Micro.Mtl import Lens.Micro.TH #if __GLASGOW_HASKELL__ < 710@@ -130,8 +131,8 @@     , _params      :: [C.Param]     , _args        :: [C.Exp]     , _locals      :: [C.InitGroup]-    , _stms        :: [C.Stm]-    , _finalStms   :: [C.Stm]+    , _items       :: [C.BlockItem]+    , _finalItems  :: [C.BlockItem]      , _usedVars    :: Set.Set C.Id     , _funUsedVars :: Map.Map String (Set.Set C.Id)@@ -139,22 +140,6 @@  makeLenses ''CEnv --- | Reimplementation of @<<%=@ from the lens package-(<<%=) :: MonadState s m =>-    (forall f . Functor f => LensLike' f s a) -> (a -> a) -> m a-l <<%= f = do-    s <- get-    l %= f-    return (s ^. l)---- | Reimplementation of @<<.=@ from the lens package-(<<.=) :: MonadState s m =>-    (forall f . Functor f => LensLike' f s a) -> a -> m a-l <<.= f = do-    s <- get-    l .= f-    return (s ^. l)- -- | Default code generator state defaultCEnv :: Flags -> CEnv defaultCEnv fl = CEnv@@ -169,8 +154,8 @@     , _params      = mempty     , _args        = mempty     , _locals      = mempty-    , _stms        = mempty-    , _finalStms   = mempty+    , _items       = mempty+    , _finalItems  = mempty     , _usedVars    = mempty     , _funUsedVars = mempty     }@@ -295,21 +280,29 @@     C.InitGroup _ _ is _ -> forM_ is $ \(C.Init id _ _ _ _ _) -> touchVar id     _                    -> return () +-- | Add an item (a declaration or a statement) to the current block+--   This functionality is necessary to declare C99 variable-length arrays+--   in the middle of a block, as other local delcarations are lifted to the+--   beginning of the block, and that makes the evaluation of the length+--   expression impossible.+addItem :: MonadC m => C.BlockItem -> m ()+addItem item = items %= (item:)+ -- | Add multiple local declarations addLocals :: MonadC m => [C.InitGroup] -> m () addLocals defs = mapM_ addLocal defs -- locals %= (reverse defs++)  -- | Add a statement to the current block addStm :: MonadC m => C.Stm -> m ()-addStm stm = stms %= (stm:)+addStm stm = items %= ((C.BlockStm stm):)  -- | Add a sequence of statements to the current block addStms :: MonadC m => [C.Stm] -> m ()-addStms ss = stms %= (reverse ss++)+addStms ss = items %= (reverse (map C.BlockStm ss)++)  -- | Add a statement to the end of the current block addFinalStm :: MonadC m => C.Stm -> m ()-addFinalStm stm = finalStms %= (stm:)+addFinalStm stm = finalItems %= ((C.BlockStm stm):)  -- | Run an action in a new block inBlock :: MonadC m => m a -> m a@@ -322,16 +315,16 @@ -- Does not place the items in an actual C block. inNewBlock :: MonadC m => m a -> m (a, [C.BlockItem]) inNewBlock ma = do-    oldLocals    <- locals    <<.= mempty-    oldStms      <- stms      <<.= mempty-    oldFinalStms <- finalStms <<.= mempty+    oldLocals     <- locals     <<.= mempty+    oldItems      <- items      <<.= mempty+    oldFinalItems <- finalItems <<.= mempty     x <- ma-    ls  <- reverse <$> (locals    <<.= oldLocals)-    ss  <- reverse <$> (stms      <<.= oldStms)-    fss <- reverse <$> (finalStms <<.= oldFinalStms)+    ls  <- reverse <$> (locals     <<.= oldLocals)+    ss  <- reverse <$> (items      <<.= oldItems)+    fss <- reverse <$> (finalItems <<.= oldFinalItems)     return (x, map C.BlockDecl ls  ++-               map C.BlockStm  ss  ++-               map C.BlockStm  fss+               ss  +++               fss            )  -- | Run an action as a block and capture the items.

@@ -6,6 +6,7 @@ module Language.Embedded.Backend.C   ( module Language.Embedded.Backend.C.Expression   , module Language.Embedded.Backend.C+  , Default (..)   ) where  @@ -19,8 +20,9 @@ import System.Directory (getTemporaryDirectory, removeFile) import System.Exit (ExitCode (..)) import System.IO-import System.Process (system)+import System.Process (system, readProcess) +import Data.Default.Class import Data.Loc (noLoc) import qualified Language.C.Syntax as C import Text.PrettyPrint.Mainland (pretty)@@ -62,41 +64,37 @@ -- * Code generation user interface -------------------------------------------------------------------------------- --- | Compile a program to C code represented as a string------ This function returns only the first (main) module.--- To get every C translation units, use `compileAll`.+-- | Compile a program to C code represented as a string. To compile the+-- resulting C code, use something like ----- For programs that make use of the primitives in--- "Language.Embedded.Concurrent", the resulting C code can be compiled as--- follows:+-- > cc -std=c99 YOURPROGRAM.c ----- > gcc -Iinclude csrc/chan.c -lpthread YOURPROGRAM.c+-- This function returns only the first (main) module. To get all C translation+-- unit, use 'compileAll'. compile :: (Interp instr CGen (Param2 exp pred), HFunctor instr) =>     Program instr (Param2 exp pred) a -> String compile = snd . head . compileAll +-- | Compile a program to C modules, each one represented as a pair of a name+-- and the code represented as a string. To compile the resulting C code, use+-- something like+--+-- > cc -std=c99 YOURPROGRAM.c compileAll :: (Interp instr CGen (Param2 exp pred), HFunctor instr) =>     Program instr (Param2 exp pred) a -> [(String, String)]-compileAll = map (("", pretty 80) <*>) . prettyCGen . liftSharedLocals . wrapMain . interpret+compileAll+    = map (("", pretty 80) <*>) . prettyCGen . liftSharedLocals+    . wrapMain . interpret --- | Compile a program to C code and print it on the screen------ This function returns only the first (main) module.--- To get every C translation units, use `icompileAll`.------ For programs that make use of the primitives in--- "Language.Embedded.Concurrent", the resulting C code can be compiled as--- follows:+-- | Compile a program to C code and print it on the screen. To compile the+-- resulting C code, use something like ----- > gcc -Iinclude csrc/chan.c -lpthread YOURPROGRAM.c+-- > cc -std=c99 YOURPROGRAM.c icompile :: (Interp instr CGen (Param2 exp pred), HFunctor instr) =>     Program instr (Param2 exp pred) a -> IO ()-icompile = putStrLn . compile--icompileAll :: (Interp instr CGen (Param2 exp pred), HFunctor instr) =>-    Program instr (Param2 exp pred) a -> IO ()-icompileAll = mapM_ (\(n, m) -> putStrLn ("// module " ++ n) >> putStrLn m) . compileAll+icompile prog = case compileAll prog of+    [m] -> putStrLn $ snd m+    ms  -> mapM_ (\(n, m) -> putStrLn ("// module " ++ n) >> putStrLn m) ms  removeFileIfPossible :: FilePath -> IO () removeFileIfPossible file =@@ -109,29 +107,20 @@       , externalSilent     :: Bool      -- ^ Don't print anything besides what the program prints       } -defaultExtCompilerOpts :: ExternalCompilerOpts-defaultExtCompilerOpts = ExternalCompilerOpts-    { externalKeepFiles = False-    , externalFlagsPre  = []-    , externalFlagsPost = []-    , externalSilent    = False-    }--instance Monoid ExternalCompilerOpts+instance Default ExternalCompilerOpts   where-    mempty = defaultExtCompilerOpts-    mappend-        (ExternalCompilerOpts keep1 pre1 post1 silent1)-        (ExternalCompilerOpts keep2 pre2 post2 silent2) =-            ExternalCompilerOpts keep2 (pre1 ++ pre2) (post1 ++ post2) silent2+    def = ExternalCompilerOpts+      { externalKeepFiles = False+      , externalFlagsPre  = []+      , externalFlagsPost = []+      , externalSilent    = False+      }  maybePutStrLn :: Bool -> String -> IO () maybePutStrLn False str = putStrLn str maybePutStrLn _ _ = return () --- TODO: it would be nice to have a version that compiles all modules of a program,--- as it currently compiles only the first (main) module.--- | Generate C code and use GCC to compile it+-- | Generate C code and use CC to compile it compileC :: (Interp instr CGen (Param2 exp pred), HFunctor instr)     => ExternalCompilerOpts     -> Program instr (Param2 exp pred) a  -- ^ Program to compile@@ -146,7 +135,7 @@     when externalKeepFiles $ maybePutStrLn externalSilent $         "Created temporary file: " ++ cFile     let compileCMD = unwords-          $  ["gcc", "-std=c99"]+          $  ["cc", "-std=c99"]           ++ externalFlagsPre           ++ [cFile, "-o", exeFile]           ++ externalFlagsPost@@ -160,7 +149,7 @@   where     format = if externalKeepFiles then "%a-%H-%M-%S_" else "" --- | Generate C code and use GCC to check that it compiles (no linking)+-- | Generate C code and use CC to check that it compiles (no linking) compileAndCheck' :: (Interp instr CGen (Param2 exp pred), HFunctor instr) =>     ExternalCompilerOpts -> Program instr (Param2 exp pred) a -> IO () compileAndCheck' opts prog = do@@ -168,47 +157,74 @@     exe <- compileC opts' prog     removeFileIfPossible exe --- | Generate C code and use GCC to check that it compiles (no linking)+-- | Generate C code and use CC to check that it compiles (no linking) compileAndCheck :: (Interp instr CGen (Param2 exp pred), HFunctor instr) =>     Program instr (Param2 exp pred) a -> IO ()-compileAndCheck = compileAndCheck' mempty+compileAndCheck = compileAndCheck' def --- | Generate C code, use GCC to compile it, and run the resulting executable+-- | Generate C code, use CC to compile it, and run the resulting executable runCompiled' :: (Interp instr CGen (Param2 exp pred), HFunctor instr) =>     ExternalCompilerOpts -> Program instr (Param2 exp pred) a -> IO ()-runCompiled' opts@(ExternalCompilerOpts {..}) prog = do-    exe <- compileC opts prog-    maybePutStrLn externalSilent ""-    maybePutStrLn externalSilent "#### Running:"-    system exe-    removeFileIfPossible exe-    return ()+runCompiled' opts@(ExternalCompilerOpts {..}) prog = bracket+    (compileC opts prog)+    removeFileIfPossible+    ( \exe -> do+        maybePutStrLn externalSilent ""+        maybePutStrLn externalSilent "#### Running:"+        system exe >> return ()+    ) --- | Generate C code, use GCC to compile it, and run the resulting executable+-- | Generate C code, use CC to compile it, and run the resulting executable runCompiled :: (Interp instr CGen (Param2 exp pred), HFunctor instr) =>     Program instr (Param2 exp pred) a -> IO ()-runCompiled = runCompiled' mempty+runCompiled = runCompiled' def +-- | Compile a program and make it available as an 'IO' function from 'String'+-- to 'String' (connected to @stdin@/@stdout@. respectively). Note that+-- compilation only happens once, even if the 'IO' function is used many times+-- in the body.+withCompiled' :: (Interp instr CGen (Param2 exp pred), HFunctor instr)+    => ExternalCompilerOpts+    -> Program instr (Param2 exp pred) a  -- ^ Program to compile+    -> ((String -> IO String) -> IO b)+         -- ^ Function that has access to the compiled executable as a function+    -> IO b+withCompiled' opts prog body = bracket+    (compileC opts prog)+    removeFileIfPossible+    (\exe -> body $ readProcess exe [])++-- | Compile a program and make it available as an 'IO' function from 'String'+-- to 'String' (connected to @stdin@/@stdout@. respectively). Note that+-- compilation only happens once, even if the 'IO' function is used many times+-- in the body.+withCompiled :: (Interp instr CGen (Param2 exp pred), HFunctor instr)+    => Program instr (Param2 exp pred) a  -- ^ Program to compile+    -> ((String -> IO String) -> IO b)+         -- ^ Function that has access to the compiled executable as a function+    -> IO b+withCompiled = withCompiled' def {externalSilent = True}+ -- | Like 'runCompiled'' but with explicit input/output connected to--- @stdin@/@stdout@+-- @stdin@/@stdout@. Note that the program will be compiled every time the+-- function is applied to a string. In order to compile once and run many times,+-- use the function 'withCompiled''. captureCompiled' :: (Interp instr CGen (Param2 exp pred), HFunctor instr)     => ExternalCompilerOpts     -> Program instr (Param2 exp pred) a  -- ^ Program to run     -> String                             -- ^ Input to send to @stdin@     -> IO String                          -- ^ Result from @stdout@-captureCompiled' opts prog inp = do-    exe <- compileC opts prog-    out <- fakeIO (system exe) inp-    removeFileIfPossible exe-    return out+captureCompiled' opts prog inp = withCompiled' opts prog ($ inp)  -- | Like 'runCompiled' but with explicit input/output connected to--- @stdin@/@stdout@+-- @stdin@/@stdout@. Note that the program will be compiled every time the+-- function is applied to a string. In order to compile once and run many times,+-- use the function 'withCompiled'. captureCompiled :: (Interp instr CGen (Param2 exp pred), HFunctor instr)     => Program instr (Param2 exp pred) a  -- ^ Program to run     -> String                             -- ^ Input to send to @stdin@     -> IO String                          -- ^ Result from @stdout@-captureCompiled = captureCompiled' defaultExtCompilerOpts+captureCompiled = captureCompiled' def  -- | Compare the content written to @stdout@ from the reference program and from -- running the compiled C code@@ -237,5 +253,5 @@     -> IO a                               -- ^ Reference program     -> String                             -- ^ Input to send to @stdin@     -> IO ()-compareCompiled = compareCompiled' defaultExtCompilerOpts+compareCompiled = compareCompiled' def 

@@ -14,19 +14,13 @@ import Data.Monoid #endif -#if MIN_VERSION_syntactic(3,0,0)-import Data.TypeRep hiding (Typeable, gcast)-import Data.TypeRep.TH-import Data.TypeRep.Types.Basic-import Data.TypeRep.Types.Tuple-import Data.TypeRep.Types.IntWord-#endif- import Language.C.Monad import Language.C.Quote.C import Language.C.Syntax (Exp,Type) import qualified Language.C.Syntax as C +import Control.Monad.Operational.Higher+ import Language.Embedded.Expression  @@ -39,16 +33,6 @@     -- | Compilation of expressions     compExp :: MonadC m => exp a -> m Exp -instance ToExp Int8   where toExp = toExp . toInteger-instance ToExp Int16  where toExp = toExp . toInteger-instance ToExp Int32  where toExp = toExp . toInteger-instance ToExp Int64  where toExp = toExp . toInteger-instance ToExp Word8  where toExp = toExp . toInteger-instance ToExp Word16 where toExp = toExp . toInteger-instance ToExp Word32 where toExp = toExp . toInteger-instance ToExp Word64 where toExp = toExp . toInteger-  -- See <https://github.com/mainland/language-c-quote/pull/63>- -- | Types supported by C class (Show a, Eq a, Typeable a) => CType a   where@@ -79,38 +63,32 @@ instance CType Float  where cType _ = return [cty| float |] instance CType Double where cType _ = return [cty| double |] -#if MIN_VERSION_syntactic(3,0,0)-instance ShowClass CType where showClass _ = "CType"--pCType :: Proxy CType-pCType = Proxy--deriveWitness ''CType ''BoolType-deriveWitness ''CType ''FloatType-deriveWitness ''CType ''DoubleType-deriveWitness ''CType ''IntWordType--derivePWitness ''CType ''BoolType-derivePWitness ''CType ''FloatType-derivePWitness ''CType ''DoubleType-derivePWitness ''CType ''IntWordType--instance PWitness CType CharType t-instance PWitness CType ListType t-instance PWitness CType TupleType t-instance PWitness CType FunType t-#endif- -- | Remove one layer of a nested proxy proxyArg :: proxy1 (proxy2 a) -> Proxy a proxyArg _ = Proxy +-- | Classes that support reification to C types+class CompTypeClass ct+  where+    compType :: (ct a, MonadC m) => proxy1 ct -> proxy2 a -> m Type+    compLit  :: (ct a, MonadC m) => proxy ct -> a -> m Exp++instance CompTypeClass CType+  where+    compType _ = cType+    compLit _  = cLit++-- | Get the type predicate from an instruction type+proxyPred :: cmd (Param3 p e pred) a -> Proxy pred+proxyPred _ = Proxy+ -- | Create and declare a fresh variable-freshVar :: forall m a . (MonadC m, CType a) => m (Val a)-freshVar = do+freshVar :: forall m ct proxy a . (MonadC m, CompTypeClass ct, ct a) =>+    proxy ct -> m (Val a)+freshVar ct = do     v <- gensym "v"     touchVar v-    t <- cType (Proxy :: Proxy a)+    t <- compType ct (Proxy :: Proxy a)     case t of       C.Type _ C.Ptr{} _ -> addLocal [cdecl| $ty:t $id:v = NULL; |]       _                  -> addLocal [cdecl| $ty:t $id:v; |]

@@ -21,13 +21,9 @@ #endif import Data.Typeable -#if MIN_VERSION_syntactic(3,0,0) import Language.Syntactic import Language.Syntactic.Functional (Denotation) import Language.Syntactic.TH-#else-import Language.Syntactic-#endif  import Language.C.Quote.C import Language.C.Syntax (Type, UnOp (..), BinOp (..), Exp (UnOp, BinOp))@@ -106,21 +102,18 @@ binaryOp BiLe   = Le binaryOp BiGe   = Ge -type SupportCode = forall m . MonadC m => m ()- -- | Syntactic symbols for C data Sym sig   where     -- Literal     Lit   :: String -> a -> Sym (Full a)     -- Predefined constant-    Const :: SupportCode -> String -> a -> Sym (Full a)+    Const :: String -> a -> Sym (Full a)+      -- The difference between `Lit` and `Const` is that the latter gets turned+      -- into a variable in the C code. It is like `Var`, except that it can+      -- also be evaluated.     -- Function call-    Fun   ::-#if MIN_VERSION_syntactic(3,0,0)-             Signature sig =>-#endif-             SupportCode -> String -> Denotation sig -> Sym sig+    Fun   :: Signature sig => String -> Denotation sig -> Sym sig     -- Unary operator     UOp   :: Unary (a -> b) -> Sym (a :-> Full b)     -- Binary operator@@ -133,7 +126,13 @@     Var   :: VarId -> Sym (Full a)     -- Unsafe array indexing     ArrIx :: (Integral i, Ix i) => IArr i a -> Sym (i :-> Full a)+    -- Attach extra code to an expression+    WithCode :: SupportCode -> Sym (a :-> Full a) +type SupportCode = forall m . MonadC m => m ()+  -- Only needed because GHC 7.8 can't represent tuple constraints (like+  -- `MonadC`) in Template Haskell.+ data T sig   where     T :: CType (DenResult sig) => { unT :: Sym sig } -> T sig@@ -149,14 +148,14 @@     sugar   = CExp  evalSym :: Sym sig -> Denotation sig-evalSym (Lit _ a)     = a-evalSym (Const _ _ a) = a-evalSym (Fun _ _ f)   = f-evalSym (UOp uop)     = evalUnary uop-evalSym (Op bop)      = evalBinary bop-evalSym (Cast f)      = f-evalSym Cond          = \c t f -> if c then t else f-evalSym (ArrIx (IArrEval arr)) = \i ->+evalSym (Lit _ a)   = a+evalSym (Const _ a) = a+evalSym (Fun _ f)   = f+evalSym (UOp uop)   = evalUnary uop+evalSym (Op bop)    = evalBinary bop+evalSym (Cast f)    = f+evalSym Cond        = \c t f -> if c then t else f+evalSym (ArrIx (IArrRun arr)) = \i ->     if i<l || i>h       then error $ "index "                 ++ show (toInteger i)@@ -165,6 +164,7 @@       else arr!i   where     (l,h) = bounds arr+evalSym (WithCode _) = id evalSym (Var v) = error $ "evalCExp: cannot evaluate variable " ++ v  -- | Evaluate an expression@@ -177,8 +177,8 @@  instance FreeExp CExp   where-    type VarPred CExp = CType-    valExp a = CExp $ Sym $ T $ Lit (show a) a+    type FreePred CExp = CType+    constExp a = CExp $ Sym $ T $ Lit (show a) a     varExp = CExp . Sym . T . Var  instance EvalExp CExp where evalExp = evalCExp@@ -197,12 +197,10 @@     go :: CType (DenResult sig) => Sym sig -> Args (AST T) sig -> m Exp     go (Var v) Nil   = touchVar v >> return [cexp| $id:v |]     go (Lit _ a) Nil = cLit a-    go (Const code const _) Nil = do-      code+    go (Const const _) Nil = do       touchVar const       return [cexp| $id:const |]-    go (Fun code fun _) args = do-      code+    go (Fun fun _) args = do       as <- sequence $ listArgs compCExp' args       return [cexp| $id:fun($args:as) |]     go (UOp uop) (a :* Nil) = do@@ -233,6 +231,7 @@       i' <- compCExp' i       touchVar arr       return [cexp| $id:arr[$i'] |]+    go (WithCode code) (a :* Nil) = code >> compCExp' a  instance CompExp CExp where compExp = compCExp @@ -298,19 +297,21 @@  -- | Predefined constant constant :: CType a-    => SupportCode  -- ^ Supporting C code-    -> String       -- ^ Name of constant-    -> a            -- ^ Value of constant+    => String  -- ^ Name of constant+    -> a       -- ^ Value of constant     -> CExp a-constant code const val = CExp $ Sym $ T $ Const code const val+constant const val = CExp $ Sym $ T $ Const const val  -- | Create a named variable variable :: CType a => VarId -> CExp a variable = CExp . Sym . T . Var +withCode :: CType a => (forall m . MonadC m => m ()) -> CExp a -> CExp a+withCode code = CExp . smartSym' (T $ WithCode code) . unCExp+ true, false :: CExp Bool-true  = constant (addInclude "<stdbool.h>") "true" True-false = constant (addInclude "<stdbool.h>") "false" False+true  = withCode (addInclude "<stdbool.h>") $ constant "true" True+false = withCode (addInclude "<stdbool.h>") $ constant "false" False  instance (Num a, Ord a, CType a) => Num (CExp a)   where@@ -358,17 +359,6 @@      recip = error "recip not implemented for CExp" -instance (Floating a, Ord a, CType a) => Floating (CExp a)-  where-    pi = constant (addGlobal pi_def) "EDSL_PI" pi-      where-        pi_def = [cedecl|$esc:("#define EDSL_PI 3.141592653589793")|]-          -- This is the value of `pi :: Double`.-          -- Apparently there is no standard C99 definition of pi.-    a ** b = constFold $ sugarSym (T $ Fun (addInclude "<math.h>") "pow" (**)) a b-    sin a  = constFold $ sugarSym (T $ Fun (addInclude "<math.h>") "sin" sin) a-    cos a  = constFold $ sugarSym (T $ Fun (addInclude "<math.h>") "cos" cos) a- -- | Integer division truncated toward zero quot_ :: (Integral a, CType a) => CExp a -> CExp a -> CExp a quot_ (LitP 0) b = 0@@ -386,9 +376,6 @@ a      #% b | a == b = 0 a      #% b          = constFold $ sugarSym (T $ Op BiRem) a b -round_ :: (RealFrac a, Integral b, CType b) => CExp a -> CExp b-round_ = constFold . sugarSym (T $ Fun (addInclude "<math.h>") "lround" round)- -- | Integral type casting i2n :: (Integral a, Num b, CType b) => CExp a -> CExp b i2n a = constFold $ sugarSym (T $ Cast (fromInteger . toInteger)) a@@ -499,23 +486,20 @@ -- Instances -------------------------------------------------------------------------------- -#if MIN_VERSION_syntactic(3,0,0) deriveSymbol ''Sym-#endif  instance Render Sym   where-    renderSym (Lit a _)      = a-    renderSym (Const _ a _)  = a-    renderSym (Fun _ name _) = name-    renderSym (UOp op)       = show $ unaryOp op-    renderSym (Op op)        = show $ binaryOp op-    renderSym (Cast _)       = "cast"-    renderSym (Var v)        = v+    renderSym (Lit a _)    = a+    renderSym (Const a _)  = a+    renderSym (Fun name _) = name+    renderSym (UOp op)     = show $ unaryOp op+    renderSym (Op op)      = show $ binaryOp op+    renderSym (Cast _)     = "cast"+    renderSym (Var v)      = v     renderSym (ArrIx (IArrComp arr)) = "ArrIx " ++ arr     renderSym (ArrIx _)              = "ArrIx ..."--#if MIN_VERSION_syntactic(3,0,0)+    renderSym (WithCode _) = "WithCode ..."      renderArgs = renderArgsSmart @@ -541,28 +525,6 @@ instance StringTree T   where     stringTreeSym as (T s) = stringTreeSym as s--#else--instance Semantic Sym-  where-    semantics s = Sem (renderSym s) (evalSym s)--instance Equality Sym-  where-    equal    = equalDefault-    exprHash = exprHashDefault--instance Semantic T-  where-    semantics (T s) = semantics s--instance Equality T-  where-    equal (T s) (T t) = equal s t-    exprHash (T s)    = exprHash s--#endif  deriving instance Eq (CExp a)   -- Must be placed here due to the sequential dependencies introduced by

@@ -1,20 +1,38 @@ -- | Basic concurrency primitives.-module Language.Embedded.Concurrent (-    ThreadId (..),-    ChanBound, Chan (..),-    ThreadCMD,-    ChanCMD,-    Closeable, Uncloseable,-    fork, forkWithId, asyncKillThread, killThread, waitThread,-    newChan, newCloseableChan, readChan, writeChan,-    closeChan, lastChanReadOK,+--+-- To compile the C code resulting from 'Language.Embedded.Backend.C.compile'+-- for programs with concurrency primitives, use something like+--+-- > cc -std=c99 -Iinclude csrc/chan.c -lpthread YOURPROGRAM.c+module Language.Embedded.Concurrent+  ( ThreadId (..)+  , Chan (..)+  , ChanSize (..)+  , ThreadCMD+  , ChanCMD+  , Closeable, Uncloseable+  , fork, forkWithId, asyncKillThread, killThread, waitThread, delayThread+  , timesSizeOf, timesSize, plusSize+  , newChan, newCloseableChan+  , readChan, writeChan+  , readChanBuf, writeChanBuf+  , closeChan, lastChanReadOK+  , newChan', newCloseableChan'+  , readChan', writeChan'+  , readChanBuf', writeChanBuf'   ) where  import Control.Monad.Operational.Higher-import Language.Embedded.Expression-import Language.Embedded.Concurrent.CMD+import Data.Ix+import Data.Typeable+ import Language.Embedded.Concurrent.Backend.C ()+import Language.Embedded.Concurrent.CMD+import Language.Embedded.Expression+import Language.Embedded.Imperative.CMD (Arr) ++ -- | Fork off a computation as a new thread. fork :: (ThreadCMD :<: instr)      => ProgramT instr (Param2 exp pred) m ()@@ -44,50 +62,95 @@            => ThreadId -> ProgramT instr (Param2 exp pred) m () waitThread = singleton . inj . Wait --- | Create a new channel. Writing a reference type to a channel will copy the---   /reference/ into the queue, not its contents.------   We'll likely want to change this, actually copying arrays and the like---   into the queue instead of sharing them across threads.-newChan :: (pred a, ChanCMD :<: instr)-        => exp ChanBound+-- | Sleep for a given amount of microseconds. Implemented with `usleep`.+--   A C compiler might require a feature test macro to be defined,+--   otherwise it emits a warning about an implicitly declared function.+--   For more details, see: http://man7.org/linux/man-pages/man3/usleep.3.html+delayThread :: (Integral i, ThreadCMD :<: instr)+           => exp i -> ProgramT instr (Param2 exp pred) m ()+delayThread = singleton . inj . Sleep+++--------------------------------------------------------------------------------+-- Channel frontend+--------------------------------------------------------------------------------++-- | Create a new channel. Writing a reference type to a channel will copy+--   contents into the channel, so modifying it post-write is completely+--   safe.+newChan :: forall a i exp pred instr m+        .  (pred a, Integral i, ChanCMD :<: instr)+        => exp i         -> ProgramT instr (Param2 exp pred) m (Chan Uncloseable a)-newChan = singleInj . NewChan+newChan n = newChan' $ n `timesSizeOf` (Proxy :: Proxy a) -newCloseableChan :: (pred a, ChanCMD :<: instr)-        => exp ChanBound-        -> ProgramT instr (Param2 exp pred) m (Chan Closeable a)-newCloseableChan = singleInj . NewChan+newCloseableChan :: forall a i exp pred instr m+                 .  (pred a, Integral i, ChanCMD :<: instr)+                 => exp i+                 -> ProgramT instr (Param2 exp pred) m (Chan Closeable a)+newCloseableChan n = newCloseableChan' $ n `timesSizeOf` (Proxy :: Proxy a) + -- | Read an element from a channel. If channel is empty, blocks until there --   is an item available. --   If 'closeChan' has been called on the channel *and* if the channel is --   empty, @readChan@ returns an undefined value immediately.-readChan :: (pred a, FreeExp exp, VarPred exp a, ChanCMD :<: instr, Monad m)+readChan :: ( Typeable a, pred a+            , FreeExp exp, FreePred exp a+            , ChanCMD :<: instr, Monad m )          => Chan t a          -> ProgramT instr (Param2 exp pred) m (exp a)-readChan = fmap valToExp . singleInj . ReadChan+readChan = readChan' +-- | Read an arbitrary number of elements from a channel into an array.+--   The semantics are the same as for 'readChan', where "channel is empty"+--   is defined as "channel contains less data than requested".+--   Returns @False@ without reading any data if the channel is closed.+readChanBuf :: ( Typeable a, pred a+               , Ix i, Integral i+               , FreeExp exp, FreePred exp Bool+               , ChanCMD :<: instr, Monad m )+            => Chan t a+            -> exp i -- ^ Offset in array to start writing+            -> exp i -- ^ Elements to read+            -> Arr i a+            -> ProgramT instr (Param2 exp pred) m (exp Bool)+readChanBuf = readChanBuf'+ -- | Write a data element to a channel. --   If 'closeChan' has been called on the channel, all calls to @writeChan@ --   become non-blocking no-ops and return @False@, otherwise returns @True@.-writeChan :: (pred a,-              FreeExp exp,-              VarPred exp Bool,-              ChanCMD :<: instr,-              Monad m-             )-        => Chan t a-        -> exp a-        -> ProgramT instr (Param2 exp pred) m (exp Bool)-writeChan c = fmap valToExp . singleInj . WriteChan c+--   If the channel is full, this function blocks until there's space in the+--   queue.+writeChan :: ( Typeable a, pred a+             , FreeExp exp, FreePred exp Bool+             , ChanCMD :<: instr, Monad m )+          => Chan t a+          -> exp a+          -> ProgramT instr (Param2 exp pred) m (exp Bool)+writeChan = writeChan' +-- | Write an arbitrary number of elements from an array into an channel.+--   The semantics are the same as for 'writeChan', where "channel is full"+--   is defined as "channel has insufficient free space to store all written+--   data".+writeChanBuf :: ( Typeable a, pred a+                , Ix i, Integral i+                , FreeExp exp, FreePred exp Bool+                , ChanCMD :<: instr, Monad m )+             => Chan t a+             -> exp i -- ^ Offset in array to start reading+             -> exp i -- ^ Elements to write+             -> Arr i a+             -> ProgramT instr (Param2 exp pred) m (exp Bool)+writeChanBuf = writeChanBuf'+ -- | When 'readChan' was last called on the given channel, did the read --   succeed? --   Always returns @True@ unless 'closeChan' has been called on the channel. --   Always returns @True@ if the channel has never been read.-lastChanReadOK :: (FreeExp exp, VarPred exp Bool, ChanCMD :<: instr, Monad m)-               => Chan Closeable a+lastChanReadOK :: (FreeExp exp, FreePred exp Bool, ChanCMD :<: instr, Monad m)+               => Chan Closeable c                -> ProgramT instr (Param2 exp pred) m (exp Bool) lastChanReadOK = fmap valToExp . singleInj . ReadOK @@ -95,7 +158,58 @@ --   After the channel is drained, all subsequent read operations will be --   no-ops as well. closeChan :: (ChanCMD :<: instr)-          => Chan Closeable a+          => Chan Closeable c           -> ProgramT instr (Param2 exp pred) m () closeChan = singleInj . CloseChan ++--------------------------------------------------------------------------------+-- Unsafe channel primitives+--------------------------------------------------------------------------------++newChan' :: (Integral i, ChanCMD :<: instr)+         => ChanSize exp pred i+         -> ProgramT instr (Param2 exp pred) m (Chan Uncloseable a)+newChan' = singleInj . NewChan++newCloseableChan' :: (Integral i, ChanCMD :<: instr)+                  => ChanSize exp pred i+                  -> ProgramT instr (Param2 exp pred) m (Chan Closeable a)+newCloseableChan' = singleInj . NewChan++readChan' :: ( Typeable a, pred a+             , FreeExp exp, FreePred exp a+             , ChanCMD :<: instr, Monad m )+          => Chan t c+          -> ProgramT instr (Param2 exp pred) m (exp a)+readChan' = fmap valToExp . singleInj . ReadOne++readChanBuf' :: ( Typeable a, pred a+                , Ix i, Integral i+                , FreeExp exp, FreePred exp Bool+                , ChanCMD :<: instr, Monad m )+             => Chan t c+             -> exp i -- ^ Offset in array to start writing+             -> exp i -- ^ Elements to read+             -> Arr i a+             -> ProgramT instr (Param2 exp pred) m (exp Bool)+readChanBuf' ch off sz arr = fmap valToExp . singleInj $ ReadChan ch off sz arr++writeChan' :: ( Typeable a, pred a+              , FreeExp exp, FreePred exp Bool+              , ChanCMD :<: instr, Monad m )+           => Chan t c+           -> exp a+           -> ProgramT instr (Param2 exp pred) m (exp Bool)+writeChan' c = fmap valToExp . singleInj . WriteOne c++writeChanBuf' :: ( Typeable a, pred a+                 , Ix i, Integral i+                 , FreeExp exp, FreePred exp Bool+                 , ChanCMD :<: instr, Monad m )+              => Chan t c+              -> exp i -- ^ Offset in array to start reading+              -> exp i -- ^ Elements to write+              -> Arr i a+              -> ProgramT instr (Param2 exp pred) m (exp Bool)+writeChanBuf' ch off sz arr = fmap valToExp . singleInj $ WriteChan ch off sz arr

@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE UndecidableInstances #-}  module Language.Embedded.Concurrent.Backend.C where @@ -9,8 +10,10 @@ import Control.Applicative #endif import Control.Monad.Operational.Higher+import Data.Typeable import Language.Embedded.Expression import Language.Embedded.Concurrent.CMD+import Language.Embedded.Imperative.CMD import Language.Embedded.Backend.C.Expression import Language.C.Quote.C import Language.C.Monad@@ -29,7 +32,7 @@  -- | Compile `ThreadCMD`. --   TODO: sharing for threads with the same body-compThreadCMD :: ThreadCMD (Param3 CGen exp pred) a -> CGen a+compThreadCMD :: CompExp exp => ThreadCMD (Param3 CGen exp pred) a -> CGen a compThreadCMD (ForkWithId body) = do   tid <- TIDComp <$> gensym "t"   let funName = threadFun tid@@ -48,39 +51,68 @@ compThreadCMD (Wait tid) = do   touchVar tid   addStm [cstm| pthread_join($id:tid, NULL); |]+compThreadCMD (Sleep us) = do+  us' <- compExp us+  addSystemInclude "unistd.h"+  addStm [cstm| usleep($us'); |]  -- | Compile `ChanCMD`.-compChanCMD :: CompExp exp-            => ChanCMD (Param3 CGen exp CType) a+compChanCMD :: (CompExp exp, CompTypeClass ct, ct Bool)+            => ChanCMD (Param3 CGen exp ct) a             -> CGen a compChanCMD cmd@(NewChan sz) = do   addLocalInclude "chan.h"-  t <- cType (proxyArg cmd)-  sz' <- compExp sz+  sz' <-compChanSize sz   c <- ChanComp <$> gensym "chan"   addGlobal [cedecl| typename chan_t $id:c; |]-  addStm [cstm| $id:c = chan_new(sizeof($ty:t), $sz'); |]+  addStm [cstm| $id:c = chan_new($sz'); |]   return c-compChanCMD (WriteChan c (x :: exp a)) = do+compChanCMD cmd@(WriteOne c (x :: exp a)) = do   x'         <- compExp x-  v :: Val a <- freshVar-  ok         <- freshVar+  v :: Val a <- freshVar (proxyPred cmd)+  ok         <- freshVar (proxyPred cmd)   addStm [cstm| $id:v = $x'; |]-  addStm [cstm| $id:ok = chan_write($id:c, &$id:v); |]+  addStm [cstm| $id:ok = chan_write($id:c, sizeof($id:v), &$id:v); |]   return ok-compChanCMD (ReadChan c) = do-  var <- freshVar-  addStm [cstm| chan_read($id:c, &$id:var); |]-  return var+compChanCMD cmd@(WriteChan c from to (ArrComp arr)) = do+  from' <- compExp from+  to' <- compExp to+  ok <- freshVar (proxyPred cmd)+  addStm [cstm| $id:ok = chan_write($id:c, sizeof(*$id:arr)*(($to')-($from')), &$id:arr[$from']); |]+  return ok+compChanCMD cmd@(ReadOne c) = do+  v <- freshVar (proxyPred cmd)+  addStm [cstm| chan_read($id:c, sizeof($id:v), &$id:v); |]+  return v+compChanCMD cmd@(ReadChan c from to (ArrComp arr)) = do+  ok <- freshVar (proxyPred cmd)+  from' <- compExp from+  to' <- compExp to+  addStm [cstm| chan_read($id:c, sizeof(*$id:arr)*(($to')-($from')), &$id:arr[$from']); |]+  addStm [cstm| $id:ok = chan_last_read_ok($id:c); |]+  return ok compChanCMD (CloseChan c) = do   addStm [cstm| chan_close($id:c); |]-compChanCMD (ReadOK c) = do-  var <- freshVar+compChanCMD cmd@(ReadOK c) = do+  var <- freshVar (proxyPred cmd)   addStm [cstm| $id:var = chan_last_read_ok($id:c); |]   return var -instance Interp ThreadCMD CGen (Param2 exp pred) where+compChanSize :: forall exp ct i. (CompExp exp, CompTypeClass ct) => ChanSize exp ct i -> CGen C.Exp+compChanSize (OneSize t sz) = do+  t' <- compType (Proxy :: Proxy ct) t+  sz' <- compExp sz+  return [cexp| $sz' * sizeof($ty:t') |]+compChanSize (TimesSize n sz) = do+  n' <- compExp n+  sz' <- compChanSize sz+  return [cexp| $n' * $sz' |]+compChanSize (PlusSize a b) = do+  a' <- compChanSize a+  b' <- compChanSize b+  return [cexp| $a' + $b' |]++instance CompExp exp => Interp ThreadCMD CGen (Param2 exp pred) where   interp = compThreadCMD-instance CompExp exp => Interp ChanCMD CGen (Param2 exp CType) where+instance (CompExp exp, CompTypeClass ct, ct Bool) => Interp ChanCMD CGen (Param2 exp ct) where   interp = compChanCMD-

@@ -1,9 +1,12 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE UndecidableInstances #-}  module Language.Embedded.Concurrent.CMD (     TID, ThreadId (..),-    CID, ChanBound, Chan (..),+    CID, Chan (..),+    ChanSize (..),+    timesSizeOf, timesSize, plusSize,     ThreadCMD (..),     ChanCMD (..),     Closeable, Uncloseable@@ -13,21 +16,23 @@  #if __GLASGOW_HASKELL__ < 710 import Control.Applicative+import Data.Typeable #endif+import qualified Control.Chan as Chan+import qualified Control.Concurrent as CC import Control.Monad.Operational.Higher import Control.Monad.Reader+import Data.Dynamic import Data.IORef-import Data.Typeable+import Data.Ix (Ix)+import Data.Maybe (fromMaybe)+ import Language.Embedded.Expression-import qualified Control.Concurrent as CC-import qualified Control.Concurrent.BoundedChan as Bounded-import Data.Word (Word16)+import Language.Embedded.Imperative.CMD+import Language.Embedded.Imperative (getArr, setArr)   --- | Maximum number of elements in some bounded channel.-type ChanBound = Word16- type TID = VarId type CID = VarId @@ -56,119 +61,202 @@ waitFlag (Flag _ var) = CC.withMVar var return  data ThreadId-  = TIDEval CC.ThreadId (Flag ())+  = TIDRun CC.ThreadId (Flag ())   | TIDComp TID     deriving (Typeable)  instance Show ThreadId where-  show (TIDEval tid _) = show tid-  show (TIDComp tid)   = tid+  show (TIDRun tid _) = show tid+  show (TIDComp tid)  = tid  data Closeable data Uncloseable  -- | A bounded channel. data Chan t a-  = ChanEval (Bounded.BoundedChan a) (IORef Bool) (IORef Bool)+  = ChanRun (Chan.Chan Dynamic)   | ChanComp CID +-- | Channel size specification. For each possible element type, it shows how+--   many elements of them could be stored in the given channel at once.+data ChanSize exp pred i where+  OneSize   :: (pred a, Integral i) => proxy a -> exp i -> ChanSize exp pred i+  TimesSize :: Integral i => exp i -> ChanSize exp pred i -> ChanSize exp pred i+  PlusSize  :: Integral i => ChanSize exp pred i -> ChanSize exp pred i -> ChanSize exp pred i++mapSizeExp :: (exp i -> exp' i) -> ChanSize exp pred i -> ChanSize exp' pred i+mapSizeExp f (OneSize t sz) = OneSize t (f sz)+mapSizeExp f (TimesSize n sz) = TimesSize (f n) (mapSizeExp f sz)+mapSizeExp f (PlusSize a b) = PlusSize (mapSizeExp f a) (mapSizeExp f b)++mapSizeExpA :: (Functor m, Monad m)+            => (exp i -> m (exp' i))+            -> ChanSize exp pred i+            -> m (ChanSize exp' pred i)+mapSizeExpA f (OneSize t sz) = OneSize t <$> f sz+mapSizeExpA f (TimesSize n sz) = do+  n' <- f n+  sz' <- mapSizeExpA f sz+  return $ TimesSize n' sz'+mapSizeExpA f (PlusSize a b) = do+  a' <- mapSizeExpA f a+  b' <- mapSizeExpA f b+  return $ PlusSize a' b'++-- | Takes 'n' times the size of type refered by proxy.+timesSizeOf :: (pred a, Integral i) => exp i -> proxy a -> ChanSize exp pred i+timesSizeOf = flip OneSize++-- | Multiplies a channel size specification with a scalar.+timesSize :: Integral i => exp i -> ChanSize exp pred i -> ChanSize exp pred i+timesSize = TimesSize++-- | Adds two channel size specifications together.+plusSize :: Integral i => ChanSize exp pred i -> ChanSize exp pred i -> ChanSize exp pred i+plusSize = PlusSize+ data ThreadCMD fs a where   ForkWithId :: (ThreadId -> prog ()) -> ThreadCMD (Param3 prog exp pred) ThreadId   Kill       :: ThreadId -> ThreadCMD (Param3 prog exp pred) ()   Wait       :: ThreadId -> ThreadCMD (Param3 prog exp pred) ()+  Sleep      :: Integral i => exp i -> ThreadCMD (Param3 prog exp pred) ()  data ChanCMD fs a where-  NewChan   :: pred a => exp ChanBound -> ChanCMD (Param3 prog exp pred) (Chan t a)-  ReadChan  :: pred a => Chan t a -> ChanCMD (Param3 prog exp pred) (Val a)-  WriteChan :: pred a-            => Chan t a -> exp a -> ChanCMD (Param3 prog exp pred) (Val Bool)-  CloseChan :: Chan Closeable a -> ChanCMD (Param3 prog exp pred) ()-  ReadOK    :: Chan Closeable a -> ChanCMD (Param3 prog exp pred) (Val Bool)+  NewChan   :: ChanSize exp pred i -> ChanCMD (Param3 prog exp pred) (Chan t c)+  CloseChan :: Chan Closeable c -> ChanCMD (Param3 prog exp pred) ()+  ReadOK    :: Chan Closeable c -> ChanCMD (Param3 prog exp pred) (Val Bool) +  ReadOne   :: (Typeable a, pred a)+            => Chan t c -> ChanCMD (Param3 prog exp pred) (Val a)+  WriteOne  :: (Typeable a, pred a)+            => Chan t c -> exp a -> ChanCMD (Param3 prog exp pred) (Val Bool)++  ReadChan  :: (Typeable a, pred a, Ix i, Integral i)+            => Chan t c -> exp i -> exp i+            -> Arr i a -> ChanCMD (Param3 prog exp pred) (Val Bool)+  WriteChan :: (Typeable a, pred a, Ix i, Integral i)+            => Chan t c -> exp i -> exp i+            -> Arr i a -> ChanCMD (Param3 prog exp pred) (Val Bool)+ instance HFunctor ThreadCMD where   hfmap f (ForkWithId p) = ForkWithId $ f . p   hfmap _ (Kill tid)     = Kill tid   hfmap _ (Wait tid)     = Wait tid+  hfmap _ (Sleep tid)    = Sleep tid  instance HBifunctor ThreadCMD where   hbimap f _ (ForkWithId p) = ForkWithId $ f . p   hbimap _ _ (Kill tid)     = Kill tid   hbimap _ _ (Wait tid)     = Wait tid+  hbimap _ g (Sleep us)     = Sleep $ g us -instance (ThreadCMD :<: instr) => Reexpressible ThreadCMD instr where+instance (ThreadCMD :<: instr) => Reexpressible ThreadCMD instr env where   reexpressInstrEnv reexp (ForkWithId p) = ReaderT $ \env ->       singleInj $ ForkWithId (flip runReaderT env . p)   reexpressInstrEnv reexp (Kill tid) = lift $ singleInj $ Kill tid   reexpressInstrEnv reexp (Wait tid) = lift $ singleInj $ Wait tid+  reexpressInstrEnv reexp (Sleep us) = (lift . singleInj . Sleep) =<< reexp us  instance HFunctor ChanCMD where-  hfmap _ (NewChan sz)    = NewChan sz-  hfmap _ (ReadChan c)    = ReadChan c-  hfmap _ (WriteChan c x) = WriteChan c x-  hfmap _ (CloseChan c)   = CloseChan c-  hfmap _ (ReadOK c)      = ReadOK c+  hfmap _ (NewChan sz)        = NewChan sz+  hfmap _ (ReadOne c)         = ReadOne c+  hfmap _ (ReadChan c f t a)  = ReadChan c f t a+  hfmap _ (WriteOne c x)      = WriteOne c x+  hfmap _ (WriteChan c f t a) = WriteChan c f t a+  hfmap _ (CloseChan c)       = CloseChan c+  hfmap _ (ReadOK c)          = ReadOK c  instance HBifunctor ChanCMD where-  hbimap _ f (NewChan sz)    = NewChan (f sz)-  hbimap _ _ (ReadChan c)    = ReadChan c-  hbimap _ f (WriteChan c x) = WriteChan c (f x)-  hbimap _ _ (CloseChan c)   = CloseChan c-  hbimap _ _ (ReadOK c)      = ReadOK c+  hbimap _ f (NewChan sz)         = NewChan (mapSizeExp f sz)+  hbimap _ _ (ReadOne c)          = ReadOne c+  hbimap _ f (ReadChan c n n' a)  = ReadChan c (f n) (f n') a+  hbimap _ f (WriteOne c x)       = WriteOne c (f x)+  hbimap _ f (WriteChan c n n' a) = WriteChan c (f n) (f n') a+  hbimap _ _ (CloseChan c    )    = CloseChan c+  hbimap _ _ (ReadOK c)           = ReadOK c -instance (ChanCMD :<: instr) => Reexpressible ChanCMD instr where-  reexpressInstrEnv reexp (NewChan sz)    = lift . singleInj . NewChan =<< reexp sz-  reexpressInstrEnv reexp (ReadChan c)    = lift $ singleInj $ ReadChan c-  reexpressInstrEnv reexp (WriteChan c x) = lift . singleInj . WriteChan c =<< reexp x+instance (ChanCMD :<: instr) => Reexpressible ChanCMD instr env where+  reexpressInstrEnv reexp (NewChan sz) =+      lift . singleInj . NewChan =<< mapSizeExpA reexp sz+  reexpressInstrEnv reexp (ReadOne c) = lift $ singleInj $ ReadOne c+  reexpressInstrEnv reexp (ReadChan c f t a) = do+      rf <- reexp f+      rt <- reexp t+      lift $ singleInj $ ReadChan c rf rt a+  reexpressInstrEnv reexp (WriteOne c x)  = lift . singleInj . WriteOne c =<< reexp x+  reexpressInstrEnv reexp (WriteChan c f t a) = do+      rf <- reexp f+      rt <- reexp t+      lift $ singleInj $ WriteChan c rf rt a   reexpressInstrEnv reexp (CloseChan c)   = lift $ singleInj $ CloseChan c   reexpressInstrEnv reexp (ReadOK c)      = lift $ singleInj $ ReadOK c -runThreadCMD :: ThreadCMD (Param3 IO exp pred) a-             -> IO a+runThreadCMD :: ThreadCMD (Param3 IO IO pred) a -> IO a runThreadCMD (ForkWithId p) = do   f <- newFlag   tidvar <- CC.newEmptyMVar   cctid <- CC.forkIO . void $ CC.takeMVar tidvar >>= p >> setFlag f ()-  let tid = TIDEval cctid f+  let tid = TIDRun cctid f   CC.putMVar tidvar tid   return tid-runThreadCMD (Kill (TIDEval t f)) = do+runThreadCMD (Kill (TIDRun t f)) = do   setFlag f ()   CC.killThread t   return ()-runThreadCMD (Wait (TIDEval _ f)) = do+runThreadCMD (Wait (TIDRun _ f)) = do   waitFlag f+runThreadCMD (Sleep us) = do+  us' <- us+  CC.threadDelay $ fromIntegral us' -runChanCMD :: ChanCMD (Param3 IO IO pred) a -> IO a+runChanCMD :: forall pred a. ChanCMD (Param3 IO IO pred) a -> IO a runChanCMD (NewChan sz) = do-  sz' <- sz-  ChanEval <$> Bounded.newBoundedChan (fromIntegral sz')-           <*> newIORef False-           <*> newIORef True-runChanCMD (ReadChan (ChanEval c closedref lastread)) = do-  closed <- readIORef closedref-  mval <- Bounded.tryReadChan c-  case mval of-    Just x -> do-        return $ ValEval x-    Nothing-      | closed -> do-        writeIORef lastread False-        return undefined-      | otherwise -> do-        ValEval <$> Bounded.readChan c-runChanCMD (WriteChan (ChanEval c closedref _) x) = do-  closed <- readIORef closedref-  x' <- x-  if closed-    then return (ValEval False)-    else Bounded.writeChan c x' >> return (ValEval True)-runChanCMD (CloseChan (ChanEval _ closedref _)) = do-  writeIORef closedref True-runChanCMD (ReadOK (ChanEval _ _ lastread)) = do-  ValEval <$> readIORef lastread+  sz' <- evalChanSize sz+  ChanRun <$> Chan.newChan sz'+runChanCMD (ReadOne (ChanRun c)) =+  ValRun . convertDynamic . head <$> Chan.readChan c 1+runChanCMD (ReadChan (ChanRun c) off len arr) = do+  off' <- off+  len' <- len+  xs <- Chan.readChan c $ fromIntegral (len' - off')+  let xs' = map convertDynamic xs+  interpretBi id $ forM_ (zip [off' .. ] xs') $ \(i, x) -> do+    setArr (return i) (return x) arr :: Program ArrCMD (Param2 IO pred) ()+  ValRun <$> Chan.lastReadOK c+runChanCMD (WriteOne (ChanRun c) x) =+  ValRun <$> (Chan.writeChan c . return . toDyn =<< x)+runChanCMD (WriteChan (ChanRun c) off len (arr :: Arr ix el)) = do+  off' <- off+  len' <- len+  xs <- interpretBi id $ forM [off' .. off' + len' - 1] $ \i -> do+    getArr (return i) arr :: Program ArrCMD (Param2 IO pred) (IO el)+  ValRun <$> (Chan.writeChan c =<< map toDyn <$> sequence xs)+runChanCMD (CloseChan (ChanRun c)) = Chan.closeChan c+runChanCMD (ReadOK    (ChanRun c)) = ValRun <$> Chan.lastReadOK c  instance InterpBi ThreadCMD IO (Param1 pred) where   interpBi = runThreadCMD instance InterpBi ChanCMD IO (Param1 pred) where   interpBi = runChanCMD +evalChanSize :: ChanSize IO pred i -> IO Int+evalChanSize (OneSize _ sz) = do+  sz' <- sz+  return $ fromIntegral sz'+evalChanSize (TimesSize n sz) = do+  n' <- n+  sz' <- evalChanSize sz+  return $ fromIntegral n' * sz'+evalChanSize (PlusSize a b) = do+  a' <- evalChanSize a+  b' <- evalChanSize b+  return $ a' + b'++convertDynamic :: Typeable a => Dynamic -> a+convertDynamic = fromMaybe (error "readChan: unknown element") . fromDynamic++instance FreeExp IO+  where+    type FreePred IO = Typeable+    constExp = return+    varExp   = error "varExp: unimplemented over IO"

@@ -8,7 +8,11 @@  import Data.Typeable +#if __GLASGOW_HASKELL__ >= 800+import GHC.Types (Constraint)+#else import GHC.Prim (Constraint)+#endif  import Language.C.Quote.C (ToIdent (..)) @@ -17,36 +21,37 @@ -- | Variable identifier type VarId = String --- | Expressions that support injection of values and named variables+-- | Expressions that support injection of constants and named variables class FreeExp exp   where-    -- | Constraint on the types of values and variables in an expression+    -- | Constraint on the types of constants and variables in an expression     -- language-    type VarPred exp :: * -> Constraint+    type FreePred exp :: * -> Constraint -    -- | Construct a value expression-    valExp :: VarPred exp a => a -> exp a+    -- | Inject a constant value+    constExp :: FreePred exp a => a -> exp a -    -- | Construct a named variable expression-    varExp :: VarPred exp a => VarId -> exp a+    -- | Inject a named variable+    varExp :: FreePred exp a => VarId -> exp a  -- | Value data Val a     = ValComp VarId  -- ^ Symbolic value-    | ValEval a      -- ^ Concrete value+    | ValRun a       -- ^ Concrete value   deriving Typeable  instance ToIdent (Val a) where toIdent (ValComp r) = toIdent r  -- | Convert a value to an expression-valToExp :: (VarPred exp a, FreeExp exp) => Val a -> exp a+valToExp :: (FreeExp exp, FreePred exp a) => Val a -> exp a valToExp (ValComp v) = varExp v-valToExp (ValEval a) = valExp a+valToExp (ValRun a)  = constExp a  -- | Expressions that support evaluation class FreeExp exp => EvalExp exp     -- The super class is motivated by the fact that evaluation of functions-    -- `exp a -> exp b` can be done by constructing an argument using `valExp`.+    -- `exp a -> exp b` can be done by constructing an argument using+    -- `constExp`.   where     -- | Evaluation of a closed expression     evalExp :: exp a -> a

@@ -36,7 +36,7 @@   , (:<:)     -- * Interface for expression types   , FreeExp-  , VarPred+  , FreePred   , EvalExp   , CompExp     -- * Front end

@@ -7,7 +7,6 @@ import Data.Proxy  import Language.C.Quote.C-import Language.C.Syntax hiding (Deref)  import Language.C.Monad import Language.Embedded.Imperative.CMD@@ -17,40 +16,40 @@ data RefArg pred where   RefArg :: pred a => Ref a -> RefArg pred -instance Arg RefArg CType where+instance CompTypeClass ct => Arg RefArg ct where   mkArg   (RefArg r) = touchVar r >> return [cexp| &$id:r |]   mkParam (RefArg (r :: Ref a)) = do-    t <- cType (Proxy :: Proxy a)+    t <- compType (Proxy :: Proxy ct) (Proxy :: Proxy a)     return [cparam| $ty:t* |]  -- | Mutable array argument data ArrArg pred where   ArrArg :: pred a => Arr i a -> ArrArg pred -instance Arg ArrArg CType where+instance CompTypeClass ct => Arg ArrArg ct where   mkArg   (ArrArg a) = touchVar a >> return [cexp| $id:a |]   mkParam (ArrArg (_ :: Arr i a)) = do-    t <- cType (Proxy :: Proxy a)+    t <- compType (Proxy :: Proxy ct) (Proxy :: Proxy a)     return [cparam| $ty:t* |]  -- | Immutable array argument data IArrArg pred where   IArrArg :: pred a => IArr i a -> IArrArg pred -instance Arg IArrArg CType where+instance CompTypeClass ct => Arg IArrArg ct where   mkArg   (IArrArg a) = touchVar a >> return [cexp| $id:a |]   mkParam (IArrArg (_ :: IArr i a)) = do-    t <- cType (Proxy :: Proxy a)+    t <- compType (Proxy :: Proxy ct) (Proxy :: Proxy a)     return [cparam| $ty:t* |]  -- | Pointer argument data PtrArg pred where   PtrArg :: pred a => Ptr a -> PtrArg pred -instance Arg PtrArg CType where+instance CompTypeClass ct => Arg PtrArg ct where   mkArg   (PtrArg p) = touchVar p >> return [cexp| $id:p |]   mkParam (PtrArg (_ :: Ptr a)) = do-    t <- cType (Proxy :: Proxy a)+    t <- compType (Proxy :: Proxy ct) (Proxy :: Proxy a)     return [cparam| $ty:t* |]  -- | Abstract object argument@@ -70,6 +69,15 @@   StrArg :: String -> StrArg pred  instance Arg StrArg pred where-  mkArg   (StrArg s) = return [cexp| $string:s |]+  mkArg   (StrArg s) = return [cexp| $s |]   mkParam (StrArg s) = return [cparam| const char* |]++data ConstArg pred where+  ConstArg :: { constArgType :: String, constArg :: String } -> ConstArg pred++instance Arg ConstArg pred where+  mkArg   (ConstArg _ n) = return [cexp| $id:n |]+  mkParam (ConstArg t _) = return [cparam| $ty:t' |]+    where+      t' = namedType t 

@@ -14,7 +14,7 @@ import Control.Monad.State import Data.Proxy -import Language.C.Quote.C+import Language.C.Quote.GCC import qualified Language.C.Syntax as C  import Control.Monad.Operational.Higher@@ -27,23 +27,24 @@   -- | Compile `RefCMD`-compRefCMD :: CompExp exp => RefCMD (Param3 prog exp CType) a -> CGen a+compRefCMD :: (CompExp exp, CompTypeClass ct) =>+    RefCMD (Param3 prog exp ct) a -> CGen a compRefCMD cmd@(NewRef base) = do-    t <- cType (proxyArg cmd)+    t <- compType (proxyPred cmd) (proxyArg cmd)     r <- RefComp <$> gensym base     addLocal $ case t of       C.Type _ C.Ptr{} _ -> [cdecl| $ty:t $id:r = NULL; |]       _                  -> [cdecl| $ty:t $id:r; |]     return r-compRefCMD (InitRef base exp) = do-    t <- cType exp+compRefCMD cmd@(InitRef base exp) = do+    t <- compType (proxyPred cmd) exp     r <- RefComp <$> gensym base     e <- compExp exp     addLocal [cdecl| $ty:t $id:r; |]     addStm   [cstm| $id:r = $e; |]     return r-compRefCMD (GetRef ref) = do-    v <- freshVar+compRefCMD cmd@(GetRef ref) = do+    v <- freshVar (proxyPred cmd)     touchVar ref     addStm [cstm| $id:v = $id:ref; |]     return v@@ -63,40 +64,28 @@ --     int _a[] = {0,1,2,3,4,5,6,7,8,9}; --     int * a = _a; ----- This extra pointer is not needed when using `alloca` since then the array is--- a pointer anyway. One option might be to use `alloca` for all arrays, but--- that doesn't permit defining constant arrays using a literal as above.+-- The declaration of a variable-sized array could only be done where its size+-- expression can be evaluated. This is why the declaration of variable-sized+-- arrays is done with `addItem` insted of `addLocal`: it preserves the position+-- of the declaration in the block, as it would be a statement. -- -- Pointers that are used between multiple functions will be lifted to shared globals. -- To ensure the correctness of the resulting program the underlying arrays must also -- be lifted, hence the extra `touchVar` application on their symbols. +-- | Generates the symbol name as an identifier for a given array.+newtype BaseArrOf i a = BaseArrOf (Arr i a)++instance ToIdent (BaseArrOf i a)+  where toIdent (BaseArrOf (ArrComp sym)) = toIdent $ '_':sym+ -- | Compile `ArrCMD`-compArrCMD :: CompExp exp => ArrCMD (Param3 prog exp CType) a -> CGen a-compArrCMD cmd@(NewArr base size) = do-    sym <- gensym base-    let sym' = '_':sym-    n <- compExp size-    t <- cType (proxyArg cmd)-    case n of-      C.Const _ _ -> do-        addLocal [cdecl| $ty:t $id:sym'[ $n ]; |]-        addLocal [cdecl| $ty:t * $id:sym = $id:sym'; |]  -- explanation above-      _ -> do-        addInclude "<alloca.h>"-        addLocal [cdecl| $ty:t * $id:sym; |]-        addStm [cstm| $id:sym = alloca($n * sizeof($ty:t)); |]-    return $ ArrComp sym-compArrCMD cmd@(InitArr base as) = do-    sym <- gensym base-    let sym' = '_':sym-    t   <- cType (proxyArg cmd)-    as' <- mapM cLit as-    addLocal [cdecl| $ty:t $id:sym'[] = $init:(arrayInit as');|]-    addLocal [cdecl| $ty:t * $id:sym = $id:sym'; |]  -- explanation above-    return $ ArrComp sym-compArrCMD (GetArr expi arr) = do-    v <- freshVar+compArrCMD :: forall exp ct a. (CompExp exp, CompTypeClass ct) =>+    ArrCMD (Param3 CGen exp ct) a -> CGen a+compArrCMD cmd@(NewArr base size) = compC_CMD (NewCArr base Nothing size :: C_CMD (Param3 CGen exp ct) a)+compArrCMD cmd@(InitArr base as) = compC_CMD (InitCArr base Nothing as   :: C_CMD (Param3 CGen exp ct) a)+compArrCMD cmd@(GetArr expi arr) = do+    v <- freshVar (proxyPred cmd)     i <- compExp expi     touchVar $ BaseArrOf arr  -- explanation above     touchVar arr@@ -108,24 +97,28 @@     touchVar $ BaseArrOf arr  -- explanation above     touchVar arr     addStm [cstm| $id:arr[ $i ] = $v; |]-compArrCMD cmd@(CopyArr arr1 arr2 expl) = do+compArrCMD cmd@(CopyArr (arr1,expo1) (arr2,expo2) expl) = do     addInclude "<string.h>"-    mapM_ touchVar [BaseArrOf arr1,BaseArrOf arr2]  -- explanation above+    mapM_ touchVar [BaseArrOf arr1, BaseArrOf arr2]  -- explanation above     mapM_ touchVar [arr1,arr2]-    l <- compExp expl-    t <- cType arr1-    addStm [cstm| memcpy($id:arr1, $id:arr2, $l * sizeof($ty:t)); |]+    o1 <- compExp expo1+    o2 <- compExp expo2+    l  <- compExp expl+    t  <- compType (proxyPred cmd) arr1+    let a1 = case o1 of+          C.Const (C.IntConst _ _ 0 _) _ -> [cexp| $id:arr1 |]+          _ -> [cexp| $id:arr1 + $o1 |]+    let a2 = case o2 of+          C.Const (C.IntConst _ _ 0 _) _ -> [cexp| $id:arr2 |]+          _ -> [cexp| $id:arr2 + $o2 |]+    addStm [cstm| memcpy($a1, $a2, $l * sizeof($ty:t)); |] compArrCMD (UnsafeFreezeArr (ArrComp arr)) = return $ IArrComp arr compArrCMD (UnsafeThawArr (IArrComp arr))  = return $ ArrComp arr --- | Generates the symbol name as an identifier for a given array.-newtype BaseArrOf i a = BaseArrOf (Arr i a)-instance ToIdent (BaseArrOf i a)-    where toIdent (BaseArrOf (ArrComp sym)) = toIdent $ '_':sym - -- | Compile `ControlCMD`-compControlCMD :: CompExp exp => ControlCMD (Param3 CGen exp CType) a -> CGen a+compControlCMD :: (CompExp exp, CompTypeClass ct) =>+    ControlCMD (Param3 CGen exp ct) a -> CGen a compControlCMD (If c t f) = do     cc <- compExp c     ct <- inNewBlock_ t@@ -154,10 +147,10 @@               _      -> addStm [cstm| if (! $contc) {break;} |]         body     when (not noop) $ addStm [cstm| while (1) {$items:bodyc} |]-compControlCMD (For (lo,step,hi) body) = do+compControlCMD cmd@(For (lo,step,hi) body) = do     loe <- compExp lo     hie <- compExp $ borderVal hi-    i   <- freshVar+    i   <- freshVar (proxyPred cmd)     bodyc <- inNewBlock_ (body i)     let incl = borderIncl hi     let conte@@ -193,7 +186,8 @@ compIOMode ReadWriteMode = "r+"  -- | Compile `FileCMD`-compFileCMD :: CompExp exp => FileCMD (Param3 prog exp CType) a -> CGen a+compFileCMD :: (CompExp exp, CompTypeClass ct, ct Bool) =>+    FileCMD (Param3 prog exp ct) a -> CGen a compFileCMD (FOpen path mode) = do     addInclude "<stdio.h>"     addInclude "<stdlib.h>"@@ -218,25 +212,59 @@     addStm [cstm| fprintf($args:as'); |] compFileCMD cmd@(FGet h) = do     addInclude "<stdio.h>"-    v <- freshVar+    v <- freshVar (proxyPred cmd)     touchVar h     let mkProxy = (\_ -> Proxy) :: FileCMD (Param3 prog exp pred) (Val a) -> Proxy a-        form    = formatSpecifier (mkProxy cmd)+        form    = formatSpecScan (mkProxy cmd)     addStm [cstm| fscanf($id:h, $string:form, &$id:v); |]     return v-compFileCMD (FEof h) = do+compFileCMD cmd@(FEof h) = do     addInclude "<stdbool.h>"     addInclude "<stdio.h>"-    v <- freshVar+    v <- freshVar (proxyPred cmd)     touchVar h     addStm [cstm| $id:v = feof($id:h); |]     return v -compC_CMD :: CompExp exp => C_CMD (Param3 CGen exp CType) a -> CGen a+compC_CMD :: (CompExp exp, CompTypeClass ct) =>+    C_CMD (Param3 CGen exp ct) a -> CGen a+compC_CMD cmd@(NewCArr base align size) = do+    sym <- gensym base+    let sym' = '_':sym+    n <- compExp size+    t <- compType (proxyPred cmd) (proxyArg cmd)+    case n of+      C.Const _ _ -> do+        case align of+          Just a -> do+            let a' = fromIntegral a :: Int+            addLocal [cdecl| $ty:t $id:sym'[ $n ] __attribute__((aligned($a'))); |]+          _ -> addLocal [cdecl| $ty:t $id:sym'[ $n ]; |]+        addLocal [cdecl| $ty:t * $id:sym = $id:sym'; |]  -- explanation at 'compArrCMD'+      _ -> do+        case align of+          Just a -> do+            let a' = fromIntegral a :: Int+            addItem [citem| $ty:t $id:sym'[ $n ] __attribute__((aligned($a'))); |]+          _ -> addItem [citem| $ty:t $id:sym'[ $n ]; |]+        addItem [citem| $ty:t * $id:sym = $id:sym'; |]  -- explanation at 'compArrCMD'+    return $ ArrComp sym+compC_CMD cmd@(InitCArr base align as) = do+    sym <- gensym base+    let sym' = '_':sym+    t   <- compType (proxyPred cmd) (proxyArg cmd)+    as' <- mapM (compLit (proxyPred cmd)) as+    case align of+      Just a -> do+        let a' = fromIntegral a :: Int+        addLocal [cdecl| $ty:t $id:sym'[] __attribute__((aligned($a'))) = $init:(arrayInit as'); |]+      _ -> addLocal [cdecl| $ty:t $id:sym'[] = $init:(arrayInit as');|]+    addLocal [cdecl| $ty:t * $id:sym = $id:sym'; |]  -- explanation at 'compArrCMD'+    return $ ArrComp sym compC_CMD cmd@(NewPtr base) = do     addInclude "<stddef.h>"     p <- PtrComp <$> gensym base-    t <- cType (proxyArg cmd)+    t <- compType (proxyPred cmd) (proxyArg cmd)     addLocal [cdecl| $ty:t * $id:p = NULL; |]     return p compC_CMD (PtrToArr (PtrComp p)) = return $ ArrComp p@@ -249,16 +277,16 @@     return o compC_CMD (AddInclude inc)    = addInclude inc compC_CMD (AddDefinition def) = addGlobal def-compC_CMD (AddExternFun fun res args) = do-    tres  <- cType res+compC_CMD cmd@(AddExternFun fun res args) = do+    tres  <- compType (proxyPred cmd) res     targs <- mapM mkParam args     addGlobal [cedecl| extern $ty:tres $id:fun($params:targs); |] compC_CMD (AddExternProc proc args) = do     targs <- mapM mkParam args     addGlobal [cedecl| extern void $id:proc($params:targs); |]-compC_CMD (CallFun fun as) = do+compC_CMD cmd@(CallFun fun as) = do     as' <- mapM mkArg as-    v   <- freshVar+    v   <- freshVar (proxyPred cmd)     addStm [cstm| $id:v = $id:fun($args:as'); |]     return v compC_CMD (CallProc obj fun as) = do@@ -268,10 +296,10 @@       Just o  -> addStm [cstm| $id:o = $id:fun($args:as'); |] compC_CMD (InModule mod prog) = inModule mod prog -instance CompExp exp => Interp RefCMD     CGen (Param2 exp CType) where interp = compRefCMD-instance CompExp exp => Interp ArrCMD     CGen (Param2 exp CType) where interp = compArrCMD-instance CompExp exp => Interp ControlCMD CGen (Param2 exp CType) where interp = compControlCMD-instance                Interp PtrCMD     CGen (Param2 exp pred)  where interp = compPtrCMD-instance CompExp exp => Interp FileCMD    CGen (Param2 exp CType) where interp = compFileCMD-instance CompExp exp => Interp C_CMD      CGen (Param2 exp CType) where interp = compC_CMD+instance (CompExp exp, CompTypeClass ct)          => Interp RefCMD     CGen (Param2 exp ct) where interp = compRefCMD+instance (CompExp exp, CompTypeClass ct)          => Interp ArrCMD     CGen (Param2 exp ct) where interp = compArrCMD+instance (CompExp exp, CompTypeClass ct)          => Interp ControlCMD CGen (Param2 exp ct) where interp = compControlCMD+instance                                             Interp PtrCMD     CGen (Param2 exp ct) where interp = compPtrCMD+instance (CompExp exp, CompTypeClass ct, ct Bool) => Interp FileCMD    CGen (Param2 exp ct) where interp = compFileCMD+instance (CompExp exp, CompTypeClass ct)          => Interp C_CMD      CGen (Param2 exp ct) where interp = compC_CMD 

@@ -22,7 +22,7 @@   , borderIncl   , IxRange   , ControlCMD (..)-    -- * Pointers+    -- * Generic pointer manipulation   , IsPointer (..)   , PtrCMD (..)     -- * File handling@@ -87,7 +87,7 @@ -- | Mutable reference data Ref a     = RefComp VarId-    | RefEval (IORef a)+    | RefRun (IORef a)   deriving Typeable  instance ToIdent (Ref a) where toIdent (RefComp r) = C.Id r@@ -125,7 +125,7 @@     hbimap _ f (SetRef r a)        = SetRef r (f a)     hbimap _ _ (UnsafeFreezeRef r) = UnsafeFreezeRef r -instance (RefCMD :<: instr) => Reexpressible RefCMD instr+instance (RefCMD :<: instr) => Reexpressible RefCMD instr env   where     reexpressInstrEnv reexp (NewRef base)       = lift $ singleInj $ NewRef base     reexpressInstrEnv reexp (InitRef base a)    = lift . singleInj . InitRef base =<< reexp a@@ -150,25 +150,24 @@ -- | Mutable array data Arr i a     = ArrComp VarId-    | ArrEval (IORef (IOArray i a))+    | ArrRun (IORef (IOArray i a))         -- The `IORef` is needed in order to make the `IsPointer` instance   deriving Typeable  -- | Immutable array data IArr i a     = IArrComp VarId-    | IArrEval (Array i a)-        -- The `IORef` is needed in order to make the `IsPointer` instance-  deriving Typeable+    | IArrRun (Array i a)+  deriving (Eq, Show, Typeable)  -- In a way, it's not terribly useful to have `Arr` parameterized on the index -- type, since it's required to be an integer type, and it doesn't really matter -- which integer type is used since we can always cast between them. -- -- Another option would be to remove the parameter and allow any integer type--- when indexing (and use e.g. `IOArray Word32` for evaluation). However this--- has the big downside of losing type inference. E.g. the statement--- `getArr arr 0` would be ambiguously typed.+-- when indexing (and use e.g. `IOArray Word32` for running). However this has+-- the big downside of losing type inference. E.g. the statement `getArr arr 0`+-- would be ambiguously typed. -- -- Yet another option is to hard-code a specific index type. But this would -- limit the use of arrays to specific platforms.@@ -187,7 +186,8 @@     InitArr :: (pred a, Integral i, Ix i) => String -> [a] -> ArrCMD (Param3 prog exp pred) (Arr i a)     GetArr  :: (pred a, Integral i, Ix i) => exp i -> Arr i a -> ArrCMD (Param3 prog exp pred) (Val a)     SetArr  :: (pred a, Integral i, Ix i) => exp i -> exp a -> Arr i a -> ArrCMD (Param3 prog exp pred) ()-    CopyArr :: (pred a, Integral i, Ix i) => Arr i a -> Arr i a -> exp i -> ArrCMD (Param3 prog exp pred) ()+    CopyArr :: (pred a, Integral i, Ix i) => (Arr i a, exp i) -> (Arr i a, exp i) -> exp i -> ArrCMD (Param3 prog exp pred) ()+      -- The arrays are paired with their offset     UnsafeFreezeArr :: (pred a, Integral i, Ix i) => Arr i a -> ArrCMD (Param3 prog exp pred) (IArr i a)     UnsafeThawArr   :: (pred a, Integral i, Ix i) => IArr i a -> ArrCMD (Param3 prog exp pred) (Arr i a) #if  __GLASGOW_HASKELL__>=708@@ -208,23 +208,27 @@  instance HBifunctor ArrCMD   where-    hbimap _ f (NewArr base n)       = NewArr base (f n)-    hbimap _ _ (InitArr base as)     = InitArr base as-    hbimap _ f (GetArr i arr)        = GetArr (f i) arr-    hbimap _ f (SetArr i a arr)      = SetArr (f i) (f a) arr-    hbimap _ f (CopyArr a1 a2 l)     = CopyArr a1 a2 (f l)-    hbimap _ _ (UnsafeFreezeArr arr) = UnsafeFreezeArr arr-    hbimap _ _ (UnsafeThawArr arr)   = UnsafeThawArr arr+    hbimap _ f (NewArr base n)             = NewArr base (f n)+    hbimap _ _ (InitArr base as)           = InitArr base as+    hbimap _ f (GetArr i arr)              = GetArr (f i) arr+    hbimap _ f (SetArr i a arr)            = SetArr (f i) (f a) arr+    hbimap _ f (CopyArr (a1,o1) (a2,o2) l) = CopyArr (a1, f o1) (a2, f o2) (f l)+    hbimap _ _ (UnsafeFreezeArr arr)       = UnsafeFreezeArr arr+    hbimap _ _ (UnsafeThawArr arr)         = UnsafeThawArr arr -instance (ArrCMD :<: instr) => Reexpressible ArrCMD instr+instance (ArrCMD :<: instr) => Reexpressible ArrCMD instr env   where     reexpressInstrEnv reexp (NewArr base n)       = lift . singleInj . NewArr base =<< reexp n     reexpressInstrEnv reexp (InitArr base as)     = lift $ singleInj $ InitArr base as     reexpressInstrEnv reexp (GetArr i arr)        = lift . singleInj . flip GetArr arr =<< reexp i     reexpressInstrEnv reexp (SetArr i a arr)      = do i' <- reexp i; a' <- reexp a; lift $ singleInj $ SetArr i' a' arr-    reexpressInstrEnv reexp (CopyArr a1 a2 l)     = lift . singleInj . CopyArr a1 a2 =<< reexp l     reexpressInstrEnv reexp (UnsafeFreezeArr arr) = lift $ singleInj $ UnsafeFreezeArr arr     reexpressInstrEnv reexp (UnsafeThawArr arr)   = lift $ singleInj $ UnsafeThawArr arr+    reexpressInstrEnv reexp (CopyArr (a1,o1) (a2,o2) l) = do+        o1' <- reexp o1+        o2' <- reexp o2+        l'  <- reexp l+        lift $ singleInj $ CopyArr (a1,o1') (a2,o2') l'  instance DryInterp ArrCMD   where@@ -295,7 +299,7 @@     hbimap _ _ Break                   = Break     hbimap _ g (Assert cond msg)       = Assert (g cond) msg -instance (ControlCMD :<: instr) => Reexpressible ControlCMD instr+instance (ControlCMD :<: instr) => Reexpressible ControlCMD instr env   where     reexpressInstrEnv reexp (If c thn els) = do         c' <- reexp c@@ -324,7 +328,7 @@   ----------------------------------------------------------------------------------- * Pointers+-- * Generic pointer manipulation --------------------------------------------------------------------------------  -- The reason for not implementing `SwapPtr` using the `Ptr` type is that it's@@ -337,7 +341,7 @@  instance IsPointer (Arr i a)   where-    runSwapPtr (ArrEval arr1) (ArrEval arr2) = do+    runSwapPtr (ArrRun arr1) (ArrRun arr2) = do         arr1' <- readIORef arr1         arr2' <- readIORef arr2         writeIORef arr1 arr2'@@ -350,7 +354,7 @@ instance HFunctor   PtrCMD where hfmap _    (SwapPtr a b) = SwapPtr a b instance HBifunctor PtrCMD where hbimap _ _ (SwapPtr a b) = SwapPtr a b -instance (PtrCMD :<: instr) => Reexpressible PtrCMD instr+instance (PtrCMD :<: instr) => Reexpressible PtrCMD instr env   where     reexpressInstrEnv reexp (SwapPtr a b) = lift $ singleInj (SwapPtr a b) @@ -367,7 +371,7 @@ -- | File handle data Handle     = HandleComp VarId-    | HandleEval IO.Handle+    | HandleRun IO.Handle   deriving Typeable  instance ToIdent Handle where toIdent (HandleComp h) = C.Id h@@ -397,21 +401,36 @@ -- | Values that can be printed\/scanned using @printf@\/@scanf@ class (Typeable a, Read a, Printf.PrintfArg a) => Formattable a   where-    formatSpecifier :: Proxy a -> String+    -- | Format specifier for `printf`+    formatSpecPrint :: Proxy a -> String+    -- | Format specifier for `scanf`+    formatSpecScan  :: Proxy a -> String+    formatSpecScan = formatSpecPrint -instance Formattable Int    where formatSpecifier _ = "%d"-instance Formattable Int8   where formatSpecifier _ = "%d"-instance Formattable Int16  where formatSpecifier _ = "%d"-instance Formattable Int32  where formatSpecifier _ = "%d"-instance Formattable Int64  where formatSpecifier _ = "%d"-instance Formattable Word   where formatSpecifier _ = "%u"-instance Formattable Word8  where formatSpecifier _ = "%u"-instance Formattable Word16 where formatSpecifier _ = "%u"-instance Formattable Word32 where formatSpecifier _ = "%u"-instance Formattable Word64 where formatSpecifier _ = "%u"-instance Formattable Float  where formatSpecifier _ = "%f"-instance Formattable Double where formatSpecifier _ = "%f"+instance Formattable Int    where formatSpecPrint _ = "%d"+instance Formattable Int8   where formatSpecPrint _ = "%hhd"+instance Formattable Int16  where formatSpecPrint _ = "%hd"+instance Formattable Int32  where formatSpecPrint _ = "%d"+instance Formattable Int64  where formatSpecPrint _ = "%ld"+instance Formattable Word   where formatSpecPrint _ = "%u"+instance Formattable Word8  where formatSpecPrint _ = "%hhu"+instance Formattable Word16 where formatSpecPrint _ = "%hu"+instance Formattable Word32 where formatSpecPrint _ = "%u"+instance Formattable Word64 where formatSpecPrint _ = "%lu" +instance Formattable Float+  where+    formatSpecPrint _ = "%.9g"+      -- See <http://stackoverflow.com/a/21162120/1105347>+    formatSpecScan _ = "%g"++instance Formattable Double+  where+    formatSpecPrint _ = "%.17g"+      -- See <http://stackoverflow.com/a/21162120/1105347>+    formatSpecScan _ = "%lg"+      -- See <http://stackoverflow.com/q/210590/1105347>+ data FileCMD fs a   where     FOpen   :: FilePath -> IOMode                  -> FileCMD (Param3 prog exp pred) Handle@@ -436,7 +455,7 @@     hbimap _ _ (FGet hdl)            = FGet hdl     hbimap _ _ (FEof hdl)            = FEof hdl -instance (FileCMD :<: instr) => Reexpressible FileCMD instr+instance (FileCMD :<: instr) => Reexpressible FileCMD instr env   where     reexpressInstrEnv reexp (FOpen file mode)   = lift $ singleInj $ FOpen file mode     reexpressInstrEnv reexp (FClose h)          = lift $ singleInj $ FClose h@@ -460,7 +479,7 @@  -- | Pointer newtype Ptr (a :: *) = PtrComp {ptrId :: VarId}-  deriving Typeable+  deriving (Eq, Show, Typeable)  instance ToIdent (Ptr a) where toIdent = C.Id . ptrId @@ -481,12 +500,13 @@  data FunArg exp pred   where-    ValArg   :: pred a => exp a -> FunArg exp pred-    AddrArg  :: FunArg exp pred -> FunArg exp pred-    DerefArg :: FunArg exp pred -> FunArg exp pred-    FunArg   :: Arg arg pred => arg pred -> FunArg exp pred+    ValArg    :: pred a => exp a -> FunArg exp pred+    AddrArg   :: FunArg exp pred -> FunArg exp pred+    DerefArg  :: FunArg exp pred -> FunArg exp pred+    OffsetArg :: FunArg exp pred -> exp i -> FunArg exp pred+    FunArg    :: Arg arg pred => arg pred -> FunArg exp pred -instance CompExp exp => Arg (FunArg exp) CType+instance (CompExp exp, CompTypeClass ct) => Arg (FunArg exp) ct   where     mkArg (ValArg a) = compExp a     mkArg (AddrArg arg) = do@@ -495,10 +515,17 @@     mkArg (DerefArg arg) = do         e <- mkArg arg         return [cexp| *$e |]+    mkArg (OffsetArg arg i) = do+        e  <- mkArg arg+        i' <- compExp i+        return $ case i' of+          (C.Const (C.IntConst _ _ 0 _) _) -> e+          (C.Const (C.IntConst _ _ c _) _) | c < 0 -> [cexp| $e - $(negate c) |]+          _ -> [cexp| $e + $i' |]     mkArg (FunArg a) = mkArg a      mkParam (ValArg (a :: exp a)) = do-        t <- cType (Proxy :: Proxy a)+        t <- compType (Proxy :: Proxy ct) (Proxy :: Proxy a)         return [cparam| $ty:t |]     mkParam (AddrArg arg) = do       p <- mkParam arg@@ -511,23 +538,26 @@          C.Param mid spec (C.Ptr [] decl _) loc -> return $ C.Param mid spec decl loc          C.Param _ _ _ _ -> error "mkParam for Deref: cannot dereference non-pointer parameter"          _ -> error "mkParam for Deref: cannot deal with antiquotes"-    mkParam (FunArg a) = mkParam a+    mkParam (OffsetArg a _) = mkParam a+    mkParam (FunArg a)      = mkParam a  mapFunArg ::     (forall a . exp1 a -> exp2 a) -> FunArg exp1 pred -> FunArg exp2 pred-mapFunArg f (ValArg a)   = ValArg (f a)-mapFunArg f (AddrArg a)  = AddrArg $ mapFunArg f a-mapFunArg f (DerefArg a) = DerefArg $ mapFunArg f a-mapFunArg f (FunArg a)   = FunArg a+mapFunArg f (ValArg a)      = ValArg (f a)+mapFunArg f (AddrArg a)     = AddrArg $ mapFunArg f a+mapFunArg f (OffsetArg a i) = OffsetArg (mapFunArg f a) (f i)+mapFunArg f (DerefArg a)    = DerefArg $ mapFunArg f a+mapFunArg f (FunArg a)      = FunArg a  mapFunArgM :: Monad m     => (forall a . exp1 a -> m (exp2 a))     -> FunArg exp1 pred     -> m (FunArg exp2 pred)-mapFunArgM f (ValArg a)   = liftM ValArg (f a)-mapFunArgM f (AddrArg a)  = liftM AddrArg $ mapFunArgM f a-mapFunArgM f (DerefArg a) = liftM DerefArg $ mapFunArgM f a-mapFunArgM f (FunArg a)   = return (FunArg a)+mapFunArgM f (ValArg a)      = liftM ValArg (f a)+mapFunArgM f (AddrArg a)     = liftM AddrArg $ mapFunArgM f a+mapFunArgM f (OffsetArg a i) = do a' <- mapFunArgM f a; i' <- f i; return $ OffsetArg a' i'+mapFunArgM f (DerefArg a)    = liftM DerefArg $ mapFunArgM f a+mapFunArgM f (FunArg a)      = return (FunArg a)  class ToIdent obj => Assignable obj @@ -539,6 +569,8 @@  data C_CMD fs a   where+    NewCArr  :: (pred a, Integral i, Ix i) => String -> Maybe i -> exp i -> C_CMD (Param3 prog exp pred) (Arr i a)+    InitCArr :: (pred a, Integral i, Ix i) => String -> Maybe i -> [a] -> C_CMD (Param3 prog exp pred) (Arr i a)     NewPtr   :: pred a => String -> C_CMD (Param3 prog exp pred) (Ptr a)     PtrToArr :: Ptr a -> C_CMD (Param3 prog exp pred) (Arr i a)     NewObject@@ -556,6 +588,8 @@  instance HFunctor C_CMD   where+    hfmap _ (NewCArr base al n)       = NewCArr base al n+    hfmap _ (InitCArr base al as)     = InitCArr base al as     hfmap _ (NewPtr base)             = NewPtr base     hfmap _ (PtrToArr p)              = PtrToArr p     hfmap _ (NewObject base p t)      = NewObject base p t@@ -569,6 +603,8 @@  instance HBifunctor C_CMD   where+    hbimap _ f (NewCArr base al n)       = NewCArr base al (f n)+    hbimap _ _ (InitCArr base al as)     = InitCArr base al as     hbimap _ _ (NewPtr base)             = NewPtr base     hbimap _ _ (PtrToArr p)              = PtrToArr p     hbimap _ _ (NewObject base p t)      = NewObject base p t@@ -580,8 +616,10 @@     hbimap _ f (CallProc obj proc args)  = CallProc obj proc (map (mapFunArg f) args)     hbimap f _ (InModule mod prog)       = InModule mod (f prog) -instance (C_CMD :<: instr) => Reexpressible C_CMD instr+instance (C_CMD :<: instr) => Reexpressible C_CMD instr env   where+    reexpressInstrEnv reexp (NewCArr base al n)       = lift . singleInj . NewCArr base al =<< reexp n+    reexpressInstrEnv reexp (InitCArr base al as)     = lift $ singleInj $ InitCArr base al as     reexpressInstrEnv reexp (NewPtr base)             = lift $ singleInj $ NewPtr base     reexpressInstrEnv reexp (PtrToArr p)              = lift $ singleInj $ PtrToArr p     reexpressInstrEnv reexp (NewObject base p t)      = lift $ singleInj $ NewObject base p t@@ -595,6 +633,8 @@  instance DryInterp C_CMD   where+    dryInterp (NewCArr base _ _)     = liftM ArrComp $ freshStr base+    dryInterp (InitCArr base _ _)    = liftM ArrComp $ freshStr base     dryInterp (NewPtr base)          = liftM PtrComp $ freshStr base     dryInterp (PtrToArr (PtrComp p)) = return $ ArrComp p     dryInterp (NewObject base t p)   = liftM (Object p t) $ freshStr base@@ -613,19 +653,20 @@ --------------------------------------------------------------------------------  runRefCMD :: RefCMD (Param3 IO IO pred) a -> IO a-runRefCMD (NewRef _)              = fmap RefEval $ newIORef $ error "reading uninitialized reference"-runRefCMD (InitRef _ a)           = fmap RefEval . newIORef =<< a-runRefCMD (SetRef (RefEval r) a)  = writeIORef r =<< a-runRefCMD (GetRef (RefEval r))    = ValEval <$> readIORef r+runRefCMD (NewRef _)              = fmap RefRun $ newIORef $ error "reading uninitialized reference"+runRefCMD (InitRef _ a)           = fmap RefRun . newIORef =<< a+runRefCMD (SetRef (RefRun r) a)   = writeIORef r =<< a+runRefCMD (GetRef (RefRun r))     = ValRun <$> readIORef r runRefCMD cmd@(UnsafeFreezeRef r) = runRefCMD (GetRef r `asTypeOf` cmd)  runArrCMD :: ArrCMD (Param3 IO IO pred) a -> IO a runArrCMD (NewArr _ n) = do     n'  <- n     arr <- newArray_ (0, fromIntegral n'-1)-    ArrEval <$> newIORef arr-runArrCMD (InitArr _ as) = fmap ArrEval . newIORef =<< newListArray (0, genericLength as - 1) as-runArrCMD (GetArr i (ArrEval arr)) = do+    ArrRun <$> newIORef arr+runArrCMD (InitArr _ as) =+    fmap ArrRun . newIORef =<< newListArray (0, genericLength as - 1) as+runArrCMD (GetArr i (ArrRun arr)) = do     arr'  <- readIORef arr     i'    <- i     (l,h) <- getBounds arr'@@ -634,8 +675,8 @@                 ++ show (toInteger i')                 ++ " out of bounds "                 ++ show (toInteger l, toInteger h)-      else ValEval <$> readArray arr' i'-runArrCMD (SetArr i a (ArrEval arr)) = do+      else ValRun <$> readArray arr' i'+runArrCMD (SetArr i a (ArrRun arr)) = do     arr'  <- readIORef arr     i'    <- i     a'    <- a@@ -646,30 +687,38 @@                 ++ " out of bounds "                 ++ show (toInteger l, toInteger h)       else writeArray arr' (fromIntegral i') a'-runArrCMD (CopyArr (ArrEval arr1) (ArrEval arr2) l) = do+runArrCMD (CopyArr (ArrRun arr1, o1) (ArrRun arr2, o2) l) = do     arr1'  <- readIORef arr1     arr2'  <- readIORef arr2+    o1'    <- o1+    o2'    <- o2     l'     <- l     (0,h1) <- getBounds arr1'     (0,h2) <- getBounds arr2'-    if l'>h2+1+    let l1 = h1+1-o1'+        l2 = h2+1-o2'+    if l'>l2     then error $ "copyArr: cannot copy "               ++ show (toInteger l')               ++ " elements from array with "-              ++ show (toInteger (h2+1))+              ++ show (toInteger l2)               ++ " allocated elements"-    else if l'>h1+1+    else if l'>l1     then error $ "copyArr: cannot copy "               ++ show (toInteger l')               ++ " elements to array with "-              ++ show (toInteger (h1+1))+              ++ show (toInteger l1)               ++ " allocated elements"     else sequence_-      [ readArray arr2' i >>= writeArray arr1' i | i <- genericTake l' [0..] ]-runArrCMD (UnsafeFreezeArr (ArrEval arr)) =-    fmap IArrEval . freeze =<< readIORef arr-runArrCMD (UnsafeThawArr (IArrEval arr)) =-    fmap ArrEval . newIORef =<< thaw arr+      [ readArray arr2' (i+o2') >>= writeArray arr1' (i+o1')+          | i <- genericTake l' [0..]+      ]+runArrCMD (UnsafeFreezeArr (ArrRun arr)) =+    fmap IArrRun . freeze =<< readIORef arr+runArrCMD (UnsafeThawArr (IArrRun arr)) =+    fmap ArrRun . newIORef =<< thaw arr+  -- Could use `unsafeFreeze` and `unsafeThaw` here. The downside would be that+  -- incorrect use could lead to crash of the Haskell runtime (I think).  runControlCMD :: ControlCMD (Param3 IO IO pred) a -> IO a runControlCMD (If c t f)        = c >>= \c' -> if c' then t else f@@ -689,7 +738,7 @@       | step >= 0         = i <  h       | step < 0          = i >  h     loop i h-      | cont i h  = body (ValEval i) >> loop (i + fromIntegral step) h+      | cont i h  = body (ValRun i) >> loop (i + fromIntegral step) h       | otherwise = return () runControlCMD Break = error "cannot run programs involving break" runControlCMD (Assert cond msg) = do@@ -699,10 +748,10 @@ runPtrCMD :: PtrCMD (Param3 IO IO pred) a -> IO a runPtrCMD (SwapPtr a b) = runSwapPtr a b -evalHandle :: Handle -> IO.Handle-evalHandle (HandleEval h)        = h-evalHandle (HandleComp "stdin")  = IO.stdin-evalHandle (HandleComp "stdout") = IO.stdout+runHandle :: Handle -> IO.Handle+runHandle (HandleRun h)         = h+runHandle (HandleComp "stdin")  = IO.stdin+runHandle (HandleComp "stdout") = IO.stdout  readWord :: IO.Handle -> IO String readWord h = do@@ -722,19 +771,21 @@ runFPrintf (PrintfArg a:as) pf = a >>= \a' -> runFPrintf as (pf a')  runFileCMD :: FileCMD (Param3 IO IO pred) a -> IO a-runFileCMD (FOpen file mode)              = HandleEval <$> IO.openFile file mode-runFileCMD (FClose (HandleEval h))        = IO.hClose h+runFileCMD (FOpen file mode)              = HandleRun <$> IO.openFile file mode+runFileCMD (FClose (HandleRun h))         = IO.hClose h runFileCMD (FClose (HandleComp "stdin"))  = return () runFileCMD (FClose (HandleComp "stdout")) = return ()-runFileCMD (FPrintf h format as)          = runFPrintf as (Printf.hPrintf (evalHandle h) format)+runFileCMD (FPrintf h format as)          = runFPrintf as (Printf.hPrintf (runHandle h) format) runFileCMD (FGet h)   = do-    w <- readWord $ evalHandle h+    w <- readWord $ runHandle h     case reads w of-        [(f,"")] -> return $ ValEval f+        [(f,"")] -> return $ ValRun f         _        -> error $ "fget: no parse (input " ++ show w ++ ")"-runFileCMD (FEof h) = fmap ValEval $ IO.hIsEOF $ evalHandle h+runFileCMD (FEof h) = fmap ValRun $ IO.hIsEOF $ runHandle h -runC_CMD :: C_CMD (Param3 IO IO pred) a -> IO a+runC_CMD :: forall pred a. C_CMD (Param3 IO IO pred) a -> IO a+runC_CMD (NewCArr base _ n)   = runArrCMD (NewArr base n   :: ArrCMD (Param3 IO IO pred) a)+runC_CMD (InitCArr base _ as) = runArrCMD (InitArr base as :: ArrCMD (Param3 IO IO pred) a) runC_CMD (NewPtr base)        = error $ "cannot run programs involving newPtr (base name " ++ base ++ ")" runC_CMD (PtrToArr p)         = error "cannot run programs involving ptrToArr" runC_CMD (NewObject base _ _) = error $ "cannot run programs involving newObject (base name " ++ base ++ ")"

@@ -59,7 +59,7 @@ initNamedRef base a = singleInj (InitRef base a)  -- | Get the contents of a reference-getRef :: (pred a, FreeExp exp, VarPred exp a, RefCMD :<: instr, Monad m) =>+getRef :: (pred a, FreeExp exp, FreePred exp a, RefCMD :<: instr, Monad m) =>     Ref a -> ProgramT instr (Param2 exp pred) m (exp a) getRef = fmap valToExp . singleInj . GetRef @@ -69,14 +69,14 @@ setRef r = singleInj . SetRef r  -- | Modify the contents of reference-modifyRef :: (pred a, FreeExp exp, VarPred exp a, RefCMD :<: instr, Monad m) =>+modifyRef :: (pred a, FreeExp exp, FreePred exp a, RefCMD :<: instr, Monad m) =>     Ref a -> (exp a -> exp a) -> ProgramT instr (Param2 exp pred) m () modifyRef r f = setRef r . f =<< unsafeFreezeRef r  -- | Freeze the contents of reference (only safe if the reference is not updated -- as long as the resulting value is alive) unsafeFreezeRef-    :: (pred a, FreeExp exp, VarPred exp a, RefCMD :<: instr, Monad m)+    :: (pred a, FreeExp exp, FreePred exp a, RefCMD :<: instr, Monad m)     => Ref a -> ProgramT instr (Param2 exp pred) m (exp a) unsafeFreezeRef = fmap valToExp . singleInj . UnsafeFreezeRef @@ -86,11 +86,11 @@ -- It is almost always better to use 'unsafeFreezeRef' instead. -- -- 'veryUnsafeFreezeRef' behaves predictably when doing code generation, but it--- can give strange results when evaluating in 'IO', as explained here:+-- can give strange results when running in 'IO', as explained here: -- -- <http://fun-discoveries.blogspot.se/2015/09/strictness-can-fix-non-termination.html>-veryUnsafeFreezeRef :: (FreeExp exp, VarPred exp a) => Ref a -> exp a-veryUnsafeFreezeRef (RefEval r) = valExp $! unsafePerformIO $! readIORef r+veryUnsafeFreezeRef :: (FreeExp exp, FreePred exp a) => Ref a -> exp a+veryUnsafeFreezeRef (RefRun r)  = constExp $! unsafePerformIO $! readIORef r veryUnsafeFreezeRef (RefComp v) = varExp v  @@ -135,7 +135,7 @@ getArr     :: ( pred a        , FreeExp exp-       , VarPred exp a+       , FreePred exp a        , Integral i        , Ix i        , ArrCMD :<: instr@@ -153,21 +153,21 @@ -- copy must not be greater than the number of allocated elements in either -- array. copyArr :: (pred a, Integral i, Ix i, ArrCMD :<: instr)-    => Arr i a  -- ^ Destination-    -> Arr i a  -- ^ Source-    -> exp i    -- ^ Number of elements+    => (Arr i a, exp i)  -- ^ (destination,offset)+    -> (Arr i a, exp i)  -- ^ (source,offset+    -> exp i             -- ^ Number of elements     -> ProgramT instr (Param2 exp pred) m () copyArr arr1 arr2 len = singleInj $ CopyArr arr1 arr2 len  -- | Freeze a mutable array to an immutable one. This involves copying the array -- to a newly allocated one.-freezeArr :: (pred a, Integral i, Ix i, ArrCMD :<: instr, Monad m)+freezeArr :: (pred a, Integral i, Ix i, Num (exp i), ArrCMD :<: instr, Monad m)     => Arr i a     -> exp i  -- ^ Length of new array     -> ProgramT instr (Param2 exp pred) m (IArr i a) freezeArr arr n = do     arr2 <- newArr n-    copyArr arr2 arr n+    copyArr (arr2,0) (arr,0) n     unsafeFreezeArr arr2  -- | Freeze a mutable array to an immutable one without making a copy. This is@@ -179,14 +179,14 @@  -- | Thaw an immutable array to a mutable one. This involves copying the array -- to a newly allocated one.-thawArr :: (pred a, Integral i, Ix i, ArrCMD :<: instr, Monad m)+thawArr :: (pred a, Integral i, Ix i, Num (exp i), ArrCMD :<: instr, Monad m)     => IArr i a     -> exp i  -- ^ Number of elements to copy     -> ProgramT instr (Param2 exp pred) m (Arr i a) thawArr arr n = do     arr2 <- unsafeThawArr arr     arr3 <- newArr n-    copyArr arr3 arr2 n+    copyArr (arr3,0) (arr2,0) n     return arr3  -- | Thaw an immutable array to a mutable one without making a copy. This is@@ -219,7 +219,7 @@ ifE     :: ( pred a        , FreeExp exp-       , VarPred exp a+       , FreePred exp a        , ControlCMD :<: instr        , RefCMD     :<: instr        , Monad m@@ -246,7 +246,7 @@        , ControlCMD :<: instr        , Integral n        , pred n-       , VarPred exp n+       , FreePred exp n        )     => IxRange (exp n)                                   -- ^ Index range     -> (exp n -> ProgramT instr (Param2 exp pred) m ())  -- ^ Loop body@@ -297,7 +297,7 @@ fclose = singleInj . FClose  -- | Check for end of file-feof :: (FreeExp exp, VarPred exp Bool, FileCMD :<: instr, Monad m) =>+feof :: (FreeExp exp, FreePred exp Bool, FileCMD :<: instr, Monad m) =>     Handle -> ProgramT instr (Param2 exp pred) m (exp Bool) feof = fmap valToExp . singleInj . FEof @@ -324,21 +324,21 @@  -- | Put a single value to a handle fput :: forall instr exp pred a m-    .  (Formattable a, VarPred exp a, FileCMD :<: instr)+    .  (Formattable a, FreePred exp a, FileCMD :<: instr)     => Handle     -> String  -- ^ Prefix     -> exp a   -- ^ Expression to print     -> String  -- ^ Suffix     -> ProgramT instr (Param2 exp pred) m () fput hdl prefix a suffix =-    fprintf hdl (prefix ++ formatSpecifier (Proxy :: Proxy a) ++ suffix) a+    fprintf hdl (prefix ++ formatSpecPrint (Proxy :: Proxy a) ++ suffix) a  -- | Get a single value from a handle fget     :: ( Formattable a        , pred a        , FreeExp exp-       , VarPred exp a+       , FreePred exp a        , FileCMD :<: instr        , Monad m        )@@ -392,13 +392,6 @@     -> ProgramT instr (Param2 exp pred) m Object newNamedObject base t p = singleInj $ NewObject base t p --- | Generate code into another translation unit-inModule :: (C_CMD :<: instr)-    => String-    -> ProgramT instr (Param2 exp pred) m ()-    -> ProgramT instr (Param2 exp pred) m ()-inModule mod prog = singleInj $ InModule mod prog- -- | Add an @#include@ statement to the generated code addInclude :: (C_CMD :<: instr) => String -> ProgramT instr (Param2 exp pred) m () addInclude = singleInj . AddInclude@@ -443,7 +436,7 @@ addExternProc proc args = singleInj $ AddExternProc proc args  -- | Call a function-callFun :: (pred a, FreeExp exp, VarPred exp a, C_CMD :<: instr, Monad m)+callFun :: (pred a, FreeExp exp, FreePred exp a, C_CMD :<: instr, Monad m)     => String             -- ^ Function name     -> [FunArg exp pred]  -- ^ Arguments     -> ProgramT instr (Param2 exp pred) m (exp a)@@ -469,7 +462,7 @@  -- | Declare and call an external function externFun :: forall instr m exp pred res-    .  (pred res, FreeExp exp, VarPred exp res, C_CMD :<: instr, Monad m)+    .  (pred res, FreeExp exp, FreePred exp res, C_CMD :<: instr, Monad m)     => String             -- ^ Function name     -> [FunArg exp pred]  -- ^ Arguments     -> ProgramT instr (Param2 exp pred) m (exp res)@@ -486,9 +479,16 @@     addExternProc proc args     callProc proc args +-- | Generate code into another translation unit+inModule :: (C_CMD :<: instr)+    => String+    -> ProgramT instr (Param2 exp pred) m ()+    -> ProgramT instr (Param2 exp pred) m ()+inModule mod prog = singleInj $ InModule mod prog+ -- | Get current time as number of seconds passed today getTime-    :: (pred Double, FreeExp exp, VarPred exp Double, C_CMD :<: instr, Monad m)+    :: (pred Double, FreeExp exp, FreePred exp Double, C_CMD :<: instr, Monad m)     => ProgramT instr (Param2 exp pred) m (exp Double) getTime = do     addInclude "<sys/time.h>"@@ -537,6 +537,13 @@ strArg :: String -> FunArg exp pred strArg = FunArg . StrArg +-- | Named constant argument+constArg+    :: String  -- ^ Type+    -> String  -- ^ Named constant+    -> FunArg exp pred+constArg t n = FunArg $ ConstArg t n+ -- | Modifier that takes the address of another argument addr :: FunArg exp pred -> FunArg exp pred addr = AddrArg@@ -544,6 +551,12 @@ -- | Modifier that dereferences another argument deref :: FunArg exp pred -> FunArg exp pred deref = DerefArg++-- | Add an offset to another argument+offset :: Integral i => FunArg exp pred -> exp i -> FunArg exp pred+offset = OffsetArg+  -- The `Integral` constraint isn't needed, but it makes sense, since the+  -- intention of `offset` is to add an offset to a pointer.   

@@ -32,5 +32,5 @@ import Language.Embedded.Imperative.CMD  import Language.C.Syntax-import Language.C.Quote.C+import Language.C.Quote.GCC 

@@ -19,7 +19,7 @@ -- | Signature annotations data Ann exp a where   Empty  :: Ann exp a-  Native :: (VarPred exp a) => exp len -> Ann exp [a]+  Native :: (FreePred exp a) => exp len -> Ann exp [a]   Named  :: String -> Ann exp a  -- | Signatures@@ -32,11 +32,11 @@  -- * Combinators -lam :: (pred a, FreeExp exp, VarPred exp a)+lam :: (pred a, FreeExp exp, FreePred exp a)     => (exp a -> Signature exp pred b) -> Signature exp pred (a -> b) lam f = Lam Empty $ \x -> f (valToExp x) -name :: (pred a, FreeExp exp, VarPred exp a)+name :: (pred a, FreeExp exp, FreePred exp a)      => String -> (exp a -> Signature exp pred b) -> Signature exp pred (a -> b) name s f = Lam (Named s) $ \x -> f (valToExp x) @@ -45,7 +45,7 @@ ret = Ret ptr = Ptr -arg :: (pred a, FreeExp exp, VarPred exp a)+arg :: (pred a, FreeExp exp, FreePred exp a)     => Ann exp a     -> (exp a -> exp b)     -> (exp b -> Signature exp pred c)@@ -77,7 +77,7 @@         addStm [cstm| *out = $e; |]     go fun@(Lam Empty f) prelude = do       t <- cType (argProxy fun)-      v <- freshVar+      v <- freshVar (Proxy :: Proxy CType)       go (f v) $ prelude >> addParam [cparam| $ty:t $id:v |]     go fun@(Lam n@(Native l) f) prelude = do       t <- cType n

@@ -13,11 +13,7 @@ import Test.Tasty.TH  import Language.Syntactic (AST (..), DenResult)-#if MIN_VERSION_syntactic(3,0,0) import Language.Syntactic.Functional (Denotation)-#else-import Language.Syntactic (Denotation)-#endif  import Language.Embedded.Imperative import Language.Embedded.Backend.C

@@ -10,6 +10,10 @@  import Data.Int import Data.Word+import System.Directory+import System.FilePath+import System.Process+import System.Random  import Language.Embedded.Imperative import Language.Embedded.Backend.C@@ -59,8 +63,7 @@ testCExp = do     a :: CExp Int32 <- fget stdin     let b = a#==10 ? a*3 $ a-5+8-    let c = sin (i2n a) :: CExp Double-    let d = c/23+    let c = i2n a/23 :: CExp Double     printf "%d " b     printf "%d " (not_ (a#==10) ? a*3 $ a-5+8)     printf "%d " (a `quot_` b)@@ -68,12 +71,7 @@     printf "%d " (cond (i2b a) a b)     printf "%d " (b2i (not_ (a#==10)) * a)     printf "%.3f " c-    printf "%.3f " d     printf "%.3f " (i2n a :: CExp Float)-    printf "%ld "  (round_ (c*1000)              :: CExp Int32)-    printf "%d "   (round_ (11.5 :: CExp Float)  :: CExp Int32)-    printf "%d "   (round_ (-11.5 :: CExp Float) :: CExp Int32)-    printf "%.3f " (c**d)  testRef :: Prog () testRef = do@@ -85,15 +83,24 @@     b <- unsafeFreezeRef r2     printf "%d %d\n" a b -testArr1 :: Prog ()-testArr1 = do+testCopyArr1 :: Prog ()+testCopyArr1 = do     arr1 :: Arr Word32 Int32 <- newArr (10 :: CExp Word32)     arr2 :: Arr Word32 Int32 <- newArr (10 :: CExp Word32)     sequence_ [setArr i (i2n i+10) arr1 | i' <- [0..9], let i = fromInteger i']-    copyArr arr2 arr1 10+    copyArr (arr2,0) (arr1,0) 10     sequence_ [getArr i arr2 >>= printf "%d " . (*3) | i' <- [0..9], let i = fromInteger i']     printf "\n" +testCopyArr2 :: Prog ()+testCopyArr2 = do+    arr1 :: Arr Word32 Int32 <- newArr (20 :: CExp Word32)+    arr2 :: Arr Word32 Int32 <- newArr (20 :: CExp Word32)+    sequence_ [setArr i (i2n i+10) arr1 | i' <- [0..19], let i = fromInteger i']+    copyArr (arr2,10) (arr1,5) 10+    sequence_ [getArr i arr2 >>= printf "%d " . (*3) | i' <- [10..19], let i = fromInteger i']+    printf "\n"+ testArr2 :: Prog () testArr2 = do     n <- fget stdin@@ -153,7 +160,7 @@     arr1 :: Arr Word32 Int32 <- initArr [1,2,3,4]     n <- fget stdin     arr2 :: Arr Word32 Int32 <- newArr n-    copyArr arr2 arr1 4+    copyArr (arr2,0) (arr1,0) 4     setArr 2 22 arr2     unsafeSwap arr1 arr2     sequence_ [getArr i arr1 >>= printf "%d " | i <- map fromInteger [0..3]]@@ -202,6 +209,12 @@     assert (inp #> 0) "input too small"     printf "past assertion\n" +-- This tests that `formatSpecifier` works as it should for different types+testPrintScan :: (Formattable a, CType a) => CExp a -> Prog ()+testPrintScan a = do+    i <- fget stdin+    fput stdout "" (i `asTypeOf` a) ""+ testPtr :: Prog () testPtr = do     addInclude "<stdlib.h>"@@ -219,6 +232,7 @@ testArgs :: Prog () testArgs = do     addInclude "<stdio.h>"+    addInclude "<stdbool.h>"     addDefinition setPtr_def     addDefinition ret_def     let v = 55 :: CExp Int32@@ -232,14 +246,17 @@     callProcAssign o "ret" [valArg v]     callProcAssign op "setPtr" [refArg r]     callProc "printf"-        [ strArg "%d %d %d %d %d %d %d\n"+        [ strArg "%d %d %d %d %d %d %d %d %d %d\n"         , valArg v         , deref (refArg r)         , deref (arrArg a)         , deref (iarrArg ia)         , deref (ptrArg p)+        , deref (offset (iarrArg ia) (3 :: CExp Word32))+        , deref (offset (ptrArg p) (0 :: CExp Word32))         , objArg o         , deref (objArg op)+        , constArg "bool" "true"         ]   where     setPtr_def = [cedecl|@@ -255,8 +272,12 @@  testExternArgs :: Prog () testExternArgs = do+    addInclude "<stdbool.h>"     let v = 55 :: CExp Int32-    externProc "val_proc" [valArg v]+    externProc "val_proc1" [valArg v]+    externProc "val_proc2" [offset3 $ valArg v]+      -- Normal integer addition (slight misuse of `offset`)+    _ :: CExp Int32 <- externFun "val_fun" [valArg v]     r <- initRef v     externProc "ref_proc1" [refArg r]     externProc "ref_proc2" [deref $ refArg r]  -- TODO Simplify@@ -264,6 +285,9 @@     externProc "arr_proc1" [arrArg a]     externProc "arr_proc2" [addr $ arrArg a]     externProc "arr_proc3" [deref $ arrArg a]+    externProc "arr_proc4" [offset3 $ arrArg a]+    externProc "arr_proc5" [deref $ offset3 $ arrArg a]+    externProc "arr_proc6" [offsetMinus $ arrArg a]     p :: Ptr Int32 <- newPtr     externProc "ptr_proc1" [ptrArg p]     externProc "ptr_proc2" [addr $ ptrArg p]@@ -275,13 +299,57 @@     externProc "obj_proc3" [objArg op]     externProc "obj_proc4" [addr $ objArg op]     externProc "obj_proc5" [deref $ objArg op]+    externProc "obj_proc6" [offset3 $ objArg op]     let s = "apa"-    externProc "str_proc1"  [strArg s]-    externProc "str_proc2"  [deref $ strArg s]+    externProc "str_proc1" [strArg s]+    externProc "str_proc2" [deref $ strArg s]+    externProc "const_proc" [constArg "bool" "true"]     return ()+  where+    offset3     = flip offset (3 :: CExp Int32)+    offsetMinus = flip offset (-3 :: CExp Int32) . offset3 +testCallFun :: Prog ()+testCallFun = do+    addInclude "<math.h>"+    i :: CExp Int32 <- fget stdin+    a <- callFun "sin" [valArg (i2n i :: CExp Double)]+    printf "%.3f\n" (a :: CExp Double) +multiModule :: Prog ()+multiModule = do+    addInclude "<stdlib.h>"+    addExternProc "func_in_other" []+    inModule "other" $ do+      addDefinition [cedecl|+        void func_in_other(void) {+          puts("Hello from the other module!");+        } |]+      addInclude "<stdio.h>"+    callProc "func_in_other" [] +testMultiModule :: IO ()+testMultiModule = do+    tmp <- getTemporaryDirectory+    rand <- randomRIO (1, maxBound :: Int)+    let temp = tmp </> "imperative-edsl_" ++ show rand+    exists <- doesDirectoryExist temp+    when exists $ removeDirectoryRecursive temp+    createDirectory temp+    let ms    = compileAll multiModule+        files = [temp </> "imperative-edsl_" ++ m ++ ".c" | (m,_) <- ms]+        exe   = temp </> "imperative-edsl"+        cmd   = unwords $ ("cc -o" : exe : files)+    zipWithM_ writeFile files (map snd ms)+    putStrLn cmd+    system cmd+    putStrLn exe+    system exe+    exists <- doesDirectoryExist temp+    when exists $ removeDirectoryRecursive temp+++ ----------------------------------------  -- It would be nice to be able to run these tests using Tests.Tasty.HUnit, but@@ -290,30 +358,57 @@ -- secondly, the tests would always fail when running a second time.  testAll = do-    tag "testTypes"  >> compareCompiled  testTypes  (runIO testTypes)                      "0\n"-    tag "testCExp"   >> compareCompiledM testCExp   (runIO testCExp)                       "44\n"-    tag "testRef"    >> compareCompiled  testRef    (runIO testRef)                        ""-    tag "testArr1"   >> compareCompiled  testArr1   (runIO testArr1)                       ""-    tag "testArr2"   >> compareCompiled  testArr2   (runIO testArr2)                       "20\n"-    tag "testArr3"   >> compareCompiled  testArr3   (runIO testArr3)                       ""-    tag "testArr4"   >> compareCompiled  testArr4   (runIO testArr4)                       ""-    tag "testArr5"   >> compareCompiled  testArr5   (runIO testArr5)                       ""-    tag "testArr6"   >> compareCompiled  testArr6   (runIO testArr6)                       ""-    tag "testArr7"   >> compareCompiled  testArr7   (runIO testArr6)                       ""-    tag "testArr7"   >> compareCompiled  testArr7   (runIO testArr7)                       ""-    tag "testSwap1"  >> compareCompiled  testSwap1  (runIO testSwap1)                      ""-    tag "testSwap2"  >> compareCompiled  testSwap2  (runIO testSwap2)                      "45\n"-    tag "testIf1"    >> compareCompiled  testIf1    (runIO testIf1)                        "12\n"-    tag "testIf2"    >> compareCompiled  testIf2    (runIO testIf2)                        "12\n"-    tag "testFor1"   >> compareCompiled  testFor1   (runIO testFor1)                       ""-    tag "testFor2"   >> compareCompiled  testFor2   (runIO testFor2)                       ""-    tag "testFor3"   >> compareCompiled  testFor3   (runIO testFor3)                       ""-    tag "testAssert" >> compareCompiled  testAssert (runIO testAssert)                     "45"-    tag "testPtr"    >> compareCompiled  testPtr    (putStrLn "34" >> putStrLn "sum: 280") ""-    tag "testArgs"   >> compareCompiled  testArgs   (putStrLn "55 66 234 234 66 55 66")    ""-    tag "testExternArgs" >> compileAndCheck  testExternArgs+    tag "testTypes"    >> compareCompiled  testTypes    (runIO testTypes)                      "0\n"+    tag "testCExp"     >> compareCompiledM testCExp     (runIO testCExp)                       "44\n"+    tag "testRef"      >> compareCompiled  testRef      (runIO testRef)                        ""+    tag "testCopyArr1" >> compareCompiled  testCopyArr1 (runIO testCopyArr1)                   ""+    tag "testCopyArr2" >> compareCompiled  testCopyArr2 (runIO testCopyArr2)                   ""+    tag "testArr2"     >> compareCompiled  testArr2     (runIO testArr2)                       "20\n"+    tag "testArr3"     >> compareCompiled  testArr3     (runIO testArr3)                       ""+    tag "testArr4"     >> compareCompiled  testArr4     (runIO testArr4)                       ""+    tag "testArr5"     >> compareCompiled  testArr5     (runIO testArr5)                       ""+    tag "testArr6"     >> compareCompiled  testArr6     (runIO testArr6)                       ""+    tag "testArr7"     >> compareCompiled  testArr7     (runIO testArr6)                       ""+    tag "testArr7"     >> compareCompiled  testArr7     (runIO testArr7)                       ""+    tag "testSwap1"    >> compareCompiled  testSwap1    (runIO testSwap1)                      ""+    tag "testSwap2"    >> compareCompiled  testSwap2    (runIO testSwap2)                      "45\n"+    tag "testIf1"      >> compareCompiled  testIf1      (runIO testIf1)                        "12\n"+    tag "testIf2"      >> compareCompiled  testIf2      (runIO testIf2)                        "12\n"+    tag "testFor1"     >> compareCompiled  testFor1     (runIO testFor1)                       ""+    tag "testFor2"     >> compareCompiled  testFor2     (runIO testFor2)                       ""+    tag "testFor3"     >> compareCompiled  testFor3     (runIO testFor3)                       ""+    tag "testAssert"   >> compareCompiled  testAssert   (runIO testAssert)                     "45"+    tag "testPtr"      >> compareCompiled  testPtr      (putStrLn "34" >> putStrLn "sum: 280") ""+    tag "testArgs"     >> compareCompiled  testArgs     (putStrLn "55 66 234 234 66 237 66 55 66 1")  ""++    tag "testPrintScan_Int8"   >> compareCompiled (testPrintScan int8)   (runIO (testPrintScan int8))   "45"+    tag "testPrintScan_Int16"  >> compareCompiled (testPrintScan int16)  (runIO (testPrintScan int16))  "45"+    tag "testPrintScan_Int32"  >> compareCompiled (testPrintScan int32)  (runIO (testPrintScan int32))  "45"+    tag "testPrintScan_Int64"  >> compareCompiled (testPrintScan int64)  (runIO (testPrintScan int64))  "45"+    tag "testPrintScan_Word8"  >> compareCompiled (testPrintScan word8)  (runIO (testPrintScan word8))  "45"+    tag "testPrintScan_Word16" >> compareCompiled (testPrintScan word16) (runIO (testPrintScan word16)) "45"+    tag "testPrintScan_Word32" >> compareCompiled (testPrintScan word32) (runIO (testPrintScan word32)) "45"+    tag "testPrintScan_Word64" >> compareCompiled (testPrintScan word64) (runIO (testPrintScan word64)) "45"+    tag "testPrintScan_Float"  >> captureCompiled (testPrintScan float)  "45"+    tag "testPrintScan_Double" >> captureCompiled (testPrintScan double) "45"+      -- `testPrintScan` for floating point types can't be compared to `runIO`,+      -- becuase different number of digits are printed++    tag "testExternArgs" >> compileAndCheck testExternArgs+    tag "testCallFun" >> compareCompiledM testCallFun (putStrLn "-0.757") "4"+    tag "multiModule" >> testMultiModule   where     tag str = putStrLn $ "---------------- tests/Imperative.hs/" ++ str ++ "\n"-    compareCompiledM = compareCompiled'-        defaultExtCompilerOpts {externalFlagsPost = ["-lm"]}+    compareCompiledM = compareCompiled' def {externalFlagsPost = ["-lm"]}++    int8   = 0 :: CExp Int8+    int16  = 0 :: CExp Int16+    int32  = 0 :: CExp Int32+    int64  = 0 :: CExp Int64+    word8  = 0 :: CExp Word8+    word16 = 0 :: CExp Word16+    word32 = 0 :: CExp Word32+    word64 = 0 :: CExp Word64+    float  = 0 :: CExp Float+    double = 0 :: CExp Double