diff --git a/csound-expression-dynamic.cabal b/csound-expression-dynamic.cabal --- a/csound-expression-dynamic.cabal +++ b/csound-expression-dynamic.cabal @@ -1,18 +1,17 @@ Name: csound-expression-dynamic -Version: 0.3.9 -Cabal-Version: >= 1.22 +Version: 0.3.9.1 +Cabal-Version: 1.12 License: BSD3 License-file: LICENSE Author: Anton Kholomiov Synopsis: dynamic core for csound-expression library +Description: Basic bare bone library to generate Csound code Stability: Experimental Tested-With: GHC==7.6 Build-Type: Simple Category: Music, Sound Maintainer: -Description: - Homepage: https://github.com/anton-k/csound-expression-dynamic Bug-Reports: https://github.com/anton-k/csound-expression-dynamic/issues @@ -24,14 +23,35 @@ Library Ghc-Options: -Wall Build-Depends: - base >= 4.6, base < 5, data-default, containers, array, transformers >= 0.3, wl-pprint >= 1.2.1, - Boolean >= 0.1.0, data-fix >= 0.3.0, data-fix-cse >= 0.0.3, hashable >=1.2.7.0, - deriving-compat + base >= 4.10, base < 5 + , base64-bytestring + , bytestring + , data-default + , dlist + , cereal + , cereal-text + , containers + , array + , transformers >= 0.3 + , wl-pprint-text >= 1.2.0.2 + , Boolean >= 0.1.0 + , data-fix >= 0.3.2 + , data-fix-cse >= 0.0.3 + , deriving-compat + , safe + , text + , cryptohash-sha256 + , vector + , unordered-containers + , pretty-show + , safe Hs-Source-Dirs: src/ default-language: Haskell2010 Exposed-Modules: Csound.Dynamic + Csound.Dynamic.Const + Csound.Dynamic.Types Csound.Dynamic.Types.Exp Csound.Dynamic.Types.Dep @@ -47,9 +67,27 @@ Csound.Dynamic.Render.Instr Csound.Dynamic.Render.Pretty Other-Modules: - Csound.Dynamic.Tfm.DeduceTypes + Csound.Dynamic.Tfm.IfBlocks + Csound.Dynamic.Tfm.InferTypes Csound.Dynamic.Tfm.Liveness Csound.Dynamic.Tfm.UnfoldMultiOuts + + default-extensions: + BangPatterns + DeriveFunctor + DeriveFoldable + DeriveTraversable + DerivingStrategies + DeriveGeneric + GeneralizedNewtypeDeriving + ImportQualifiedPost + LambdaCase + RecordWildCards + OverloadedStrings + ScopedTypeVariables + TupleSections + TypeApplications + diff --git a/src/Csound/Dynamic.hs b/src/Csound/Dynamic.hs --- a/src/Csound/Dynamic.hs +++ b/src/Csound/Dynamic.hs @@ -3,7 +3,7 @@ module Csound.Dynamic.Types, module Csound.Dynamic.Types.Exp, module Csound.Dynamic.Types.Dep, - module Csound.Dynamic.Types.CsdFile, + module Csound.Dynamic.Types.CsdFile, module Csound.Dynamic.Types.Flags, module Csound.Dynamic.Build, diff --git a/src/Csound/Dynamic/Build.hs b/src/Csound/Dynamic/Build.hs --- a/src/Csound/Dynamic/Build.hs +++ b/src/Csound/Dynamic/Build.hs @@ -1,39 +1,41 @@ module Csound.Dynamic.Build ( - - -- * Expression tree - -- | Working with expression tree - toExp, onExp, + -- * Expression tree + -- | Working with expression tree + toExp, onExp, - -- * Rates - -- * Queries - getRates, isMultiOutSignature, getPrimUnsafe, + -- * Rates + -- * Queries + getRates, isMultiOutSignature, getPrimUnsafe, - -- * Constructors - -- | Basic constructors - prim, opcPrefix, oprPrefix, oprInfix, - numExp1, - tfm, tfmNoInlineArgs, pn, withInits, - double, int, str, verbatim, instrIdE, - inlineVar, gInit, gInitDouble, + -- * Constructors + -- | Basic constructors + 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, + -- ** Opcodes constructors + Spec1, spec1, opcs, opcsNoInlineArgs, opr1, opr1k, infOpr, oprBy, + Specs, specs, MultiOut, mopcs, mo, - -- * Global init statements - setSr, setKsmps, setNchnls, setNchnls_i, setKr, setZeroDbfs, + -- * Global init statements + setSr, setKsmps, setNchnls, setNchnls_i, setKr, setZeroDbfs, - -- * Arrays - opcsArr, infOprArr + -- * Arrays + opcsArr, infOprArr, initPureArr, readPureArr ) where import qualified Data.Map as M(fromList, toList) +import Data.Serialize qualified as Cereal import Data.List(transpose) import Data.Fix(Fix(..)) import Csound.Dynamic.Types.Exp import Csound.Dynamic.Types.Dep +import Data.Text (Text) +import Data.Text qualified as Text ------------------------------------------------ -- basic constructors @@ -50,36 +52,43 @@ oprInfix :: Name -> Signature -> Info oprInfix name signature = Info name signature Infix +toArgs :: [Rate] -> [E] -> [PrimOr E] +toArgs = zipWith toPrimOrTfm + tfm :: Info -> [E] -> E -tfm info args = noRate $ Tfm info $ zipWith toPrimOrTfm (getInfoRates info) args +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 $ zipWith toPrimOrTfm (getInfoRates info) args +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 + where + getInRates x = + case x of + SingleRate m -> fmap minimum $ transpose $ fmap snd $ M.toList m + MultiRate _ ins -> ins tfmNoInlineArgs :: Info -> [E] -> E tfmNoInlineArgs info args = noRate $ Tfm info $ fmap (PrimOr . Right) args inlineVar :: Var -> E -inlineVar = Fix . RatedExp Nothing Nothing . ReadVar +inlineVar var = Fix $ RatedExp h Nothing Nothing $ ReadVar var + where + h = Cereal.encode var pn :: Int -> E pn = prim . P withInits :: E -> [E] -> E withInits a es = onExp phi a - where phi x = case x of - -- for opcodes with single output - Tfm t xs -> Tfm t (xs ++ (fmap toPrimOr es)) - -- for opcodes with multiple outputs - Select r n expr -> Select r n $ fmap (\t -> withInits t es) expr - _ -> x + where + phi = \case + -- for opcodes with single output + Tfm t xs -> Tfm t (xs ++ (fmap toPrimOr es)) + -- for opcodes with multiple outputs + Select r n expr -> Select r n $ fmap (\t -> withInits t es) expr + x -> x -- | Converts Haskell's doubles to Csound's doubles double :: Double -> E @@ -87,20 +96,22 @@ -- | Converts Haskell's strings to Csound's strings str :: String -> E -str = prim . PrimString +str = prim . PrimString . Text.pack -- | Converts Haskell's integers to Csound's doubles int :: Int -> E int = prim . PrimInt -verbatim :: Monad m => String -> DepT m () +verbatim :: Monad m => Text -> DepT m () verbatim = stmtOnlyT . Verbatim instrIdE :: InstrId -> E -instrIdE x = case x of +instrIdE x = + case x of InstrId Nothing m -> int m InstrId (Just _) _ -> error "instrId undefined for fractional InstrIds" - InstrLabel s -> str s + InstrLabel s -> prim (PrimString s) + ---------------------------------------------------------------------- -- constructing opcodes @@ -139,6 +150,16 @@ infOprArr :: Monad m => IsArrInit -> Var -> Name -> E -> E -> DepT m () infOprArr isArrInit out name a b = tfmArr isArrInit out (oprInfix name $ spec1 [(Ar, [Ar, Ar]), (Kr, [Kr, Kr]), (Ir, [Ir, Ir])]) [a, b] +initPureArr :: Rate -> IfRate -> [E] -> E +initPureArr outRate procRate initVals = + noRate $ InitPureArr outRate procRate $ toArgs (repeat initRate) initVals + where + initRate = fromIfRate procRate + +readPureArr :: Rate -> IfRate -> E -> E -> E +readPureArr outRate procRate arr index = + noRate $ ReadPureArr outRate procRate (toPrimOr arr) (toPrimOrTfm (fromIfRate procRate) index) + -- multiple output -- User friendly type for multiple outputs type signatures @@ -152,27 +173,31 @@ mo :: Int -> E -> [E] mo n e = zipWith (\cellId r -> select cellId r e') [0 ..] outRates - where outRates = take n $ getRates $ toExp e - e' = onExp (setMultiRate outRates) e + where + outRates = take n $ getRates $ toExp e + e' = onExp (setMultiRate outRates) e - 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" + 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" - select cellId rate expr = withRate rate $ Select rate cellId (PrimOr $ Right expr) + select cellId rate expr = withRate rate $ Select rate cellId (PrimOr $ Right expr) getRates :: MainExp a -> [Rate] -getRates (Tfm info _) = case infoSignature info of +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" isMultiOutSignature :: Signature -> Bool -isMultiOutSignature x = case x of +isMultiOutSignature x = + case x of MultiRate _ _ -> True _ -> False @@ -188,7 +213,8 @@ -- Lifts transformation of main expression onExp :: (Exp E -> Exp E) -> E -> E -onExp f x = case unFix x of +onExp f x = + case unFix x of a -> Fix $ a{ ratedExpExp = f (ratedExpExp a) } ---------------------------------------------------------------- @@ -198,8 +224,8 @@ setZeroDbfs :: Monad m => Double -> DepT m () -setGlobal :: (Monad m, Show a) => String -> a -> DepT m () -setGlobal name val = verbatim $ name ++ " = " ++ show val +setGlobal :: (Monad m, Show a) => Text -> a -> DepT m () +setGlobal name val = verbatim $ Text.unwords [name, "=", Text.pack $ show val] setSr = setGlobal "sr" setKr = setGlobal "kr" @@ -208,9 +234,9 @@ setKsmps = setGlobal "ksmps" setZeroDbfs = setGlobal "0dbfs" -gInit :: Monad m => String -> Int -> DepT m () +gInit :: Monad m => Text -> Int -> DepT m () gInit name val = writeVar (VarVerbatim Ir name) (int val) -gInitDouble :: Monad m => String -> Double -> DepT m () +gInitDouble :: Monad m => Text -> Double -> DepT m () gInitDouble name val = writeVar (VarVerbatim Ir name) (double val) diff --git a/src/Csound/Dynamic/Build/Logic.hs b/src/Csound/Dynamic/Build/Logic.hs --- a/src/Csound/Dynamic/Build/Logic.hs +++ b/src/Csound/Dynamic/Build/Logic.hs @@ -3,70 +3,150 @@ -- | Boolean instances module Csound.Dynamic.Build.Logic( when1, whens, - ifBegin, ifEnd, elseBegin, - untilDo, - untilBegin, untilEnd, - whileDo, - whileBegin, whileRef, whileEnd + ifExp, + ifElseBlock, + -- ifBegin, ifEnd, elseBegin, + untilBlock, + whileBlock, + + -- untilDo, + -- untilBegin, untilEnd, + -- whileDo, + -- whileBegin, + whileRef, whileEnd ) where -import Control.Monad.Trans.State(State, state, evalState) +import Control.Monad +import Control.Monad.Trans.State.Strict (State, state, evalState, runStateT, StateT(..)) 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 + } + + +ifT1, untilT, whileT :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m E + +ifT1 = ifT1By IfBlock +untilT = ifT1By UntilBlock +whileT = ifT1By WhileBlock + +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 + } + + + ------------------------------------------------------ -- imperative if-then-else -when1 :: Monad m => Rate -> E -> DepT m () -> DepT m () -when1 rate p body = do - ifBegin rate p - body - ifEnd +setIfRate :: IfRate -> E -> E +setIfRate rate = setRate (fromIfRate rate) -whens :: Monad m => Rate -> [(E, DepT m ())] -> DepT m () -> DepT m () -whens rate bodies el = case bodies of - [] -> el - a:as -> do - ifBegin rate (fst a) - snd a - elseIfs as - elseBegin - el - foldl1 (>>) $ replicate (1 + length as) ifEnd - where elseIfs = mapM_ (\(p, body) -> elseBegin >> ifBegin rate p >> body) +when1 :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m () +when1 ifRate p body = void $ ifT1 ifRate p body -ifBegin :: Monad m => Rate -> E -> DepT m () -ifBegin rate = withCond $ IfBegin rate +whens :: Monad m => IfRate -> [(E, DepT m (CodeBlock E))] -> DepT m (CodeBlock E) -> 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 +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 +-} -untilDo :: Monad m => E -> DepT m () -> DepT m () -untilDo p body = do - untilBegin p +untilBlock :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> DepT m () +untilBlock ifRate p body = void $ untilT ifRate p body + +whileBlock :: Monad m => IfRate -> E -> DepT m (CodeBlock E) -> 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 => E -> DepT m () -untilBegin = withCond UntilBegin +untilBegin :: Monad m => IfRate -> E -> DepT m () +untilBegin ifRate = withCond ifRate (UntilBegin ifRate) untilEnd :: Monad m => DepT m () untilEnd = stmtOnlyT UntilEnd +-} -whileDo :: Monad m => E -> DepT m () -> DepT m () -whileDo p body = do - whileBegin p +{- +whileDo :: Monad m => IfRate -> E -> DepT m () -> DepT m () +whileDo ifRate p body = do + whileBegin ifRate p body whileEnd -whileBegin :: Monad m => E -> DepT m () -whileBegin = withCond WhileBegin +whileBegin :: Monad m => IfRate -> E -> DepT m () +whileBegin ifRate = withCond IfKr (WhileBegin ifRate) +-} whileRef :: Monad m => Var -> DepT m () whileRef var = stmtOnlyT $ WhileRefBegin var @@ -74,8 +154,10 @@ whileEnd :: Monad m => DepT m () whileEnd = stmtOnlyT WhileEnd -withCond :: Monad m => (CondInfo (PrimOr E) -> MainExp (PrimOr E)) -> E -> DepT m () -withCond stmt p = depT_ $ noRate $ stmt (condInfo p) +{- +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 @@ -88,9 +170,6 @@ type instance BooleanOf E = E -instance IfB E where - ifB = condExp - instance EqB E where (==*) = boolOp2 Equals (/=*) = boolOp2 NotEquals @@ -109,22 +188,25 @@ boolExp :: a -> [b] -> PreInline a b boolExp = PreInline -condExp :: E -> E -> E -> E -condExp = mkCond . condInfo +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 pr (toPrimOr th) (toPrimOr 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 + 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) + onExpr _ (op, args) = fmap mkNode $ mapM condInfo' args where mkNode as = (InlineExp op (map fst as), concat $ map snd as) diff --git a/src/Csound/Dynamic/Const.hs b/src/Csound/Dynamic/Const.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Dynamic/Const.hs @@ -0,0 +1,51 @@ +-- | Constants +module Csound.Dynamic.Const + ( controlOpcodes + , audioOpcodes + ) where + +import Data.HashSet (HashSet) +import Data.HashSet qualified as HashSet +import Data.Text + +-- | Envelope generators are Kr by default +controlOpcodes :: HashSet Text +controlOpcodes = + HashSet.fromList + [ "adsr" + , "madsr" + , "xadsr" + , "linen" + , "linenr" + , "envlpx" + , "envlpxr" + , "expon" + , "expseg" + , "expsegr" + , "jspline" + , "line" + , "linseg" + , "linsegr" + , "rspline" + , "transeg" + , "bpf" + , "bpfcos" + ] + +-- | Oscillators and table access are Ar by default +audioOpcodes :: HashSet Text +audioOpcodes = + HashSet.fromList + [ "oscil" + , "oscili" + , "oscil3" + , "poscil" + , "poscil3" + , "oscilikt" + , "table" + , "tablei" + , "table3" + , "tab" + , "tabw" + ] + diff --git a/src/Csound/Dynamic/Render.hs b/src/Csound/Dynamic/Render.hs --- a/src/Csound/Dynamic/Render.hs +++ b/src/Csound/Dynamic/Render.hs @@ -1,32 +1,46 @@ module Csound.Dynamic.Render( - renderCsd + RenderOptions (..), + renderCsd, + module X ) where -import qualified Text.PrettyPrint.Leijen as P +import qualified Text.PrettyPrint.Leijen.Text as P import Csound.Dynamic.Render.Instr import Csound.Dynamic.Render.Pretty import Csound.Dynamic.Types +import Csound.Dynamic.Tfm.InferTypes as X (InferenceOptions (..), OpcodeInferenceStrategy (..)) +import Data.Default -renderCsd :: Csd -> String -renderCsd a = show $ ppCsdFile +data RenderOptions = RenderOptions + { inferenceOptions :: !InferenceOptions + } + deriving (Eq, Ord, Show, Read) + +instance Default RenderOptions where + def = RenderOptions + { inferenceOptions = def + } + +renderCsd :: RenderOptions -> Csd -> String +renderCsd opts a = show $ ppCsdFile (renderFlags $ csdFlags a) - (renderOrc $ csdOrc a) + (renderOrc (inferenceOptions opts) $ csdOrc a) (renderSco $ csdSco a) (csdPlugins a) renderFlags :: Flags -> Doc renderFlags = P.pretty -renderOrc :: Orc -> Doc -renderOrc a = vcatSep $ headExpr : instrExprs - where - headExpr = renderInstrBody (orcHead a) - instrExprs = fmap renderInstr (orcInstruments a) +renderOrc :: InferenceOptions -> Orc -> Doc +renderOrc opts a = vcatSep $ headExpr : instrExprs + where + headExpr = renderInstrBody opts (orcHead a) + instrExprs = fmap (renderInstr opts) (orcInstruments a) renderSco :: Sco -> Doc renderSco a = vcatSep - [ P.vcat $ fmap (uncurry ppGen) $ scoGens a + [ P.vcat $ fmap (uncurry ppGen) $ scoGens a , maybe P.empty ppTotalDur $ scoTotalDur a , P.vcat $ fmap (uncurry ppNotes) $ scoNotes a ] diff --git a/src/Csound/Dynamic/Render/Instr.hs b/src/Csound/Dynamic/Render/Instr.hs --- a/src/Csound/Dynamic/Render/Instr.hs +++ b/src/Csound/Dynamic/Render/Instr.hs @@ -1,238 +1,79 @@ module Csound.Dynamic.Render.Instr( - renderInstr, renderInstrBody + renderInstr, + renderInstrBody ) where import Control.Arrow(second) import Control.Monad.Trans.State.Strict -import Data.List(sort, find) -import qualified Data.Map as M -import Data.Maybe(fromJust) import Data.Fix(Fix(..), foldFix) -import Data.Fix.Cse(fromDag, cseFramed, FrameInfo(..)) +import Data.Fix.Cse(fromDag, cse {-cseFramed, FrameInfo(..)-}) -import qualified Text.PrettyPrint.Leijen as P +import qualified Text.PrettyPrint.Leijen.Text as P -import Csound.Dynamic.Tfm.DeduceTypes +import Csound.Dynamic.Tfm.InferTypes (InferenceOptions) +import Csound.Dynamic.Tfm.InferTypes qualified as Infer import Csound.Dynamic.Tfm.UnfoldMultiOuts +import Csound.Dynamic.Tfm.IfBlocks import Csound.Dynamic.Tfm.Liveness import Csound.Dynamic.Types hiding (Var) -import Csound.Dynamic.Build(getRates, isMultiOutSignature) import Csound.Dynamic.Render.Pretty -import qualified Csound.Dynamic.Types as T(Var) +-- import Debug.Trace type Dag f = [(Int, f Int)] -renderInstr :: Instr -> Doc -renderInstr a = ppInstr (instrName a) $ renderInstrBody (instrBody a) +renderInstr :: InferenceOptions -> Instr -> Doc +renderInstr opts a = ppInstr (instrName a) $ renderInstrBody opts (instrBody a) -renderInstrBody :: E -> Doc -renderInstrBody a +renderInstrBody :: InferenceOptions -> E -> Doc +renderInstrBody opts a | null dag = P.empty | otherwise = render dag where dag = toDag a - render = P.vcat . flip evalState 0 . mapM (uncurry ppStmt . clearEmptyResults) . collectRates + render = P.vcat . flip evalState 0 . mapM (uncurry ppStmt . clearEmptyResults) . collectRates opts ------------------------------------------------------------- -- E -> Dag toDag :: E -> Dag RatedExp -toDag expr = filterDepCases $ fromDag $ cseFramed getFrameInfo $ trimByArgLength expr - -getFrameInfo :: RatedExp a -> FrameInfo -getFrameInfo x = case ratedExpExp x of - -- Imperative If-then-else - IfBegin _ _ -> StartFrame --- ElseIfBegin _ -> NextFrame - ElseBegin -> NextFrame - IfEnd -> StopFrame - -- looping constructions - UntilBegin _ -> StartFrame - UntilEnd -> StopFrame - WhileBegin _ -> StartFrame - WhileRefBegin _ -> StartFrame - WhileEnd -> StopFrame - _ -> NoFrame - +toDag expr = fromDag $ cse $ trimByArgLength expr trimByArgLength :: E -> E trimByArgLength = foldFix $ \x -> Fix x{ ratedExpExp = phi $ ratedExpExp x } - where phi x = case x of - Tfm info xs -> Tfm (info{infoSignature = trimInfo (infoSignature info) xs}) xs - _ -> x - trimInfo signature args = case signature of - SingleRate tab -> SingleRate $ fmap trim tab - MultiRate outs ins -> MultiRate outs (trim ins) - where trim = take (length args) + where + phi x = case x of + Tfm info xs -> Tfm (info{infoSignature = trimInfo (infoSignature info) xs}) xs + _ -> x -clearEmptyResults :: ([RatedVar], Exp RatedVar) -> ([RatedVar], Exp RatedVar) -clearEmptyResults (res, expr) = (filter ((/= Xr) . ratedVarRate) res, expr) + trimInfo signature args = case signature of + SingleRate tab -> SingleRate $ fmap trim tab + MultiRate outs ins -> MultiRate outs (trim ins) + where + trim = take (length args) -collectRates :: Dag RatedExp -> [([RatedVar], Exp RatedVar)] -collectRates dag = fmap (second ratedExpExp) res2 - where res2 = liveness lastFreshId1 res1 - (res1, lastFreshId1)= unfoldMultiOuts unfoldSpec lastFreshId dag1 - (dag1, lastFreshId) = rateGraph dag +clearEmptyResults :: ([Infer.Var], Exp Infer.Var) -> ([Infer.Var], Exp Infer.Var) +clearEmptyResults (res, expr) = (filter ((/= Xr) . Infer.varType) res, expr) +collectRates :: InferenceOptions -> Dag RatedExp -> [([Infer.Var], Exp Infer.Var)] +collectRates opts dag = fmap (second ratedExpExp) res4 + where + res4 = liveness lastFreshId3 res3 + (res3, lastFreshId3) = unfoldMultiOuts inferRes2 + 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) + dag + ----------------------------------------------------------- -- Dag -> Dag -filterDepCases :: Dag RatedExp -> Dag RatedExp -filterDepCases = filter (not . isDepCase . snd) +filterDepCases :: [Infer.Stmt Infer.Var] -> [Infer.Stmt Infer.Var] +filterDepCases = filter (not . isDepCase . Infer.stmtRhs) where isDepCase x = case ratedExpExp x of Starts -> True Seq _ _ -> True Ends _ -> True _ -> False - ------------------------------------------------------------ --- deduces types - -rateGraph :: [Stmt RatedExp Int] -> ([Stmt RatedExp (Var Rate)], Int) -rateGraph dag = (stmts, lastId) - where (stmts, lastId) = deduceTypes algSpec dag - algSpec = TypeGraph mkConvert' defineType' - - mkConvert' a = (to, RatedExp Nothing Nothing $ - ConvertRate (ratedVarRate to) (ratedVarRate from) $ PrimOr $ Right from) - where from = convertFrom a - to = convertTo a - - defineType' (outVar, expr) desiredRates = (ratesForConversion, (outVar', expr')) - where possibleRate = deduceRate desiredRates expr - ratesForConversion = filter (not . flip coherentRates possibleRate) desiredRates - expr' = RatedExp Nothing Nothing $ rateExp possibleRate $ ratedExpExp expr - outVar' = ratedVar possibleRate outVar - ----------------------------------------------------------- --- unfolds multiple rates - -unfoldSpec :: UnfoldMultiOuts RatedExp Rate -unfoldSpec = UnfoldMultiOuts getSelector' getParentTypes' - where getSelector' x = case ratedExpExp x of - Select _ order (PrimOr (Right parent)) -> Just $ Selector parent order - _ -> Nothing - getParentTypes' x = case ratedExpExp x of - Tfm i _ -> if (isMultiOutSignature $ infoSignature i) - then Just (getRates $ ratedExpExp x) - else Nothing - _ -> Nothing - -coherentRates :: Rate -> Rate -> Bool -coherentRates to from = case (to, from) of - (a, b) | a == b -> True - (Xr, _) -> True - (Kr, Ir) -> True - _ -> False - -deduceRate :: [Rate] -> RatedExp Int -> Rate -deduceRate desiredRates expr = case ratedExpExp expr of - ExpPrim _ -> case desiredRates of - [Sr] -> Sr - _ -> Ir - - Tfm info _ -> case infoSignature info of - MultiRate _ _ -> Xr - SingleRate tab -> - let r1 = tfmNoRate (infoName info) desiredRates tab - in case ratedExpRate expr of - Just r | M.member r tab -> r - Just _ -> r1 - Nothing -> r1 - - ExpNum _ -> case ratedExpRate expr of - Just r -> r - Nothing -> case maximum (Ar : desiredRates) of - Xr -> Ar - r -> r - - Select rate _ _ -> rate - If _ _ _ -> case head $ sort desiredRates of - Xr -> Ar - r -> r - ReadVar v -> varRate v - ReadArr v _ -> varRate v - ReadMacrosString _ -> Sr - ReadMacrosDouble _ -> Ir - ReadMacrosInt _ -> Ir - _ -> Xr - where tfmNoRate name rates tab = case sort rates of - [Xr] -> tfmNoRate name [Ar] tab - Xr:as -> tfmNoRate name as tab - as | any (== Ir) as -> fromJust $ find (flip M.member tab) (Ir : as ++ [minBound .. maxBound]) - as -> fromJust $ find (flip M.member tab) (as ++ [minBound .. maxBound]) - -rateExp :: Rate -> Exp Int -> Exp RatedVar -rateExp curRate expr = case expr of - ExpPrim (P n) | curRate == Sr -> ExpPrim (PString n) - Tfm i xs -> Tfm i $ mergeWithPrimOr (ratesFromSignature curRate (infoSignature i)) xs - Select rate pid a -> Select rate pid (fmap (ratedVar Xr) a) - If p t e -> If (rec2 condRate p) (rec1 curRate t) (rec1 curRate e) - ExpNum _ | curRate == Ar || curRate == Xr -> rec2 Xr expr - ExpNum _ -> rec2 curRate expr - - ReadVar v -> ReadVar v - WriteVar v a -> WriteVar v $ rec1 (varRate v) a - InitVar v a -> InitVar v $ rec1 Ir a -- rec1 (varRate v) a - - ReadArr v as -> ReadArr v $ arrIndex v as - WriteArr v as b -> WriteArr v (arrIndex v as) (rec1 (varRate v) b) - WriteInitArr v as b -> WriteInitArr v (arrIndex v as) (rec1 Ir b) - InitArr v as -> InitArr v $ fmap (rec1 Ir) as - TfmArr isInit v i xs -> TfmArr isInit v i $ mergeWithPrimOr (ratesFromSignature curRate (infoSignature i)) xs - - ExpPrim p -> ExpPrim p - IfBegin rootRate _ -> rec2 rootRate expr - UntilBegin _ -> rec2 condRate expr - WhileBegin _ -> rec2 condRate expr - WhileRefBegin var -> WhileRefBegin var --- ElseIfBegin _ -> rec2 condRate expr - ElseBegin -> ElseBegin - IfEnd -> IfEnd - UntilEnd -> UntilEnd - WhileEnd -> WhileEnd - EmptyExp -> EmptyExp - Verbatim a -> Verbatim a - InitMacrosString name initValue -> InitMacrosString name initValue - InitMacrosDouble name initValue -> InitMacrosDouble name initValue - ReadMacrosString name -> ReadMacrosString name - ReadMacrosDouble name -> ReadMacrosDouble name - ReadMacrosInt name -> ReadMacrosInt name - ExpBool _ -> error $ msg "ExpBool expression should be substituted" - ConvertRate _ _ _ -> error $ msg "ConvertRate couldn't be here. It's introduced on the later stages of processing" - Seq _ _ -> error "No rateExp for Seq" - Ends _ -> error "No rateExp for Ends" - InitMacrosInt _ _ -> error "No rateExp for InitMacrosInt" - Starts -> error "No rateExp for Starts" - where ratesFromSignature rate signature = case signature of - SingleRate table -> table M.! rate - MultiRate _ rs -> rs - - condRate :: Rate - condRate = max Kr curRate -- Kr - - rec2 r = fmap (fmap (ratedVar r)) - rec1 r = fmap (ratedVar r) - - arrIndex v as = fmap (rec1 (arrIndexVarRate v)) as - - msg txt = "Csound.Dynamic.Render.Instr.rateExp: " ++ txt - -arrIndexVarRate :: T.Var -> Rate -arrIndexVarRate v = case varRate v of - Ir -> Ir - _ -> Kr - -mergeWithPrimOr :: [Rate] -> [PrimOr Int] -> [PrimOr (Var Rate)] -mergeWithPrimOr = zipWith phi - where - phi r (PrimOr x) = PrimOr $ case x of - Left p -> Left $ updateVarTargetRate r p - Right n -> Right $ ratedVar r n - updateVarTargetRate r p = case p of - PrimVar _ v -> PrimVar r v - _ -> p - - diff --git a/src/Csound/Dynamic/Render/Pretty.hs b/src/Csound/Dynamic/Render/Pretty.hs --- a/src/Csound/Dynamic/Render/Pretty.hs +++ b/src/Csound/Dynamic/Render/Pretty.hs @@ -1,32 +1,39 @@ module Csound.Dynamic.Render.Pretty( Doc, vcatSep, - ppCsdFile, ppGen, ppNotes, ppInstr, ppStmt, ppTotalDur + ppCsdFile, ppGen, ppNotes, ppInstr, ppStmt, ppTotalDur, + PrettyE(..), PrettyShowE(..), + ppE ) where import Control.Monad.Trans.State.Strict -import Data.Char(toLower) import qualified Data.IntMap as IM -import Text.PrettyPrint.Leijen +import Text.PrettyPrint.Leijen.Text import Csound.Dynamic.Types -import qualified Csound.Dynamic.Tfm.DeduceTypes as R(Var(..)) +import Csound.Dynamic.Tfm.InferTypes qualified as R(Var(..)) +import Data.Text (Text) +import Data.Text qualified as Text +import Text.Show.Pretty (ppShow) +import Data.Fix (foldFix) +import Data.ByteString.Base64 qualified as Base64 +import Data.Text.Encoding qualified as Text vcatSep :: [Doc] -> Doc vcatSep = vcat . punctuate line -binaries, unaries :: String -> [Doc] -> Doc +binaries, unaries :: Text -> [Doc] -> Doc binaries op as = binary op (as !! 0) (as !! 1) unaries op as = unary op (as !! 0) -binary :: String -> Doc -> Doc -> Doc -binary op a b = parens $ a <+> text op <+> b +binary :: Text -> Doc -> Doc -> Doc +binary op a b = parens $ a <+> textStrict op <+> b -unary :: String -> Doc -> Doc -unary op a = parens $ text op <> a +unary :: Text -> Doc -> Doc +unary op a = parens $ textStrict op <> a -func :: String -> Doc -> Doc -func op a = text op <> parens a +func :: Text -> Doc -> Doc +func op a = textStrict op <> parens a ppCsdFile :: Doc -> Doc -> Doc -> [Plugin] -> Doc ppCsdFile flags orc sco plugins = @@ -38,13 +45,13 @@ ] ppPlugins :: [Plugin] -> Doc -ppPlugins plugins = vcatSep $ fmap (\(Plugin name body) -> tag name (text body)) plugins +ppPlugins plugins = vcatSep $ fmap (\(Plugin name body) -> tag name (textStrict body)) plugins -tag :: String -> Doc -> Doc +tag :: Text -> Doc -> Doc tag name content = vcatSep [ - char '<' <> text name <> char '>', + char '<' <> textStrict name <> char '>', content, - text " text name <> char '>'] + text " textStrict name <> char '>'] ppNotes :: InstrId -> [CsdEvent] -> Doc ppNotes instrId = vcat . fmap (ppNote instrId) @@ -62,7 +69,7 @@ PString a -> int a PrimInt n -> int n PrimDouble d -> double d - PrimString s -> dquotes $ text s + PrimString s -> dquotes $ textStrict s PrimVar targetRate v -> ppConverter targetRate (varRate v) $ ppVar v where ppConverter dst src t @@ -86,13 +93,13 @@ <+> int 0 <+> (int $ genSize ft) <+> (ppGenId $ genId ft) - <+> (maybe empty (text . show) $ genFile ft) + <+> (maybe empty (textStrict . Text.pack . show) $ genFile ft) <+> (hsep $ map double $ genArgs ft) ppGenId :: GenId -> Doc ppGenId x = case x of IntGenId a -> int a - StringGenId a -> dquotes $ text a + StringGenId a -> dquotes $ textStrict a ppInstr :: InstrId -> Doc -> Doc ppInstr instrId body = vcat [ @@ -103,33 +110,33 @@ ppInstrHeadId :: InstrId -> Doc ppInstrHeadId x = case x of InstrId den nom -> int nom <> maybe empty ppAfterDot den - InstrLabel name -> text name - where ppAfterDot a = text $ ('.': ) $ reverse $ show a + InstrLabel name -> textStrict name + where ppAfterDot a = textStrict $ Text.pack $ ('.': ) $ reverse $ show a ppInstrId :: InstrId -> Doc ppInstrId x = case x of InstrId den nom -> int nom <> maybe empty ppAfterDot den - InstrLabel name -> dquotes $ text name - where ppAfterDot a = text $ ('.': ) $ reverse $ show a + InstrLabel name -> dquotes $ textStrict name + where ppAfterDot a = textStrict $ Text.pack $ ('.': ) $ reverse $ show a type TabDepth = Int -ppStmt :: [RatedVar] -> Exp RatedVar -> State TabDepth Doc +ppStmt :: [R.Var] -> Exp R.Var -> State TabDepth Doc ppStmt outs expr = maybe (ppExp (ppOuts outs) expr) id (maybeStringCopy outs expr) -maybeStringCopy :: [RatedVar] -> Exp RatedVar -> Maybe (State TabDepth Doc) +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) + ([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) + ([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) _ -> Nothing ppStringCopy :: Doc -> Doc -> Doc ppStringCopy outs src = ppOpc outs "strcpyk" [src] -ppExp :: Doc -> Exp RatedVar -> State TabDepth Doc +ppExp :: Doc -> Exp R.Var -> State TabDepth Doc ppExp res expr = case fmap ppPrimOrVar expr of ExpPrim (PString n) -> tab $ ppStrget res n ExpPrim p -> tab $ res $= ppPrim p @@ -137,13 +144,13 @@ Tfm info xs | isPrefix info -> tab $ res $= prefix (infoName info) xs Tfm info xs -> tab $ ppOpc res (infoName info) xs ConvertRate to from x -> tab $ ppConvertRate res to from x - If info t e -> tab $ ppIf res (ppCond info) t e + 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 InitVar v a -> tab $ ppOpc (ppVar v) "init" [a] ReadVar v -> tab $ res $= ppVar v - InitArr v as -> tab $ ppOpc (ppArrVar (length as) v) "init" as + 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 @@ -151,30 +158,45 @@ 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 + InitPureArr _outRate _procRate initVals -> tab $ ppOpc (ppArrVar 1 res) "fillarray" initVals + ReadPureArr outRate _procRate arr index -> tab $ if (outRate /= Sr) then res $= ppReadPureArr arr [index] else res <+> text "strcpy" <+> ppReadPureArr arr [index] + IfBegin _ a -> succTab $ text "if " <> ppCond a <> text " then" + IfBlock _ cond (CodeBlock th) -> tab $ ppIf1 res (ppCond cond) th + IfElseBlock _ cond (CodeBlock th) (CodeBlock el) -> tab $ ppIf res (ppCond cond) th el -- ElseIfBegin a -> left >> (succTab $ text "elseif " <> ppCond a <> text " then") ElseBegin -> left >> (succTab $ text "else") IfEnd -> left >> (tab $ text "endif") - UntilBegin a -> succTab $ text "until " <> ppCond a <> text " do" + 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" + 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 (text name) (text initValue) - InitMacrosDouble name initValue -> tab $ initMacros (text name) (double initValue) - InitMacrosInt name initValue -> tab $ initMacros (text name) (int initValue) + InitMacrosString name initValue -> tab $ initMacros (textStrict name) (textStrict initValue) + InitMacrosDouble name initValue -> tab $ initMacros (textStrict name) (double initValue) + InitMacrosInt name initValue -> tab $ initMacros (textStrict name) (int initValue) ReadMacrosString name -> tab $ res <+> text "strcpy" <+> readMacro name ReadMacrosDouble name -> tab $ res $= readMacro name ReadMacrosInt name -> tab $ res $= readMacro name EmptyExp -> return empty - Verbatim str -> return $ text str - x -> error $ "unknown expression: " ++ show x + Verbatim str -> return $ textStrict str + Select _rate _n a -> tab $ res $= ("SELECTS" <+> a) + Starts -> tab $ res $= "STARTS" + Seq a b -> tab $ hsep ["SEQ", a, b] + Ends _a -> tab $ "ENDS" + ExpBool _ -> tab "ExpBool" + -- x -> error $ "unknown expression: " ++ show x + -- pp macros -readMacro :: String -> Doc -readMacro name = char '$' <> text name +readMacro :: Text -> Doc +readMacro name = char '$' <> textStrict name initMacros :: Doc -> Doc -> Doc initMacros name initValue = vcat @@ -191,12 +213,15 @@ ppArrIndex :: Var -> [Doc] -> Doc ppArrIndex v as = ppVar v <> (hcat $ fmap brackets as) -ppArrVar :: Int -> Var -> Doc -ppArrVar n v = ppVar v <> (hcat $ replicate n $ text "[]") +ppArrVar :: Int -> Doc -> Doc +ppArrVar n v = v <> (hcat $ replicate n $ text "[]") ppReadArr :: Var -> [Doc] -> Doc ppReadArr v as = ppArrIndex v as +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 @@ -216,7 +241,7 @@ shiftByTab :: Doc -> TabDepth -> Doc shiftByTab doc n | n == 0 = doc - | otherwise = (text $ replicate (tabWidth * n) ' ') <> doc + | otherwise = indent (tabWidth * n) doc left :: State TabDepth () left = modify pred @@ -227,8 +252,8 @@ modify succ return a -prefix :: String -> [Doc] -> Doc -prefix name args = text name <> tupled args +prefix :: Text -> [Doc] -> Doc +prefix name args = textStrict name <> tupled args ppCond :: Inline CondOp Doc -> Doc ppCond = ppInline ppCondOp @@ -236,10 +261,10 @@ ($=) :: Doc -> Doc -> Doc ($=) a b = a <+> equals <+> b -ppOuts :: [RatedVar] -> Doc +ppOuts :: [R.Var] -> Doc ppOuts xs = hsep $ punctuate comma $ map ppRatedVar xs -ppPrimOrVar :: PrimOr RatedVar -> Doc +ppPrimOrVar :: PrimOr R.Var -> Doc ppPrimOrVar x = either ppPrim ppRatedVar $ unPrimOr x ppStrget :: Doc -> Int -> Doc @@ -254,16 +279,36 @@ , text "endif" ] -ppOpc :: Doc -> String -> [Doc] -> Doc +ppIf1, ppWhile, ppUntil :: Doc -> Doc -> Doc -> Doc + +ppIf1 = ppIfBy "if" +ppWhile = ppIfBy "while" +ppUntil = ppIfBy "until" + +ppIfBy :: Text -> Doc -> Doc -> Doc -> Doc +ppIfBy leadTag res p t = vcat + [ textStrict leadTag <+> p <+> text "then" + , text " " <> res <+> char '=' <+> t + , 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 -ppProc :: String -> [Doc] -> Doc -ppProc name xs = text name <+> (hsep $ punctuate comma xs) +ppProc :: Text -> [Doc] -> Doc +ppProc name xs = textStrict name <+> (hsep $ punctuate comma xs) ppVar :: Var -> Doc ppVar v = case v of - Var ty rate name -> ppVarType ty <> ppRate rate <> text (varPrefix ty : name) - VarVerbatim _ name -> text name + Var ty rate name -> ppVarType ty <> ppRate rate <> textStrict (Text.cons (varPrefix ty) name) + VarVerbatim _ name -> textStrict name varPrefix :: VarType -> Char varPrefix x = case x of @@ -275,20 +320,25 @@ LocalVar -> empty GlobalVar -> char 'g' -ppConvertRate :: Doc -> Rate -> Rate -> Doc -> Doc +ppConvertRate :: Doc -> Rate -> Maybe Rate -> Doc -> Doc ppConvertRate out to from var = case (to, from) of - (Ar, Kr) -> upsamp var - (Ar, Ir) -> upsamp $ k var - (Kr, Ar) -> downsamp var - (Kr, Ir) -> out $= k var - (Ir, Ar) -> downsamp var - (Ir, Kr) -> out $= i var + (Ar, Just Kr) -> upsamp var + (Ar, Just Ir) -> upsamp $ toK var + (Kr, Just Ar) -> downsamp var + (Kr, Just Ir) -> out $= var + (Ir, Just Ar) -> downsamp var + (Ir, Just Kr) -> out $= toI var + (Ar, Nothing) -> out $= toA var + (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 ++ "." where upsamp x = ppOpc out "upsamp" [x] downsamp x = ppOpc out "downsamp" [x] - k = func "k" - i = func "i" + toA = func "a" + toK = func "k" + toI = func "i" -- expressions @@ -329,15 +379,145 @@ bi = binaries uno = unaries -ppRatedVar :: RatedVar -> Doc -ppRatedVar v = ppRate (ratedVarRate v) <> int (ratedVarId v) +ppRatedVar :: R.Var -> Doc +ppRatedVar v = ppRate (R.varType v) <> int (R.varId v) ppRate :: Rate -> Doc -ppRate x = case x of +ppRate x = case removeArrRate x of Sr -> char 'S' _ -> phi x - where phi = text . map toLower . show + where phi = textStrict . Text.toLower . Text.pack . show ppTotalDur :: Double -> Doc ppTotalDur d = text "f0" <+> double d + +-------------------------------------------------------------- +-- debug + +newtype PrettyShowE = PrettyShowE E +newtype PrettyE = PrettyE E + +instance Show PrettyShowE where + show (PrettyShowE expr) = ppShow expr + +instance Show PrettyE where + show (PrettyE expr) = show $ ppE expr + +ppE :: E -> Doc +ppE = foldFix go + where + go :: RatedExp Doc -> Doc + go x = fromExp (fromInfo x) x + + fromInfo :: RatedExp Doc -> Doc + fromInfo RatedExp{..} = + hsep + [ ppHash ratedExpHash + , maybe mempty ppRate ratedExpRate + , maybe mempty pretty ratedExpDepends + ] + + ppHash = textStrict . Text.take 4 . Text.decodeUtf8 . Base64.encode + + 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 + 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 + + -- TODO + InitArr _v _size -> undefined + ReadArr _v _index -> undefined + WriteArr _v _index _ -> undefined + WriteInitArr _v _index _ -> undefined + TfmArr _isInit _v _info _args -> undefined + + InitPureArr _outRate _procRate _vals -> undefined + ReadPureArr _outRate _procRate _arr _index -> undefined + + IfBegin rate cond -> hsep ["IF", ppRate $ fromIfRate rate, ppCond $ fmap pp cond, "\n"] + + IfBlock rate cond (CodeBlock th) -> ppIfBlockBy "IF-BLOCK" rate cond th + IfElseBlock rate cond (CodeBlock th) (CodeBlock el) -> + ppFun (hsep ["IF-BLOCK", ppRate $ fromIfRate rate, ppCond $ fmap pp cond ]) + [ pp th + , "ELSE-BLOCK" + , pp el + , "END-BLOCK" + ] + ElseBegin -> "ELSE" + IfEnd -> "END_IF" + 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" + Seq a b -> vcat ["SEQ", pp a, pp b] + Ends a -> vcat ["ENDS", pp a] + InitMacrosInt _name _n -> undefined + InitMacrosDouble _name _d -> undefined + InitMacrosString _name _str -> undefined + ReadMacrosInt _name -> undefined + ReadMacrosDouble _name -> undefined + ReadMacrosString _name -> undefined + where + post a = hsep [hcat ["{",info, "}:"], a] + + ppIfBlockBy leadTag rate cond th = + ppFun (hsep [leadTag, ppRate $ fromIfRate rate, ppCond $ fmap pp cond ]) + [ pp th + , "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) + + ppConvert to from a = + ppFun (hsep [textStrict "Convert-rate", ppRate to, maybe mempty ppRate from]) [pp a] + + ppSelect rate n arg = + ppFun (hsep ["select", ppRate rate, pretty n]) [pp arg] + + ppIff rate cond th el = + vcat + [ hsep ["if", ppRate (fromIfRate rate), ppCond $ fmap pp cond] + , indent 2 $ vcat + [ "then" <+> pp th + , "else" <+> pp el + ] + ] + + ppExpNum (PreInline op as) = ppNumOp op (fmap pp as) + + ppInitVar v a = + ppFun (hsep ["InitVar", ppVar v]) [pp a] + + ppFun name args = + vcat + [ name + , indent 2 $ vcat args + ] + + pp = either ppPrim id . unPrimOr diff --git a/src/Csound/Dynamic/Tfm/DeduceTypes.hs b/src/Csound/Dynamic/Tfm/DeduceTypes.hs deleted file mode 100644 --- a/src/Csound/Dynamic/Tfm/DeduceTypes.hs +++ /dev/null @@ -1,124 +0,0 @@ -module Csound.Dynamic.Tfm.DeduceTypes( - Var(..), TypeGraph(..), Convert(..), Stmt, deduceTypes -) where - -import Data.List(nub) -import qualified Data.Map as M -import qualified Data.IntMap as IM -import qualified Data.Traversable as T - -import Data.STRef -import Control.Monad.ST -import Data.Array.ST - -type TypeRequests s ty = STArray s Int [ty] - -initTypeRequests :: Int -> ST s (TypeRequests s ty) -initTypeRequests size = newArray (0, size - 1) [] - -requestType :: Var ty -> TypeRequests s ty -> ST s () -requestType v arr = modifyArray arr (varId v) (varType v :) - -modifyArray :: Ix i => STArray s i a -> i -> (a -> a) -> ST s () -modifyArray arr i f = writeArray arr i . f =<< readArray arr i - -getTypes :: Int -> TypeRequests s ty -> ST s [ty] -getTypes n arr = readArray arr n - --- | Typed variable. -data Var a = Var - { varId :: Int - , varType :: a - } deriving (Show, Eq, Ord) - -data GetType ty - = NoConversion ty - -- If there is a conversion we look for a fresh identifier by map - -- (map converts mismatched type to fresh identifier) - | ConversionLookup (Var ty) (M.Map ty Int) - -type TypeMap ty = IM.IntMap (GetType ty) - -lookupVar :: (Show a, Ord a) => TypeMap a -> Var a -> Var a -lookupVar m (Var i r) = case m IM.! i of - NoConversion ty -> Var i ty - ConversionLookup noConv f -> maybe noConv (flip Var r) $ M.lookup r f - --- Statement: assignment, like --- leftHandSide = RightHandSide( arguments ) -type Stmt f a = (a, f a) - --- When we have type collisions we have to insert converters: -data Convert a = Convert - { convertFrom :: Var a - , convertTo :: Var a } - -data Line f a = Line - { lineType :: (Int, GetType a) - , lineStmt :: Stmt f (Var a) - , lineConverts :: [Convert a] } - --- Algorithm specification for the given functor 'f' and type labels of 'a'. -data TypeGraph f a = TypeGraph - -- create a type conversion statement - { mkConvert :: Convert a -> Stmt f (Var a) - -- for a given statement and a list of requested types for the output produces a pair of - -- (nonConvertibleTypes, statementWithDeducedTypes) - -- nonConvertibleTypes is used for insertion of converters. - , defineType :: Stmt f Int -> [a] -> ([a], Stmt f (Var a)) } - --- | Deduces types for a dag: --- --- deduceTypes (functorSpecificFuns) (dag) = (dagWithTypes, lastFreshIdentifier) --- --- Assumption -- dag is labeled with integers. Labels are unique --- and a list of labels is a range (0, n) (It's just what we get with CSE algorithm). --- --- Algorithm proceeds as follows. We init an array of type requests and a reference for fresh identifiers. --- Type request comes from right hand side of the statement. We need fresh identifiers for converters. --- If we are going to use a new statement for conversion we need new variables. --- --- (discussLine) --- Then we process lines in reverse order and collect type requests by looking at right hand sides --- and writing type requests for all arguments. --- --- (processLine) --- In the second run we substitute all identifiers with typed variables. It's no so strightforward --- due to converters. If there are converters we have to insert new statements and substitute identifiers --- with new ones. That's why we convert variables to variables in the processLine. --- -deduceTypes :: (Show a, Ord a, T.Traversable f) => TypeGraph f a -> [Stmt f Int] -> ([Stmt f (Var a)], Int) -deduceTypes spec as = runST $ do - freshIds <- newSTRef n - typeRequests <- initTypeRequests n - lines' <- mapM (discussLine spec typeRequests freshIds) $ reverse as - let typeMap = IM.fromList $ fmap lineType lines' - lastId <- readSTRef freshIds - return (reverse $ processLine typeMap =<< lines', lastId) - where n = succ $ if (null as) then 0 else (fst $ last as) - processLine typeMap line = fmap (mkConvert spec) (lineConverts line) ++ [(a, fmap (lookupVar typeMap) b)] - where (a, b) = lineStmt line - -discussLine :: (Ord a, T.Traversable f) => TypeGraph f a -> TypeRequests s a -> STRef s Int -> Stmt f Int -> ST s (Line f a) -discussLine spec typeRequests freshIds stmt@(pid, _) = do - (conv, expr') <- fmap (defineType spec stmt . nub) $ getTypes pid typeRequests - _ <- T.traverse (flip requestType typeRequests) (snd expr') - let curType = fst expr' - (getType, convs) <- mkGetType conv curType freshIds - return $ Line (pid, getType) expr' convs - -mkGetType :: Ord a => [a] -> Var a -> STRef s Int -> ST s (GetType a, [Convert a]) -mkGetType typesToConvert curVar freshIds - | null typesToConvert = return (NoConversion $ varType curVar, []) - | otherwise = do - ids <- nextIds n freshIds - return (ConversionLookup curVar $ M.fromList (zip typesToConvert ids), - zipWith (\i t -> Convert curVar (Var i t)) ids typesToConvert) - where n = length typesToConvert - -nextIds :: Int -> STRef s Int -> ST s [Int] -nextIds n ref = do - curId <- readSTRef ref - writeSTRef ref (curId + n) - return [curId .. n + curId] - diff --git a/src/Csound/Dynamic/Tfm/IfBlocks.hs b/src/Csound/Dynamic/Tfm/IfBlocks.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Dynamic/Tfm/IfBlocks.hs @@ -0,0 +1,573 @@ +-- | We collect all if-blocks under the if-the-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 +-- relative to that block +-- +-- For exampe consider expression: +-- +-- > k3 opcA k2 k1 +-- > k4 opcB 1, 120 +-- > +-- > if cond then +-- > k5 = k3 +-- > else +-- > k5 = k4 +-- > endif +-- > +-- It can be transformed to: +-- +-- > if cond then +-- > k3 opcA k2 k1 +-- > k5 = k3 +-- > else +-- > k4 opcB 1, 120 +-- > k5 = k4 +-- > endif +-- +-- We bring relevant to if-blocks expressions inside the block. +-- But we should be careful not to touch the expressions that are dependencies +-- to expressions outside of the block. +-- +-- The algorithm to find groups of such expressions proceeds as follows: +-- +-- * count how many times given expression is used in RHS of the expression. +-- Create a table for fast access (O (expr-size)). Let's call it global count. +-- +-- * for a given expression definition start to follow it's dependencies recursively +-- and count for all siblings how many times they are used in RHS of the expression.-- +-- Let's call it local count +-- +-- * The rule: for a given integer label/name +-- * if the global count equals to the local count +-- it can be brought inside if-block. Because all it's usages are inside the sub-expressions +-- of that block and does not leak to the outer scope. +-- * if name is not a sibling of the node for which the rule does not hold true +-- +-- There are cases when node is inside if sub-graph but the problem is that one of it's +-- parents may be not fit to the graph. To solve this problem we go over the sub-graph 2 times: +-- +-- 1) to collect local counts we create IntMap of Usage counts local to the if-block +-- 2) to mark as False all nodes that are not local to if and also (IMPORTANT) mark as False all it's children. +-- As we traverse the graph in breadth first we will recursively mark all non fit siblings. +-- I hope that it works :) +-- On this stage we create a set of nodes which are truly local +-- this is a set of local variables +-- +-- One buggy solution was to traverse the sub graph and put inside the set the +-- nodes which are local regarding the ussage count. But this does not work as +-- valid node can have invalid parent. And algorithm will exclude parent but +-- keep the child which will lead to the broken code. +-- +-- This rule works for generic expressions defined on traversable functor F. +-- +-- But there are some Csound peculiriaties: +-- +-- * reminder: +-- * if-blocks can work on Ir and on Kr rates. +-- * Kr if-blocks are ignored on initialization Ir stage. +-- +-- * this leads to csound syntax specific rules: +-- +-- * init expressions can not be brought inside Kr if-block (they will be ignored) +-- also Opcodes that run at I-rate. +-- +-- * variable / array initialisation can not be brought inside Kr if-block +-- +-- * all constants inside the block should have the same rate as the block itself. +-- i.e. ir constants inside Ir block and kr constants inside kr block +-- +-- So we should recursively follow the depndencies of the if-block root variable definition. +-- But we also exclude nodes early if they can not be present inside the block by rate. +module Csound.Dynamic.Tfm.IfBlocks + ( collectIfBlocks + ) where + +import Csound.Dynamic.Types.Exp hiding (Var(..)) +import Csound.Dynamic.Types.Exp qualified as Exp +import Control.Monad +import Control.Monad.ST +import Control.Monad.Trans.Class +import Control.Monad.Trans.State.Strict +import Data.Maybe (fromMaybe) +import Data.Vector.Mutable qualified as Vector +import Data.Vector.Unboxed.Mutable qualified as UnboxedVector +import Data.List qualified as List +import Data.IntMap.Strict (IntMap) +import Data.IntMap.Strict qualified as IntMap +import Data.IntSet (IntSet) +import Data.IntSet qualified as IntSet +import Data.STRef +import Data.Bifunctor (first) +import Csound.Dynamic.Tfm.InferTypes (InferenceResult (..), Stmt(..), Var(..)) +import Data.Text qualified as Text +-- import Debug.Trace + +type Expr = Stmt Var + +collectIfBlocks :: InferenceResult -> InferenceResult +collectIfBlocks infRes@InferenceResult{..} + | programHasIfs = runST $ do + env <- newEnv programLastFreshId typedProgram + uncurry toResult =<< runStateT (collectIter [] $ List.reverse typedProgram) env + | otherwise = infRes + where + toResult :: [Stmt Var] -> Env s -> ST s InferenceResult + toResult prog Env{..} = do + lastId <- readSTRef envLastFreshId + pure $ infRes { typedProgram = prog, programLastFreshId = lastId } + +-- | Monad of the algorithm +type Collect s a = StateT (Env s) (ST s) a + +type UsageCounts s = UnboxedVector.STVector s Int +type DagGraph s = Vector.STVector s (RatedExp Var) +type IsInits s = UnboxedVector.STVector s Bool + +-- | Internal mutable state of the algorithm +data Env s = Env + { envUsageCount :: UsageCounts s + , envDag :: DagGraph s + , envIsInit :: IsInits s + , envLastFreshId :: STRef s Int + , envDagSize :: Int + } + +--------------------------------------------------- +-- collect interface + +getDagSize :: Collect s Int +getDagSize = gets envDagSize + +readGlobalUsages :: Int -> Collect s Int +readGlobalUsages n = do + dagSize <- getDagSize + if n < dagSize + then do + usages <- gets envUsageCount + lift $ UnboxedVector.read usages n + else pure 0 + +readIsInit :: Int -> Collect s Bool +readIsInit n = do + dagSize <- getDagSize + if n < dagSize + then do + inits <- gets envIsInit + lift $ UnboxedVector.read inits n + else pure False + +readDag :: Var -> Collect s (Maybe Expr) +readDag lhs = do + dagSize <- getDagSize + if varId lhs < dagSize + then do + dag <- gets envDag + fmap (Just . (Stmt lhs )) $ lift $ Vector.read dag (varId lhs) + else pure Nothing + +withDag :: Var -> (Expr -> Collect s ()) -> Collect s () +withDag n cont = do + mExpr <- readDag n + forM_ mExpr cont + +freshId :: Collect s Int +freshId = do + ref <- gets envLastFreshId + lift $ do + newId <- readSTRef ref + modifySTRef' ref succ + pure newId + +--------------------------------------------------------------------------- +-- 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 update initSt getIsEnd (PrimOr root) = do + case root of + Left _ -> pure initSt + Right var -> do + ref <- lift $ newSTRef initSt + traverseDag var getIsEnd (go ref) + lift $ readSTRef ref + where + go :: STRef s a -> Expr -> Collect s () + go ref expr = do + val <- lift $ readSTRef ref + newVal <- update expr val + lift $ writeSTRef ref $ + -- trace (unlines ["GO", show $ stmtLhs expr, show $ ratedExpExp $ stmtRhs expr, show newVal]) $ + 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) + + +----------------------------------------------------------- + +newEnv :: forall s . Int -> [Expr] -> ST s (Env s) +newEnv exprSize exprs = do + usageCount <- UnboxedVector.replicate exprSize 0 + dag <- Vector.new exprSize + isInit <- UnboxedVector.replicate exprSize False + exprSizeRef <- newSTRef exprSize + let env = Env usageCount dag isInit exprSizeRef exprSize + mapM_ (go env) exprs + pure env + where + go :: Env s -> Expr -> ST s () + go env expr = do + updateUsageCount (envUsageCount env) expr + updateDag (envDag env) expr + updateIsInit (envIsInit env) expr + + updateUsageCount :: UsageCounts s -> Expr -> ST s () + updateUsageCount usageCounts expr = + mapM_ count (stmtRhs expr) + where + count v = UnboxedVector.modify usageCounts succ (varId v) + + updateDag :: DagGraph s -> Expr -> ST s () + updateDag dag (Stmt lhs rhs) = + Vector.write dag (varId lhs) rhs + + updateIsInit :: IsInits s -> Expr -> ST s () + updateIsInit isInit expr = + when (isInitExpr expr) $ + UnboxedVector.write isInit (varId $ stmtLhs expr) True + +-- | Be sure not to bring initialization expression inside the if-blocks +isInitExpr :: Stmt Var -> Bool +isInitExpr expr = + (varType (stmtLhs expr) == Ir) || checkExpr (ratedExpExp $ stmtRhs expr) + where + checkExpr = \case + InitVar _ _ -> True + InitArr _ _ -> True + TfmArr isInit _ _ _ -> isInit + InitPureArr _ _ _ -> True + InitMacrosInt _ _ -> True + InitMacrosDouble _ _ -> True + InitMacrosString _ _ -> True + ConvertRate Ir _ _ -> True + Select Ir _ _ -> True + _ -> False + +data ExprType a + = PlainType + | IfType IfRate (CondInfo a) a (IfCons a) + | IfElseType IfRate (CondInfo a) a a (IfElseCons a) + | IfExpType IfRate (CondInfo a) a a + +data IfCons a = IfCons + { ifBegin :: IfRate -> CondInfo a -> MainExp a + , ifEnd :: MainExp a + } + +data IfElseCons a = IfElseCons + { ifElseBegin :: IfRate -> CondInfo a -> MainExp a + , elseBegin :: MainExp a + , ifElseEnd :: MainExp a + } + +type LocalUsageCounts = IntMap Int +type LocalVars = IntSet + +-- | We process statements in reverse order +-- and then also accumulation happens in reverse +-- so we don't need to reverse twice +collectIter :: [Stmt Var] -> [Stmt Var] -> Collect s [Stmt Var] +collectIter results = \case + [] -> pure results + expr : exprs -> + case getExprType (stmtRhs expr) of + PlainType -> onPlain expr exprs + IfType rate check th cons -> onIf rate check th cons (stmtLhs expr) exprs + IfElseType rate check th el cons -> onIfElse rate check th el cons (stmtLhs expr) exprs + IfExpType rate check th el -> onIfExp rate check th el (stmtLhs expr) exprs + where + onPlain expr rest = collectIter (expr : results) rest + + onIf ifRate check th cons lhs exprs = do + vs <- blockLocalVars ifRate th + (newIfBlock, rest) <- redefineIf vs lhs ifRate check cons exprs + toResult newIfBlock rest + + toResult newIfBlock rest = do + collectIter (copyToResult newIfBlock results) rest + + copyToResult :: [a] -> [a] -> [a] + copyToResult items result = List.foldl' (flip (:)) result items + + blockLocalVars ifRate root = do + localUsage <- getLocalUsage ifRate root + -- globals <- mapM (\v -> (\g -> (v, (g, localUsage IntMap.! v))) <$> readGlobalUsages v) $ IntMap.keys localUsage + -- trace (unlines $ show <$> globals) $ + getLocalVars localUsage ifRate root + + onIfElse ifRate check th el cons lhs exprs = do + thVars <- blockLocalVars ifRate th + elVars <- blockLocalVars ifRate el + (newIfBlock, rest) <- redefineIfElse thVars elVars lhs ifRate check cons exprs + toResult newIfBlock rest + + onIfExp ifRate check th el lhs exprs = do + thVars <- blockLocalVars ifRate th + elVars <- blockLocalVars ifRate el + (newIfBlock, rest) <- redefineIfElseExp thVars elVars th el lhs ifRate check cons exprs + toResult newIfBlock rest + where + cons = IfElseCons { ifElseBegin = IfBegin, elseBegin = ElseBegin, ifElseEnd = IfEnd } + +collectSubs :: Bool -> [Expr] -> Collect s [Expr] +collectSubs hasIfs newIfBlock + | hasIfs = List.reverse <$> collectIter [] newIfBlock + | otherwise = pure newIfBlock + +redefineIf :: + LocalVars + -> Var + -> IfRate + -> CondInfo (PrimOr Var) + -> IfCons (PrimOr Var) + -> [Expr] + -> Collect s ([Expr], [Expr]) +redefineIf localVars ifBeginId ifRate condInfo IfCons{..} exprs = do + ifStmts <- getIfStmts + first (toResult ifStmts) <$> iterRedefine ifRate localVars blockSize [] False [] exprs + where + blockSize = IntSet.size localVars + + -- | we expect if-block expressions to be reversed + toResult (ifBeginStmt, ifEndStmt) blockExprs = + ifEndStmt : blockExprs <> [ifBeginStmt] + + getIfStmts = do + ifEndId <- freshId + let ifEndStmt = Stmt (Var Xr ifEndId) (toRatedExp ifEnd) + ifBeginStmt = Stmt ifBeginId (toRatedExp $ ifBegin ifRate condInfo) + pure (ifBeginStmt, ifEndStmt) + +iterRedefine :: IfRate -> LocalVars -> Int -> [Expr] -> Bool -> [Expr]-> [Expr] -> Collect s ([Expr], [Expr]) +iterRedefine ifRate localVars currentBlockSize resultIfExprs hasIfs resultRest nextExprs + | currentBlockSize <= 0 = result + | otherwise = + case nextExprs of + [] -> result + e@(Stmt lhs _) : es -> + if isLocal lhs + then appendLocal e es + else appendRest e es + where + rec onBlockSize expr onIfExprs onRestExprs newNextExprs = + iterRedefine + ifRate + localVars + (onBlockSize currentBlockSize) + (onIfExprs resultIfExprs) + (hasIfs || (isIfExpr $ stmtRhs expr)) + (onRestExprs resultRest) + newNextExprs + + result = recollect + ( List.reverse $ resultIfExprs + , hasIfs + , List.reverse resultRest <> nextExprs + ) + + recollect (newIfBlock, finalHasIfs, rest) = do + newIfBlockCollected <- collectSubs finalHasIfs newIfBlock + pure (newIfBlockCollected, rest) + + appendLocal e es = rec pred e (e : ) id es + appendRest e es = rec id e id (e : ) es + + isLocal :: Var -> Bool + isLocal var = IntSet.member (varId var) localVars + +redefineIfElse :: + LocalVars + -> LocalVars + -> Var + -> IfRate + -> CondInfo (PrimOr Var) + -> IfElseCons (PrimOr Var) + -> [Expr] + -> Collect s ([Expr], [Expr]) +redefineIfElse thLocalVars elLocalVars ifBeginId ifRate condInfo IfElseCons{..} exprs = do + ifStmts <- getIfElseStmts + (ifBlockExprs, rest1) <- getIfPart exprs + (elseBlockExprs, rest2) <- getElsePart rest1 + pure (toResult ifStmts ifBlockExprs elseBlockExprs, rest2) + where + -- note that block epxressions are reversed + toResult (ifBeginStmt, elseBeginStmt, ifEndStmt) ifBlockExprs elseBlockExprs = + ifEndStmt : mconcat + [ elseBlockExprs + , [elseBeginStmt] + , ifBlockExprs + , [ifBeginStmt] + ] + + getIfElseStmts = do + let ifBeginStmt = Stmt ifBeginId (toRatedExp $ ifElseBegin ifRate condInfo) + elseBeginStmt <- (\elId -> Stmt (Var Xr elId) (toRatedExp elseBegin)) <$> freshId + ifEndStmt <- (\endId -> Stmt (Var Xr endId) (toRatedExp ifElseEnd)) <$> freshId + pure (ifBeginStmt, elseBeginStmt, ifEndStmt) + + getIfPart es = iterRedefine ifRate thLocalVars ifBlockSize [] False [] es + getElsePart es = iterRedefine ifRate elLocalVars elseBlockSize [] False [] es + + ifBlockSize = IntSet.size thLocalVars + elseBlockSize = IntSet.size elLocalVars + +redefineIfElseExp :: + forall s + . LocalVars + -> LocalVars + -> PrimOr Var + -> PrimOr Var + -> Var + -> IfRate + -> CondInfo (PrimOr Var) + -> IfElseCons (PrimOr Var) + -> [Expr] + -> Collect s ([Expr], [Expr]) +redefineIfElseExp thLocalVars elLocalVars th el ifResultId ifRate condInfo IfElseCons{..} exprs = do + ifStmts <- getIfElseStmts + -- note that blocks are returned in reversed order + (ifBlockExprs, rest1) <- getIfPart exprs + (elseBlockExprs, rest2) <- getElsePart rest1 + ifResult <- toResult ifStmts ifBlockExprs elseBlockExprs + pure (ifResult, rest2) + where + -- note that expressions in the blocks are returned in reversed order + toResult :: (Expr, Expr, Expr) -> [Expr] -> [Expr] -> Collect s [Expr] + toResult (ifBeginStmt, elseBeginStmt, ifEndStmt) ifBlockExprs elseBlockExprs = do + thAssign <- writeRes ifResultId th + elAssign <- writeRes ifResultId el + pure $ + ifEndStmt : elAssign : mconcat + [ elseBlockExprs + , [elseBeginStmt, thAssign] + , ifBlockExprs + , [ifBeginStmt] + ] + + getIfElseStmts = do + ifBeginStmt <- (\ifBeginId -> (Stmt (Var Xr ifBeginId) $ toRatedExp $ ifElseBegin ifRate condInfo)) <$> freshId + elseBeginStmt <- (\elId -> (Stmt (Var Xr elId) $ toRatedExp elseBegin)) <$> freshId + ifEndStmt <- (\endId -> (Stmt (Var Xr endId) $ toRatedExp ifElseEnd)) <$> freshId + pure (ifBeginStmt, elseBeginStmt, ifEndStmt) + + getIfPart es = iterRedefine ifRate thLocalVars ifBlockSize [] False [] es + getElsePart es = iterRedefine ifRate elLocalVars elseBlockSize [] False [] es + + ifBlockSize = IntSet.size thLocalVars + elseBlockSize = IntSet.size elLocalVars + + writeRes :: Var -> PrimOr Var -> Collect s Expr + writeRes resId expr = do + varWriteId <- freshId + pure $ Stmt + { stmtLhs = Var Xr varWriteId + , stmtRhs = toRatedExp $ WriteVar (toVar resId) expr + } + + toVar v = Exp.VarVerbatim (varType v) name + where + name = Text.toLower $ Text.pack $ show (varType v) ++ show (varId v) + + +toRatedExp :: MainExp (PrimOr a) -> RatedExp a +toRatedExp expr = + RatedExp + { ratedExpHash = "" + , ratedExpDepends = Nothing + , ratedExpRate = Nothing + , ratedExpExp = expr + } + +type LocalMarks = IntMap Bool + +getLocalVars :: forall s . LocalUsageCounts -> IfRate -> PrimOr Var -> Collect s LocalVars +getLocalVars localUsages ifRate root = toSet <$> + traverseAccumDag update initMarks (isEnd ifRate) root + where + initMarks = either (const IntMap.empty) (\var -> IntMap.singleton (varId var) True) $ unPrimOr root + + update :: Expr -> LocalMarks -> Collect s LocalMarks + update (Stmt lhs rhs) localMarks + | isParentLocal = do + isLocal <- fullyInsideLocal lhs + let tfm = if isLocal then id else onFalseLocal + pure $ tfm $ IntMap.alter (Just . maybe isLocal (isLocal &&)) (varId lhs) localMarks + | otherwise = pure $ onFalseLocal localMarks + where + isParentLocal = fromMaybe True $ IntMap.lookup (varId lhs) localMarks + + onFalseLocal = + execState (mapM_ (\v -> modify' $ IntMap.insert (varId v) False) rhs) + + fullyInsideLocal :: Var -> Collect s Bool + fullyInsideLocal lhs = do + globalCount <- readGlobalUsages (varId lhs) + let localCount = IntMap.lookup (varId lhs) localUsages + pure $ Just globalCount == localCount + + toSet :: LocalMarks -> LocalVars + toSet = IntMap.keysSet . IntMap.filter id + +getLocalUsage :: forall s . IfRate -> PrimOr Var -> Collect s LocalUsageCounts +getLocalUsage ifRate root = + traverseAccumDag update initCount (isEnd ifRate) root + where + initCount = either (const IntMap.empty) (\var -> IntMap.singleton (varId var) 1) $ unPrimOr root + + update :: Expr -> LocalUsageCounts -> Collect s LocalUsageCounts + update (Stmt _lhs rhs) st = pure $ + execState (mapM_ count rhs) st + + count var = modify' $ IntMap.alter (Just . maybe 1 succ) (varId var) + +--------------------------------------------------------------------------- + +-- | Defines rule that if we are inside Kr if-block we can not bring inside +-- Ir-expressions +isEnd :: IfRate -> Expr -> Collect s Bool +isEnd ifRate (Stmt lhs rhs) + | isInitVar rhs = pure True + | otherwise = case ifRate of + IfIr -> pure False + IfKr -> readIsInit (varId lhs) + +isInitVar :: RatedExp Var -> Bool +isInitVar expr = + case ratedExpExp expr of + InitVar _ _ -> True + InitArr _ _ -> True + _ -> False + +isIfExpr :: RatedExp Var -> Bool +isIfExpr rhs = case getExprType rhs of + PlainType -> False + _ -> True + +getExprType :: RatedExp Var -> ExprType (PrimOr Var) +getExprType expr = + case ratedExpExp expr of + If rate c th el -> IfExpType rate c th el + IfBlock rate c (CodeBlock th) -> IfType rate c th $ IfCons { ifBegin = IfBegin, ifEnd = IfEnd } + IfElseBlock rate c (CodeBlock th) (CodeBlock el) -> -- trace (unlines ["TH/EL", show (th, el)]) + 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 diff --git a/src/Csound/Dynamic/Tfm/InferTypes.hs b/src/Csound/Dynamic/Tfm/InferTypes.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Dynamic/Tfm/InferTypes.hs @@ -0,0 +1,692 @@ +-- | Algorithm to infer csound rates. It's type inference for Csound. +-- +-- It proceeds from epxression leaves to the top of the expression tree while assigning the rates. +-- The expression is DAG defined as list which is sorted by dependencies from bottom to top. +-- +-- We traverse over the list and assign types to the terms. +-- Assumptions: +-- +-- * type of primitive values is Ir or Sr +-- * type of numeric expression is minimal type of it's arguments +-- +-- * type of opcode is determined by the choice of the most fit signature to the arguments +-- unless it's required by the user to be of specific type. +-- We try to find the signature that leads to lesser amount of destructive conversions overall. +-- +-- * If-then-else type: +-- * for condition it is derived form ifRate in the argument of If-constructor +-- * the output is a minimum of types of the branches +-- +-- * procedures' output is asssigned with Xr type +-- +-- Note on type ordering they go in order of definition from amount of memory used: +-- Xr | Ar | Kr | Ir +-- +-- So the Ar is the minimum +module Csound.Dynamic.Tfm.InferTypes + ( inferTypes + , InferenceOptions (..) + , InferenceResult (..) + , OpcodeInferenceStrategy (..) + , Stmt(..) + , Var(..) + ) where + +import Safe +import Control.Monad (zipWithM, foldM) +import Data.Semigroup (Min(..)) +import Data.List qualified as List +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 +import Data.Vector.Mutable (STVector) +import Data.Vector.Mutable qualified as Vector +import Control.Monad.ST +import Data.Maybe (fromMaybe) +import Data.IntMap (IntMap) +import Data.IntMap qualified as IntMap +import Data.Text qualified as Text + +import Csound.Dynamic.Const qualified as Const +import Csound.Dynamic.Types.Exp hiding (Var, varType) +import Csound.Dynamic.Types.Exp qualified as Exp +-- import Debug.Trace (trace) + +-- core types + +data Stmt a = Stmt + { stmtLhs :: !a + , stmtRhs :: !(RatedExp a) + } + deriving (Show, Eq, Ord) + +data Var = Var + { varType :: !Rate + , varId :: !Int + } + deriving (Show, Eq, Ord) + +data InferenceResult = InferenceResult + { typedProgram :: ![Stmt Var] + , programLastFreshId :: !Int + , programHasIfs :: !Bool + -- ^ does program has if-statemenrs + -- we need it for the next optimization stage + } + +-- option types + +data InferenceOptions = InferenceOptions + { opcodeInferenceStrategy :: !OpcodeInferenceStrategy + , opcodeInferencePreference :: !OpcodeInferencePreference + } + deriving (Eq, Ord, Show, Read) + +data OpcodeInferenceStrategy + = PreferControlRate -- prefer Kr-outputs for opcodes + | PreferAudioRate -- prefer Ar-outputs for opcodes + deriving (Eq, Ord, Show, Read) + +data OpcodeInferencePreference = OpcodeInferencePreference + { preferControlOpcodes :: HashSet Name -- ^ set of opcode names to use Kr by default + , preferAudioOpcodes :: HashSet Name -- ^ set of opcode names to use Ar by default + } + deriving (Eq, Ord, Show, Read) + + +-- | Infer types/rates for a csound program +inferTypes :: InferenceOptions -> [Stmt Int] -> InferenceResult +inferTypes opts exprs = runST $ do + env <- initEnv + toResult <$> execStateT (mapM_ (inferIter opts) exprs) env + where + initEnv :: ST s (InferEnv s) + initEnv = do + typeMap <- Vector.replicate size Xr + pure InferEnv + { envTypeMap = typeMap + , envConversions = IntMap.empty + , envLastFreshId = size + , envResult = [] + , envHasIfs = False + , envPrims = Map.empty + } + + toResult InferEnv{..} = + InferenceResult + { typedProgram = List.reverse envResult + , programLastFreshId = envLastFreshId + , programHasIfs = envHasIfs + } + + size = succ $ maybe 0 stmtLhs $ headMay $ List.reverse exprs + +type Infer s a = StateT (InferEnv s) (ST s) a + +-- | Type-inference state +data InferEnv s = InferEnv + { envTypeMap :: !(STVector s Rate) + -- ^ types inferrred so far + , envConversions :: !(IntMap (Map Rate Var)) + -- ^ conversions + , envLastFreshId :: !Int + -- ^ last fresh id (we use it to insert new variables for conversions) + , envResult :: ![Stmt Var] + -- ^ typed program accumulated in reversed order + , envPrims :: Map Prim Var + -- ^ sometimes we need to allocate new primitive value to convert it + , envHasIfs :: !Bool + } + +------------------------------------------------------------------------------------- +-- options + +type OpcSignature = (Rate, [Rate]) + +preferOpc :: InferenceOptions -> Name -> Map Rate [Rate] -> Either [OpcSignature] OpcSignature +preferOpc (InferenceOptions strategy opcPrefs) name signatureMap + | Just sig <- getControl = Right sig + | Just sig <- getAudio = Right sig + | otherwise = Left $ + case strategy of + PreferControlRate -> List.reverse $ Map.toList signatureMap + PreferAudioRate -> Map.toList signatureMap + where + getControl = getBy Kr (preferControlOpcodes opcPrefs) + getAudio = getBy Ar (preferAudioOpcodes opcPrefs) + + getBy rate s + | HashSet.member name s = (rate, ) <$> Map.lookup rate signatureMap + | otherwise = Nothing + +instance Default InferenceOptions where + def = InferenceOptions + { opcodeInferenceStrategy = PreferControlRate + , opcodeInferencePreference = + OpcodeInferencePreference + { preferControlOpcodes = Const.controlOpcodes + , preferAudioOpcodes = Const.audioOpcodes + } + } + +------------------------------------------------------------------------------------- +-- inference + +inferIter :: forall s . InferenceOptions -> Stmt Int -> Infer s () +inferIter opts (Stmt lhs rhs) = + -- trace (unlines ["INFER RHS", show $ ratedExpExp rhs, show $ ratedExpRate rhs, "\n"]) $ + case ratedExpExp rhs of + -- primitives + ExpPrim p -> onPrim p + + -- | Application of the opcode: we have opcode information (Info) and the arguments [a] + Tfm info args -> onTfm info args + + ConvertRate toRate fromRate a -> onConvertRate toRate fromRate a + Select rate outId arg -> onSelect rate outId arg + + -- | Numerical expressions (rendered in infix notation in the Csound) + ExpNum args -> onExpNum args + ExpBool _ -> error "Bool Exp should be substituted" + + -- | Reading/writing a named variable + InitVar v arg -> onInitVar v arg + ReadVar v -> onReadVar v + WriteVar v arg -> onWriteVar v arg + + -- | Selects a cell from the tuple, here argument is always a tuple (result of opcode that returns several outputs) + -- | if-then-else + If ifRate cond th el -> onIf ifRate cond th el + -- | Imperative If-then-else + IfBlock ifRate cond th -> onIfBlock ifRate cond th + IfElseBlock ifRate cond th el -> onIfElseBlock ifRate cond th el + IfBegin ifRate cond -> onIfBegin ifRate cond + ElseBegin -> saveProcedure ElseBegin + IfEnd -> saveProcedure IfEnd + + -- | Verbatim stmt + Verbatim txt -> saveProcedure (Verbatim txt) + + -- | 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 + TfmArr isArrInit v info args -> onTfmArr isArrInit v info args + + -- | Pure arrays (read-only) + InitPureArr outRate procRate initVals -> onInitPureArr outRate procRate initVals + ReadPureArr outRate procRate inArr index -> onReadPureArr outRate procRate inArr index + + -- | read macros arguments + InitMacrosInt name n -> saveProcedure (InitMacrosInt name n) + InitMacrosDouble name dbl -> saveProcedure (InitMacrosDouble name dbl) + InitMacrosString name txt -> saveProcedure (InitMacrosString name txt) + ReadMacrosInt name -> save Ir (ReadMacrosInt name) + ReadMacrosDouble name -> save Ir (ReadMacrosDouble name) + ReadMacrosString name -> save Ir (ReadMacrosString name) + + -- | 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 + + -- | Dependency tracking + Starts -> saveProcedure Starts + Seq a b -> saveProcedure (Seq (setXr a) (setXr b)) + Ends a -> saveProcedure (Ends (setXr a)) + + where + onPrim p = save rate (ExpPrim p) + where + rate = fromMaybe (primRate p) $ ratedExpRate rhs + + onTfm info args = + case infoSignature info of + MultiRate outRates inRates -> onMultiRateTfm info outRates inRates args + SingleRate rateTab -> onSingleRateTfm info rateTab args + + onMultiRateTfm info _outRates inRates args = do + typedExpr <- Tfm info <$> zipWithM applyArg inRates args + save Xr typedExpr + + onSingleRateTfm info rateTab args + | Just userRates <- getUserDefinedRate = onFixedRateTfm info userRates args + | otherwise = onFreeTfm info rateTab args + where + getUserDefinedRate = do + userRate <- ratedExpRate rhs + (userRate, ) <$> Map.lookup userRate rateTab + + onFixedRateTfm info (outRate, inRates) args = do + typedExpr <- Tfm info <$> zipWithM applyArg inRates args + save outRate typedExpr + + onFreeTfm info rateTab args = do + signature <- + case Map.toList rateTab of + [rateInfo] -> pure rateInfo + _ -> + case preferOpc opts (infoName info) rateTab of + Right opcRate -> pure opcRate + Left opcRates -> findSignature args opcRates + onFixedRateTfm info signature args + + findSignature :: [PrimOr Int] -> [OpcSignature] -> Infer s OpcSignature + findSignature args allOpcRates = go (fromMaybe (Kr, []) $ headMay allOpcRates) Nothing allOpcRates + where + go :: OpcSignature -> Maybe SignatureChoice -> [OpcSignature] -> Infer s OpcSignature + go defaultRate mBestFit candidateRates = + case candidateRates of + [] -> pure $ maybe defaultRate signatureCandidate mBestFit + candidate : rest -> do + scores <- tryCandidate candidate + if isFit scores + then pure candidate + else go defaultRate (Just $ getBestFit scores mBestFit) rest + + tryCandidate :: OpcSignature -> Infer s SignatureChoice + tryCandidate candidate@(_outRate, inRates) = do + conversions <- countDestructiveConversions inRates + pure $ SignatureChoice + { destructiveConversionsCount = conversions + , signatureCandidate = candidate + } + + countDestructiveConversions :: [Rate] -> Infer s Int + countDestructiveConversions rates = foldM countConversion 0 $ zip rates args + + countConversion :: Int -> (Rate, PrimOr Int) -> Infer s Int + countConversion total (targetRate, arg) = do + argVar <- mapM (getVar targetRate) arg + let opcodeArg = + OpcodeArg + { opcodeTo = targetRate + , opcodeFrom = varType <$> argVar + } + pure $ if not (destructiveConversion opcodeArg) || unifies opcodeArg + then total + else total + 1 + + isFit (SignatureChoice score _candidate) = score == 0 + + getBestFit (SignatureChoice scores candidate) = \case + Just (SignatureChoice prevScores prevCandidate) | prevScores < scores -> (SignatureChoice prevScores prevCandidate) + _ -> (SignatureChoice scores candidate) + + onConvertRate toRate mFromRate arg = do + fromRate <- maybe (either primRate varType . unPrimOr <$> mapM (getVar Ir) arg) pure mFromRate + save toRate (ConvertRate toRate (Just fromRate) (Var fromRate <$> arg)) + + setXr = fmap (Var Xr) + + onSelect rate outId arg = + save rate (Select rate outId (Var Xr <$> arg)) + + onInitVar v arg = save (Exp.varRate v) =<< typedRhs + where + typedRhs = do + argVar <- mapM (getVar Ir) arg + pure (InitVar v argVar) + + onReadVar v = save (Exp.varRate v) (ReadVar v) + + onWriteVar v arg = saveProcedure =<< typedRhs + where + typedRhs = do + argVar <- mapM (getVar (Exp.varRate v)) arg + pure $ WriteVar v argVar + + onExpNum args = do + argVars <- mapM (mapM $ getVar Ir) args + save (numRate argVars) (ExpNum argVars) + where + numRate :: NumExp (PrimOr Var) -> Rate + numRate e = max Ar $ getMin $ foldMap (Min . primOrRate) e + + onIf ifRate cond th el = do + setHasIfs + thVar <- mapM (getVar condMaxRate) th + elVar <- mapM (getVar condMaxRate) el + let rate = min (primOrRate thVar ) (primOrRate elVar) + condVar <- mapM (mapM $ getVar condMaxRate) cond + condVarSafe <- insertBoolConverters condMaxRate condVar + case ifRate of + IfIr -> saveIr rate condVarSafe thVar elVar + IfKr -> saveKr rate condVarSafe thVar elVar + where + condMaxRate = fromIfRate ifRate + + saveIr rate condVarSafe thVar elVar + | rate < Ir = do + thVar1 <- convertIf Ir thVar + elVar1 <- convertIf Ir elVar + save Ir (If ifRate condVarSafe thVar1 elVar1) + | otherwise = save rate (If ifRate condVarSafe thVar elVar) + + saveKr rate condVarSafe thVar elVar + | rate == Ir = do + thVar1 <- convertIf Kr thVar + elVar1 <- convertIf Kr elVar + save Kr (If ifRate condVarSafe thVar1 elVar1) + | otherwise = save rate (If ifRate condVarSafe thVar elVar) + + onIfBlock = onIfBlockBy IfBlock + + onUntilBlock = onIfBlockBy UntilBlock + + 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 + condVarSafe <- insertBoolConverters condMaxRate condVar + saveProcedure (cons ifRate condVarSafe (fmap (Var Xr) <$> th)) + where + condMaxRate = fromIfRate ifRate + + onIfElseBlock ifRate cond th el = do + setHasIfs + condVar <- mapM (mapM $ getVar condMaxRate) cond + condVarSafe <- insertBoolConverters condMaxRate condVar + saveProcedure (IfElseBlock ifRate condVarSafe (fmap (Var Xr) <$> th) (fmap (Var Xr) <$> el)) + where + condMaxRate = fromIfRate ifRate + + onIfBegin ifRate cond = do + setHasIfs + ifBeginBy IfBegin ifRate cond + + onWhileBegin = ifBeginBy WhileBegin + onUntilBegin = ifBeginBy UntilBegin + + ifBeginBy cons ifRate cond = do + condVar <- mapM (mapM $ getVar condMaxRate) cond + condVarSafe <- insertBoolConverters condMaxRate condVar + saveProcedure (cons ifRate condVarSafe) + where + condMaxRate = fromIfRate ifRate + + ------------------------------------------------------------- + -- arrays + + onInitArr v arrSize = do + typedArrSize <- mapM (mapM (getVar Ir)) arrSize + saveProcedure (InitArr v typedArrSize) + + onReadArr v index = save (Exp.varRate v) . ReadArr v =<< typedIndex + where + indexRate = getArrIndexRate v + typedIndex = mapM (mapM (getVar indexRate)) index + + onWriteArr v index arg = do + typedIndex <- mapM (mapM (getVar indexRate)) index + argVar <- mapM (getVar (Exp.varRate v)) arg + saveProcedure (WriteArr v typedIndex argVar) + where + indexRate = getArrIndexRate v + + onWriteInitArr v arrSize initVal = do + typedArrSize <- mapM (mapM (getVar Ir)) arrSize + typedInitVal <- mapM (getVar (Exp.varRate v)) initVal + saveProcedure (WriteInitArr v typedArrSize typedInitVal) + + getArrIndexRate v= + case Exp.varRate v of + Ir -> Ir + Sr -> Ir + _ -> Kr + + onTfmArr isArrInit vout info args = do + typedArgs <- getTypedArrArgs args + saveProcedure (TfmArr isArrInit vout info typedArgs) + where + outRate = Exp.varRate vout + + inRates = + case infoSignature info of + SingleRate rateMap -> + case Map.lookup outRate rateMap of + Just res -> res + Nothing -> toError "Rate conversion is not supported for arrays" + MultiRate _ _ -> toError "Arrays with multiple argument s are not supported" + where + toError msg = error (unwords [msg, "Found on array opcode", Text.unpack $ infoName info]) + + getTypedArrArgs ins = zipWithM applyArg inRates ins + + ------------------------------------------------------------- + -- pure (read-only) arrays + + onInitPureArr outRate processingRate initVals = do + typedInits <- mapM (mapM (getVar initRate)) initVals + save (toArrRate outRate) (InitPureArr outRate processingRate typedInits) + where + initRate = fromIfRate processingRate + + onReadPureArr outRate processingRate arr index = do + typedIndex <- mapM (getVar initRate) index + typedArr <- mapM (getVar outRate) arr + save outRate (ReadPureArr outRate processingRate typedArr typedIndex) + where + initRate = fromIfRate processingRate + + ------------------------------------------------------------- + -- generic funs + + save :: Rate -> Exp Var -> Infer s () + save rate typedRhs = + saveStmt $ Stmt + { stmtLhs = Var rate lhs + , stmtRhs = rhs { ratedExpExp = typedRhs } + } + + -- procedure does not save output rate to type map, as it's never going to + -- be referenced from any right hand side of the expression + -- + -- Procedures always have Xr as output rate + saveProcedure :: Exp Var -> Infer s () + saveProcedure typedRhs = + appendResult $ Stmt + { stmtLhs = Var Xr lhs + , stmtRhs = rhs { ratedExpExp = typedRhs } + } + +------------------------------------------------------------- +-- generic funs + +setType :: Var -> Infer s () +setType (Var rate name) = do + typeMap <- gets envTypeMap + Vector.write typeMap name rate + +appendResult :: Stmt Var -> Infer s () +appendResult expr = modify' $ \s -> s { envResult = expr : envResult s } + +data SignatureChoice = SignatureChoice + { destructiveConversionsCount :: !Int + , signatureCandidate :: !OpcSignature + } + +data OpcodeArg = OpcodeArg + { opcodeTo :: !Rate + , opcodeFrom :: !(PrimOr Rate) + } + +unifies :: OpcodeArg -> Bool +unifies (OpcodeArg to (PrimOr from)) = + case to of + Xr -> True + Ar -> is Ar + Kr -> is Kr || is Ir || isPrim + Ir -> is Ir + _ -> is to + where + is r = either primRate id from == r + + isPrim = either (const True) (const False) from + +-- | Checks if opcode conversion is destructive +-- Note that we rely on Haskell type-checker and don't consider +-- cases of type-mismatch lke comparing number with string. +-- +-- There are two cases of destructive updates: +-- +-- * Ar or Kr is converted to Ir +-- * Ar is converted to Kr +destructiveConversion :: OpcodeArg -> Bool +destructiveConversion (OpcodeArg to (PrimOr from)) = + case to of + Ir -> fromRate /= Ir + Kr -> fromRate == Ar + _ -> False + where + fromRate = either primRate id from + +applyArg :: Rate -> PrimOr Int -> Infer s (PrimOr Var) +applyArg targetRate arg = do + argVar <- mapM (getVar Ir) arg + let opcArg = + OpcodeArg + { opcodeTo = targetRate + , opcodeFrom = varType <$> argVar + } + if unifies opcArg + then pure argVar + else PrimOr . Right <$> convert (opcodeTo opcArg) argVar + +------------------------------------------------------------------- +-- utils + +getVar :: Rate -> Int -> Infer s Var +getVar _defaultRate vid = do + types <- gets envTypeMap + ty <- Vector.read types vid + pure (Var ty vid) + +convert :: Rate -> PrimOr Var -> Infer s Var +convert toRate (PrimOr fromVar) = do + case fromVar of + Left p -> convertPrim p + Right v -> convertVar v + where + convertPrim :: Prim -> Infer s Var + convertPrim prim = do + primMap <- gets envPrims + v <- case Map.lookup prim primMap of + Just v -> pure v + Nothing -> allocatePrim prim + convertVar v + + convertVar :: Var -> Infer s Var + convertVar inVar = do + mOutVar <- tryExistingConverters inVar + case mOutVar of + Just outVar -> pure outVar + Nothing -> do + let rhs = newExp $ ConvertRate toRate (Just $ varType inVar) (PrimOr $ Right inVar) + outVar <- defineVar toRate rhs + saveConversion outVar inVar + pure outVar + + tryExistingConverters :: Var -> Infer s (Maybe Var) + tryExistingConverters (Var _ name) = do + convMap <- gets envConversions + pure $ Map.lookup toRate =<< IntMap.lookup name convMap + + allocatePrim :: Prim -> Infer s Var + allocatePrim prim = do + var <- defineVar (primRate prim) (newExp $ ExpPrim prim) + modify' $ \s -> s { envPrims = Map.insert prim var $ envPrims s } + pure var + +-- | Checks if convertion is identity, then returns original +convertIf :: Rate -> PrimOr Var -> Infer s (PrimOr Var) +convertIf toRate var + | toRate == primOrRate var = pure var + | otherwise = PrimOr . Right <$> convert toRate var + +newExp :: Exp a -> RatedExp a +newExp rhs = + RatedExp + { ratedExpHash = ignoreHash + , ratedExpRate = Nothing + , ratedExpDepends = Nothing + , ratedExpExp = rhs + } + +-- | On this stage we don't need expression hashes anymore +ignoreHash :: ByteString +ignoreHash = "" + +-- | Allocate new var and assign RHS expression to it +defineVar :: Rate -> RatedExp Var -> Infer s Var +defineVar rate rhs = do + v <- freshVar rate + appendResult (Stmt v rhs) + pure v + +-- | Allocate fresh variable with given rate +freshVar :: Rate -> Infer s Var +freshVar rate = Var rate <$> freshId + +-- | Allocate new fresh id +freshId :: Infer s Int +freshId = do + lastFreshId <- gets envLastFreshId + modify' $ \s -> s { envLastFreshId = lastFreshId + 1 } + pure lastFreshId + +insertBoolConverters :: Rate -> CondInfo (PrimOr Var) -> Infer s (CondInfo (PrimOr Var)) +insertBoolConverters ifRate = mapM (mapM go) + where + go :: Var -> Infer s Var + go v + | ifRate >= varType v = pure v + | otherwise = convert ifRate (PrimOr $ Right v) + +saveStmt :: Stmt Var -> Infer s () +saveStmt expr = do + setType (stmtLhs expr) + appendResult expr + +saveConversion :: Var -> Var -> Infer s () +saveConversion outVar inVar = + modify' $ \s -> s { envConversions = update $ envConversions s } + where + update conversionMap = IntMap.alter go (varId inVar) conversionMap + + go = Just . \case + Nothing -> Map.singleton (varType outVar) outVar + Just m -> Map.insert (varType outVar) outVar m + +setHasIfs :: Infer s () +setHasIfs = modify' $ \s -> s { envHasIfs = True } + +---------------------------------------------------------------- +-- rate calculations + +primRate :: Prim -> Rate +primRate = \case + PrimString _ -> Sr + PrimVar r _ -> r + _ -> Ir + +primOrRate :: PrimOr Var -> Rate +primOrRate = either primRate varType . unPrimOr diff --git a/src/Csound/Dynamic/Tfm/Liveness.hs b/src/Csound/Dynamic/Tfm/Liveness.hs --- a/src/Csound/Dynamic/Tfm/Liveness.hs +++ b/src/Csound/Dynamic/Tfm/Liveness.hs @@ -1,3 +1,5 @@ +-- | Analyses variable for reusal. +-- So that we spend less memory and allocate lesser variables and audio vectors. module Csound.Dynamic.Tfm.Liveness ( liveness ) where @@ -7,22 +9,20 @@ import Control.Monad.Trans.State.Strict import Data.Traversable import Data.Foldable -import qualified Data.Map as M import Control.Monad.Trans.Class import Control.Monad hiding (mapM, mapM_) import Control.Monad.ST -import qualified Data.Array.Unboxed as A -import qualified Data.Array.MArray as A -import qualified Data.Array.ST as A +import Data.Vector.Unboxed.Mutable qualified as UVector -import qualified Csound.Dynamic.Tfm.DeduceTypes as D -import Csound.Dynamic.Tfm.DeduceTypes(varType, varId) +import Csound.Dynamic.Tfm.InferTypes (Var (..)) import Csound.Dynamic.Types.Exp(Rate(..)) +-- | Reuses variables. It analyses weather the vraibel is used further +-- in the code and if it's not used it tries to reuse it for the next assignments liveness :: Traversable f => Int -> Dag f -> Dag f liveness lastFreshId as = runST $ do - st <- initSt lastFreshId $ analyse lastFreshId as + st <- initSt lastFreshId =<< analyse lastFreshId as evalStateT (mapM substExp $ countLines $ as) st type LineNumber = Int @@ -30,8 +30,6 @@ countLines :: [a] -> [(LineNumber, a)] countLines = zip [0 ..] -type Var = D.Var Rate - type Lhs = [Var] type Rhs f = f Var type Exp f = (Lhs, Rhs f) @@ -41,11 +39,14 @@ ----------------------------------------------- data IdList = IdList - [Int] -- fresh ids - Int -- the biggest used id + [Int] -- fresh ids (always infinite list) + !Int -- the biggest used id allocId :: IdList -> (Int, IdList) -allocId (IdList is lastId) = (head is, IdList (tail is) (max (head is) lastId)) +allocId (IdList is lastId) = + case is of + hd : tl -> (hd, IdList tl (max hd lastId)) + [] -> error "impossible: list of IDs is always infinite" freeId :: Int -> IdList -> IdList freeId n (IdList is lastId) = IdList (insertSorted n is) lastId1 @@ -58,108 +59,123 @@ | otherwise = a : insertSorted n as insertSorted n [] = [n] +initIdList :: IdList +initIdList = IdList [0..] 0 + ----------------------------------------------- -type StArr s = A.STUArray s Int Int +type StArr s = UVector.STVector s Int -type LivenessTable = A.UArray Int Int -type SubstTable s = StArr s +type LivenessTable s = UVector.STVector s Int +type SubstTable s = StArr s data Registers s = Registers - { registers :: M.Map Rate IdList - , livenessTable :: LivenessTable - , substTable :: SubstTable s + { arRegisters :: !IdList + , krRegisters :: !IdList + , livenessTable :: !(LivenessTable s) + , substTable :: !(SubstTable s) } type Memory s a = StateT (Registers s) (ST s) a -onRegs :: (M.Map Rate IdList -> M.Map Rate IdList) -> (Registers s -> Registers s) -onRegs f rs = rs { registers = f $ registers rs } +onRegs :: Rate -> (IdList -> IdList) -> Memory s () +onRegs rate f = modify' $ \rs -> + case rate of + Ar -> rs { arRegisters = f $ arRegisters rs } + Kr -> rs { krRegisters = f $ krRegisters rs } + _ -> rs -initRegs :: M.Map Rate IdList -initRegs = M.fromList $ fmap (\x -> (x, initIdList)) [(minBound :: Rate) .. maxBound] - where initIdList = IdList [0..] 0 +setArRegisters :: IdList -> Memory s () +setArRegisters ids = modify' $ \s -> s { arRegisters = ids } +setKrRegisters :: IdList -> Memory s () +setKrRegisters ids = modify' $ \s -> s { krRegisters = ids } + + isAlive :: LineNumber -> Var -> Memory s Bool isAlive lineNum v = do tab <- fmap livenessTable get - return $ lineNum < tab A.! (varId v) + lastUsage <- UVector.read tab (varId v) + pure $ lineNum < lastUsage lookUpSubst :: Int -> Memory s Int lookUpSubst i = do tab <- fmap substTable get - lift $ A.readArray tab i + lift $ UVector.read tab i saveSubst :: Int -> Int -> Memory s () saveSubst from to = do tab <- fmap substTable get - lift $ A.writeArray tab from to + lift $ UVector.write tab from to substLhs :: Var -> Memory s Var -substLhs v = do - v1 <- allocAndSkipInits v +substLhs = onlyForAK $ \v -> do + v1 <- alloc v saveSubst (varId v) (varId v1) return v1 substRhs :: LineNumber -> Var -> Memory s Var -substRhs lineNum v = do +substRhs lineNum = onlyForAK $ \v -> do i1 <- lookUpSubst (varId v) - let v1 = D.Var i1 (varType v) + let v1 = Var (varType v) i1 b <- isAlive lineNum v unless b $ free v1 return v1 -allocAndSkipInits :: Var -> Memory s Var -allocAndSkipInits v - | isInit r = return v - | otherwise = alloc r - where - r = varType v - isInit x = x == Ir || x == Sr - -alloc :: Rate -> Memory s Var -alloc rate = state $ \mem -> - let (i, mem1) = allocRegister rate mem - in (D.Var i rate, mem1) +alloc :: Var -> Memory s Var +alloc v = + case varType v of + Ar -> allocBy arRegisters setArRegisters + Kr -> allocBy krRegisters setKrRegisters + _ -> pure v where - allocRegister :: Rate -> Registers s -> (Int, Registers s) - allocRegister r mem = (i, onRegs (M.update (const $ Just is) r) mem) - where (i, is) = allocId $ registers mem M.! r + allocBy extract update = do + ids <- gets extract + let (name, newIds) = allocId ids + void $ update newIds + pure (Var (varType v) name) free :: Var -> Memory s () -free v = state $ \mem -> - let mem1 = freeRegister (varType v) (varId v) mem - in ((), mem1) - where - freeRegister :: Rate -> Int -> Registers s -> Registers s - freeRegister rate i = onRegs $ M.update (Just . freeId i) rate +free (Var rate name) = onRegs rate (freeId name) -------------------------------------------------------------------------- -analyse :: Traversable f => Int -> Dag f -> LivenessTable -analyse lastFreshId as = A.runSTUArray $ do - arr <- A.newArray (0, lastFreshId) 0 +analyse :: Traversable f => Int -> Dag f -> ST s (LivenessTable s) +analyse lastFreshId as = do + arr <- UVector.replicate lastFreshId 0 mapM_ (go arr) $ countLines as return arr where go :: Traversable f => StArr s -> (LineNumber, Exp f) -> ST s () - go arr (lineNum, (_, rhs)) = mapM (countVar arr lineNum) rhs >> return () + go arr (lineNum, (_, rhs)) = mapM_ (countVar arr lineNum) rhs countVar :: StArr s -> LineNumber -> Var -> ST s () - countVar arr lineNum v = do - val <- A.readArray arr i - A.writeArray arr i (val `max` lineNum) - where i = varId v + countVar arr lineNum v + | isAOrK v = UVector.write arr (varId v) lineNum + | otherwise = pure () +onlyForAK :: Monad f => (Var -> f Var) -> Var -> f Var +onlyForAK go v + | isAOrK v = go v + | otherwise = pure v + +-- we optimise for livenes only for Ar and Kr variables +isAOrK :: Var -> Bool +isAOrK v = + case varType v of + Ar -> True + Kr -> True + _ -> False + substExp :: Traversable f => (LineNumber, Exp f) -> Memory s (Exp f) substExp (lineNum, (lhs, rhs)) = do freshLhs <- traverse substLhs lhs freshRhs <- traverse (substRhs lineNum) rhs return (freshLhs, freshRhs) -initSt :: Int -> LivenessTable -> ST s (Registers s) -initSt lastFreshId livenessTab = fmap (Registers initRegs livenessTab) (initSubstTable lastFreshId) +initSt :: Int -> LivenessTable s -> ST s (Registers s) +initSt lastFreshId livenessTab = fmap (Registers initIdList initIdList livenessTab) (initSubstTable lastFreshId) initSubstTable :: Int -> ST s (SubstTable s) -initSubstTable n = A.newListArray (0, n+1) [0 .. n + 1] +initSubstTable n = UVector.generate (n + 1) id diff --git a/src/Csound/Dynamic/Tfm/UnfoldMultiOuts.hs b/src/Csound/Dynamic/Tfm/UnfoldMultiOuts.hs --- a/src/Csound/Dynamic/Tfm/UnfoldMultiOuts.hs +++ b/src/Csound/Dynamic/Tfm/UnfoldMultiOuts.hs @@ -1,70 +1,86 @@ {-# Language TupleSections #-} module Csound.Dynamic.Tfm.UnfoldMultiOuts( - unfoldMultiOuts, UnfoldMultiOuts(..), Selector(..) + unfoldMultiOuts, Selector(..) ) where import Data.List(sortBy) import Data.Ord(comparing) -import Data.Maybe(mapMaybe, isNothing) import Control.Monad.Trans.State.Strict -import qualified Data.IntMap as IM +import qualified Data.IntMap.Strict as IM +import Data.Either (partitionEithers) -import Csound.Dynamic.Tfm.DeduceTypes(Var(..)) +import Csound.Dynamic.Tfm.InferTypes(Var(..), Stmt(..), InferenceResult(..)) +import Csound.Dynamic.Types.Exp hiding (Var (..)) +import Csound.Dynamic.Build(getRates, isMultiOutSignature) type ChildrenMap = IM.IntMap [Port] -lookupChildren :: ChildrenMap -> Var a -> [Port] +lookupChildren :: ChildrenMap -> Var -> [Port] lookupChildren m parentVar = m IM.! varId parentVar -mkChildrenMap :: [(Var a, Selector a)] -> ChildrenMap -mkChildrenMap = IM.fromListWith (++) . fmap extract - where extract (var, sel) = (varId $ selectorParent sel, +mkChildrenMap :: [(Var, Selector)] -> ChildrenMap +mkChildrenMap = IM.fromListWith (++) . fmap extract + where extract (var, sel) = (varId $ selectorParent sel, return $ Port (varId var) (selectorOrder sel)) -data Port = Port +data Port = Port { portId :: Int , portOrder :: Int } deriving (Show) -type SingleStmt f a = (Var a, f (Var a)) -type MultiStmt f a = ([Var a], f (Var a)) - -data Selector a = Selector - { selectorParent :: Var a - , selectorOrder :: Int } +type SingleStmt = Stmt Var +type MultiStmt = ([Var], RatedExp Var) -data UnfoldMultiOuts f a = UnfoldMultiOuts { - getSelector :: f (Var a) -> Maybe (Selector a), - getParentTypes :: f (Var a) -> Maybe [a] } +data Selector = Selector + { selectorParent :: Var + , selectorOrder :: Int + } -unfoldMultiOuts :: UnfoldMultiOuts f a -> Int -> [SingleStmt f a] -> ([MultiStmt f a], Int) -unfoldMultiOuts algSpec lastFreshId stmts = runState st lastFreshId - where selectors = mapMaybe (\(lhs, rhs) -> fmap (lhs,) $ getSelector algSpec rhs) stmts - st = mapM (unfoldStmt algSpec $ mkChildrenMap selectors) $ dropSelectors stmts - dropSelectors = filter (isNothing . getSelector algSpec . snd) +unfoldMultiOuts :: InferenceResult -> ([MultiStmt], Int) +unfoldMultiOuts InferenceResult{..} = runState st programLastFreshId + where + (noSelectorStmts, selectors) = partitionEithers $ + fmap (\stmt@(Stmt lhs rhs) -> maybe (Left stmt) (Right . (lhs, )) $ getSelector rhs) typedProgram + st = mapM (unfoldStmt $ mkChildrenMap selectors) $ noSelectorStmts -unfoldStmt :: UnfoldMultiOuts f a -> ChildrenMap -> SingleStmt f a -> State Int (MultiStmt f a) -unfoldStmt algSpec childrenMap (lhs, rhs) = case getParentTypes algSpec rhs of +unfoldStmt :: ChildrenMap -> SingleStmt -> State Int MultiStmt +unfoldStmt childrenMap (Stmt lhs rhs) = case getParentTypes rhs of Nothing -> return ([lhs], rhs) Just types -> fmap (,rhs) $ formLhs (lookupChildren childrenMap lhs) types -formLhs :: [Port] -> [a] -> State Int [Var a] -formLhs ports types = fmap (zipWith (flip Var) types) (getPorts ports) - where getPorts ps = state $ \lastFreshId -> +formLhs :: [Port] -> [Rate] -> State Int [Var] +formLhs ports types = fmap (zipWith Var types) (getPorts ports) + where getPorts ps = state $ \lastFreshId -> let ps' = sortBy (comparing portOrder) ps (ids, lastPortOrder) = runState (mapM (fillMissingPorts lastFreshId) ps') 0 freshIdForTail = 1 + lastFreshId + inUsePortsSize tailIds = map (+ freshIdForTail) [0 .. outputArity - 1 - lastPortOrder] in (concat ids ++ tailIds, lastFreshId + outputArity - inUsePortsSize) - outputArity = length types - inUsePortsSize = length ports - + outputArity = length types + inUsePortsSize = length ports + fillMissingPorts :: Int -> Port -> State Int [Int] fillMissingPorts lastFreshId port = state $ \s -> if s == order - then ([e], next) + then ([e], next) else (fmap (+ lastFreshId) [s .. order - 1] ++ [e], next) where e = portId port - order = portOrder port + order = portOrder port next = order + 1 +----------------------------------------------------------------------- +-- unfolds multiple rates generic functions + +getSelector :: RatedExp Var -> Maybe Selector +getSelector x = + case ratedExpExp x of + Select _ order (PrimOr (Right parent)) -> Just $ Selector parent order + _ -> Nothing + +getParentTypes :: RatedExp Var -> Maybe [Rate] +getParentTypes x = + case ratedExpExp x of + Tfm i _ -> if (isMultiOutSignature $ infoSignature i) + then Just (getRates $ ratedExpExp x) + else Nothing + _ -> Nothing diff --git a/src/Csound/Dynamic/Types.hs b/src/Csound/Dynamic/Types.hs --- a/src/Csound/Dynamic/Types.hs +++ b/src/Csound/Dynamic/Types.hs @@ -11,4 +11,3 @@ import Csound.Dynamic.Types.Dep import Csound.Dynamic.Types.Flags import Csound.Dynamic.Types.CsdFile - diff --git a/src/Csound/Dynamic/Types/CsdFile.hs b/src/Csound/Dynamic/Types/CsdFile.hs --- a/src/Csound/Dynamic/Types/CsdFile.hs +++ b/src/Csound/Dynamic/Types/CsdFile.hs @@ -7,34 +7,35 @@ import Csound.Dynamic.Types.Exp import Csound.Dynamic.Types.Flags +import Data.Text (Text) data Csd = Csd - { csdFlags :: Flags - , csdOrc :: Orc - , csdSco :: Sco - , csdPlugins :: [Plugin] + { csdFlags :: !Flags + , csdOrc :: !Orc + , csdSco :: !Sco + , csdPlugins :: ![Plugin] } data Orc = Orc - { orcHead :: InstrBody - , orcInstruments :: [Instr] + { orcHead :: !InstrBody + , orcInstruments :: ![Instr] } type InstrBody = E data Instr = Instr - { instrName :: InstrId - , instrBody :: InstrBody + { instrName :: !InstrId + , instrBody :: !InstrBody } data Sco = Sco - { scoTotalDur :: Maybe Double - , scoGens :: [(Int, Gen)] - , scoNotes :: [(InstrId, [CsdEvent])] } + { scoTotalDur :: !(Maybe Double) + , scoGens :: ![(Int, Gen)] + , scoNotes :: ![(InstrId, [CsdEvent])] } data Plugin = Plugin - { pluginName :: String - , pluginContent :: String + { pluginName :: !Text + , pluginContent :: !Text } ---------------------------------------------------------------- @@ -48,7 +49,6 @@ alwaysOn :: InstrId -> (InstrId, [CsdEvent]) alwaysOn instrId = (instrId, [(0, -1, [])]) - -- | The Csound note. It's a triple of -- diff --git a/src/Csound/Dynamic/Types/Dep.hs b/src/Csound/Dynamic/Types/Dep.hs --- a/src/Csound/Dynamic/Types/Dep.hs +++ b/src/Csound/Dynamic/Types/Dep.hs @@ -3,7 +3,7 @@ module Csound.Dynamic.Types.Dep( DepT(..), LocalHistory(..), runDepT, execDepT, evalDepT, -- * Dependencies - depT, depT_, mdepT, stripDepT, stmtOnlyT, + depT, depT_, mdepT, stripDepT, stmtOnlyT, toBlock, depends, -- * Variables newLocalVar, newLocalVars, @@ -28,6 +28,8 @@ import Data.Default import Data.Fix(Fix(..)) +import Data.Text (Text) +import Data.Text qualified as Text import Csound.Dynamic.Types.Exp @@ -39,24 +41,52 @@ newtype DepT m a = DepT { unDepT :: StateT LocalHistory m a } data LocalHistory = LocalHistory - { expDependency :: E - , newLineNum :: Int - , newLocalVarId :: Int } + { expDependency :: !E + , newLineNum :: !Int + , newLocalVarId :: !Int } instance Default LocalHistory where - def = LocalHistory start 0 0 + def = LocalHistory (noRate Starts) 0 0 instance Monad m => Functor (DepT m) where fmap = liftM instance Monad m => Applicative (DepT m) where - pure = return + pure = DepT . return (<*>) = ap instance Monad m => Monad (DepT m) where - return = DepT . return - ma >>= mf = DepT $ unDepT ma >>= unDepT . mf + 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 + } + + +{- +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 @@ -71,24 +101,42 @@ -- dependency tracking -start :: E -start = noRate Starts - depends :: E -> E -> E -depends a1 a2 = noRate $ Seq (toPrimOr a1) (toPrimOr a2) +depends a1 a2 = + case ratedExpExp (unFix a2) of + Starts -> a1 + _ -> + case ratedExpExp (unFix a1) of + Starts -> a2 + _ -> noRate $ Seq (toPrimOr a1) (toPrimOr a2) depT :: Monad m => E -> DepT m E depT a = DepT $ do s <- get - let a1 = Fix $ (unFix a) { ratedExpDepends = Just (newLineNum s) } + let a1 = rehashE $ Fix $ (unFix a) { ratedExpDepends = Just (newLineNum s) } put $ s { - newLineNum = succ $ newLineNum s, - expDependency = depends (expDependency s) a1 } + newLineNum = succ $ newLineNum s -- , + -- expDependency = depends (expDependency s) a1 + } return a1 depT_ :: (Monad m) => E -> DepT m () -depT_ = fmap (const ()) . depT +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 @@ -115,7 +163,7 @@ newVar :: Monad m => Rate -> DepT m Var newVar rate = DepT $ do s <- get - let v = Var LocalVar rate (show $ newLocalVarId s) + let v = Var LocalVar rate (Text.pack $ show $ newLocalVarId s) put $ s { newLocalVarId = succ $ newLocalVarId s } return v @@ -134,7 +182,7 @@ readOnlyVar v = noRate $ ReadVar v initVar :: Monad m => Var -> E -> DepT m () -initVar v x = depT_ $ setRate Ir $ noRate $ InitVar v $ toPrimOr x +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 @@ -176,28 +224,28 @@ -------------------------------------------------- -- read global macros arguments -readMacrosDouble :: String -> E +readMacrosDouble :: Text -> E readMacrosDouble = readMacrosBy ReadMacrosDouble Ir -readMacrosInt :: String -> E +readMacrosInt :: Text -> E readMacrosInt = readMacrosBy ReadMacrosInt Ir -readMacrosString :: String -> E +readMacrosString :: Text -> E readMacrosString = readMacrosBy ReadMacrosString Sr -initMacrosDouble :: Monad m => String -> Double -> DepT m () +initMacrosDouble :: Monad m => Text -> Double -> DepT m () initMacrosDouble = initMacrosBy InitMacrosDouble -initMacrosString :: Monad m => String -> String -> DepT m () +initMacrosString :: Monad m => Text -> Text -> DepT m () initMacrosString = initMacrosBy InitMacrosString -initMacrosInt :: Monad m => String -> Int -> DepT m () +initMacrosInt :: Monad m => Text -> Int -> DepT m () initMacrosInt = initMacrosBy InitMacrosInt -readMacrosBy :: (String -> Exp E) -> Rate -> String -> E +readMacrosBy :: (Text -> Exp E) -> Rate -> Text -> E readMacrosBy readMacro rate name = withRate rate $ readMacro name -initMacrosBy :: Monad m => (String -> a -> Exp E) -> String -> a -> DepT m () +initMacrosBy :: Monad m => (Text -> a -> Exp E) -> Text -> a -> DepT m () initMacrosBy maker name value = depT_ $ noRate $ maker name value diff --git a/src/Csound/Dynamic/Types/Exp.hs b/src/Csound/Dynamic/Types/Exp.hs --- a/src/Csound/Dynamic/Types/Exp.hs +++ b/src/Csound/Dynamic/Types/Exp.hs @@ -8,51 +8,55 @@ TemplateHaskell, CPP #-} module Csound.Dynamic.Types.Exp( - E, RatedExp(..), isEmptyExp, RatedVar, ratedVar, ratedVarRate, ratedVarId, + E, RatedExp(..), isEmptyExp, ratedExp, noRate, withRate, setRate, + toArrRate, removeArrRate, Exp, toPrimOr, toPrimOrTfm, PrimOr(..), MainExp(..), Name, InstrId(..), intInstrId, ratioInstrId, stringInstrId, VarType(..), Var(..), Info(..), OpcFixity(..), Rate(..), + CodeBlock (..), Signature(..), isInfix, isPrefix, Prim(..), Gen(..), GenId(..), Inline(..), InlineExp(..), PreInline(..), BoolExp, CondInfo, CondOp(..), isTrue, isFalse, NumExp, NumOp(..), Note, MultiOut, - IsArrInit, ArrSize, ArrIndex + IsArrInit, ArrSize, ArrIndex, + IfRate(..), fromIfRate, + hashE, + rehashE, ) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif +import Crypto.Hash.SHA256 qualified as Crypto import GHC.Generics (Generic, Generic1) import Data.Traversable -import Data.Foldable hiding (concat) - -import Data.Hashable +import Data.ByteString (ByteString) -import Data.Map(Map) +import Data.Map.Strict (Map) import Data.Maybe(isNothing) -import qualified Data.IntMap as IM +import qualified Data.IntMap.Strict as IM import qualified Data.IntMap.Internal as IM import Data.Fix import Data.Eq.Deriving import Data.Ord.Deriving import Text.Show.Deriving -import Data.Hashable.Lifted - -import qualified Csound.Dynamic.Tfm.DeduceTypes as R(Var(..)) +import Data.Text (Text) +import Data.Serialize qualified as Cereal +import Data.Serialize.Text () -type Name = String +type Name = Text type LineNum = Int -- | An instrument identifier data InstrId = InstrId - { instrIdFrac :: Maybe Int - , instrIdCeil :: Int } - | InstrLabel String + { instrIdFrac :: !(Maybe Int) + , instrIdCeil :: !Int } + | InstrLabel Text deriving (Show, Eq, Ord, Generic) -- | Constructs an instrument id with the integer. @@ -64,40 +68,35 @@ ratioInstrId beforeDot afterDot = InstrId (Just $ afterDot) beforeDot -- | Constructs an instrument id with the string label. -stringInstrId :: String -> InstrId +stringInstrId :: Text -> InstrId stringInstrId = InstrLabel -- | The inner representation of csound expressions. type E = Fix RatedExp data RatedExp a = RatedExp - { ratedExpRate :: Maybe Rate + { ratedExpHash :: !ByteString + -- ^ 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 + , ratedExpDepends :: !(Maybe LineNum) -- ^ Dependency (it is used for expressions with side effects, -- value contains the privious statement) - , ratedExpExp :: Exp a + , ratedExpExp :: !(Exp a) -- ^ Main expression - } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic, Generic1) - --- | RatedVar is for pretty printing of the wiring ports. -type RatedVar = R.Var Rate - --- | Makes an rated variable. -ratedVar :: Rate -> Int -> RatedVar -ratedVar = flip R.Var + } deriving (Show, Functor, Foldable, Traversable, Generic, Generic1) --- | Querries a rate. -ratedVarRate :: RatedVar -> Rate -ratedVarRate = R.varType +instance Eq (RatedExp a) where + (==) a b = ratedExpHash a == ratedExpHash b --- | Querries an integral identifier. -ratedVarId :: RatedVar -> Int -ratedVarId = R.varId +instance Ord (RatedExp a) where + compare a b = ratedExpHash a `compare` ratedExpHash b ratedExp :: Maybe Rate -> Exp E -> E -ratedExp r = Fix . RatedExp r Nothing +ratedExp r expr = Fix $ RatedExp h r Nothing expr + where + h = Crypto.hash $ Cereal.encode $ fmap (fmap hashE) expr noRate :: Exp E -> E noRate = ratedExp Nothing @@ -105,16 +104,40 @@ withRate :: Rate -> Exp E -> E withRate r = ratedExp (Just r) +hashE :: E -> ByteString +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 + } + -- rate coversion setRate :: Rate -> E -> E -setRate r a = Fix $ (\x -> x { ratedExpRate = Just r }) $ unFix a +setRate r a = + 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 _ -> Fix $ (unFix a) { ratedExpRate = Just r } + -- don't convert rate twice + ConvertRate _ b arg -> withRate r $ ConvertRate r b arg + -- for booleans pass conversion over boolean operators + ExpBool boolArg -> noRate $ ExpBool $ fmap (fmap (setRate r)) boolArg + -- for other cases we insert rate conversion + _ -> withRate r $ ConvertRate r Nothing (PrimOr $ Right a) -- | It's a primitive value or something else. It's used for inlining -- of the constants (primitive values). newtype PrimOr a = PrimOr { unPrimOr :: Either Prim a } deriving (Show, Eq, Ord, Functor, Generic, Generic1) +instance Cereal.Serialize a => Cereal.Serialize (PrimOr a) + -- | Constructs PrimOr values from the expressions. It does inlining in -- case of primitive values. toPrimOr :: E -> PrimOr E @@ -141,72 +164,121 @@ -- Expressions with inlining. type Exp a = MainExp (PrimOr a) +newtype CodeBlock a = CodeBlock a + deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic, Generic1) + -- Csound expressions data MainExp a = EmptyExp -- | Primitives - | ExpPrim Prim + | ExpPrim !Prim -- | Application of the opcode: we have opcode information (Info) and the arguments [a] - | Tfm Info [a] + | Tfm Info ![a] -- | Rate conversion - | ConvertRate Rate Rate a + | ConvertRate !Rate !(Maybe Rate) !a -- | Selects a cell from the tuple, here argument is always a tuple (result of opcode that returns several outputs) - | Select Rate Int a + | Select !Rate !Int !a -- | if-then-else - | If (CondInfo a) a a + | If !IfRate !(CondInfo a) !a !a -- | Boolean expressions (rendered in infix notation in the Csound) - | ExpBool (BoolExp a) + | ExpBool !(BoolExp a) -- | Numerical expressions (rendered in infix notation in the Csound) - | ExpNum (NumExp a) + | ExpNum !(NumExp a) -- | Reading/writing a named variable - | InitVar Var a - | ReadVar Var - | WriteVar Var a + | InitVar !Var !a + | ReadVar !Var + | WriteVar !Var !a -- | Arrays - | InitArr Var (ArrSize a) - | ReadArr Var (ArrIndex a) - | WriteArr Var (ArrIndex a) a - | WriteInitArr Var (ArrIndex a) a - | TfmArr IsArrInit Var Info [a] + | InitArr !Var !(ArrSize a) + | ReadArr !Var !(ArrIndex a) + | WriteArr !Var !(ArrIndex a) !a + | WriteInitArr !Var !(ArrIndex a) !a + | TfmArr !IsArrInit !Var !Info ![a] + -- | inits 1-dimensional read only array (uses fillaray) + -- args: rateOfTheOutput processingRate initValues + | InitPureArr !Rate !IfRate ![a] + -- | Reads read only array with index + -- args: rateOfTheOutput processingRate array index + | ReadPureArr !Rate !IfRate !a !a -- | Imperative If-then-else - | IfBegin Rate (CondInfo a) --- | ElseIfBegin (CondInfo a) -- It's expressed with nested if-else + | IfBlock !IfRate !(CondInfo a) (CodeBlock a) + | IfElseBlock !IfRate !(CondInfo a) (CodeBlock a) (CodeBlock a) + | IfBegin !IfRate !(CondInfo a) | ElseBegin | IfEnd -- | looping constructions - | UntilBegin (CondInfo a) + | UntilBlock !IfRate !(CondInfo a) (CodeBlock a) + | UntilBegin !IfRate !(CondInfo a) | UntilEnd - | WhileBegin (CondInfo a) - | WhileRefBegin Var + | WhileBlock !IfRate !(CondInfo a) (CodeBlock a) + | WhileBegin !IfRate !(CondInfo a) + | WhileRefBlock !Var !(CodeBlock a) + | WhileRefBegin !Var | WhileEnd -- | Verbatim stmt - | Verbatim String + | Verbatim !Text -- | Dependency tracking | Starts | Seq a a | Ends a -- | read macros arguments - | InitMacrosInt String Int - | InitMacrosDouble String Double - | InitMacrosString String String - | ReadMacrosInt String - | ReadMacrosDouble String - | ReadMacrosString String + | InitMacrosInt !Text !Int + | InitMacrosDouble !Text !Double + | InitMacrosString !Text !Text + | ReadMacrosInt !Text + | ReadMacrosDouble !Text + | ReadMacrosString !Text deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic, Generic1) +-- | Rate of if-then-else conditional. +-- It can run at Ir or Kr +data IfRate = IfIr | IfKr + deriving (Show, Eq, Ord, Generic) + +fromIfRate :: IfRate -> Rate +fromIfRate = \case + IfKr -> Kr + IfIr -> Ir + +-- | Can be infinite so fe just ignore the value +instance Cereal.Serialize Signature where + put = \_a -> pure () + get = undefined + +instance Cereal.Serialize a => Cereal.Serialize (RatedExp a) +instance Cereal.Serialize Prim +instance Cereal.Serialize Rate +instance Cereal.Serialize IfRate +instance Cereal.Serialize Info +instance Cereal.Serialize OpcFixity +instance Cereal.Serialize InstrId +instance Cereal.Serialize CondOp +instance Cereal.Serialize NumOp +instance Cereal.Serialize Var +instance Cereal.Serialize VarType +instance Cereal.Serialize a => Cereal.Serialize (CodeBlock a) +instance Cereal.Serialize a => Cereal.Serialize (MainExp a) +instance (Cereal.Serialize a, Cereal.Serialize b) => Cereal.Serialize (Inline a b) +instance (Cereal.Serialize a, Cereal.Serialize b) => Cereal.Serialize (PreInline a b) +instance (Cereal.Serialize a) => Cereal.Serialize (InlineExp a) + type IsArrInit = Bool + +-- | Array sizes by demensions type ArrSize a = [a] + +-- | Array multi index type ArrIndex a = [a] -- Named variable data Var = Var - { varType :: VarType -- global / local - , varRate :: Rate - , varName :: Name } + { varType :: !VarType -- global / local + , varRate :: !Rate + , varName :: !Name } | VarVerbatim - { varRate :: Rate - , varName :: Name + { varRate :: !Rate + , varName :: !Name } deriving (Show, Eq, Ord, Generic) -- Variables can be global (then we have to prefix them with `g` in the rendering) or local. @@ -216,11 +288,11 @@ -- Opcode information. data Info = Info -- Opcode name - { infoName :: Name + { infoName :: !Name -- Opcode type signature - , infoSignature :: Signature + , infoSignature :: !Signature -- Opcode can be infix or prefix - , infoOpcFixity :: OpcFixity + , infoOpcFixity :: !OpcFixity } deriving (Show, Eq, Ord, Generic) isPrefix, isInfix :: Info -> Bool @@ -243,8 +315,28 @@ | Fr -- spectrum (for pvs opcodes) | Wr -- special spectrum | Tvar -- I don't understand what it is (fix me) used with Fr + | ArArr -- array rates + | KrArr + | IrArr + | SrArr deriving (Show, Eq, Ord, Enum, Bounded, Generic) +toArrRate :: Rate -> Rate +toArrRate = \case + Ar -> ArArr + Kr -> KrArr + Ir -> IrArr + Sr -> SrArr + other -> other + +removeArrRate :: Rate -> Rate +removeArrRate = \case + ArArr -> Ar + KrArr -> Kr + IrArr -> Ir + SrArr -> Sr + other -> other + -- Opcode type signature. Opcodes can produce single output (SingleRate) or multiple outputs (MultiRate). -- In Csound opcodes are often have several signatures. That is one opcode name can produce signals of the -- different rate (it depends on the type of the outputs). Here we assume (to make things easier) that @@ -252,46 +344,37 @@ data Signature -- For SingleRate-opcodes type signature is the Map from output rate to the rate of the arguments. -- With it we can deduce the type of the argument from the type of the output. - = SingleRate (Map Rate [Rate]) + = SingleRate !(Map Rate [Rate]) -- For MultiRate-opcodes Map degenerates to the singleton. We have only one link. -- It contains rates for outputs and inputs. | MultiRate - { outMultiRate :: [Rate] - , inMultiRate :: [Rate] } - deriving (Show, Eq, Ord) - -instance Hashable Signature where - hashWithSalt s x = case x of - SingleRate m -> s `hashWithSalt` (0 :: Int) `hashWithSalt` (hash $ fmap (\b -> (take 5 b)) $ head' $ toList m) - MultiRate a b -> s `hashWithSalt` (1 :: Int) `hashWithSalt` (hash $ take 5 a) `hashWithSalt` (hash $ take 5 b) - where - head' xs = case xs of - [] -> Nothing - value:_ -> Just value + { outMultiRate :: ![Rate] + , inMultiRate :: ![Rate] } + deriving (Show, Eq, Ord, Generic) -- Primitive values data Prim -- instrument p-arguments - = P Int - | PString Int -- >> p-string (read p-string notes at the bottom of the file): - | PrimInt Int - | PrimDouble Double - | PrimString String - | PrimInstrId InstrId + = P !Int + | PString !Int -- >> p-string (read p-string notes at the bottom of the file): + | PrimInt !Int + | PrimDouble !Double + | PrimString !Text + | PrimInstrId !InstrId | PrimVar - { primVarTargetRate :: Rate - , primVar :: Var } + { primVarTargetRate :: !Rate + , primVar :: !Var } deriving (Show, Eq, Ord, Generic) -- Gen routine. data Gen = Gen - { genSize :: Int - , genId :: GenId - , genArgs :: [Double] - , genFile :: Maybe String + { genSize :: !Int + , genId :: !GenId + , genArgs :: ![Double] + , genFile :: !(Maybe Text) } deriving (Show, Eq, Ord, Generic) -data GenId = IntGenId Int | StringGenId String +data GenId = IntGenId !Int | StringGenId !Text deriving (Show, Eq, Ord, Generic) -- Csound note @@ -300,22 +383,19 @@ ------------------------------------------------------------ -- types for arithmetic and boolean expressions -data Inline a b = Inline - { inlineExp :: InlineExp a - , inlineEnv :: IM.IntMap b - } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic1) - -instance (Hashable a, Hashable b) => Hashable (Inline a b) where - hashWithSalt s (Inline a m) = s `hashWithSalt` (hash a) `hashWithSalt` (hash $ IM.toList m) +data Inline op arg = Inline + { inlineExp :: !(InlineExp op) + , inlineEnv :: !(IM.IntMap arg) + } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic1, Generic) -- Inlined expression. -data InlineExp a - = InlinePrim Int - | InlineExp a [InlineExp a] +data InlineExp op + = InlinePrim !Int + | InlineExp !op ![InlineExp op] deriving (Show, Eq, Ord, Generic) -- Expression as a tree (to be inlined) -data PreInline a b = PreInline a [b] +data PreInline a b = PreInline !a ![b] deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic, Generic1) -- booleans @@ -364,62 +444,38 @@ -- | Multiple output. Specify the number of outputs to get the result. type MultiOut a = Int -> a - ------------------------------------------------------ -- hashable instances - -instance (Hashable a, Hashable b) => Hashable (PreInline a b) -instance (Hashable a) => Hashable (InlineExp a) -instance Hashable CondOp -instance Hashable NumOp - -instance Hashable Gen -instance Hashable GenId -instance Hashable Prim -instance Hashable Rate - -instance Hashable OpcFixity -instance Hashable Info -instance Hashable VarType -instance Hashable Var - -instance Hashable a => Hashable (MainExp a) -instance Hashable a => Hashable (PrimOr a) -instance Hashable a => Hashable (RatedExp a) -instance Hashable InstrId - - -#if !MIN_VERSION_hashable(1,3,4) -instance Hashable1 IM.IntMap -#endif -deriving instance Generic1 IM.IntMap -instance Hashable a => Hashable1 (PreInline a) -instance Hashable a => Hashable1 (Inline a) -instance Hashable1 RatedExp -instance Hashable1 MainExp -instance Hashable1 PrimOr - $(deriveEq1 ''PrimOr) $(deriveEq1 ''PreInline) $(deriveEq1 ''Inline) +$(deriveEq1 ''CodeBlock) $(deriveEq1 ''MainExp) $(deriveEq1 ''RatedExp) $(deriveOrd1 ''PrimOr) $(deriveOrd1 ''PreInline) $(deriveOrd1 ''Inline) +$(deriveOrd1 ''CodeBlock) $(deriveOrd1 ''MainExp) $(deriveOrd1 ''RatedExp) $(deriveShow1 ''PrimOr) $(deriveShow1 ''PreInline) $(deriveShow1 ''Inline) +$(deriveShow1 ''CodeBlock) $(deriveShow1 ''MainExp) $(deriveShow1 ''RatedExp) +deriving instance Generic1 IM.IntMap + isEmptyExp :: E -> Bool -isEmptyExp (Fix re) = isNothing (ratedExpDepends re) && (ratedExpExp re == EmptyExp) +isEmptyExp (Fix re) = isNothing (ratedExpDepends re) && + (case ratedExpExp re of + EmptyExp -> True + _ -> False + ) -------------------------------------------------------------- -- comments diff --git a/src/Csound/Dynamic/Types/Flags.hs b/src/Csound/Dynamic/Types/Flags.hs --- a/src/Csound/Dynamic/Types/Flags.hs +++ b/src/Csound/Dynamic/Types/Flags.hs @@ -30,8 +30,10 @@ import Data.Default import Data.Maybe import Data.Monoid +import Data.Text (Text) +import Data.Text qualified as Text -import Text.PrettyPrint.Leijen +import Text.PrettyPrint.Leijen.Text mappendBool :: Bool -> Bool -> Bool mappendBool a b = getAny $ mappend (Any a) (Any b) @@ -46,7 +48,7 @@ , rtmidi :: Maybe Rtmidi , displays :: Displays , config :: Config - , flagsVerbatim :: Maybe String + , flagsVerbatim :: Maybe Text } deriving (Eq, Show, Read) instance Default Flags where @@ -88,8 +90,8 @@ data AudioFileOutput = AudioFileOutput { formatSamples :: Maybe FormatSamples , formatType :: Maybe FormatType - , output :: Maybe String - , input :: Maybe String + , output :: Maybe Text + , input :: Maybe Text , nosound :: Bool , nopeaks :: Bool , dither :: Maybe Dither @@ -144,12 +146,12 @@ -- Output file id tags data IdTags = IdTags - { idArtist :: Maybe String - , idComment :: Maybe String - , idCopyright :: Maybe String - , idDate :: Maybe String - , idSoftware :: Maybe String - , idTitle :: Maybe String + { idArtist :: Maybe Text + , idComment :: Maybe Text + , idCopyright :: Maybe Text + , idDate :: Maybe Text + , idSoftware :: Maybe Text + , idTitle :: Maybe Text } deriving (Eq, Show, Read) instance Default IdTags where @@ -184,25 +186,25 @@ data Rtaudio = PortAudio | Alsa | Jack - { jackClient :: String - , jackInport :: String - , jackOutport :: String } + { jackClient :: Text + , jackInport :: Text + , jackOutport :: Text } | Mme | CoreAudio | NoRtaudio deriving (Eq, Show, Read) data PulseAudio = PulseAudio - { paServer :: String - , paOutput :: String - , paInput :: String + { paServer :: Text + , paOutput :: Text + , paInput :: Text } deriving (Eq, Show, Read) -- MIDI File Input/Ouput data MidiIO = MidiIO - { midiFile :: Maybe String - , midiOutFile :: Maybe String - , muteTracks :: Maybe String + { midiFile :: Maybe Text + , midiOutFile :: Maybe Text + , muteTracks :: Maybe Text , rawControllerMode :: Bool , terminateOnMidi :: Bool } deriving (Eq, Show, Read) @@ -237,14 +239,14 @@ -- MIDI Realtime Input/Ouput data MidiRT = MidiRT - { midiDevice :: Maybe String + { midiDevice :: Maybe Text , midiKey :: Maybe Int , midiKeyCps :: Maybe Int , midiKeyOct :: Maybe Int , midiKeyPch :: Maybe Int , midiVelocity :: Maybe Int , midiVelocityAmp :: Maybe Int - , midiOutDevice :: Maybe String + , midiOutDevice :: Maybe Text } deriving (Eq, Show, Read) instance Default MidiRT where @@ -347,12 +349,12 @@ , ioBuf :: Maybe Int , newKr :: Maybe Int , newSr :: Maybe Int - , scoreIn :: Maybe String - , omacro :: Maybe (String, String) - , smacro :: Maybe (String, String) + , scoreIn :: Maybe Text + , omacro :: Maybe (Text, Text) + , smacro :: Maybe (Text, Text) , setSched :: Bool , schedNum :: Maybe Int - , strsetN :: Maybe (Int, String) + , strsetN :: Maybe (Int, Text) , skipSeconds :: Maybe Double , setTempo :: Maybe Int } deriving (Eq, Show, Read) @@ -406,28 +408,25 @@ | otherwise = Just res where res = pretty x -bo :: String -> (a -> Bool) -> (a -> Maybe Doc) +bo :: Text -> (a -> Bool) -> (a -> Maybe Doc) bo property extract a - | extract a = Just $ text property + | extract a = Just $ textStrict property | otherwise = Nothing -mp :: (String -> String) -> (a -> Maybe String) -> (a -> Maybe Doc) -mp f a = p (fmap f . a) - -mi :: (String -> String) -> (a -> Maybe Int) -> (a -> Maybe Doc) -mi f a = mp f (fmap show . a) +mp :: Pretty b => (Doc -> Doc) -> (a -> Maybe b) -> (a -> Maybe Doc) +mp f a = fmap (f . pretty) . a -p1 :: String -> String -> String -p1 pref x = ('-' : pref) ++ (' ' : x) +p1 :: Doc -> Doc -> Doc +p1 pref x = hcat [char '-', pref, char ' ', x] -p2 :: String -> String -> String -p2 pref x = ('-' : '-' : pref) ++ ('=' : x) +p2 :: Doc -> Doc -> Doc +p2 pref x = hcat [char '-', char '-', pref, char '=', x] -p3 :: String -> String -> String -p3 pref x = ('-' : '+' : pref) ++ ('=' : x) +p3 :: Doc -> Doc -> Doc +p3 pref x = hcat [char '-', char '+', pref, char '=', x] fields :: [a -> Maybe Doc] -> a -> Doc -fields fs a = hsep $ catMaybes $ fmap ( $ a) fs +fields fs a = hsep $ mapMaybe ( $ a) fs instance Pretty Flags where pretty = fields @@ -449,7 +448,7 @@ , mp (p2 "input") input , bo "--nosound" nosound , bo "--nopeaks" nopeaks - , mp (p2 "d/Mither") $ fmap (firstToLower . show) . dither ] + , mp (p2 "d/Mither") $ fmap (firstToLower . Text.pack . show) . dither ] pSamplesAndType :: (Maybe FormatSamples, Maybe FormatType) -> Maybe Doc pSamplesAndType (ma, mb) = fmap pretty $ case (ma, mb) of @@ -461,25 +460,26 @@ samplesToStr x = case x of Bit24 -> "24bit" FloatSamples -> "float" - _ -> firstToLower $ show x + _ -> textStrict $ firstToLower $ Text.pack $ show x - typeToStr = firstToLower . show + typeToStr = textStrict . firstToLower . Text.pack . show - samplesAndTypeToStr a b = samplesToStr a ++ ":" ++ typeToStr b + samplesAndTypeToStr a b = hcat [samplesToStr a, ":", typeToStr b] instance Pretty Dither where - pretty = pretty . p2 "dither" . show + pretty = p2 "dither" . textStrict . Text.pack . show instance Pretty IdTags where pretty = fields - [ mp (p3' "id_artist") idArtist - , mp (p3' "id_comment") idComment - , mp (p3' "id_copyright") idCopyright - , mp (p3' "id_date") idDate - , mp (p3' "id_software") idSoftware - , mp (p3' "id_title") idTitle ] + [ mp (p3 "id_artist") (subst idArtist) + , mp (p3 "id_comment") (subst idComment) + , mp (p3 "id_copyright") (subst idCopyright) + , mp (p3 "id_date") (subst idDate) + , mp (p3 "id_software") (subst idSoftware) + , mp (p3 "id_title") (subst idTitle) ] where - p3' a b = fmap substSpaces $ p3 a b + subst f = fmap (Text.map substSpaces) . f + substSpaces x | isSpace x = '_' | otherwise = x @@ -493,17 +493,21 @@ CoreAudio -> rt "auhal" NoRtaudio -> rt "0" where - rt = text . p3 "rtaudio" - jackFields name ins outs = hsep - [ text $ p3 "jack_client" name - , text $ p3 "jack_inportname" ins - , text $ p3 "jack_outportname" outs ] + rt = p3 "rtaudio" + jackFields name ins outs = + hsep + [ p3 "jack_client" (textStrict name) + , p3 "jack_inportname" (textStrict ins) + , p3 "jack_outportname" (textStrict outs) ] + instance Pretty PulseAudio where - pretty a = hsep $ fmap text $ - [ p3 "server" $ paServer a - , p3 "output_stream" $ paOutput a - , p3 "input_stream" $ paInput a ] + pretty a = + hsep + [ p3 "server" $ textStrict (paServer a) + , p3 "output_stream" $ textStrict (paOutput a) + , p3 "input_stream" $ textStrict (paInput a) + ] instance Pretty MidiIO where pretty = fields @@ -516,16 +520,16 @@ instance Pretty MidiRT where pretty = fields [ mp (p2 "midi-device") midiDevice - , mi (p2 "midi-key") midiKey - , mi (p2 "midi-key-cps") midiKeyCps - , mi (p2 "midi-key-oct") midiKeyOct - , mi (p2 "midi-key-pch") midiKeyPch - , mi (p2 "midi-velocity") midiVelocity - , mi (p2 "midi-velocity-amp") midiVelocityAmp + , mp (p2 "midi-key") midiKey + , mp (p2 "midi-key-cps") midiKeyCps + , mp (p2 "midi-key-oct") midiKeyOct + , mp (p2 "midi-key-pch") midiKeyPch + , mp (p2 "midi-velocity") midiVelocity + , mp (p2 "midi-velocity-amp") midiVelocityAmp , mp (p1 "Q") midiOutDevice ] instance Pretty Rtmidi where - pretty x = text $ p3 "rtmidi" $ case x of + pretty x = p3 "rtmidi" $ case x of VirtualMidi -> "virtual" PortMidi -> "PortMidi" AlsaMidi -> "alsa" @@ -537,51 +541,52 @@ instance Pretty Displays where pretty = fields - [ mi (p2 "csd-line-nums") csdLineNums + [ mp (p2 "csd-line-nums") csdLineNums , p displayMode - , mi (p2 "heartbeat") displayHeartbeat - , mi (p2 "messagelevel") messageLevel - , mi (p2 "m-amps") mAmps - , mi (p2 "m-range") mRange - , mi (p2 "m-warnings") mWarnings - , mi (p2 "m-dB") mDb - , mi (p2 "m-colours") mColours - , mi (p2 "m-benchmarks") mBenchmarks + , mp (p2 "heartbeat") displayHeartbeat + , mp (p2 "messagelevel") messageLevel + , mp (p2 "m-amps") mAmps + , mp (p2 "m-range") mRange + , mp (p2 "m-warnings") mWarnings + , mp (p2 "m-dB") mDb + , mp (p2 "m-colours") mColours + , mp (p2 "m-benchmarks") mBenchmarks , bo "-+msg_color" msgColor , bo "--verbose" displayVerbose - , mi (p2 "list-opcodes") listOpcodes ] + , mp (p2 "list-opcodes") listOpcodes ] instance Pretty DisplayMode where - pretty x = text $ case x of + pretty x = case x of NoDisplay -> "--nodisplays" PostScriptDisplay -> "--postscriptdisplay" AsciiDisplay -> "--asciidisplay" instance Pretty Config where pretty = fields - [ mi (p2 "hardwarebufsamps") hwBuf - , mi (p2 "iobufsamps") ioBuf - , mi (p2 "control-rate") newKr - , mi (p2 "sample-rate") newSr + [ mp (p2 "hardwarebufsamps") hwBuf + , mp (p2 "iobufsamps") ioBuf + , mp (p2 "control-rate") newKr + , mp (p2 "sample-rate") newSr , mp (p2 "score-in") scoreIn , macro "omacro" omacro , macro "smacro" smacro , bo "--sched" setSched - , mi (p2 "sched") schedNum + , mp (p2 "sched") schedNum , strset strsetN - , mp (p3 "skip_seconds") (fmap show . skipSeconds) - , mi (p2 "tempo") setTempo ] + , mp (p3 "skip_seconds") skipSeconds + , mp (p2 "tempo") setTempo ] where - macro name f = fmap (pretty . phi) . f - where phi (a, b) = "--" ++ name ++ ":" ++ a ++ "=" ++ b - strset f = fmap (pretty . phi) . f - where phi (n, a) = "--strset" ++ (show n) ++ "=" ++ a + macro :: Doc -> (a -> Maybe (Text, Text)) -> a -> Maybe Doc + macro name f = fmap phi . f + where phi (a, b) = hcat ["--", pretty name, ":", textStrict a, "=", textStrict b] + strset f = fmap phi . f + where phi (n, a) = hcat ["--strset", int n,"=", textStrict a] + --------------------------------------------------- -- utilities -firstToLower :: String -> String -firstToLower x = case x of - a:as -> toLower a : as - [] -> [] - +firstToLower :: Text -> Text +firstToLower x = case Text.uncons x of + Just (a, as) -> Text.cons (toLower a) as + Nothing -> x