csound-expression-dynamic 0.3.9.1 → 0.4.0.0

raw patch · 14 files changed

+672/−384 lines, 14 filesdep +hashablePVP ok

version bump matches the API change (PVP)

Dependencies added: hashable

API changes (from Hackage documentation)

Files

• csound-expression-dynamic.cabal +6/−7
• src/Csound/Dynamic/Build.hs +85/−41
• src/Csound/Dynamic/Build/Logic.hs +45/−127
• src/Csound/Dynamic/Debug.hs +24/−0
• src/Csound/Dynamic/Render.hs +6/−3
• src/Csound/Dynamic/Render/Instr.hs +16/−3
• src/Csound/Dynamic/Render/Pretty.hs +92/−51
• src/Csound/Dynamic/Tfm/IfBlocks.hs +28/−15
• src/Csound/Dynamic/Tfm/InferTypes.hs +50/−28
• src/Csound/Dynamic/Tfm/TmpVars.hs +119/−0
• src/Csound/Dynamic/Tfm/UnfoldMultiOuts.hs +10/−3
• src/Csound/Dynamic/Types/Dep.hs +85/−80
• src/Csound/Dynamic/Types/Exp.hs +106/−24
• src/Csound/Dynamic/Types/Flags.hs +0/−2

@@ -1,5 +1,5 @@ Name:          csound-expression-dynamic-Version:       0.3.9.1+Version:       0.4.0.0 Cabal-Version: 1.12 License:       BSD3 License-file:  LICENSE@@ -44,6 +44,7 @@       , vector       , unordered-containers       , pretty-show+      , hashable       , safe   Hs-Source-Dirs:      src/   default-language: Haskell2010@@ -57,6 +58,7 @@     Csound.Dynamic.Types.Dep     Csound.Dynamic.Types.CsdFile     Csound.Dynamic.Types.Flags+    Csound.Dynamic.Debug      Csound.Dynamic.Build     Csound.Dynamic.Build.Numeric@@ -69,6 +71,7 @@   Other-Modules:     Csound.Dynamic.Tfm.IfBlocks     Csound.Dynamic.Tfm.InferTypes+    Csound.Dynamic.Tfm.TmpVars     Csound.Dynamic.Tfm.Liveness     Csound.Dynamic.Tfm.UnfoldMultiOuts @@ -87,9 +90,5 @@     ScopedTypeVariables     TupleSections     TypeApplications------+    OverloadedRecordDot+    StrictData

@@ -9,15 +9,15 @@    -- * Constructors   -- | Basic constructors-  prim, opcPrefix, oprPrefix, oprInfix,+  emptyE, prim, opcPrefix, oprPrefix, oprInfix,   numExp1,   tfm, tfmNoInlineArgs, pn, withInits,   double, int, str, verbatim, instrIdE,   inlineVar, gInit, gInitDouble,    -- ** Opcodes constructors-  Spec1, spec1, opcs, opcsNoInlineArgs, opr1, opr1k, infOpr, oprBy,-  Specs, specs, MultiOut, mopcs, mo,+  Spec1, spec1, opcs, opcsDep, opcsDep_, opcsNoInlineArgs, opr1, opr1k, opr1kDep, infOpr, infOprDep, oprBy, oprByDep,+  Specs, specs, MultiOut, mopcs, mopcsDep, mo,    -- * Global init statements   setSr, setKsmps, setNchnls, setNchnls_i, setKr, setZeroDbfs,@@ -26,10 +26,8 @@   opcsArr, infOprArr, initPureArr, readPureArr ) where -import qualified Data.Map as M(fromList, toList)+import qualified Data.Map as M(fromList) import Data.Serialize qualified as Cereal--import Data.List(transpose) import Data.Fix(Fix(..))  import Csound.Dynamic.Types.Exp@@ -40,6 +38,9 @@ ------------------------------------------------ -- basic constructors +emptyE :: E+emptyE = noRate EmptyExp+ prim :: Prim -> E prim = noRate . ExpPrim @@ -55,30 +56,27 @@ toArgs :: [Rate] -> [E] -> [PrimOr E] toArgs = zipWith toPrimOrTfm +toArgsNoInlineConst :: [Rate] -> [E] -> [PrimOr E]+toArgsNoInlineConst = zipWith toPrimOrTfmNoConst+ tfm :: Info -> [E] -> E tfm info args = noRate $ Tfm info $ toArgs (getInfoRates info) args  tfmArr :: Monad m => IsArrInit -> Var -> Info -> [E] -> DepT m ()-tfmArr isArrInit var info args = depT_ $ noRate $ TfmArr isArrInit var info $ toArgs (getInfoRates info) args--getInfoRates :: Info -> [Rate]-getInfoRates a = getInRates $ infoSignature a-  where-    getInRates x =-      case x of-        SingleRate m    -> fmap minimum $ transpose $ fmap snd $ M.toList m-        MultiRate _ ins -> ins+tfmArr isArrInit var info args =+  depT_ $ noRate $ TfmArr isArrInit var info $ toArgs (getInfoRates info) args  tfmNoInlineArgs :: Info -> [E] -> E-tfmNoInlineArgs info args = noRate $ Tfm info $ fmap (PrimOr . Right) args+tfmNoInlineArgs info args =+  noRate $ Tfm info $ toArgsNoInlineConst (getInfoRates info) args -inlineVar :: Var -> E-inlineVar var = Fix $ RatedExp h Nothing Nothing $ ReadVar var+inlineVar :: IfRate -> Var -> E+inlineVar ifRate var = Fix $ RatedExp h Nothing Nothing $ ReadVar ifRate var   where-    h = Cereal.encode var+    h = ExpHash (Cereal.encode var) -pn :: Int -> E-pn = prim . P+pn :: Rate -> Int -> E+pn rate = prim . P rate  withInits :: E -> [E] -> E withInits a es = onExp phi a@@ -126,6 +124,12 @@ opcs :: Name -> Spec1 -> [E] -> E opcs name signature = tfm (opcPrefix name $ spec1 signature) +opcsDep :: Monad m => Name -> Spec1 -> [E] -> DepT m E+opcsDep name signature = tfmDep (opcPrefix name $ spec1 signature)++opcsDep_ :: Monad m => Name -> Spec1 -> [E] -> DepT m ()+opcsDep_ name signature args = depT_ (tfm (opcPrefix name $ spec1 signature) args)+ opcsNoInlineArgs :: Name -> Spec1 -> [E] -> E opcsNoInlineArgs name signature = tfmNoInlineArgs (opcPrefix name $ spec1 signature) @@ -135,12 +139,21 @@ oprBy :: Name -> Spec1 -> [E] -> E oprBy name signature = tfm (oprPrefix name $ spec1 signature) +oprByDep :: Monad m => Name -> Spec1 -> [E] -> DepT m E+oprByDep name signature = tfmDep (oprPrefix name $ spec1 signature)+ opr1k :: Name -> E -> E opr1k name a = tfm (oprPrefix name $ spec1 [(Kr, [Kr]), (Ir, [Ir])]) [a] +opr1kDep :: Monad m => Name -> E -> DepT m E+opr1kDep name a = tfmDep (oprPrefix name $ spec1 [(Kr, [Kr]), (Ir, [Ir])]) [a]+ infOpr :: Name -> E -> E -> E infOpr name a b = tfm (oprInfix name $ spec1 [(Ar, [Ar, Ar]), (Kr, [Kr, Kr]), (Ir, [Ir, Ir])]) [a, b] +infOprDep :: Monad m => Name -> E -> E -> DepT m E+infOprDep name a b = tfmDep (oprInfix name $ spec1 [(Ar, [Ar, Ar]), (Kr, [Kr, Kr]), (Ir, [Ir, Ir])]) [a, b]+ numExp1 :: NumOp -> E -> E numExp1 op x = noRate $ ExpNum $ fmap toPrimOr $ PreInline op [x] @@ -169,32 +182,63 @@ specs = uncurry MultiRate  mopcs :: Name -> Specs -> [E] -> MultiOut [E]-mopcs name signature as = \numOfOuts -> mo numOfOuts $ tfm (opcPrefix name $ specs signature) as+mopcs name signature as =+  \numOfOuts ->+    mo (+      take numOfOuts $ fst signature) $+      tfm (opcPrefix name $ limitMultiRateSignature numOfOuts signature) as -mo :: Int -> E -> [E]-mo n e = zipWith (\cellId r -> select cellId r e') [0 ..] outRates+limitMultiRateSignature :: Int -> Specs -> Signature+limitMultiRateSignature size (outRates, inRates) =+  MultiRate (take size outRates) inRates++mopcsDep :: Monad m => Int -> Name -> Specs -> [E] -> DepT m [E]+mopcsDep numOfOuts name signature as =+  moDep rates <$> tfmDepVar (opcPrefix name (limitMultiRateSignature numOfOuts signature)) as   where-    outRates = take n $ getRates $ toExp e-    e' = onExp (setMultiRate outRates) e+    rates = take numOfOuts $ fst signature -    setMultiRate rates (Tfm info xs) = Tfm (info{ infoSignature = MultiRate rates ins }) xs-        where-          ins = case infoSignature info of-              MultiRate _ a -> a-              _ -> error "Tuple.hs: multiOutsSection -- should be multiOut expression"-    setMultiRate _ _ = error "Tuple.hs: multiOutsSection -- argument should be Tfm-expression"+mo :: [Rate] -> E -> [E]+mo outRates e = zipWith (\cellId r -> select cellId r e) [0 ..] outRates+  where+    {-+    e' = onExp setMultiRate e +    setInfo info = info{ infoSignature = MultiRate outRates ins }+      where+        ins = case infoSignature info of+            MultiRate _ a -> a+            _ -> error "Tuple.hs: multiOutsSection -- should be multiOut expression"++    setMultiRate  = \case+      Tfm info xs -> Tfm (setInfo info) xs+      ExpPrim (PrimTmpVar v) -> ExpPrim (PrimTmpVar $ v { tmpVarInfo = setInfo <$> tmpVarInfo v })+      other -> other -- error "Tuple.hs: multiOutsSection -- argument should be Tfm-expression"+    -}     select cellId rate expr = withRate rate $ Select rate cellId (PrimOr $ Right expr)  -getRates :: MainExp a -> [Rate]-getRates (Tfm info _) =-  case infoSignature info of-    MultiRate outs _ -> outs-    _ -> error "Build.hs:getRates - argument should be multiOut"-getRates _ = error "Build.hs:getRates - argument should be Tfm-expression"+moDep :: [Rate] -> TmpVar -> [E]+moDep outRates e = zipWith (\cellId r -> select cellId r e) [0 ..] outRates+  where+    select cellId rate tmpVar =+      withRate rate $ Select rate cellId (PrimOr $ Left (PrimTmpVar tmpVar)) +getRates :: Show a => MainExp a -> [Rate]+getRates = \case+  Tfm info _ -> fromInfo info+  ExpPrim (PrimTmpVar v) ->+    case tmpVarInfo v of+      Just info -> fromInfo info+      Nothing -> error "Build.hs:getRates - no info for tmpVar"+  other -> error $ "Build.hs:getRates - argument should be Tfm-expression. But got " <> show other+  where+    fromInfo info =+      case infoSignature info of+        MultiRate outs _ -> outs+        _ -> error "Build.hs:getRates - argument should be multiOut" + isMultiOutSignature :: Signature -> Bool isMultiOutSignature x =   case x of@@ -213,7 +257,7 @@  -- Lifts transformation of main expression onExp :: (Exp E -> Exp E) -> E -> E-onExp f x =+onExp f x = rehashE $   case unFix x of     a -> Fix $ a{ ratedExpExp = f (ratedExpExp a) } @@ -235,8 +279,8 @@ setZeroDbfs = setGlobal "0dbfs"  gInit :: Monad m => Text -> Int -> DepT m ()-gInit name val = writeVar (VarVerbatim Ir name) (int val)+gInit name val = writeVar IfIr (VarVerbatim Ir name) (int val)  gInitDouble :: Monad m => Text -> Double -> DepT m ()-gInitDouble name val = writeVar (VarVerbatim Ir name) (double val)+gInitDouble name val = writeVar IfIr (VarVerbatim Ir name) (double val) 

@@ -8,72 +8,46 @@     -- ifBegin, ifEnd, elseBegin,     untilBlock,     whileBlock,--    -- untilDo,-    -- untilBegin, untilEnd,-    -- whileDo,-    -- whileBegin,-    whileRef, whileEnd+    whileEnd,+    condInfo ) where  import Control.Monad-import Control.Monad.Trans.State.Strict (State, state, evalState, runStateT, StateT(..))+import Control.Monad.Trans.State.Strict (State, state, evalState, get, put, execStateT) import qualified Data.IntMap as IM(fromList)  import Data.Boolean import Csound.Dynamic.Types import Csound.Dynamic.Build(onExp, toExp) import Data.List qualified as List-import Data.Fix--ifT :: forall m . Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m (CodeBlock E) -> DepT m E-ifT ifRate check (DepT th) (DepT el) = DepT $ StateT $ \s -> do-  (_thE, thS) <- runStateT th (startSt s)-  (_elE, elS) <- runStateT el (startSt thS)-  let thDeps = expDependency thS-      elDeps = expDependency elS-      a  = noRate $ IfElseBlock ifRate (condInfo $ setIfRate ifRate check) (CodeBlock $ PrimOr $ Right thDeps) (CodeBlock $ PrimOr $ Right elDeps)-      a1 = rehashE $ Fix $ (unFix a) { ratedExpDepends = Just (newLineNum elS) }-      s1 = elS-            { newLineNum = succ $ newLineNum elS-            , expDependency = a1-            -- depends (expDependency thS) (depends (expDependency elS) a1)-            }-  pure (a1, s1)-  where-    startSt s = s-      { expDependency = rehashE $ Fix $ (unFix $ noRate Starts) { ratedExpDepends = Just (newLineNum s) }-      , newLineNum = succ $ newLineNum s-      }+import Control.Monad.Trans.Class (lift) +ifT :: forall m . Monad m => IfRate -> E -> DepT m () -> DepT m () -> DepT m ()+ifT ifRate check th el = do+  thBlock <- execNoDeps th+  elBlock <- execNoDeps el+  depT_ $ noRate $+    IfElseBlock ifRate (condInfo $ setIfRate ifRate check) (CodeBlock $ PrimOr $ Right thBlock) (CodeBlock $ PrimOr $ Right elBlock) -ifT1, untilT, whileT :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m E+ifT1, untilT, whileT :: Monad m => IfRate -> E -> DepT m () -> DepT m ()  ifT1 = ifT1By IfBlock untilT = ifT1By UntilBlock whileT = ifT1By WhileBlock +execNoDeps :: Monad m => DepT m () -> DepT m E+execNoDeps block = DepT $ do+  st <- get+  st1 <- lift $ execStateT (unDepT block) (st { expDependency = noRate Starts })+  put $ st1 { expDependency = expDependency st }+  pure (expDependency st1)+ ifT1By :: Monad m   => (IfRate -> CondInfo (PrimOr E) -> CodeBlock (PrimOr E) -> Exp E)-  -> IfRate -> E -> DepT m (CodeBlock E) -> DepT m E-ifT1By cons ifRate check (DepT th) = DepT $ StateT $ \s -> do-  (_thE, thS)  <- runStateT th (startSt s)-  let thDeps = expDependency thS-      a  = noRate $ cons ifRate (condInfo $ setIfRate ifRate check) (CodeBlock $ PrimOr $ Right thDeps)-      a1 = rehashE $ Fix $ (unFix a) { ratedExpDepends = Just (newLineNum thS) }-      s1 = thS-            { newLineNum = succ $ newLineNum thS-            , expDependency = a1-            -- depends (expDependency thS) (depends (expDependency elS) a1)-            }-  pure (a1, s1)-  where-    startSt s = s-      { expDependency = rehashE $ Fix $ (unFix $ noRate Starts) { ratedExpDepends = Just (newLineNum s) }-      , newLineNum = succ $ newLineNum s-      }--+  -> IfRate -> E -> DepT m () -> DepT m ()+ifT1By cons ifRate check codeBlock = do+  block <- execNoDeps codeBlock+  depT_ $ noRate $ cons ifRate (condInfo $ setIfRate ifRate check) (CodeBlock $ PrimOr $ Right block)  ------------------------------------------------------ -- imperative if-then-else@@ -81,84 +55,27 @@ setIfRate :: IfRate -> E -> E setIfRate rate = setRate (fromIfRate rate) -when1 :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m ()+when1 :: Monad m => IfRate -> E -> DepT m () -> DepT m () when1 ifRate p body = void $ ifT1 ifRate p body -whens :: Monad m => IfRate -> [(E, DepT m (CodeBlock E))] -> DepT m (CodeBlock E) -> DepT m ()+whens :: Monad m => IfRate -> [(E, DepT m ())] -> DepT m () -> DepT m () whens rate bodies el =   void $ List.foldl' go el (List.reverse bodies)   where-    go res (check, th) = CodeBlock <$> ifT rate check th res+    go res (check, th) = ifT rate check th res  ifElseBlock :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m (CodeBlock E) -> DepT m () ifElseBlock rate p th el = void $ ifElseBlock rate p th el -{--ifElseBlock' :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m (CodeBlock E) -> DepT m (CodeBlock E)-ifElseBlock' ifRate p th el = do-  thE <- th-  elE <- el-  fmap CodeBlock $ depT $ noRate $-    IfElseBlock ifRate-      (condInfo $ setIfRate ifRate p)-      (PrimOr . Right <$> thE)-      (PrimOr . Right <$> elE)--}--- withCond ifRate stmt p = depT_ $ noRate $ stmt (condInfo $ setIfRate ifRate p)--{--ifBegin :: Monad m => IfRate -> E -> DepT m ()-ifBegin ifRate = withCond ifRate $ (IfBegin ifRate)--elseBegin :: Monad m => DepT m ()-elseBegin = stmtOnlyT ElseBegin--ifEnd :: Monad m => DepT m ()-ifEnd = stmtOnlyT IfEnd--}--untilBlock :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m ()+untilBlock :: Monad m => IfRate -> E -> DepT m () -> DepT m () untilBlock ifRate p body = void $ untilT ifRate p body -whileBlock :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m ()+whileBlock :: Monad m => IfRate -> E -> DepT m () -> DepT m () whileBlock ifRate p body = void $ whileT ifRate p body -{--untilDo :: Monad m => IfRate -> E -> DepT m () -> DepT m ()-untilDo ifRate p body = do-    untilBegin ifRate p-    body-    untilEnd--untilBegin :: Monad m => IfRate -> E -> DepT m ()-untilBegin ifRate = withCond ifRate (UntilBegin ifRate)--untilEnd :: Monad m => DepT m ()-untilEnd = stmtOnlyT UntilEnd--}--{--whileDo :: Monad m => IfRate -> E -> DepT m () -> DepT m ()-whileDo ifRate p body = do-    whileBegin ifRate p-    body-    whileEnd--whileBegin :: Monad m => IfRate -> E -> DepT m ()-whileBegin ifRate = withCond IfKr (WhileBegin ifRate)--}--whileRef :: Monad m => Var -> DepT m ()-whileRef var = stmtOnlyT $ WhileRefBegin var- whileEnd :: Monad m => DepT m () whileEnd = stmtOnlyT WhileEnd -{--withCond :: Monad m => IfRate -> (CondInfo (PrimOr E) -> MainExp (PrimOr E)) -> E -> DepT m ()-withCond ifRate stmt p = depT_ $ noRate $ stmt (condInfo $ setIfRate ifRate p)--}- instance Boolean E where     true = boolOp0 TrueOp     false = boolOp0 FalseOp@@ -190,30 +107,31 @@  ifExp :: IfRate -> E -> E -> E -> E ifExp ifRate c = mkCond (condInfo (setIfRate ifRate c))-    where mkCond :: CondInfo (PrimOr E) -> E -> E -> E-          mkCond pr th el-            | isTrue pr = th-            | isFalse pr = el-            | otherwise = noRate $ If ifRate pr (toPrimOr th) (toPrimOr el)+  where+    mkCond :: CondInfo (PrimOr E) -> E -> E -> E+    mkCond pr th el+      | isTrue pr = th+      | isFalse pr = el+      | otherwise = noRate $ If ifRate pr (toPrimOr th) (toPrimOr el)  condInfo :: E -> CondInfo (PrimOr E) condInfo p = go $ toPrimOr p-    where-        go :: PrimOr E -> CondInfo (PrimOr E)-        go expr = (\(a, b) -> Inline a (IM.fromList b)) $ evalState (condInfo' expr) 0+  where+    go :: PrimOr E -> CondInfo (PrimOr E)+    go expr = (\(a, b) -> Inline a (IM.fromList b)) $ evalState (condInfo' expr) 0 -        condInfo' :: PrimOr E -> State Int (InlineExp CondOp, [(Int, PrimOr E)])-        condInfo' e = maybe (onLeaf e) (onExpr e) $ parseNode e+    condInfo' :: PrimOr E -> State Int (InlineExp CondOp, [(Int, PrimOr E)])+    condInfo' e = maybe (onLeaf e) (onExpr e) $ parseNode e -        onLeaf e = state $ \n -> ((InlinePrim n, [(n, e)]), n+1)+    onLeaf e = state $ \n -> ((InlinePrim n, [(n, e)]), n+1) -        onExpr  _ (op, args) = fmap mkNode $ mapM condInfo' args-            where mkNode as = (InlineExp op (map fst as), concat $ map snd as)+    onExpr  _ (op, args) = fmap mkNode $ mapM condInfo' args+        where mkNode as = (InlineExp op (map fst as), concat $ map snd as) -        parseNode :: PrimOr E -> Maybe (CondOp, [PrimOr E])-        parseNode x = case unPrimOr $ fmap toExp x of-          Right (ExpBool (PreInline op args)) -> Just (op, args)-          _ -> Nothing+    parseNode :: PrimOr E -> Maybe (CondOp, [PrimOr E])+    parseNode x = case unPrimOr $ fmap toExp x of+      Right (ExpBool (PreInline op args)) -> Just (op, args)+      _ -> Nothing  -------------------------------------------------------------------------------- -- constructors for boolean expressions

@@ -0,0 +1,24 @@+module Csound.Dynamic.Debug+  ( IsDebug (..)+  , traceIf+  , traceShowIf+  ) where++import Debug.Trace (trace, traceShow)+import Data.Default++newtype IsDebug = IsDebug Bool+  deriving newtype (Show, Eq, Ord, Read)++instance Default IsDebug where+  def = IsDebug False++traceIf :: IsDebug -> String -> a -> a+traceIf (IsDebug isDebug) str a+  | not isDebug = a+  | otherwise = trace str a++traceShowIf :: Show b => IsDebug -> b -> a -> a+traceShowIf (IsDebug isDebug) debugValue a+  | not isDebug = a+  | otherwise   = traceShow debugValue a

@@ -11,9 +11,12 @@ import Csound.Dynamic.Types import Csound.Dynamic.Tfm.InferTypes as X (InferenceOptions (..), OpcodeInferenceStrategy (..)) import Data.Default+import Text.PrettyPrint.Leijen.Text qualified as Pretty+import Data.Text (Text)+import Data.Text.Lazy qualified as Lazy.Text  data RenderOptions = RenderOptions-  { inferenceOptions :: !InferenceOptions+  { inferenceOptions :: InferenceOptions   }   deriving (Eq, Ord, Show, Read) @@ -22,8 +25,8 @@           { inferenceOptions = def           } -renderCsd :: RenderOptions -> Csd -> String-renderCsd opts a = show $ ppCsdFile+renderCsd :: RenderOptions -> Csd -> Text+renderCsd opts a = Lazy.Text.toStrict $ Pretty.displayT $ Pretty.renderPretty 0.4 80 $ ppCsdFile     (renderFlags $ csdFlags a)     (renderOrc (inferenceOptions opts) $ csdOrc a)     (renderSco   $ csdSco a)

@@ -16,10 +16,11 @@ import Csound.Dynamic.Tfm.UnfoldMultiOuts import Csound.Dynamic.Tfm.IfBlocks import Csound.Dynamic.Tfm.Liveness+import Csound.Dynamic.Tfm.TmpVars  import Csound.Dynamic.Types hiding (Var)+import Csound.Dynamic.Debug import Csound.Dynamic.Render.Pretty--- import Debug.Trace  type Dag f = [(Int, f Int)] @@ -32,7 +33,7 @@   | otherwise = render dag     where       dag = toDag a-      render = P.vcat . flip evalState 0 . mapM (uncurry ppStmt . clearEmptyResults) . collectRates opts+      render = P.vcat . flip evalState 0 . mapM (uncurry ppStmt . clearEmptyResults) . collectRates opts . removeTmpVars . (\p -> traceIf opts.opcodeInferenceDebug (ppDag p) p)  ------------------------------------------------------------- -- E -> Dag@@ -64,8 +65,20 @@     inferRes2 = inferRes1 { Infer.typedProgram = filterDepCases $ Infer.typedProgram inferRes1 }     inferRes1 = collectIfBlocks inferRes     inferRes = Infer.inferTypes opts $ fmap (uncurry Infer.Stmt) $-        -- (\a -> trace (unlines ["DAG", unlines $ fmap (\(ls, rs) -> unwords [show ls, "=", show $ fmap (either (const (-1)) id . unPrimOr) $ ratedExpExp rs]) a]) $ a)+        (\a -> traceIf opts.opcodeInferenceDebug (ppDag a) a)         dag++ppDag :: Dag RatedExp -> String+ppDag a =+  unlines+    [ "DAG"+    , unlines $+        fmap (\(ls, rs) -> unwords+          [ show ls, "="+          , show $ fmap (either show show . unPrimOr) $ ratedExpExp rs+          , maybe "" (("| rate: " <> ) . show) (ratedExpRate rs)+          ] ) a+    ]  ----------------------------------------------------------- -- Dag -> Dag

@@ -8,6 +8,7 @@ import Control.Monad.Trans.State.Strict import qualified Data.IntMap as IM +import Data.String import Text.PrettyPrint.Leijen.Text import Csound.Dynamic.Types import Csound.Dynamic.Tfm.InferTypes qualified as R(Var(..))@@ -62,15 +63,19 @@     <+> double (csdEventStart evt) <+> double (csdEventDur evt)     <+> hsep (fmap ppPrim $ csdEventContent evt) +ppStr :: Text -> Doc+ppStr = textStrict . Text.pack . show+ ppPrim :: Prim -> Doc ppPrim x = case x of-    P n -> char 'p' <> int n+    P _rate n -> char 'p' <> int n     PrimInstrId a -> ppInstrId a     PString a -> int a     PrimInt n -> int n     PrimDouble d -> double d-    PrimString s -> dquotes $ textStrict s+    PrimString s -> ppStr s     PrimVar targetRate v -> ppConverter targetRate (varRate v) $ ppVar v+    PrimTmpVar v -> ppTmpVar v     where         ppConverter dst src t             | dst == src = t@@ -86,6 +91,15 @@                 k = tfm 'k'                 i = tfm 'i' +ppTmpVar :: TmpVar -> Doc+ppTmpVar (TmpVar mRate _mInfo n) =+  "tmp_var_"+  <> int n+  <> maybe mempty (\r -> "_" <> ppTmpRate r) mRate+  where+    ppTmpRate = \case+      SingleTmpRate r -> ppRate r+      MultiTmpRate rs -> "multi_rate_" <> hcat (punctuate "_" (fmap ppRate rs))  ppGen :: Int -> Gen -> Doc ppGen tabId ft = char 'f'@@ -99,7 +113,7 @@ ppGenId :: GenId -> Doc ppGenId x = case x of     IntGenId a      -> int a-    StringGenId a   -> dquotes $ textStrict a+    StringGenId a   -> ppStr a  ppInstr :: InstrId -> Doc -> Doc ppInstr instrId body = vcat [@@ -116,7 +130,7 @@ ppInstrId :: InstrId -> Doc ppInstrId x = case x of     InstrId den nom -> int nom <> maybe empty ppAfterDot den-    InstrLabel name -> dquotes $ textStrict name+    InstrLabel name -> ppStr name     where ppAfterDot a = textStrict $ Text.pack $ ('.': ) $ reverse $ show a  type TabDepth = Int@@ -126,16 +140,22 @@  maybeStringCopy :: [R.Var] -> Exp R.Var -> Maybe (State TabDepth Doc) maybeStringCopy outs expr = case (outs, expr) of-    ([R.Var Sr _], ExpPrim (PrimVar _rate var)) -> Just $ tab $ ppStringCopy (ppOuts outs) (ppVar var)-    ([R.Var Sr _], ReadVar var) -> Just $ tab $ ppStringCopy (ppOuts outs) (ppVar var)-    ([], WriteVar outVar a) | varRate outVar == Sr  -> Just $ tab $ ppStringCopy (ppVar outVar) (ppPrimOrVar a)-    ([R.Var Sr _], ReadArr var as) -> Just $ tab $ ppStringCopy (ppOuts outs) (ppReadArr var $ fmap ppPrimOrVar as)-    ([], WriteArr outVar bs a) | varRate outVar == Sr -> Just $ tab $ ppStringCopy (ppArrIndex outVar $ fmap ppPrimOrVar bs) (ppPrimOrVar a)+    ([R.Var Sr _], ExpPrim (PrimVar _rate var)) -> Just $ tab $ ppStringCopy IfIr (ppOuts outs) (ppVar var)+    ([R.Var Sr _], ReadVar ifRate var) -> Just $ tab $ ppStringCopy ifRate (ppOuts outs) (ppVar var)+    ([R.Var Sr _], ReadVarTmp ifRate _tmp var) -> Just $ tab $ ppStringCopy ifRate (ppOuts outs) (ppVar var)+    ([], WriteVar ifRate outVar a) | varRate outVar == Sr -> Just $ tab $ ppStringCopy ifRate (ppVar outVar) (ppPrimOrVar a)+    ([R.Var Sr _], ReadArr ifRate var as) -> Just $ tab $ ppStringCopy ifRate (ppOuts outs) (ppReadArr var $ fmap ppPrimOrVar as)+    ([], WriteArr ifRate outVar bs a) | varRate outVar == Sr -> Just $ tab $ ppStringCopy ifRate (ppArrIndex outVar $ fmap ppPrimOrVar bs) (ppPrimOrVar a)     _ -> Nothing -ppStringCopy :: Doc -> Doc -> Doc-ppStringCopy outs src = ppOpc outs "strcpyk" [src]+ppStringCopy :: IfRate -> Doc -> Doc -> Doc+ppStringCopy ifRate outs src = ppOpc outs (strcpy ifRate) [src] +strcpy :: IsString a => IfRate -> a+strcpy = \case+  IfKr -> "strcpyk"+  IfIr -> "strcpy"+ ppExp :: Doc -> Exp R.Var -> State TabDepth Doc ppExp res expr = case fmap ppPrimOrVar expr of     ExpPrim (PString n)             -> tab $ ppStrget res n@@ -143,17 +163,42 @@     Tfm info [a, b] | isInfix  info -> tab $ res $= binary (infoName info) a b     Tfm info xs     | isPrefix info -> tab $ res $= prefix (infoName info) xs     Tfm info xs                     -> tab $ ppOpc res (infoName info) xs+    TfmInit _ _ _                   -> error "TfmInit should not stay to the rendering stage, it's temporal"     ConvertRate to from x           -> tab $ ppConvertRate res to from x     If _ifRate info t e             -> tab $ ppIf res (ppCond info) t e     ExpNum (PreInline op as)        -> tab $ res $= ppNumOp op as-    WriteVar v a                    -> tab $ ppVar v $= a+    WriteVar ifRate v a                    ->+      case ifRate of+        IfKr -> tab $ ppVar v $= a+        IfIr -> tab $ ppVar v <+> "init" <+> a     InitVar v a                     -> tab $ ppOpc (ppVar v) "init" [a]-    ReadVar v                       -> tab $ res $= ppVar v+    ReadVar ifRate v                  ->+      case ifRate of+        IfIr -> tab $ res <+> "init" <+> ppVar v+        IfKr -> tab $ res $= ppVar v+    ReadVarTmp ifRate _tmp v                  ->+      case ifRate of+        IfIr -> tab $ res <+> "init" <+> ppVar v+        IfKr -> tab $ res $= ppVar v      InitArr v as                    -> tab $ ppOpc (ppArrVar (length as) (ppVar v)) "init" as-    ReadArr v as                    -> tab $ if (varRate v /= Sr) then res $= ppReadArr v as else res <+> text "strcpy" <+> ppReadArr v as-    WriteArr v as b                 -> tab $ ppWriteArr v as b-    WriteInitArr v as b             -> tab $ ppWriteInitArr v as b+    ReadArr ifRate v as                    ->+      tab $ if (varRate v /= Sr)+        then+          case ifRate of+            IfKr -> res $= ppReadArr v as+            IfIr -> res <+> "init" <+> ppReadArr v as+        else res <+> strcpy ifRate <+> ppReadArr v as+    ReadArrTmp ifRate _tmp v as                    ->+      tab $+        if (varRate v /= Sr)+          then+            case ifRate of+              IfKr -> res $= ppReadArr v as+              IfIr -> res <+> "init" <+> ppReadArr v as+          else res <+> strcpy ifRate <+> ppReadArr v as+    WriteArr ifRate v as b                 -> tab $ ppWriteArr ifRate v as b+    WriteInitArr ifRate v as b             -> tab $ ppWriteInitArr ifRate v as b     TfmArr isInit v op [a,b]| isInfix  op  -> tab $ ppTfmArrOut isInit v <+> binary (infoName op) a b     TfmArr isInit v op args | isPrefix op  -> tab $ ppTfmArrOut isInit v <+> prefix (infoName op) args     TfmArr isInit v op xs                  -> tab $ ppOpc (ppTfmArrOut isInit v) (infoName op) xs@@ -169,12 +214,10 @@     IfEnd                           -> left >> (tab     $ text "endif")     UntilBlock _ cond (CodeBlock th) -> tab $ ppUntil res (ppCond cond)  th     WhileBlock _ cond (CodeBlock th) -> tab $ ppWhile res (ppCond cond)  th-    WhileRefBlock var (CodeBlock th) -> tab $ ppWhileRef res var th      UntilBegin _ a                  -> succTab          $ text "until " <> ppCond a <> text " do"     UntilEnd                        -> left >> (tab     $ text "od")     WhileBegin _ a                  -> succTab          $ text "while " <> ppCond a <> text " do"-    WhileRefBegin var               -> succTab          $ text "while " <> ppVar var <+> equals <+> text "1" <+> text "do"     WhileEnd                        -> left >> (tab     $ text "od")     InitMacrosString name initValue -> tab $ initMacros (textStrict name) (textStrict initValue)     InitMacrosDouble name initValue -> tab $ initMacros (textStrict name) (double initValue)@@ -222,13 +265,13 @@ ppReadPureArr :: Doc -> [Doc] -> Doc ppReadPureArr v as = v <> (hcat $ fmap brackets as) -ppWriteArr :: Var -> ArrIndex Doc -> Doc -> Doc-ppWriteArr v as b = ppArrIndex v as <+> equalsWord <+> b-    where equalsWord = if (varRate v == Sr) then text "strcpy" else equals+ppWriteArr :: IfRate -> Var -> ArrIndex Doc -> Doc -> Doc+ppWriteArr ifRate v as b = ppArrIndex v as <+> equalsWord <+> b+    where equalsWord = if (varRate v == Sr) then strcpy ifRate else equals -ppWriteInitArr :: Var -> [Doc] -> Doc -> Doc-ppWriteInitArr v as b = ppArrIndex v as <+> initWord <+> b-    where initWord = text $ if (varRate v == Sr) then "strcpy" else "init"+ppWriteInitArr :: IfRate -> Var -> [Doc] -> Doc -> Doc+ppWriteInitArr ifRate v as b = ppArrIndex v as <+> initWord <+> b+    where initWord = text $ if (varRate v == Sr) then (strcpy ifRate) else "init"  ------------------------------------- @@ -292,13 +335,6 @@     , text "endif"     ] -ppWhileRef :: Doc -> Var -> Doc -> Doc-ppWhileRef res p t = vcat-    [ textStrict "while" <+> ppVar p <+> text "then"-    , text "    " <> res <+> char '=' <+> t-    , text "endif"-    ]- ppOpc :: Doc -> Text -> [Doc] -> Doc ppOpc out name xs = out <+> ppProc name xs @@ -332,7 +368,7 @@     (Kr, Nothing) -> out $= toK var     (Ir, Nothing) -> out $= toI var     (a, Just b) | a == b -> out $= var-    (a, b)   -> error $ "bug: no rate conversion from " ++ show b ++ " to " ++ show a ++ "."+    (a, b)   -> hsep ["bug: no rate conversion from ", pretty (show b), "to", pretty (show a)]     where         upsamp x = ppOpc out "upsamp" [x]         downsamp x = ppOpc out "downsamp" [x]@@ -417,32 +453,43 @@         , maybe mempty pretty ratedExpDepends         ] -    ppHash = textStrict . Text.take 4 . Text.decodeUtf8 . Base64.encode+    ppHash = textStrict . Text.take 4 . Text.decodeUtf8 . Base64.encode . unExpHash +    ppIndex index = either ppPrim id (unPrimOr index)++    ppSize sizes = parens ("Size" <+> hcat (fmap ppIndex sizes))++    ppIfRate = ppRate . fromIfRate+     fromExp :: Doc -> RatedExp Doc -> Doc     fromExp info RatedExp{..} = indent 2 $ post $       case ratedExpExp of         ExpPrim p -> ppPrim p         EmptyExp -> textStrict "EMPTY_EXPR"         Tfm inf args -> ppTfm inf args+        TfmInit v inf args -> ppTfmInit v inf args         ConvertRate to from a -> ppConvert to from a         Select r n a -> ppSelect r n a         If rate cond th el -> ppIff rate cond th el         ExpBool args -> hsep ["some bool expr", pretty $ show args]         ExpNum arg -> ppExpNum arg         InitVar v a -> ppInitVar v a-        ReadVar v -> "ReadVar" <+> ppVar v-        WriteVar v a -> ppVar v $= pp a+        ReadVar ifRate v -> "ReadVar" <+> ppIfRate ifRate <+> ppVar v+        ReadVarTmp ifRate tmp v -> hcat [ppTmpVar tmp, "=", "ReadVarTmp" <+> ppIfRate ifRate <+> ppVar v]+        WriteVar ifRate v a ->+          case ifRate of+            IfKr -> ppVar v $= pp a+            IfIr -> ppVar v <+> "init" <+> pp a -        -- TODO-        InitArr _v _size -> undefined-        ReadArr _v _index -> undefined-        WriteArr _v _index _ -> undefined-        WriteInitArr _v _index _ -> undefined-        TfmArr _isInit _v _info _args -> undefined+        InitArr v size -> "InitArr" <+> ppVar v <+> ppSize size+        ReadArr ifRate v index -> "ReadArr" <+> ppIfRate ifRate <+> ppVar v <+> (hcat $ fmap ppIndex index)+        ReadArrTmp ifRate tmp v index -> hcat [ppTmpVar tmp, "=", "ReadArrTmp", ppIfRate ifRate, ppVar v, (hcat $ fmap ppIndex index)]+        WriteArr ifRate v index _ -> "WriteArr" <+> ppIfRate ifRate <+> ppVar v <+> (hcat $ fmap ppIndex index)+        WriteInitArr ifRate v index _ -> "WriteInitArr" <+> ppIfRate ifRate <+> ppVar v <+> (hcat $ fmap ppIndex index)+        TfmArr isInit v inf args -> "TfmArr" <+> bool isInit <+> ppVar v <+> ppTfm inf args -        InitPureArr _outRate _procRate _vals -> undefined-        ReadPureArr _outRate _procRate _arr _index -> undefined+        InitPureArr outRate procRate vals -> "InitPureArr" <+> ppRate outRate <+> ppIfRate procRate <+> (hcat $ fmap ppIndex vals)+        ReadPureArr outRate procRate arr index -> "ReadPureArr" <+> ppRate outRate <+> ppIfRate procRate <+> ppIndex arr <+> ppIndex index          IfBegin rate cond -> hsep ["IF", ppRate $ fromIfRate rate, ppCond $ fmap pp cond, "\n"] @@ -459,12 +506,10 @@         UntilBegin rate cond -> hsep ["UNTIL", ppRate $ fromIfRate rate, ppCond $ fmap pp cond, "\n"]         UntilEnd -> "END_UNTIL"         WhileBegin rate cond -> hsep ["WHILE", ppRate $ fromIfRate rate, ppCond $ fmap pp cond, "\n"]-        WhileRefBegin v -> hsep ["WHILE_REF", ppVar v]         WhileEnd -> "END_WHILE"          UntilBlock rate cond (CodeBlock th) -> ppIfBlockBy "UNTIL-BLOCK" rate cond th         WhileBlock rate cond (CodeBlock th) -> ppIfBlockBy "WHILE-BLOCK" rate cond th-        WhileRefBlock var (CodeBlock th) -> ppWhileRefBlock var th          Verbatim txt -> ppFun "VERBATIM" [textStrict txt]         Starts -> "STARTS"@@ -485,13 +530,9 @@         , "END-BLOCK"         ] -    ppWhileRefBlock var th =-      ppFun (hsep ["WHILE-REF-BLOCK", ppVar var])-        [ pp th-        , "END-BLOCK"-        ]-     ppTfm info args = ppFun (textStrict $ infoName info) (fmap pp args)++    ppTfmInit v info args = hcat [ppTmpVar v, "=", ppFun (textStrict $ infoName info) (fmap pp args)]      ppConvert to from a =       ppFun (hsep [textStrict "Convert-rate", ppRate to, maybe mempty ppRate from]) [pp a]

@@ -1,4 +1,4 @@--- | We collect all if-blocks under the if-the-else expressions and statements.+-- | We collect all if-blocks under the if-then-else expressions and statements. -- -- For a given if-block of code the taks is to agregate all expressions -- that can be used inside that block and don't affect external expressions@@ -182,13 +182,21 @@ --------------------------------------------------------------------------- -- working with DAG-graph -traverseAccumDag :: forall s a . Show a => (Expr -> a -> Collect s a) -> a -> (Expr -> Collect s Bool) -> PrimOr Var -> Collect s a+traverseAccumDag ::+  forall s a .+  Show a =>+  (Expr -> a -> Collect s a) ->+  a ->+  (Expr -> Collect s Bool) ->+  PrimOr Var ->+  Collect s a traverseAccumDag update initSt getIsEnd (PrimOr root) = do   case root of     Left _    -> pure initSt     Right var -> do       ref <- lift $ newSTRef initSt-      traverseDag var getIsEnd (go ref)+      visitedRef <- lift $ newSTRef IntSet.empty+      traverseDag visitedRef var getIsEnd (go ref)       lift $ readSTRef ref   where     go :: STRef s a -> Expr -> Collect s ()@@ -200,14 +208,16 @@         newVal  -- | Breadth first traversal-traverseDag :: Var -> (Expr -> Collect s Bool) -> (Expr -> Collect s ()) -> Collect s ()-traverseDag root getIsEnd go =-  withDag root $ \expr -> do-    isTerminal <- getIsEnd expr-    unless isTerminal $ do-      go expr-      mapM_ (\var -> traverseDag var getIsEnd go) (stmtRhs expr)-+traverseDag :: STRef s IntSet -> Var -> (Expr -> Collect s Bool) -> (Expr -> Collect s ()) -> Collect s ()+traverseDag visitedRef root getIsEnd go = do+  visited <- lift $ readSTRef visitedRef+  unless (IntSet.member (varId root) visited) $ do+    lift $ modifySTRef' visitedRef (IntSet.insert (varId root))+    withDag root $ \expr -> do+      isTerminal <- getIsEnd expr+      unless isTerminal $ do+        go expr+        mapM_ (\var -> traverseDag visitedRef var getIsEnd go) (stmtRhs expr)  ----------------------------------------------------------- @@ -477,7 +487,7 @@       varWriteId <- freshId       pure $ Stmt         { stmtLhs = Var Xr varWriteId-        , stmtRhs = toRatedExp $ WriteVar (toVar resId) expr+        , stmtRhs = toRatedExp $ WriteVar ifRate (toVar resId) expr         }      toVar v = Exp.VarVerbatim (varType v) name@@ -488,7 +498,7 @@ toRatedExp :: MainExp (PrimOr a) -> RatedExp a toRatedExp expr =   RatedExp-    { ratedExpHash = ""+    { ratedExpHash = ExpHash ""     , ratedExpDepends = Nothing     , ratedExpRate = Nothing     , ratedExpExp = expr@@ -507,6 +517,8 @@       | isParentLocal = do           isLocal <- fullyInsideLocal lhs           let tfm = if isLocal then id else onFalseLocal+          -- when (varId lhs == 92)+          --   $ trace (unwords ["IS 92:", show isLocal]) $ pure ()           pure $ tfm $ IntMap.alter (Just . maybe isLocal (isLocal &&)) (varId lhs) localMarks       | otherwise = pure $ onFalseLocal localMarks       where@@ -519,6 +531,9 @@     fullyInsideLocal lhs = do       globalCount <- readGlobalUsages (varId lhs)       let localCount = IntMap.lookup (varId lhs) localUsages+      -- how to do node specific debug:+      -- when (varId lhs == 92)+      --  $ trace (unwords ["IS 92:", "global:", show globalCount, "local:", show localCount]) $ pure ()       pure $ Just globalCount == localCount      toSet :: LocalMarks -> LocalVars@@ -568,6 +583,4 @@       IfElseType rate c th el $ IfElseCons { ifElseBegin = IfBegin, elseBegin = ElseBegin, ifElseEnd = IfEnd }     WhileBlock rate c (CodeBlock th) -> IfType rate c th $ IfCons { ifBegin = WhileBegin, ifEnd = WhileEnd }     UntilBlock rate c (CodeBlock th) -> IfType rate c th $ IfCons { ifBegin = UntilBegin, ifEnd = UntilEnd }-    -- TODO:-    --     While Ref case     _ -> PlainType

@@ -32,6 +32,7 @@   , Var(..)   ) where +import Control.Applicative ((<|>)) import Safe import Control.Monad (zipWithM, foldM) import Data.Semigroup (Min(..))@@ -39,7 +40,6 @@ import Control.Monad.Trans.State.Strict import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map-import Data.ByteString (ByteString) import Data.Default import Data.HashSet (HashSet) import Data.HashSet qualified as HashSet@@ -51,6 +51,7 @@ import Data.IntMap qualified as IntMap import Data.Text qualified as Text +import Csound.Dynamic.Debug import Csound.Dynamic.Const qualified as Const import Csound.Dynamic.Types.Exp hiding (Var, varType) import Csound.Dynamic.Types.Exp qualified as Exp@@ -77,12 +78,14 @@       -- ^ does program has if-statemenrs       -- we need it for the next optimization stage   }+  deriving (Show)  -- option types  data InferenceOptions = InferenceOptions   { opcodeInferenceStrategy    :: !OpcodeInferenceStrategy   , opcodeInferencePreference  :: !OpcodeInferencePreference+  , opcodeInferenceDebug       :: !IsDebug   }   deriving (Eq, Ord, Show, Read) @@ -148,7 +151,7 @@ type OpcSignature = (Rate, [Rate])  preferOpc :: InferenceOptions -> Name -> Map Rate [Rate] -> Either [OpcSignature] OpcSignature-preferOpc (InferenceOptions strategy opcPrefs) name signatureMap+preferOpc (InferenceOptions strategy opcPrefs _isDebug) name signatureMap   | Just sig <- getControl = Right sig   | Just sig <- getAudio   = Right sig   | otherwise              = Left $@@ -171,6 +174,7 @@           { preferControlOpcodes = Const.controlOpcodes           , preferAudioOpcodes   = Const.audioOpcodes           }+    , opcodeInferenceDebug = def     }  -------------------------------------------------------------------------------------@@ -195,8 +199,9 @@      -- | Reading/writing a named variable     InitVar v arg -> onInitVar v arg-    ReadVar v -> onReadVar v-    WriteVar v arg -> onWriteVar v arg+    ReadVar ifRate v -> onReadVar ifRate (ratedExpRate rhs) v+    ReadVarTmp ifRate tmp v -> onReadVarTmp ifRate (ratedExpRate rhs) tmp v+    WriteVar ifRate v arg -> onWriteVar ifRate v arg      -- | Selects a cell from the tuple, here argument is always a tuple (result of opcode that returns several outputs)     -- | if-then-else@@ -213,9 +218,10 @@      -- | Arrays     InitArr v arrSize -> onInitArr v arrSize-    ReadArr v index -> onReadArr v index-    WriteArr v index val -> onWriteArr v index val-    WriteInitArr v arrSize initVal -> onWriteInitArr v arrSize initVal+    ReadArr ifRate v index -> onReadArr ifRate v index+    ReadArrTmp ifRate tmp v index -> onReadArrTmp ifRate tmp v index+    WriteArr ifRate v index val -> onWriteArr ifRate v index val+    WriteInitArr ifRate v arrSize initVal -> onWriteInitArr ifRate v arrSize initVal     TfmArr isArrInit v info args -> onTfmArr isArrInit v info args      -- | Pure arrays (read-only)@@ -233,12 +239,10 @@     -- | looping constructions     UntilBlock ifRate cond th -> onUntilBlock ifRate cond th     WhileBlock ifRate cond th -> onWhileBlock ifRate cond th-    WhileRefBlock var th -> onWhileRefBlock var th      UntilBegin ifRate cond -> onUntilBegin ifRate cond     UntilEnd -> saveProcedure UntilEnd     WhileBegin ifRate cond -> onWhileBegin ifRate cond-    WhileRefBegin v -> saveProcedure (WhileRefBegin v)     WhileEnd -> saveProcedure WhileEnd      EmptyExp  -> saveProcedure EmptyExp@@ -248,6 +252,7 @@     Seq a b -> saveProcedure (Seq (setXr a) (setXr b))     Ends a -> saveProcedure (Ends (setXr a)) +    TfmInit _ _ _ -> error "No inference for TfmInit"   where     onPrim p = save rate (ExpPrim p)       where@@ -341,13 +346,27 @@           argVar <- mapM (getVar Ir) arg           pure (InitVar v argVar) -    onReadVar v = save (Exp.varRate v) (ReadVar v)+    onReadVar ifRate mRate v =+      save (fromMaybe varRate mRate) (withConvert v)+      where+        varRate = Exp.varRate v -    onWriteVar v arg = saveProcedure =<< typedRhs+        withConvert var =+          case mRate of+            Nothing -> ReadVar ifRate var+            Just target | target == varRate -> ReadVar ifRate var+            Just target -> ExpPrim (PrimVar target var)++    onReadVarTmp ifRate mRate tmp v =+      save+        (fromMaybe (Exp.varRate v) ((if ifRate == IfIr then Just Ir else Nothing) <|> mRate <|> (getSingleTmpRate =<< tmpVarRate tmp)))+        (ReadVarTmp ifRate tmp v)++    onWriteVar ifRate v arg = saveProcedure =<< typedRhs       where         typedRhs = do           argVar <- mapM (getVar (Exp.varRate v)) arg-          pure $ WriteVar v argVar+          pure $ WriteVar ifRate v argVar      onExpNum args = do       argVars <- mapM (mapM $ getVar Ir) args@@ -389,10 +408,6 @@      onWhileBlock = onIfBlockBy WhileBlock -    onWhileRefBlock var th = do-      setHasIfs-      saveProcedure (WhileRefBlock var (fmap (Var Xr) <$> th))-     onIfBlockBy cons ifRate cond th = do       setHasIfs       condVar <- mapM (mapM $ getVar condMaxRate) cond@@ -430,22 +445,27 @@       typedArrSize <- mapM (mapM (getVar Ir)) arrSize       saveProcedure (InitArr v typedArrSize) -    onReadArr v index = save (Exp.varRate v) . ReadArr v =<< typedIndex+    onReadArr ifRate v index = save (Exp.varRate v) . ReadArr ifRate v =<< typedIndex       where         indexRate = getArrIndexRate v         typedIndex = mapM (mapM (getVar indexRate)) index -    onWriteArr v index arg = do+    onReadArrTmp ifRate tmp v index = save (Exp.varRate v) . ReadArrTmp ifRate tmp v =<< typedIndex+      where+        indexRate = getArrIndexRate v+        typedIndex = mapM (mapM (getVar indexRate)) index++    onWriteArr ifRate v index arg = do       typedIndex <- mapM (mapM (getVar indexRate)) index       argVar <- mapM (getVar (Exp.varRate v)) arg-      saveProcedure (WriteArr v typedIndex argVar)+      saveProcedure (WriteArr ifRate v typedIndex argVar)       where         indexRate = getArrIndexRate v -    onWriteInitArr v arrSize initVal = do+    onWriteInitArr ifRate v arrSize initVal = do       typedArrSize <- mapM (mapM (getVar Ir)) arrSize       typedInitVal <- mapM (getVar (Exp.varRate v)) initVal-      saveProcedure (WriteInitArr v typedArrSize typedInitVal)+      saveProcedure (WriteInitArr ifRate v typedArrSize typedInitVal)      getArrIndexRate v=       case Exp.varRate v of@@ -494,7 +514,7 @@     save rate typedRhs =       saveStmt $ Stmt         { stmtLhs = Var rate lhs-        , stmtRhs = rhs { ratedExpExp = typedRhs }+        , stmtRhs = rhs { ratedExpExp = typedRhs, ratedExpDepends = Nothing }         }      -- procedure does not save output rate to type map, as it's never going to@@ -505,7 +525,7 @@     saveProcedure typedRhs =       appendResult $ Stmt         { stmtLhs = Var Xr lhs-        , stmtRhs = rhs { ratedExpExp = typedRhs }+        , stmtRhs = rhs { ratedExpExp = typedRhs, ratedExpDepends = Nothing }         }  -------------------------------------------------------------@@ -632,8 +652,8 @@     }  -- | On this stage we don't need expression hashes anymore-ignoreHash :: ByteString-ignoreHash = ""+ignoreHash :: ExpHash+ignoreHash = ExpHash ""  -- | Allocate new var and assign RHS expression to it defineVar :: Rate -> RatedExp Var -> Infer s Var@@ -684,9 +704,11 @@  primRate :: Prim -> Rate primRate = \case-  PrimString _ -> Sr-  PrimVar r _  -> r-  _            -> Ir+  PrimString _      -> Sr+  PrimVar r _       -> r+  P r _             -> r+  PrimInstrId instr -> instrIdRate instr+  _                 -> Ir  primOrRate :: PrimOr Var -> Rate primOrRate = either primRate varType . unPrimOr

@@ -0,0 +1,119 @@+-- | In this module we substitute temporary vars with graph vars+--+-- After this stage no TmpVars should left in the DAg.+-- typical problems: TmpVar is not inlined by some reason in the next expression down the flow.+--+-- Assumption: every tmpVar is inlined in the next expression+module Csound.Dynamic.Tfm.TmpVars+  ( removeTmpVars+  ) where++import Control.Monad.Trans.State.Strict+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IntMap+import Data.Maybe+import Control.Monad+-- import Debug.Trace++import Csound.Dynamic.Types.Exp+  ( RatedExp (..),+    TmpVar (..),+    MainExp (..),+    PrimOr (..),+    Prim (..),+    Rate (..),+    getTmpVars,+    IfRate (..),+    Info (..),+    TmpVarRate (..),+    getSingleTmpRate,+  )++type Node f = (Int, f Int)+type Dag f = [Node f]++type RemoveTmp a = State St a++data St = St+  { stIds :: IntMap Int+    -- ^ ids of tmp vars LHS in equations+  , stRates :: IntMap (Maybe TmpVarRate, Maybe Info)+    -- ^ rates if requested for TmpVar's+  }+  deriving (Show)++removeTmpVars :: Dag RatedExp -> Dag RatedExp+removeTmpVars dag = flip evalState (St IntMap.empty IntMap.empty) $ do+  mapM_ (mapM_ saveTmpVarRate . getTmpVars . ratedExpExp .  snd) dag+  mapM (substArgs <=< saveTmpVar) dag++  where+    requestRate ifRate mRate =+      case ifRate of+        IfIr -> Just Ir+        _ -> mRate++    saveTmpVar :: (Int, RatedExp Int) -> RemoveTmp (Int, RatedExp Int)+    saveTmpVar (resId, expr) = case ratedExpExp expr of+      ReadVarTmp ifRate tmp v -> do+        mRate <- lookupRate tmp+        insertTmpVar tmp resId+        pure $+          -- (\x -> trace (unwords ["TMP VAR:", show $ratedExpRate $ snd x]) x) $+          (resId, expr { ratedExpExp = ReadVar ifRate v, ratedExpRate = requestRate ifRate mRate })++      ReadArrTmp ifRate tmp v index -> do+        mRate <- lookupRate tmp+        insertTmpVar tmp resId+        pure $ (resId, expr { ratedExpExp = ReadArr ifRate v index, ratedExpRate = requestRate ifRate mRate })++      TfmInit tmp info args -> do+        mTmpRate <- lookupTmpRate tmp+        let+          onSingleRate mRate = do+            insertTmpVar tmp resId+            pure (resId, expr { ratedExpExp = Tfm info args, ratedExpRate = mRate })++          onMultiRate = do+            insertTmpVar tmp resId+            pure (resId, expr { ratedExpExp = Tfm info args, ratedExpRate = Nothing })+        case mTmpRate of+          Just tmpRate ->+            case tmpRate of+              SingleTmpRate rate -> onSingleRate (Just rate)+              MultiTmpRate _rates -> onMultiRate+          Nothing -> onSingleRate Nothing++      _ -> pure (resId, expr)++    substArgs :: (Int, RatedExp Int) -> RemoveTmp (Int, RatedExp Int)+    substArgs (resId, expr) = do+      e <- mapM (substTmp resId) (ratedExpExp expr)+      pure $ (resId, expr { ratedExpExp = e })++    substTmp :: Int -> PrimOr Int -> RemoveTmp (PrimOr Int)+    substTmp resId (PrimOr e) = fmap PrimOr $ case e of+      Right n -> pure (Right n)+      Left p -> case p of+        PrimTmpVar tmp -> Right <$> lookupTmpVar resId tmp+        _              -> pure $ Left p++insertTmpVar :: TmpVar -> Int -> RemoveTmp ()+insertTmpVar (TmpVar _ _ v) resId =+  modify' $ \st -> st { stIds = IntMap.insert v resId (stIds st) }++lookupTmpVar :: Int -> TmpVar -> RemoveTmp Int+lookupTmpVar resId (TmpVar _ _ n) = gets (fromMaybe err . IntMap.lookup n . stIds)+  where+    err = error $ "TmpVar not found: " <> show n <> " on result id: " <> show resId++saveTmpVarRate :: TmpVar -> RemoveTmp ()+saveTmpVarRate (TmpVar mRate mInfo n) = do+  modify' $ \st -> st { stRates = IntMap.insert n (mRate, mInfo) (stRates st)}++lookupRate :: TmpVar -> RemoveTmp (Maybe Rate)+lookupRate var =+  fmap (getSingleTmpRate =<<) (lookupTmpRate var)++lookupTmpRate :: TmpVar -> RemoveTmp (Maybe TmpVarRate)+lookupTmpRate (TmpVar _ _ n) = gets (fst <=< (IntMap.lookup n . stRates))

@@ -16,7 +16,10 @@ type ChildrenMap = IM.IntMap [Port]  lookupChildren :: ChildrenMap -> Var -> [Port]-lookupChildren m parentVar = m IM.! varId parentVar+lookupChildren m parentVar =+  case IM.lookup (varId parentVar) m of+    Just ports -> ports+    Nothing -> error $ "Invalid children map for id: " <> (show $ varId parentVar)  mkChildrenMap :: [(Var, Selector)] -> ChildrenMap mkChildrenMap = IM.fromListWith (++) . fmap extract@@ -80,7 +83,11 @@ getParentTypes :: RatedExp Var -> Maybe [Rate] getParentTypes x =   case ratedExpExp x of-    Tfm i _ -> if (isMultiOutSignature $ infoSignature i)+    Tfm i _ -> fromInfo i+    ExpPrim (PrimTmpVar v) -> fromInfo =<< tmpVarInfo v+    _ -> Nothing+  where+  fromInfo i =+    if (isMultiOutSignature $ infoSignature i)                 then Just (getRates $ ratedExpExp x)                 else Nothing-    _ -> Nothing

@@ -3,7 +3,8 @@ module Csound.Dynamic.Types.Dep(     DepT(..), LocalHistory(..), runDepT, execDepT, evalDepT,     -- * Dependencies-    depT, depT_, mdepT, stripDepT, stmtOnlyT, toBlock, depends,+    {-depT, -} depT_, {- mdepT, -} stripDepT, stmtOnlyT, depends,+    tfmDep, tfmDepVar,      -- * Variables     newLocalVar, newLocalVars,@@ -18,10 +19,6 @@     initMacrosDouble, initMacrosString, initMacrosInt ) where -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif- import Control.Monad.Trans.Class import Control.Monad.Trans.State.Strict import Control.Monad(ap, liftM, zipWithM_)@@ -43,10 +40,12 @@ data LocalHistory = LocalHistory     { expDependency :: !E     , newLineNum    :: !Int-    , newLocalVarId :: !Int }+    , newLocalVarId :: !Int+    , newTmpVarNum  :: !Int+    }  instance Default LocalHistory where-    def = LocalHistory (noRate Starts) 0 0+    def = LocalHistory (noRate Starts) 0 0 0  instance Monad m => Functor (DepT m) where     fmap = liftM@@ -56,37 +55,8 @@     (<*>) = ap  instance Monad m => Monad (DepT m) where-    ma >>= mf = -- DepT $ unDepT ma >>= unDepT . mf-      DepT $ StateT $ \s -> do-        (aE, aS) <- runStateT (unDepT ma) (startSt s)-        (bE, bS) <- runStateT (unDepT (mf aE)) (startSt aS)-        pure (bE, setDeps bS aS)-      where-        startSt s = s-          { expDependency = rehashE $ Fix $ (unFix $ noRate Starts) { ratedExpDepends = Just (newLineNum s) }-          , newLineNum = succ $ newLineNum s-          }--        setDeps bS aS = bS-          { expDependency = depends (expDependency aS) (expDependency bS)-          , newLineNum = succ $ newLineNum bS-          }-+    ma >>= mf = DepT $ unDepT ma >>= unDepT . mf -{--ifT1 :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m E-ifT1 ifRate check (DepT th) = DepT $ StateT $ \s -> do-  (_thE, thS)  <- runStateT th s-  let thDeps = expDependency thS-      a  = noRate $ IfBlock ifRate (condInfo $ setIfRate ifRate check) (CodeBlock $ PrimOr $ Right thDeps)-      a1 = rehashE $ Fix $ (unFix a) { ratedExpDepends = Just (newLineNum thS) }-      s1 = thS-            { newLineNum = succ $ newLineNum thS-            , expDependency = a1-            -- depends (expDependency thS) (depends (expDependency elS) a1)-            }-  pure (a1, s1)--} instance MonadTrans DepT where     lift ma = DepT $ lift ma @@ -96,7 +66,7 @@ evalDepT :: (Functor m, Monad m) => DepT m a -> m a evalDepT a = evalStateT (unDepT $ a) def -execDepT :: (Functor m, Monad m) => DepT m () -> m E+execDepT :: (Functor m, Monad m) => DepT m a -> m E execDepT a = fmap expDependency $ execStateT (unDepT $ a) def  -- dependency tracking@@ -110,35 +80,36 @@         Starts -> a2         _      -> noRate $ Seq (toPrimOr a1) (toPrimOr a2) -depT :: Monad m => E -> DepT m E-depT a = DepT $ do-    s <- get-    let a1 = rehashE $ Fix $ (unFix a) { ratedExpDepends = Just (newLineNum s) }-    put $ s {-        newLineNum = succ $ newLineNum s -- ,-        -- expDependency = depends (expDependency s) a1-        }-    return a1+tfmDep :: Monad m => Info -> [E] -> DepT m E+tfmDep info args = fmap fromTmpVar $ tfmDepVar info args +tfmDepVar :: Monad m => Info -> [E] -> DepT m TmpVar+tfmDepVar info args = do+  v <- getNewTmpVar (Just info)+  depT_ $ tfmInit v info args+  pure v++tfmInit:: TmpVar -> Info -> [E] -> E+tfmInit v info args = noRate $ TfmInit v info $ toArgs (getInfoRates info) args++toArgs :: [Rate] -> [E] -> [PrimOr E]+toArgs = zipWith toPrimOrTfm++getNewTmpVar :: Monad m => Maybe Info -> DepT m TmpVar+getNewTmpVar mInfo = DepT $ do+  n <- gets newTmpVarNum+  modify' $ \s -> s { newTmpVarNum = n + 1 }+  pure (TmpVar Nothing mInfo n)+ depT_ :: (Monad m) => E -> DepT m () depT_ a = -- fmap (const ()) . depT   DepT $ do     s <- get     let a1 = rehashE $ Fix $ (unFix a) { ratedExpDepends = Just (newLineNum s) }-    put $ s {-        newLineNum = succ $ newLineNum s,-        expDependency = depends (expDependency s) a1-        }-    return ()---toBlock :: Monad m => DepT m () -> DepT m (CodeBlock E)-toBlock (DepT act) = DepT $ do-  act-  CodeBlock <$> gets expDependency--mdepT :: (Monad m) => MultiOut [E] -> MultiOut (DepT m [E])-mdepT mas = \n -> mapM depT $ ( $ n) mas+    put $ s+      { newLineNum = succ $ newLineNum s+      , expDependency = depends (expDependency s) a1+      }  stripDepT :: Monad m => DepT m a -> m a stripDepT (DepT a) = evalStateT a def@@ -172,21 +143,53 @@  -- generic funs -writeVar :: Monad m => Var -> E -> DepT m ()-writeVar v x = depT_ $ noRate $ WriteVar v $ toPrimOr x+writeVar :: Monad m => IfRate -> Var -> E -> DepT m ()+writeVar ifRate v x = depT_ $ noRate $ WriteVar ifRate v $ toPrimOr x -readVar :: Monad m => Var -> DepT m E-readVar v = depT $ noRate $ ReadVar v+readVar :: Monad m => IfRate -> Var -> DepT m E+readVar ifRate v = do+  tmp <- getNewTmpVar Nothing+  depT_ $ noRate $ ReadVarTmp ifRate tmp v+  pure $ fromTmpVar tmp -readOnlyVar :: Var -> E-readOnlyVar v = noRate $ ReadVar v+fromTmpVar :: TmpVar -> E+fromTmpVar v = noRate $ ExpPrim $ PrimTmpVar v +readOnlyVar :: IfRate -> Var -> E+readOnlyVar ifRate v = noRate $ ReadVar ifRate v+ initVar :: Monad m => Var -> E -> DepT m () initVar v x = depT_ $ noRate $ InitVar v $ toPrimOr $ setRate Ir x -appendVarBy :: Monad m => (E -> E -> E) -> Var -> E -> DepT m ()-appendVarBy op v x = writeVar v . op x =<< readVar v+appendVarBy :: Monad m => (E -> E -> E) -> IfRate -> Var -> E -> DepT m ()+appendVarBy op ifRate v x = writeVar ifRate v . op x =<< readVar ifRate v +{-+setRateDep :: Monad m => Rate -> E -> DepT m E+setRateDep rate a = do+  case ratedExpExp $ unFix a of+    ExpPrim (PrimTmpVar _) ->+      setLastDepRate rate+    _ -> pure ()+  pure (setRate rate a)++setLastDepRate :: Monad m => Rate -> DepT m ()+setLastDepRate rate = DepT $+  modify' $ \st -> st { expDependency = setOpcodeRate (expDependency st) }+  where+    setOpcodeRate arg@(Fix expr) =+      case ratedExpExp expr of+        Seq prevExpr (PrimOr (Right (Fix lastExpr))) ->+          case ratedExpExp lastExpr of+            TfmInit _ _ _ ->+              let+                wrapLast a = rehashE $ Fix $ expr { ratedExpExp = Seq prevExpr (PrimOr (Right (rehashE $ Fix a))) }+              in+                wrapLast $ lastExpr { ratedExpRate = Just rate }+            _ -> arg+        _ -> arg+-}+ -------------------------------------------------- -- arrays @@ -203,23 +206,26 @@  -- ops -readArr :: Monad m => Var -> [E] -> DepT m E-readArr v ixs = depT $ noRate $ ReadArr v (fmap toPrimOr ixs)+readArr :: Monad m => IfRate -> Var -> [E] -> DepT m E+readArr ifRate v ixs = do+  tmp <- getNewTmpVar Nothing+  depT_ $ noRate $ ReadArrTmp ifRate tmp v (fmap toPrimOr ixs)+  pure $ fromTmpVar tmp -readOnlyArr :: Var -> [E] -> E-readOnlyArr v ixs = noRate $ ReadArr v (fmap toPrimOr ixs)+readOnlyArr :: IfRate -> Var -> [E] -> E+readOnlyArr ifRate v ixs = noRate $ ReadArr ifRate v (fmap toPrimOr ixs) -writeArr :: Monad m => Var -> [E] -> E -> DepT m ()-writeArr v ixs a = depT_ $ noRate $ WriteArr v (fmap toPrimOr ixs) (toPrimOr a)+writeArr :: Monad m => IfRate -> Var -> [E] -> E -> DepT m ()+writeArr ifRate v ixs a = depT_ $ noRate $ WriteArr ifRate v (fmap toPrimOr ixs) (toPrimOr a) -writeInitArr :: Monad m => Var -> [E] -> E -> DepT m ()-writeInitArr v ixs a = depT_ $ noRate $ WriteInitArr v (fmap toPrimOr ixs) (toPrimOr a)+writeInitArr :: Monad m => IfRate -> Var -> [E] -> E -> DepT m ()+writeInitArr ifRate v ixs a = depT_ $ noRate $ WriteInitArr ifRate v (fmap toPrimOr ixs) (toPrimOr a)  initArr :: Monad m => Var -> [E] -> DepT m () initArr v xs = depT_ $ noRate $ InitArr v $ fmap toPrimOr xs -appendArrBy :: Monad m => (E -> E -> E) -> Var -> [E] -> E -> DepT m ()-appendArrBy op v ixs x = writeArr v ixs . op x =<< readArr v ixs+appendArrBy :: Monad m => (E -> E -> E) -> IfRate -> Var -> [E] -> E -> DepT m ()+appendArrBy op ifRate v ixs x = writeArr ifRate v ixs . op x =<< readArr ifRate v ixs  -------------------------------------------------- -- read global macros arguments@@ -247,5 +253,4 @@  initMacrosBy :: Monad m => (Text -> a -> Exp E) -> Text -> a -> DepT m () initMacrosBy maker name value = depT_ $ noRate $ maker name value- 

@@ -9,14 +9,14 @@         CPP #-} module Csound.Dynamic.Types.Exp(     E, RatedExp(..), isEmptyExp,-    ratedExp, noRate, withRate, setRate,+    ratedExp, noRate, withRate, setRate, toCtrlRate, toInitRate,     toArrRate, removeArrRate,-    Exp, toPrimOr, toPrimOrTfm, PrimOr(..), MainExp(..), Name,-    InstrId(..), intInstrId, ratioInstrId, stringInstrId,+    Exp, toPrimOr, toPrimOrTfm, toPrimOrTfmNoConst, PrimOr(..), MainExp(..), Name,+    InstrId(..), intInstrId, ratioInstrId, stringInstrId, instrIdRate,     VarType(..), Var(..), Info(..), OpcFixity(..), Rate(..),     CodeBlock (..),     Signature(..), isInfix, isPrefix,-    Prim(..), Gen(..), GenId(..),+    Prim(..), TmpVar (..), TmpVarRate (..), getSingleTmpRate, Gen(..), GenId(..),     Inline(..), InlineExp(..), PreInline(..),     BoolExp, CondInfo, CondOp(..), isTrue, isFalse,     NumExp, NumOp(..), Note,@@ -25,6 +25,9 @@     IfRate(..), fromIfRate,     hashE,     rehashE,+    ExpHash (..),+    getInfoRates,+    getTmpVars, ) where  #if __GLASGOW_HASKELL__ < 710@@ -47,6 +50,9 @@ import Data.Text (Text) import Data.Serialize qualified as Cereal import Data.Serialize.Text ()+import Data.Hashable+import qualified Data.Map as M(toList)+import Data.List qualified as L  type Name = Text type LineNum = Int@@ -59,6 +65,11 @@     | InstrLabel Text     deriving (Show, Eq, Ord, Generic) +instrIdRate :: InstrId -> Rate+instrIdRate = \case+  InstrId{}    -> Ir+  InstrLabel{} -> Sr+ -- | Constructs an instrument id with the integer. intInstrId :: Int -> InstrId intInstrId n = InstrId Nothing n@@ -75,14 +86,14 @@ type E = Fix RatedExp  data RatedExp a = RatedExp-    { ratedExpHash      :: !ByteString+    { ratedExpHash      :: !ExpHash        -- ^ expression hash for fast comparison     , ratedExpRate      :: !(Maybe Rate)         -- ^ Rate (can be undefined or Nothing,         -- it means that rate should be deduced automatically from the context)     , ratedExpDepends   :: !(Maybe LineNum)         -- ^ Dependency (it is used for expressions with side effects,-        -- value contains the privious statement)+        -- value contains the previous statement)     , ratedExpExp       :: !(Exp a)         -- ^ Main expression     } deriving (Show, Functor, Foldable, Traversable, Generic, Generic1)@@ -96,7 +107,7 @@ ratedExp :: Maybe Rate -> Exp E -> E ratedExp r expr = Fix $ RatedExp h r Nothing expr   where-    h = Crypto.hash $ Cereal.encode $ fmap (fmap hashE) expr+    h = ExpHash $ Crypto.hash $ Cereal.encode $ fmap (fmap hashE) expr  noRate :: Exp E -> E noRate = ratedExp Nothing@@ -104,25 +115,30 @@ withRate :: Rate -> Exp E -> E withRate r = ratedExp (Just r) -hashE :: E -> ByteString+-- | Hash of the expression for fast comparison+newtype ExpHash = ExpHash { unExpHash :: ByteString }+  deriving newtype (Eq, Show, Ord, Hashable, Cereal.Serialize)++hashE :: E -> ExpHash hashE (Fix expr) = ratedExpHash expr  -- | Call it on every change in underlying expression rehashE :: E -> E rehashE (Fix expr) = Fix $   expr-    { ratedExpHash = Crypto.hash $ Cereal.encode $ fmap hashE expr+    { ratedExpHash = ExpHash $ Crypto.hash $ Cereal.encode $ fmap hashE expr     }  -- rate coversion  setRate :: Rate -> E -> E-setRate r a =+setRate r a = rehashE $   case ratedExpExp $ unFix a of     -- for Tfm we add rate to ratedExpRate hint     Tfm _ _    -> Fix $ (unFix a) { ratedExpRate = Just r }     -- conversion set's the rate for constants     -- ExpPrim _  -> a+    ExpPrim (PrimTmpVar v) -> Fix $ (unFix a) { ratedExpExp = ExpPrim (PrimTmpVar $ v { tmpVarRate = Just (SingleTmpRate r)}), ratedExpRate = Just r }     ExpPrim _  -> Fix $ (unFix a) { ratedExpRate = Just r }     -- don't convert rate twice     ConvertRate _ b arg -> withRate r $ ConvertRate r b arg@@ -136,6 +152,20 @@ newtype PrimOr a = PrimOr { unPrimOr :: Either Prim a }     deriving (Show, Eq, Ord, Functor, Generic, Generic1) +-- | Converts rate to control rate (affects Ir and Ar, other are unchainged)+toCtrlRate :: Rate -> Rate+toCtrlRate = \case+  Ar -> Kr+  Ir -> Kr+  x  -> x++-- | Converts rate to init rate (affects Kr other are unchainged)+toInitRate :: Rate -> Rate+toInitRate = \case+  Kr -> Ir+  Ar -> Ir+  x  -> x+ instance Cereal.Serialize a => Cereal.Serialize (PrimOr a)  -- | Constructs PrimOr values from the expressions. It does inlining in@@ -144,10 +174,10 @@ toPrimOr a = PrimOr $ case ratedExpExp $ unFix a of     ExpPrim (PString _) -> Right a     ExpPrim p  -> Left p-    ReadVar v | noDeps -> Left (PrimVar (varRate v) v)+    ReadVar _ v | noDeps -> Left (PrimVar (varRate v) v)     _         -> Right a     where-        noDeps = isNothing $ ratedExpDepends $ unFix a+      noDeps = isNothing $ ratedExpDepends $ unFix a  -- | Constructs PrimOr values from the expressions. It does inlining in -- case of primitive values.@@ -155,16 +185,29 @@ toPrimOrTfm r a = PrimOr $ case ratedExpExp $ unFix a of     ExpPrim (PString _) -> Right a     ExpPrim p | (r == Ir || r == Sr) -> Left p-    ReadVar v | noDeps -> Left (PrimVar (varRate v) v)+    ExpPrim (PrimTmpVar tmp) -> Left (PrimTmpVar tmp)+    ReadVar _ v | noDeps -> Left (PrimVar (varRate v) v)     _         -> Right a     where-        noDeps = isNothing $ ratedExpDepends $ unFix a+      noDeps = isNothing $ ratedExpDepends $ unFix a +-- | Constructs PrimOr values from the expressions. It does inlining in+-- case of primitive values.+toPrimOrTfmNoConst :: Rate -> E -> PrimOr E+toPrimOrTfmNoConst r a = PrimOr $ case ratedExpExp $ unFix a of+    ExpPrim (PString _) -> Right a+    ExpPrim (PrimDouble _) -> Right a+    ExpPrim p | (r == Ir || r == Sr) -> Left p+    ExpPrim (PrimTmpVar tmp) -> Left (PrimTmpVar tmp)+    ReadVar _ v | noDeps -> Left (PrimVar (varRate v) v)+    _         -> Right a+    where+      noDeps = isNothing $ ratedExpDepends $ unFix a  -- Expressions with inlining. type Exp a = MainExp (PrimOr a) -newtype CodeBlock a = CodeBlock a+newtype CodeBlock a = CodeBlock { unCodeBlock :: a }   deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic, Generic1)  -- Csound expressions@@ -174,6 +217,8 @@     | ExpPrim !Prim     -- | Application of the opcode: we have opcode information (Info) and the arguments [a]     | Tfm Info ![a]+    -- | init variable with opcode expression+    | TfmInit TmpVar Info ![a]     -- | Rate conversion     | ConvertRate !Rate !(Maybe Rate) !a     -- | Selects a cell from the tuple, here argument is always a tuple (result of opcode that returns several outputs)@@ -186,13 +231,15 @@     | ExpNum !(NumExp a)     -- | Reading/writing a named variable     | InitVar !Var !a-    | ReadVar !Var-    | WriteVar !Var !a+    | ReadVar !IfRate !Var+    | ReadVarTmp !IfRate !TmpVar !Var+    | WriteVar !IfRate !Var !a     -- | Arrays     | InitArr !Var !(ArrSize a)-    | ReadArr !Var !(ArrIndex a)-    | WriteArr !Var !(ArrIndex a) !a-    | WriteInitArr !Var !(ArrIndex a) !a+    | ReadArr !IfRate !Var !(ArrIndex a)+    | ReadArrTmp !IfRate !TmpVar !Var !(ArrIndex a)+    | WriteArr !IfRate !Var !(ArrIndex a) !a+    | WriteInitArr !IfRate !Var !(ArrIndex a) !a     | TfmArr !IsArrInit !Var !Info ![a]     -- | inits 1-dimensional read only array (uses fillaray)     -- args: rateOfTheOutput processingRate initValues@@ -212,8 +259,6 @@     | UntilEnd     | WhileBlock !IfRate !(CondInfo a) (CodeBlock a)     | WhileBegin !IfRate !(CondInfo a)-    | WhileRefBlock !Var !(CodeBlock a)-    | WhileRefBegin !Var     | WhileEnd     -- | Verbatim stmt     | Verbatim !Text@@ -235,6 +280,15 @@ data IfRate = IfIr | IfKr   deriving (Show, Eq, Ord, Generic) +getTmpVars :: Exp a -> [TmpVar]+getTmpVars = \case+  ExpPrim (PrimTmpVar tmp) -> [tmp]+  other ->+    flip foldMap other $ \(PrimOr e) ->+      case e of+        Left (PrimTmpVar tmp) -> [tmp]+        _ -> []+ fromIfRate :: IfRate -> Rate fromIfRate = \case   IfKr -> Kr@@ -254,6 +308,8 @@ instance Cereal.Serialize InstrId instance Cereal.Serialize CondOp instance Cereal.Serialize NumOp+instance Cereal.Serialize TmpVarRate+instance Cereal.Serialize TmpVar instance Cereal.Serialize Var instance Cereal.Serialize VarType instance Cereal.Serialize a => Cereal.Serialize (CodeBlock a)@@ -279,7 +335,8 @@     | VarVerbatim         { varRate :: !Rate         , varName :: !Name-        } deriving (Show, Eq, Ord, Generic)+        }+      deriving (Show, Eq, Ord, Generic)  -- Variables can be global (then we have to prefix them with `g` in the rendering) or local. data VarType = LocalVar | GlobalVar@@ -295,6 +352,14 @@     , infoOpcFixity     :: !OpcFixity     } deriving (Show, Eq, Ord, Generic) +getInfoRates :: Info -> [Rate]+getInfoRates a = getInRates $ infoSignature a+  where+    getInRates x =+      case x of+        SingleRate m    -> fmap minimum $ L.transpose $ fmap snd $ M.toList m+        MultiRate _ ins -> ins+ isPrefix, isInfix :: Info -> Bool  isPrefix = (Prefix ==) . infoOpcFixity@@ -355,7 +420,7 @@ -- Primitive values data Prim     -- instrument p-arguments-    = P !Int+    = P !Rate !Int     | PString !Int       -- >> p-string (read p-string notes at the bottom of the file):     | PrimInt !Int     | PrimDouble !Double@@ -364,7 +429,24 @@     | PrimVar         { primVarTargetRate :: !Rate         , primVar           :: !Var }+    | PrimTmpVar !TmpVar     deriving (Show, Eq, Ord, Generic)++-- | temporary var+data TmpVar = TmpVar+  { tmpVarRate :: Maybe TmpVarRate+  , tmpVarInfo :: Maybe Info+  , tmpVarId :: Int+  }+  deriving (Show, Eq, Ord, Generic)++data TmpVarRate = SingleTmpRate Rate | MultiTmpRate [Rate]+  deriving (Show, Eq, Ord, Generic)++getSingleTmpRate :: TmpVarRate -> Maybe Rate+getSingleTmpRate = \case+  SingleTmpRate rate -> Just rate+  MultiTmpRate _ -> Nothing  -- Gen routine. data Gen = Gen

@@ -54,14 +54,12 @@ instance Default Flags where     def = Flags def def def def def def def def def def - #if MIN_VERSION_base(4,11,0) instance Semigroup Flags where   x <> y          = x `mappendFlags` y  instance Monoid Flags where     mempty  = def- #else  instance Monoid Flags where