X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;ds=sidebyside;f=Translator.hs;h=37ba81dccceced799119d95b046f48391c787feb;hb=72e072d592b1e5bf2efab36b132167e027d48173;hp=93eeacd30792761438d90d92e03b78c690bad0ef;hpb=f87607e43aff4cdf81c5d57f57687ea5f81dd89a;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git a/Translator.hs b/Translator.hs
index 93eeacd..37ba81d 100644
--- a/Translator.hs
+++ b/Translator.hs
@@ -57,16 +57,11 @@ main =
     mkVHDL binds = do
       -- Add the builtin functions
       mapM (uncurry addFunc) builtin_funcs
-      -- Get the function signatures
-      funcs <- mapM mkHWFunction binds
-      -- Add them to the session
-      mapM (uncurry addFunc) funcs
-      let entities = map getEntity (snd $ unzip funcs)
-      -- Create architectures for them
-      archs <- mapM getArchitecture binds
+      -- Create entities and architectures for them
+      units <- mapM expandBind binds
       return $ AST.DesignFile 
         []
-        ((map AST.LUEntity entities) ++ (map AST.LUArch archs))
+        (concat units)
 
 printTarget (Target (TargetFile file (Just x)) obj Nothing) =
   print $ show file
@@ -357,16 +352,34 @@ mapOutputPorts (Single (portname, _)) (Single (signalname, _)) =
 mapOutputPorts (Tuple ports) (Tuple signals) =
   concat (zipWith mapOutputPorts ports signals)
 
+expandBind ::
+  CoreBind                        -- The binder to expand into VHDL
+  -> VHDLState [AST.LibraryUnit]  -- The resulting VHDL
+
+expandBind (Rec _) = error "Recursive binders not supported"
+
+expandBind bind@(NonRec var expr) = do
+  -- Create the function signature
+  hwfunc <- mkHWFunction bind
+  let ty = CoreUtils.exprType expr
+  let hsfunc = mkHsFunction var ty
+  -- Add it to the session
+  addFunc hsfunc hwfunc 
+  arch <- getArchitecture hwfunc expr
+  let entity = getEntity hwfunc
+  return $ [
+    AST.LUEntity entity,
+    AST.LUArch arch ]
+
 getArchitecture ::
-  CoreBind                  -- The binder to expand into an architecture
+  HWFunction                -- The function to generate an architecture for
+  -> CoreExpr               -- The expression that is bound to the function
   -> VHDLState AST.ArchBody -- The resulting architecture
    
-getArchitecture (Rec _) = error "Recursive binders not supported"
-
-getArchitecture (NonRec var expr) = do
-  let name = (getOccString var)
-  HWFunction vhdl_id inports outport <- getHWFunc (HsFunction name [] (Tuple []))
-  sess <- State.get
+getArchitecture hwfunc expr = do
+  -- Unpack our hwfunc
+  let HWFunction vhdl_id inports outport = hwfunc
+  -- Expand the expression into an architecture body
   (signal_decls, statements, arg_signals, res_signal) <- expandExpr [] expr
   let inport_assigns = concat $ zipWith createSignalAssignments arg_signals inports
   let outport_assigns = createSignalAssignments outport res_signal
@@ -481,10 +494,10 @@ data HWFunction = HWFunction { -- A function that is available in hardware
 -- output ports.
 mkHWFunction ::
   CoreBind                                   -- The core binder to generate the interface for
-  -> VHDLState (HsFunction, HWFunction)          -- The name of the function and its interface
+  -> VHDLState HWFunction                    -- The function interface
 
 mkHWFunction (NonRec var expr) =
-    return (hsfunc, HWFunction (mkVHDLId name) inports outport)
+    return $ HWFunction (mkVHDLId name) inports outport
   where
     name = getOccString var
     ty = CoreUtils.exprType expr
@@ -496,7 +509,6 @@ mkHWFunction (NonRec var expr) =
       [port] -> [getPortNameMapForTy "portin" port]
       ps     -> getPortNameMapForTys "portin" 0 ps
     outport = getPortNameMapForTy "portout" res
-    hsfunc = HsFunction name [] (Tuple [])
 
 mkHWFunction (Rec _) =
   error "Recursive binders not supported"
@@ -531,6 +543,23 @@ appToHsFunction f args ty =
     hsres  = mkHsValueMap mkPort ty
     hsname = getOccString f
 
+-- | Translate a top level function declaration to a HsFunction. i.e., which
+--   interface will be provided by this function. This function essentially
+--   defines the "calling convention" for hardware models.
+mkHsFunction ::
+  Var.Var         -- ^ The function defined
+  -> Type         -- ^ The function type (including arguments!)
+  -> HsFunction   -- ^ The resulting HsFunction
+
+mkHsFunction f ty =
+  HsFunction hsname hsargs hsres
+  where
+    (arg_tys, res_ty) = Type.splitFunTys ty
+    mkPort = \x -> Single Port
+    hsargs = map (mkHsValueMap mkPort) arg_tys
+    hsres  = mkHsValueMap mkPort res_ty
+    hsname = getOccString f
+
 data VHDLSession = VHDLSession {
   nameCount :: Int,                       -- A counter that can be used to generate unique names
   funcs     :: [(HsFunction, HWFunction)] -- All functions available