From ff9a8487475aa90d2f212fd24169503993a4a27d Mon Sep 17 00:00:00 2001
From: Christiaan Baaij <christiaan.baaij@gmail.com>
Date: Fri, 19 Jun 2009 13:22:06 +0200
Subject: [PATCH] Added function calls

---
 Adders.hs | 227 ++++++++++++++++++++++++++++--------------------------
 Main.hs   |   2 +-
 VHDL.hs   |  31 +++++---
 3 files changed, 141 insertions(+), 119 deletions(-)

diff --git a/Adders.hs b/Adders.hs
index 2ee1de6..ebc1c8c 100644
--- a/Adders.hs
+++ b/Adders.hs
@@ -1,36 +1,42 @@
 module Adders where
 import Bits
 import qualified Sim
+
+import qualified Prelude as P
+import Prelude hiding (
+  null, length, head, tail, last, init, take, drop, (++), map, foldl, foldr,
+  zipWith, zip, unzip, concat, reverse, iterate )
+
 import Language.Haskell.Syntax
-import qualified Data.TypeLevel as TypeLevel
-import qualified Data.Param.FSVec as FSVec
+import Types
+import Data.Param.TFVec
 
-mainIO f = Sim.simulateIO (Sim.stateless f) ()
+-- mainIO f = Sim.simulateIO (Sim.stateless f) ()
 
 -- This function is from Sim.hs, but we redefine it here so it can get inlined
 -- by default.
-stateless :: (i -> o) -> (i -> () -> ((), o))
-stateless f = \i s -> (s, f i)
-
-show_add f = do print ("Sum:   " ++ (displaysigs s)); print ("Carry: " ++ (displaysig c))
-  where
-    a = [High, High, High, High]
-    b = [Low, Low, Low, High]
-    (s, c) = f (a, b)
-
-mux2 :: Bit -> (Bit, Bit) -> Bit
-mux2 Low (a, b) = a
-mux2 High (a, b) = b
+-- stateless :: (i -> o) -> (i -> () -> ((), o))
+-- stateless f = \i s -> (s, f i)
+-- 
+-- show_add f = do print ("Sum:   " ++ (displaysigs s)); print ("Carry: " ++ (displaysig c))
+--   where
+--     a = [High, High, High, High]
+--     b = [Low, Low, Low, High]
+--     (s, c) = f (a, b)
+-- 
+-- mux2 :: Bit -> (Bit, Bit) -> Bit
+-- mux2 Low (a, b) = a
+-- mux2 High (a, b) = b
 
 -- Not really an adder, but this is nice minimal hardware description
-wire :: Bit -> Bit
-wire a = a
+-- wire :: Bit -> Bit
+-- wire a = a
 
-bus :: (TypeLevel.Pos len) => BitVec len -> BitVec len
-bus v = v
-
-bus_4 :: BitVec TypeLevel.D4 -> BitVec TypeLevel.D4
-bus_4 v = v
+-- bus :: (TypeLevel.Pos len) => BitVec len -> BitVec len
+-- bus v = v
+-- 
+-- bus_4 :: BitVec TypeLevel.D4 -> BitVec TypeLevel.D4
+-- bus_4 v = v
 
 {-
 inv_n :: (Pos len) => BitVec len -> BitVec len
@@ -52,118 +58,121 @@ instance Inv (BitVec D0) where
   inv_n_rec v = v
 -}
 -- Not really an adder either, but a slightly more complex example
-inv :: Bit -> Bit
-inv a = let r = hwnot a in r
+-- inv :: Bit -> Bit
+-- inv a = let r = hwnot a in r
 
 -- Not really an adder either, but a slightly more complex example
-invinv :: Bit -> Bit
-invinv a = hwnot (hwnot a)
+-- invinv :: Bit -> Bit
+-- invinv a = hwnot (hwnot a)
 
 -- Not really an adder either, but a slightly more complex example
-dup :: Bit -> (Bit, Bit)
-dup a = (a, a)
+-- dup :: Bit -> (Bit, Bit)
+-- dup a = (a, a)
 
 -- Not really an adder either, but a simple stateful example (D-flipflop)
-dff :: Bit -> Bit -> (Bit, Bit)
-dff d s = (s', q)
-  where
-    q = s
-    s' = d
-
-type ShifterState = (Bit, Bit, Bit, Bit)
-shifter :: Bit -> ShifterState -> (ShifterState, Bit)
-shifter i (a, b, c, d) =
-  (s', d)
-  where
-    s' = (i, a, b, c)
-
-{-# NOINLINE shifter_en #-}
-shifter_en :: Bit -> Bit-> ShifterState -> (ShifterState, Bit)
-shifter_en High i (a, b, c, d) =
-  (s', d)
-  where
-    s' = (i, a, b, c)
-
-shifter_en Low i s@(a, b, c, d) =
-  (s, d)
+-- dff :: Bit -> Bit -> (Bit, Bit)
+-- dff d s = (s', q)
+--   where
+--     q = s
+--     s' = d
+-- 
+-- type ShifterState = (Bit, Bit, Bit, Bit)
+-- shifter :: Bit -> ShifterState -> (ShifterState, Bit)
+-- shifter i (a, b, c, d) =
+--   (s', d)
+--   where
+--     s' = (i, a, b, c)
+-- 
+-- {-# NOINLINE shifter_en #-}
+-- shifter_en :: Bit -> Bit-> ShifterState -> (ShifterState, Bit)
+-- shifter_en High i (a, b, c, d) =
+--   (s', d)
+--   where
+--     s' = (i, a, b, c)
+-- 
+-- shifter_en Low i s@(a, b, c, d) =
+--   (s, d)
 
 -- Two multiplexed shifters
-type ShiftersState = (ShifterState, ShifterState)
-shifters :: Bit -> Bit -> ShiftersState -> (ShiftersState, Bit)
-shifters sel i (sa, sb) =
-  (s', out)
-  where
-    (sa', outa) = shifter_en sel i sa
-    (sb', outb) = shifter_en (hwnot sel) i sb
-    s' = (sa', sb')
-    out = if sel == High then outa else outb
+-- type ShiftersState = (ShifterState, ShifterState)
+-- shifters :: Bit -> Bit -> ShiftersState -> (ShiftersState, Bit)
+-- shifters sel i (sa, sb) =
+--   (s', out)
+--   where
+--     (sa', outa) = shifter_en sel i sa
+--     (sb', outb) = shifter_en (hwnot sel) i sb
+--     s' = (sa', sb')
+--     out = if sel == High then outa else outb
 
 -- Combinatoric stateless no-carry adder
 -- A -> B -> S
-no_carry_adder :: (Bit, Bit) -> Bit
-no_carry_adder (a, b) = a `hwxor` b
+-- no_carry_adder :: (Bit, Bit) -> Bit
+-- no_carry_adder (a, b) = a `hwxor` b
 
 -- Combinatoric stateless half adder
 -- A -> B -> (S, C)
-half_adder :: (Bit, Bit) -> (Bit, Bit)
-{-# NOINLINE half_adder #-}
-half_adder (a, b) = 
-  ( a `hwxor` b, a `hwand` b )
+-- half_adder :: (Bit, Bit) -> (Bit, Bit)
+-- {-# NOINLINE half_adder #-}
+-- half_adder (a, b) = 
+--   ( a `hwxor` b, a `hwand` b )
 
 -- Combinatoric stateless full adder
 -- (A, B, C) -> (S, C)
-full_adder :: (Bit, Bit, Bit) -> (Bit, Bit)
-full_adder (a, b, cin) = (s, c)
-  where
-    (s1, c1) = half_adder(a, b)
-    (s, c2)  = half_adder(s1, cin)
-    c        = c1 `hwor` c2
-
-sfull_adder = stateless full_adder
+-- full_adder :: (Bit, Bit, Bit) -> (Bit, Bit)
+-- full_adder (a, b, cin) = (s, c)
+--   where
+--     (s1, c1) = half_adder(a, b)
+--     (s, c2)  = half_adder(s1, cin)
+--     c        = c1 `hwor` c2
+-- 
+-- sfull_adder = stateless full_adder
 
 -- Four bit adder
 -- Explicit version
 -- [a] -> [b] -> ([s], cout)
-exp_adder :: ([Bit], [Bit]) -> ([Bit], Bit)
-
-exp_adder ([a3,a2,a1,a0], [b3,b2,b1,b0]) =
-  ([s3, s2, s1, s0], c3)
-  where
-    (s0, c0) = full_adder (a0, b0, Low)
-    (s1, c1) = full_adder (a1, b1, c0)
-    (s2, c2) = full_adder (a2, b2, c1)
-    (s3, c3) = full_adder (a3, b3, c2)
+-- exp_adder :: ([Bit], [Bit]) -> ([Bit], Bit)
+-- 
+-- exp_adder ([a3,a2,a1,a0], [b3,b2,b1,b0]) =
+--   ([s3, s2, s1, s0], c3)
+--   where
+--     (s0, c0) = full_adder (a0, b0, Low)
+--     (s1, c1) = full_adder (a1, b1, c0)
+--     (s2, c2) = full_adder (a2, b2, c1)
+--     (s3, c3) = full_adder (a3, b3, c2)
 
 -- Any number of bits adder
 -- Recursive version
 -- [a] -> [b] -> ([s], cout)
-rec_adder :: ([Bit], [Bit]) -> ([Bit], Bit)
-
-rec_adder ([], []) = ([], Low)
-rec_adder ((a:as), (b:bs)) = 
-  (s : rest, cout)
-  where
-    (rest, cin) = rec_adder (as, bs)
-    (s, cout) = full_adder (a, b, cin)
-
-foo = id
-add, sub :: Int -> Int -> Int
-add a b = a + b
-sub a b = a - b
-
-highordtest = \x ->
-  let s = foo x
-  in
-     case s of
-       (a, b) ->
-         case a of
-           High -> add
-           Low -> let
-             op' = case b of
-                High -> sub
-                Low -> \c d -> c
-             in
-                \c d -> op' d c
+-- rec_adder :: ([Bit], [Bit]) -> ([Bit], Bit)
+-- 
+-- rec_adder ([], []) = ([], Low)
+-- rec_adder ((a:as), (b:bs)) = 
+--   (s : rest, cout)
+--   where
+--     (rest, cin) = rec_adder (as, bs)
+--     (s, cout) = full_adder (a, b, cin)
+-- 
+-- foo = id
+-- add, sub :: Int -> Int -> Int
+-- add a b = a + b
+-- sub a b = a - b
+-- 
+-- highordtest = \x ->
+--   let s = foo x
+--   in
+--      case s of
+--        (a, b) ->
+--          case a of
+--            High -> add
+--            Low -> let
+--              op' = case b of
+--                 High -> sub
+--                 Low -> \c d -> c
+--              in
+--                 \c d -> op' d c
+
+functiontest :: TFVec D4 Bit -> Bit
+functiontest = \v -> let r = head v in r
 
 -- Four bit adder, using the continous adder below
 -- [a] -> [b] -> ([s], cout)
diff --git a/Main.hs b/Main.hs
index be48aa3..078f46f 100644
--- a/Main.hs
+++ b/Main.hs
@@ -3,4 +3,4 @@ module Main where
 import Translator
 
 main = do
-  makeVHDL "Adders.hs" "highordtest" True
\ No newline at end of file
+  makeVHDL "Adders.hs" "functiontest" True
\ No newline at end of file
diff --git a/VHDL.hs b/VHDL.hs
index d177a10..319b5b7 100644
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -246,19 +246,32 @@ mkConcSm ::
 
 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
   signatures <- getA vsSignatures
-  let 
-      (CoreSyn.Var f, args) = CoreSyn.collectArgs app
-      signature = Maybe.fromMaybe
-          (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!")
+  funSignatures <- getA vsNameTable
+  let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
+  case (Map.lookup (bndrToString f) funSignatures) of
+    Just funSignature ->
+      let
+        sigs = map (bndrToString.varBndr) args
+        sigsNames = map (\signal -> (AST.PrimName (AST.NSimple (mkVHDLExtId signal)))) sigs
+        func = (snd funSignature) sigsNames
+        src_wform = AST.Wform [AST.WformElem func Nothing]
+        dst_name = AST.NSimple (mkVHDLExtId (bndrToString bndr))
+        assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
+      in
+        return $ AST.CSSASm assign
+    Nothing ->
+      let  
+        signature = Maybe.fromMaybe 
+          (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!") 
           (Map.lookup (bndrToString f) signatures)
-      entity_id = ent_id signature
-      label = bndrToString bndr
+        entity_id = ent_id signature
+        label = bndrToString bndr
       -- Add a clk port if we have state
       --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
       --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
-      portmaps = mkAssocElems args bndr signature
-    in
-      return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
+        portmaps = mkAssocElems args bndr signature
+      in
+        return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
 
 -- GHC generates some funny "r = r" bindings in let statements before
 -- simplification. This outputs some dummy ConcSM for these, so things will at
-- 
2.30.2