csound-expression-dynamic 0.0.4 → 0.0.5

raw patch · 4 files changed

+165/−5 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

csound-expression-dynamic.cabal +2/−1
src/Csound/Dynamic/Render/Instr.hs +4/−2
src/Csound/Dynamic/Tfm/Liveness.hs +157/−0
src/Csound/Dynamic/Tfm/UnfoldMultiOuts.hs +2/−2

csound-expression-dynamic.cabal view

@@ -1,5 +1,5 @@ Name:          csound-expression-dynamic-Version:       0.0.4+Version:       0.0.5 Cabal-Version: >= 1.6 License:       BSD3 License-file:  LICENSE@@ -45,6 +45,7 @@    Other-Modules:     Csound.Dynamic.Tfm.DeduceTypes+    Csound.Dynamic.Tfm.Liveness     Csound.Dynamic.Tfm.UnfoldMultiOuts     Csound.Dynamic.Render.Pretty     Csound.Dynamic.Render.Instr

src/Csound/Dynamic/Render/Instr.hs view

@@ -15,6 +15,7 @@  import Csound.Dynamic.Tfm.DeduceTypes import Csound.Dynamic.Tfm.UnfoldMultiOuts+import Csound.Dynamic.Tfm.Liveness  import Csound.Dynamic.Types hiding (Var) import Csound.Dynamic.Build(getRates, isMultiOutSignature)@@ -49,8 +50,9 @@ clearEmptyResults (res, expr) = (filter ((/= Xr) . ratedVarRate) res, expr)          collectRates :: Dag RatedExp -> [([RatedVar], Exp RatedVar)]-collectRates dag = fmap (second ratedExpExp) res-    where res = unfoldMultiOuts unfoldSpec lastFreshId dag1  +collectRates dag = fmap (second ratedExpExp) res2+    where res2 = liveness lastFreshId1 res1+          (res1, lastFreshId1)= unfoldMultiOuts unfoldSpec lastFreshId dag1             (dag1, lastFreshId) = rateGraph dag  -----------------------------------------------------------

+ src/Csound/Dynamic/Tfm/Liveness.hs view

@@ -0,0 +1,157 @@+module Csound.Dynamic.Tfm.Liveness (+    liveness+) where++import Prelude hiding (mapM, mapM_)++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 qualified Csound.Dynamic.Tfm.DeduceTypes as D+import Csound.Dynamic.Tfm.DeduceTypes(varType, varId)+import Csound.Dynamic.Types.Exp(Rate(..))++liveness :: Traversable f => Int -> Dag f -> Dag f+liveness lastFreshId as = runST $ do+	st <- initSt lastFreshId $ analyse lastFreshId as+	evalStateT (mapM substExp $ countLines $ as) st++type LineNumber = Int++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)++type Dag f = [Exp f]++-----------------------------------------------++data IdList = IdList+    [Int] -- fresh ids+    Int   -- the biggest used id++allocId :: IdList -> (Int, IdList)+allocId (IdList is lastId) = (head is, IdList (tail is) (max (head is) lastId))++freeId :: Int -> IdList -> IdList +freeId  n (IdList is lastId) = IdList (insertSorted n is) lastId1+	where lastId1 = if (n == lastId) then (lastId - 1) else lastId++insertSorted :: Int -> [Int] -> [Int]+insertSorted n (a:as) +	| n < a  = n : a : as+	| n == a = a : as+	| otherwise = a : insertSorted n as +insertSorted n [] = [n]++-----------------------------------------------++type StArr s = A.STUArray s Int Int++type LivenessTable = A.UArray Int Int+type SubstTable s  = StArr s++data Registers s = Registers +	{ registers 	:: M.Map Rate IdList+	, livenessTable :: LivenessTable+	, 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 }++initRegs :: M.Map Rate IdList+initRegs = M.fromList $ fmap (\x -> (x, initIdList)) [(minBound :: Rate) .. maxBound]+	where initIdList = IdList [0..] 0++isAlive :: LineNumber -> Var -> Memory s Bool+isAlive lineNum v = do+	tab <- fmap livenessTable get+	return $ lineNum < tab A.! (varId v)++lookUpSubst :: Int -> Memory s Int+lookUpSubst i = do+	tab <- fmap substTable get+	lift $ A.readArray tab i++saveSubst :: Int -> Int -> Memory s ()+saveSubst from to = do+	tab <- fmap substTable get +	lift $ A.writeArray tab from to++substLhs :: Var -> Memory s Var+substLhs v = do+	v1 <- alloc $ varType v+	saveSubst (varId v) (varId v1)+	return v1++substRhs :: LineNumber -> Var -> Memory s Var+substRhs lineNum v = do+	i1 <- lookUpSubst (varId v)+	let v1 = D.Var i1 (varType v)+	b <- isAlive lineNum v+	unless b $ free v1+	return v1++alloc :: Rate -> Memory s Var+alloc rate = state $ \mem -> +	let (i, mem1) = allocRegister rate mem+	in  (D.Var i rate, mem1)+	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++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++--------------------------------------------------------------------------++analyse :: Traversable f => Int -> Dag f -> LivenessTable+analyse lastFreshId as = A.runSTUArray $ do+	arr <- A.newArray (0, 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 ()++		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++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)++initSubstTable :: Int ->  ST s (SubstTable s)+initSubstTable n = A.newListArray (0, n) [0 .. n]+

src/Csound/Dynamic/Tfm/UnfoldMultiOuts.hs view

@@ -36,8 +36,8 @@     getSelector    :: f (Var a) -> Maybe (Selector a),     getParentTypes :: f (Var a) -> Maybe [a] } -unfoldMultiOuts :: UnfoldMultiOuts f a -> Int -> [SingleStmt f a] -> [MultiStmt f a]-unfoldMultiOuts algSpec lastFreshId stmts = evalState st lastFreshId+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)