Wrapping up the transformation system

This introduces a transformation system which is able to transform
properly type-annotated expressions into the normal form needed for
translation to VHDL.
It suppowerts Lambda-functions, Operator-sections and the higher order
functions map,foldl,...

ForSyDe-Deep.cabal

@@ -72,6 +72,7 @@ Library
                    base>=4 && <6,
                    regex-posix,
                    mtl,
+                   syb,
                    pretty,
                    template-haskell,
                    process,
@@ -115,6 +116,7 @@ Library
                    ForSyDe.Deep.System.SysDef,
                    ForSyDe.Deep.System.Instantiate,
                    ForSyDe.Deep.Process.ProcFun,
+                   ForSyDe.Deep.Process.Desugar,
                    ForSyDe.Deep.Process.ProcVal,
                    ForSyDe.Deep.Process.ProcType,
                    ForSyDe.Deep.Process.ProcType.Instances,

examples/MapLambdaVector.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+-- A vecCounter, the simplest system with which to test netlist loops
+
+module MapLambdaVector where
+
+import ForSyDe.Deep
+import Data.TypeLevel.Num hiding ((+))
+import qualified Data.Param.FSVec as V
+import Data.Int
+
+vecLamCounter :: Signal (V.FSVec D4 Int32)
+vecLamCounter  = sourceSY "vecCounterSource" add1 (V.copy d4 (0 :: Int32))
+ where add1 = $(newProcFun [d| add1v :: (V.FSVec D4 Int32) -> (V.FSVec D4 Int32)
+                               -- Only lambda functions which are enclosed in a
+                               -- type signature are supported:
+                               add1v v = V.map ((\a -> a+1) :: Int32 -> Int32) v |])
+
+vecLamCounterSys :: SysDef (Signal (V.FSVec D4 Int32))
+vecLamCounterSys = newSysDef vecLamCounter "vecLambdaCounterMapV" [] ["countVal"]
+
+simLamVecCounter :: [(V.FSVec D4 Int32)]
+simLamVecCounter = simulate vecLamCounterSys

examples/MapVectorOperatorSection.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+
+module MapVectorOperatorSection where
+
+import ForSyDe.Deep
+import Data.TypeLevel.Num hiding ((+),(*))
+import qualified Data.Param.FSVec as V
+import Data.Int
+
+vecOpSecCounter :: Signal (V.FSVec D4 Int32)
+vecOpSecCounter  = sourceSY "vecOpSecCounterSource" add1 (V.copy d4 (0 :: Int32))
+ where add1 = $(newProcFun [d| add1v :: (V.FSVec D4 Int32) -> (V.FSVec D4 Int32)
+                               -- Operator sections (partially applied infix
+                               -- operators) are supported if they are enclosed
+                               -- in a type signature
+                               add1v v = V.map (((+1*4)*5)::Int32 -> Int32) v |])
+
+vecOpSecCounterSys :: SysDef (Signal (V.FSVec D4 Int32))
+vecOpSecCounterSys = newSysDef vecOpSecCounter "vecOpSecCounterMapV" [] ["countVal"]
+
+simVecOpSecCounter :: [(V.FSVec D4 Int32)]
+simVecOpSecCounter = simulate vecOpSecCounterSys

examples/MapVectorTransformation.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module MapVectorTransformation where
+
+import ForSyDe.Deep
+import Data.TypeLevel.Num hiding ((+))
+import qualified Data.Param.FSVec as V
+import Data.Int
+
+transfVecCounter :: Signal (V.FSVec D4 Int32)
+transfVecCounter  = sourceSY "transfVecCounterSource" add1 (V.copy d4 (0 :: Int32))
+ where add1 = $(newProcFun [d| add1v :: (V.FSVec D4 Int32) -> (V.FSVec D4 Int32)
+                               -- calls to higher order functions are
+                               -- supported, if they have a type signature of
+                               -- the form: 
+                               --   (map f v::<vectype>)::<rettype>
+                               -- This means, the returned value and all
+                               -- arguments except the argument function need
+                               -- to have proper type signatures
+                               add1v v = V.reverse ((V.map add1 (v::(V.FSVec D4 Int32)))::V.FSVec D4 Int32)
+                                 where
+                                     add1 :: Int32 -> Int32
+                                     add1 a = a+1 |])
+
+transfVecCounterSys :: SysDef (Signal (V.FSVec D4 Int32))
+transfVecCounterSys = newSysDef transfVecCounter "transfVecCounterMapV" [] ["countVal"]
+
+simTransfVecCounter :: [(V.FSVec D4 Int32)]
+simTransfVecCounter = simulate transfVecCounterSys

src/ForSyDe/Deep/Process/Desugar.hs

@@ -0,0 +1,131 @@
+{-# LANGUAGE CPP, TemplateHaskell, Rank2Types #-}
+module ForSyDe.Deep.Process.Desugar (desugarTransform) where
+
+import qualified Language.Haskell.TH as TH
+import Language.Haskell.TH
+import Control.Monad.State.Lazy
+
+import Data.Generics
+import qualified Data.Param.FSVec as V
+
+{-
+desugarTransform :: [Dec] -> Q [Dec]
+desugarTransform = return
+-}
+
+desugarTransform :: [Dec] -> Q [Dec]
+--desugarTransform decs = foldAccDecs (mkM extractTypedLambda) decs
+desugarTransform decs = (return decs) 
+                      =+=> extractTypedLambda
+                      =+=> extractInfixOpSection
+                      =+=> specializeHof
+                      =+=> deleteSigE
+#ifdef DEVELOPER
+                      >>= dumpTree
+  where
+    dumpTree :: [Dec] -> Q [Dec]
+    dumpTree ts = do _ <- runIO $ mapM (print.ppr) ts
+                     return ts
+#endif
+
+-- Apply declaration-accumulating transformation
+(=+=>) :: Typeable a => Q [Dec] -> (a -> DecAccM a) -> Q [Dec]
+decs =+=> f = decs >>= (foldAccDecs $ mkM f)
+
+-- Extract all occurences of lambda expressions within type signatures 
+--    ... ((\...  -> ...) :: ...) ...
+-- Create functions declarations for them and replace the lambda expression
+-- with a reference to the declaration:
+--    ... lambda0 ...
+--    where
+--      lambda0 :: ...
+--      lambda0 ... = ...
+extractTypedLambda :: Exp -> DecAccM Exp
+extractTypedLambda (SigE (LamE patterns lamBody) ty) = do
+    name <- lift $ newName "lambda"
+    let body = NormalB lamBody
+        signature = (SigD name ty)
+        function  = (FunD name [(Clause patterns body [])])
+    modify $ \declState -> signature:function:declState
+    return (VarE name)
+extractTypedLambda e = return e
+
+-- Make a function out of a suitably annotated operator section
+--    ... (+3)::Int32->Int32 ...
+--  is transformed to
+--    ... infix_section_0 ...
+--    where infix_section_0 a = a+3
+extractInfixOpSection :: Exp -> DecAccM Exp
+extractInfixOpSection (SigE exp@(InfixE _ _ _) ty) = do
+    name    <- lift.newName $ "infix_section"
+    argname <- lift.newName $ "a"
+    let body      = NormalB $ everywhere (mkT $ insertArgument argname) exp
+        patterns  = [VarP argname]
+        signature = SigD name ty
+        function  = FunD name [(Clause patterns body [])]
+    modify $ \declState -> signature:function:declState
+    return (VarE name)
+  where
+    insertArgument :: Name -> Exp -> Exp
+    insertArgument argn (InfixE Nothing op r) = InfixE (Just $ VarE argn) op r
+    insertArgument argn (InfixE l op Nothing) = InfixE l op (Just $ VarE argn)
+    insertArgument _ e = e
+extractInfixOpSection e = return e
+
+
+hofNames :: [TH.Name]
+hofNames = [
+            'V.foldr,
+            'V.foldl,
+            'V.map,
+            'V.zipWith,
+            'V.zipWith3
+            ]
+
+isHigherOrderFunctionName :: TH.Name -> Bool
+isHigherOrderFunctionName n = elem n hofNames
+
+-- specializing extraction:
+-- find all hof applications: (AppE (VarE hofName) (VarE fname))
+--      build specialized function definition in normal form
+--      collect specialized declarations in state of DecAccM
+--      replace application with call to specialized function
+specializeHof :: Exp -> DecAccM Exp
+-- arity=2
+specializeHof (SigE (AppE hofapp@(AppE (VarE hofName) (VarE argFunName)) arg1@(SigE _ argtype)) rettype)
+   | isHigherOrderFunctionName hofName = do 
+        name    <- lift.newName $ (nameBase hofName)++"_"++(nameBase argFunName)
+        argname <- lift.newName $ "v"
+
+        let body      = NormalB $ AppE hofapp (VarE argname)
+            patterns  = [VarP argname]
+            signature = (SigD name (AppT (AppT ArrowT argtype) rettype))
+            function  = (FunD name [(Clause patterns body [])])
+        modify $ \declState -> declState++[signature,function]
+        return (SigE (AppE (VarE name) arg1) rettype)
+specializeHof e = return e
+
+-- Delete all the type signature expressions as they are not recognized during
+-- translation
+deleteSigE :: Exp -> DecAccM Exp
+deleteSigE (SigE e _) = return e
+deleteSigE e = return e
+
+type DecAccM t = StateT [Dec] Q t
+
+-- stateful fold over the tree. Applies f everywhere within the tree,
+-- collecting additional declarations during traversal, and adding them to the
+-- corresponding scope
+foldAccDecs :: GenericM DecAccM -> [Dec] -> Q [Dec]
+foldAccDecs transform decs = mapM apply decs
+ where
+  apply :: Dec -> Q Dec
+  apply (FunD name [Clause pat body decls]) = do
+    (newBody,newDecls) <- runStateT (everywhereM transform body) []
+    transfDecls <- foldAccDecs transform decls
+    return $ FunD name [Clause pat newBody (transfDecls++newDecls)]
+  apply (ValD pat body decls) = do
+    (newBody,newDecls) <- runStateT (everywhereM transform body) []
+    transfDecls <- foldAccDecs transform decls
+    return $ ValD pat newBody (transfDecls++newDecls)
+  apply d = return d

src/ForSyDe/Deep/Process/Desugar.hs-boot

@@ -0,0 +1,7 @@
+{-# LANGUAGE Rank2Types #-}
+module ForSyDe.Deep.Process.Desugar (desugarTransform) where
+
+import Language.Haskell.TH
+import Data.Generics
+
+desugarTransform :: [Dec] -> Q [Dec]

src/ForSyDe/Deep/Process/ProcFun.hs

@@ -26,6 +26,7 @@ module ForSyDe.Deep.Process.ProcFun
 ) where
 
 import ForSyDe.Deep.Process.ProcType
+import ForSyDe.Deep.Process.Desugar (desugarTransform)
 import ForSyDe.Deep.Process.ProcVal (ProcValAST, mkProcValAST)
 import ForSyDe.Deep.ForSyDeErr
 
@@ -87,7 +88,8 @@ defArgPF pf v = pf{ ast = astPF {pars = ((pars astPF) ++ [FunAST (ast v)])},
 -- @
 newProcFun :: Q [Dec] -> ExpQ
 newProcFun fDecQs = do 
-      fDecs <- fDecQs   
+      fDecsRaw <- fDecQs   
+      fDecs <- desugarTransform fDecsRaw
       -- Check for the declarations to be correct
       (name, cls) <- recover (currErr $ IncorrProcFunDecs fDecs) 
                              (checkDecs fDecs)

tests/examples/VHDLBackend.hs

@@ -16,6 +16,9 @@ import CarrySelectAdder
 import Null
 import LFSR
 import MapVector
+import MapVectorOperatorSection
+import MapVectorTransformation
+import MapLambdaVector
 import FoldlVector
 import ZipWithVector
 import FoldlVectorOperator
@@ -42,6 +45,9 @@ vhdlBackendTest = test [aluTest,
                         nullTest,
                         lfsrTest,
                         mapVTest,
+                        mapVectorTransformationTest,
+                        mapLambdaVectorTest,
+                        mapVectorOperatorSectionTest,
                         foldlVOpTest,
                         zipWithVOpTest,
                         foldlVTest,
@@ -220,6 +226,23 @@ zipWithVOpTest = "zipWithVOpTest" ~: TestCase ioTest
      outSim @=? outVHDL 
 
 
+mapVectorOperatorSectionTest :: Test
+mapVectorOperatorSectionTest = "mapVectorOperatorSectionTest" ~: outSim <~=?> outVHDL
+ where 
+   outSim = take 100 simVecOpSecCounter
+   outVHDL = vhdlTest (Just 100) vecOpSecCounterSys
+
+mapLambdaVectorTest :: Test
+mapLambdaVectorTest = "mapLambdaVectorTest" ~: outSim <~=?> outVHDL
+ where 
+   outSim = take 100 simLamVecCounter
+   outVHDL = vhdlTest (Just 100) vecLamCounterSys
+
+mapVectorTransformationTest :: Test
+mapVectorTransformationTest = "mapVectorTransformationTest" ~: outSim <~=?> outVHDL
+ where 
+   outSim = take 100 simTransfVecCounter
+   outVHDL = vhdlTest (Just 100) transfVecCounterSys
 
 -------------------
 -- Helper functions