From 72a84356f5507b73d4d5f84844aac9334ee17795 Mon Sep 17 00:00:00 2001
From: Matthijs Kooijman <m.kooijman@student.utwente.nl>
Date: Mon, 16 Feb 2009 16:50:35 +0100
Subject: [PATCH] Store a use for each signal in a flattened function.

This allows us to differentiate between ports, signals and states more
easily (which is already possible but not so easy right now) and allows
us to differentiate between own state and substate later on.

Currently, all signals are marked as SigInternal.
---
 Flatten.hs      | 13 +++++++------
 FlattenTypes.hs | 14 +++++++++++---
 Pretty.hs       | 13 +++++++++++--
 Translator.hs   |  2 +-
 4 files changed, 30 insertions(+), 12 deletions(-)

diff --git a/Flatten.hs b/Flatten.hs
index cd51585..f7ab86c 100644
--- a/Flatten.hs
+++ b/Flatten.hs
@@ -28,21 +28,22 @@ genSignals ::
   -> FlattenState (SignalMap UnnamedSignal)
 
 genSignals ty = do
-  typeMapToUseMap tymap
+  typeMapToUseMap SigInternal tymap
   where
     -- First generate a map with the right structure containing the types
     tymap = mkHsValueMap ty
 
 typeMapToUseMap ::
-  HsValueMap Type.Type
+  SigUse
+  -> HsValueMap Type.Type
   -> FlattenState (SignalMap UnnamedSignal)
 
-typeMapToUseMap (Single ty) = do
-  id <- genSignalId ty
+typeMapToUseMap use (Single ty) = do
+  id <- genSignalId use ty
   return $ Single id
 
-typeMapToUseMap (Tuple tymaps) = do
-  usemaps <- State.mapM typeMapToUseMap tymaps
+typeMapToUseMap use (Tuple tymaps) = do
+  usemaps <- State.mapM (typeMapToUseMap use) tymaps
   return $ Tuple usemaps
 
 -- | Flatten a haskell function
diff --git a/FlattenTypes.hs b/FlattenTypes.hs
index e77a8aa..5c95632 100644
--- a/FlattenTypes.hs
+++ b/FlattenTypes.hs
@@ -75,9 +75,17 @@ data CondDef sigid = CondDef {
   condRes :: sigid
 } deriving (Show, Eq)
 
+-- | How is a given signal used in the resulting VHDL?
+data SigUse = 
+  SigPort         -- | Use as a port
+  | SigInternal   -- | Use as an internal signal
+  | SigState      -- | Use as an internal state
+  | SigSubState   -- | Do not use, state variable is used in a subcircuit
+
 -- | Information on a signal definition
 data SignalInfo = SignalInfo {
   sigName :: Maybe String,
+  sigUse  :: SigUse,
   sigTy   :: Type.Type
 }
 
@@ -121,10 +129,10 @@ addCondDef c = do
   State.put (apps, c:conds, sigs, n)
 
 -- | Generates a new signal id, which is unique within the current flattening.
-genSignalId :: Type.Type -> FlattenState UnnamedSignal 
-genSignalId ty = do
+genSignalId :: SigUse -> Type.Type -> FlattenState UnnamedSignal 
+genSignalId use ty = do
   (apps, conds, sigs, n) <- State.get
   -- Generate a new numbered but unnamed signal
-  let s = (n, SignalInfo Nothing ty)
+  let s = (n, SignalInfo Nothing use ty)
   State.put (apps, conds, s:sigs, n+1)
   return n
diff --git a/Pretty.hs b/Pretty.hs
index 2bf57f7..6f5f63d 100644
--- a/Pretty.hs
+++ b/Pretty.hs
@@ -47,8 +47,17 @@ instance Pretty id => Pretty (CondDef id) where
   pPrint _ = text "TODO"
 
 instance Pretty SignalInfo where
-  pPrint (SignalInfo Nothing ty) = empty
-  pPrint (SignalInfo (Just name) ty) = text ":" <> text name
+  pPrint (SignalInfo name use ty) =
+    text ":" <> (pPrint use) <> (ppname name)
+    where
+      ppname Nothing = empty
+      ppname (Just name) = text ":" <> text name
+
+instance Pretty SigUse where
+  pPrint SigPort     = text "P"
+  pPrint SigInternal = text "I"
+  pPrint SigState    = text "S"
+  pPrint SigSubState = text "s"
 
 instance Pretty VHDLSession where
   pPrint (VHDLSession mod nameCount funcs) =
diff --git a/Translator.hs b/Translator.hs
index cccac4c..9ce7206 100644
--- a/Translator.hs
+++ b/Translator.hs
@@ -188,7 +188,7 @@ nameFlatFunction hsfunc fdata =
     -- Name the signals in all other functions
     Just flatfunc ->
       let s = flat_sigs flatfunc in
-      let s' = map (\(id, (SignalInfo Nothing ty)) -> (id, SignalInfo (Just $ "sig_" ++ (show id)) ty)) s in
+      let s' = map (\(id, (SignalInfo Nothing use ty)) -> (id, SignalInfo (Just $ "sig_" ++ (show id)) use ty)) s in
       let flatfunc' = flatfunc { flat_sigs = s' } in
       setFlatFunc hsfunc flatfunc'
 
-- 
2.30.2