Generate vector functions on demand.

Previously, vector functions were generated all at the same time when the
corresponding vector type was generated.

diff --git a/Constants.hs b/Constants.hs
index cf77025771f11cc7ce5730eb49192ec5a33f71bc..37eb0a79c60ee99e7e37257bc1d24e37c5e4939a 100644 (file)
--- a/Constants.hs
+++ b/Constants.hs
@@ -59,103 +59,124 @@ defaultId = AST.unsafeVHDLBasicId "default"
 -- FSVec function identifiers
 
 -- | ex (operator ! in original Haskell source) function identifier
-exId :: AST.VHDLId
-exId = AST.unsafeVHDLBasicId "ex"
+exId :: String
+exId = "!"
 
 -- | sel (function select in original Haskell source) function identifier
-selId :: AST.VHDLId
-selId = AST.unsafeVHDLBasicId "sel"
+selId :: String
+selId = "select"
 
 
 -- | ltplus (function (<+) in original Haskell source) function identifier
-ltplusId :: AST.VHDLId
-ltplusId = AST.unsafeVHDLBasicId "ltplus"
+ltplusId :: String
+ltplusId = "<+"
 
 
 -- | plusplus (function (++) in original Haskell source) function identifier
-plusplusId :: AST.VHDLId
-plusplusId = AST.unsafeVHDLBasicId "plusplus"
+plusplusId :: String
+plusplusId = "++"
 
 
 -- | empty function identifier
-emptyId :: AST.VHDLId
-emptyId = AST.unsafeVHDLBasicId "empty"
+emptyId :: String
+emptyId = "empty"
 
 -- | plusgt (function (+>) in original Haskell source) function identifier
-plusgtId :: AST.VHDLId
-plusgtId = AST.unsafeVHDLBasicId "plusgt"
+plusgtId :: String
+plusgtId = "+>"
 
 -- | singleton function identifier
-singletonId :: AST.VHDLId
-singletonId = AST.unsafeVHDLBasicId "singleton"
+singletonId :: String
+singletonId = "singleton"
 
 -- | length function identifier
-lengthId :: AST.VHDLId
-lengthId = AST.unsafeVHDLBasicId "length"
+lengthId :: String
+lengthId = "length"
 
 
 -- | isnull (function null in original Haskell source) function identifier
-isnullId :: AST.VHDLId
-isnullId = AST.unsafeVHDLBasicId "isnull"
+isnullId :: String
+isnullId = "isnull"
 
 
 -- | replace function identifier
-replaceId :: AST.VHDLId
-replaceId = AST.unsafeVHDLBasicId "replace"
+replaceId :: String
+replaceId = "replace"
 
 
 -- | head function identifier
-headId :: AST.VHDLId
-headId = AST.unsafeVHDLBasicId "head"
+headId :: String
+headId = "head"
 
 
 -- | last function identifier
-lastId :: AST.VHDLId
-lastId = AST.unsafeVHDLBasicId "last"
+lastId :: String
+lastId = "last"
 
 
 -- | init function identifier
-initId :: AST.VHDLId
-initId = AST.unsafeVHDLBasicId "init"
+initId :: String
+initId = "init"
 
 
 -- | tail function identifier
-tailId :: AST.VHDLId
-tailId = AST.unsafeVHDLBasicId "tail"
+tailId :: String
+tailId = "tail"
 
 
 -- | take function identifier
-takeId :: AST.VHDLId
-takeId = AST.unsafeVHDLBasicId "take"
+takeId :: String
+takeId = "take"
 
 
 -- | drop function identifier
-dropId :: AST.VHDLId
-dropId = AST.unsafeVHDLBasicId "drop"
+dropId :: String
+dropId = "drop"
 
 -- | shiftl function identifier
-shiftlId :: AST.VHDLId
-shiftlId = AST.unsafeVHDLBasicId "shiftl"
+shiftlId :: String
+shiftlId = "shiftl"
 
 -- | shiftr function identifier
-shiftrId :: AST.VHDLId
-shiftrId = AST.unsafeVHDLBasicId "shiftr"
+shiftrId :: String
+shiftrId = "shiftr"
 
 -- | rotl function identifier
-rotlId :: AST.VHDLId
-rotlId = AST.unsafeVHDLBasicId "rotl"
+rotlId :: String
+rotlId = "rotl"
 
 -- | reverse function identifier
-rotrId :: AST.VHDLId
-rotrId = AST.unsafeVHDLBasicId "rotr"
+rotrId :: String
+rotrId = "rotr"
 
 -- | reverse function identifier
-reverseId :: AST.VHDLId
-reverseId = AST.unsafeVHDLBasicId "reverse"
+reverseId :: String
+reverseId = "reverse"
 
 -- | copy function identifier
-copyId :: AST.VHDLId
-copyId = AST.unsafeVHDLBasicId "copy"
+copyId :: String
+copyId = "copy"
+
+-- | map function identifier
+mapId :: String
+mapId = "map"
+
+-- | hwxor function identifier
+hwxorId :: String
+hwxorId = "hwxor"
+
+-- | hwor function identifier
+hworId :: String
+hworId = "hwor"
+
+-- | hwnot function identifier
+hwnotId :: String
+hwnotId = "hwnot"
+
+-- | hwand function identifier
+hwandId :: String
+hwandId = "hwand"
+
 
 ------------------
 -- VHDL type marks

diff --git a/Generate.hs b/Generate.hs
index 75bea2462a5a91dc0976b7ab19e0631de6dc3381..de8c1a6604699320024636b3d5e32a5eab7c576d 100644 (file)
--- a/Generate.hs
+++ b/Generate.hs
@@ -2,13 +2,16 @@ module Generate where
 
 -- Standard modules
 import qualified Control.Monad as Monad
+import qualified Data.Map as Map
 import qualified Maybe
+import Data.Accessor
 
 -- ForSyDe
 import qualified ForSyDe.Backend.VHDL.AST as AST
 
 -- GHC API
 import CoreSyn
+import Type
 import qualified Var
 
 -- Local imports
@@ -19,18 +22,20 @@ import CoreTools
 
 -- | Generate a binary operator application. The first argument should be a
 -- constructor from the AST.Expr type, e.g. AST.And.
-genExprOp2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> [AST.Expr] -> VHDLSession AST.Expr
-genExprOp2 op [arg1, arg2] = return $ op arg1 arg2
+genExprOp2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
+genExprOp2 op res [arg1, arg2] = return $ op arg1 arg2
 
 -- | Generate a unary operator application
-genExprOp1 :: (AST.Expr -> AST.Expr) -> [AST.Expr] -> VHDLSession AST.Expr
-genExprOp1 op [arg] = return $ op arg
+genExprOp1 :: (AST.Expr -> AST.Expr) -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
+genExprOp1 op res [arg] = return $ op arg
 
--- | Generate a function call from the Function Name and a list of expressions
---   (its arguments)
-genExprFCall :: AST.VHDLId -> [AST.Expr] -> VHDLSession AST.Expr
-genExprFCall fName args = 
-   return $ AST.PrimFCall $ AST.FCall (AST.NSimple fName)  $
+-- | Generate a function call from the destination binder, function name and a
+-- list of expressions (its arguments)
+genExprFCall :: String -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
+genExprFCall fname res args = do
+  let el_ty = (tfvec_elem . Var.varType) res
+  id <- vectorFunId el_ty fname
+  return $ AST.PrimFCall $ AST.FCall (AST.NSimple id)  $
              map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
 
 -- | Generate a generate statement for the builtin function "map"
@@ -61,22 +66,45 @@ genMapCall entity [arg, res] = return $ genSm
     -- Return the generate functions
     genSm       = AST.GenerateSm label genScheme [] [compins]
 
+-- Returns the VHDLId of the vector function with the given name for the given
+-- element type. Generates -- this function if needed.
+vectorFunId :: Type.Type -> String -> VHDLSession AST.VHDLId
+vectorFunId el_ty fname = do
+  elemTM <- vhdl_ty el_ty
+  -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
+  -- the VHDLState or something.
+  let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
+  typefuns <- getA vsTypeFuns
+  case Map.lookup (OrdType el_ty, fname) typefuns of
+    -- Function already generated, just return it
+    Just (id, _) -> return id
+    -- Function not generated yet, generate it
+    Nothing -> do
+      let functions = genUnconsVectorFuns elemTM vectorTM
+      case lookup fname functions of
+        Just body -> do
+          modA vsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, body)
+          return function_id
+        Nothing -> error $ "I don't know how to generate vector function " ++ fname
+  where
+    function_id = mkVHDLExtId fname
+
 genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
                     -> AST.TypeMark -- ^ type of the vector
-                    -> [AST.SubProgBody]
+                    -> [(String, AST.SubProgBody)]
 genUnconsVectorFuns elemTM vectorTM  = 
-  [ AST.SubProgBody exSpec      []                  [exExpr]                    
-  , AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet]   
-  , AST.SubProgBody headSpec    []                  [headExpr]                  
-  , AST.SubProgBody lastSpec    []                  [lastExpr]                  
-  , AST.SubProgBody initSpec    [AST.SPVD initVar]  [initExpr, initRet]         
-  , AST.SubProgBody tailSpec    [AST.SPVD tailVar]  [tailExpr, tailRet]         
-  , AST.SubProgBody takeSpec    [AST.SPVD takeVar]  [takeExpr, takeRet]         
-  , AST.SubProgBody dropSpec    [AST.SPVD dropVar]  [dropExpr, dropRet]    
-  , AST.SubProgBody plusgtSpec  [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet]
-  , AST.SubProgBody emptySpec   [AST.SPVD emptyVar] [emptyExpr]
-  , AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet] 
-  , AST.SubProgBody copySpec    [AST.SPVD copyVar]      [copyExpr]
+  [ (exId, AST.SubProgBody exSpec      []                  [exExpr])
+  , (replaceId, AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet])
+  , (headId, AST.SubProgBody headSpec    []                  [headExpr])
+  , (lastId, AST.SubProgBody lastSpec    []                  [lastExpr])
+  , (initId, AST.SubProgBody initSpec    [AST.SPVD initVar]  [initExpr, initRet])
+  , (tailId, AST.SubProgBody tailSpec    [AST.SPVD tailVar]  [tailExpr, tailRet])
+  , (takeId, AST.SubProgBody takeSpec    [AST.SPVD takeVar]  [takeExpr, takeRet])
+  , (dropId, AST.SubProgBody dropSpec    [AST.SPVD dropVar]  [dropExpr, dropRet])
+  , (plusgtId, AST.SubProgBody plusgtSpec  [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet])
+  , (emptyId, AST.SubProgBody emptySpec   [AST.SPVD emptyVar] [emptyExpr])
+  , (singletonId, AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet])
+  , (copyId, AST.SubProgBody copySpec    [AST.SPVD copyVar]      [copyExpr])
   ]
   where 
     ixPar   = AST.unsafeVHDLBasicId "ix"
@@ -86,12 +114,12 @@ genUnconsVectorFuns elemTM vectorTM  =
     iPar    = iId
     aPar    = AST.unsafeVHDLBasicId "a"
     resId   = AST.unsafeVHDLBasicId "res"
-    exSpec = AST.Function exId [AST.IfaceVarDec vecPar vectorTM,
+    exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
                                AST.IfaceVarDec ixPar  naturalTM] elemTM
     exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed 
               (AST.IndexedName (AST.NSimple vecPar) [AST.PrimName $ 
                 AST.NSimple ixPar]))
-    replaceSpec = AST.Function replaceId  [ AST.IfaceVarDec vecPar vectorTM
+    replaceSpec = AST.Function (mkVHDLExtId replaceId)  [ AST.IfaceVarDec vecPar vectorTM
                                           , AST.IfaceVarDec iPar   naturalTM
                                           , AST.IfaceVarDec aPar   elemTM
                                           ] vectorTM 
@@ -102,7 +130,7 @@ genUnconsVectorFuns elemTM vectorTM  =
                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
                    [AST.ToRange (AST.PrimLit "0")
                             (AST.PrimName (AST.NAttribute $ 
-                              AST.AttribName (AST.NSimple vecPar) lengthId Nothing) AST.:-:
+                              AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing) AST.:-:
                                 (AST.PrimLit "1"))   ]))
                 Nothing
        --  res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
@@ -111,25 +139,25 @@ genUnconsVectorFuns elemTM vectorTM  =
             AST.PrimName (AST.NSimple aPar) AST.:&: 
              vecSlice (AST.PrimName (AST.NSimple iPar) AST.:+: AST.PrimLit "1")
                       ((AST.PrimName (AST.NAttribute $ 
-                                AST.AttribName (AST.NSimple vecPar) lengthId Nothing)) 
+                                AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing)) 
                                                               AST.:-: AST.PrimLit "1"))
     replaceRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
     vecSlice init last =  AST.PrimName (AST.NSlice 
                                         (AST.SliceName 
                                               (AST.NSimple vecPar) 
                                               (AST.ToRange init last)))
-    headSpec = AST.Function headId [AST.IfaceVarDec vecPar vectorTM] elemTM
+    headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
        -- return vec(0);
     headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName 
                     (AST.NSimple vecPar) [AST.PrimLit "0"])))
-    lastSpec = AST.Function lastId [AST.IfaceVarDec vecPar vectorTM] elemTM
+    lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
        -- return vec(vec'length-1);
     lastExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName 
                     (AST.NSimple vecPar) 
                     [AST.PrimName (AST.NAttribute $ 
-                                AST.AttribName (AST.NSimple vecPar) lengthId Nothing) 
+                                AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing) 
                                                              AST.:-: AST.PrimLit "1"])))
-    initSpec = AST.Function initId [AST.IfaceVarDec vecPar vectorTM] vectorTM 
+    initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM 
        -- variable res : fsvec_x (0 to vec'length-2);
     initVar = 
          AST.VarDec resId 
@@ -137,17 +165,17 @@ genUnconsVectorFuns elemTM vectorTM  =
                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
                    [AST.ToRange (AST.PrimLit "0")
                             (AST.PrimName (AST.NAttribute $ 
-                              AST.AttribName (AST.NSimple vecPar) lengthId Nothing) AST.:-:
+                              AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing) AST.:-:
                                 (AST.PrimLit "2"))   ]))
                 Nothing
        -- resAST.:= vec(0 to vec'length-2)
     initExpr = AST.NSimple resId AST.:= (vecSlice 
                                (AST.PrimLit "0") 
                                (AST.PrimName (AST.NAttribute $ 
-                                  AST.AttribName (AST.NSimple vecPar) lengthId Nothing) 
+                                  AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing) 
                                                              AST.:-: AST.PrimLit "2"))
     initRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
-    tailSpec = AST.Function tailId [AST.IfaceVarDec vecPar vectorTM] vectorTM
+    tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
        -- variable res : fsvec_x (0 to vec'length-2); 
     tailVar = 
          AST.VarDec resId 
@@ -155,17 +183,17 @@ genUnconsVectorFuns elemTM vectorTM  =
                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
                    [AST.ToRange (AST.PrimLit "0")
                             (AST.PrimName (AST.NAttribute $ 
-                              AST.AttribName (AST.NSimple vecPar) lengthId Nothing) AST.:-:
+                              AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing) AST.:-:
                                 (AST.PrimLit "2"))   ]))
                 Nothing       
        -- res AST.:= vec(1 to vec'length-1)
     tailExpr = AST.NSimple resId AST.:= (vecSlice 
                                (AST.PrimLit "1") 
                                (AST.PrimName (AST.NAttribute $ 
-                                  AST.AttribName (AST.NSimple vecPar) lengthId Nothing) 
+                                  AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing) 
                                                              AST.:-: AST.PrimLit "1"))
     tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
-    takeSpec = AST.Function takeId [AST.IfaceVarDec nPar   naturalTM,
+    takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar   naturalTM,
                                    AST.IfaceVarDec vecPar vectorTM ] vectorTM
        -- variable res : fsvec_x (0 to n-1);
     takeVar = 
@@ -181,7 +209,7 @@ genUnconsVectorFuns elemTM vectorTM  =
                     (vecSlice (AST.PrimLit "1") 
                               (AST.PrimName (AST.NSimple $ nPar) AST.:-: AST.PrimLit "1"))
     takeRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
-    dropSpec = AST.Function dropId [AST.IfaceVarDec nPar   naturalTM,
+    dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar   naturalTM,
                                    AST.IfaceVarDec vecPar vectorTM ] vectorTM 
        -- variable res : fsvec_x (0 to vec'length-n-1);
     dropVar = 
@@ -190,17 +218,17 @@ genUnconsVectorFuns elemTM vectorTM  =
                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
                    [AST.ToRange (AST.PrimLit "0")
                             (AST.PrimName (AST.NAttribute $ 
-                              AST.AttribName (AST.NSimple vecPar) lengthId Nothing) AST.:-:
+                              AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing) AST.:-:
                                (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
                Nothing
        -- res AST.:= vec(n to vec'length-1)
     dropExpr = AST.NSimple resId AST.:= (vecSlice 
                                (AST.PrimName $ AST.NSimple nPar) 
                                (AST.PrimName (AST.NAttribute $ 
-                                  AST.AttribName (AST.NSimple vecPar) lengthId Nothing) 
+                                  AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing) 
                                                              AST.:-: AST.PrimLit "1"))
     dropRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
-    plusgtSpec = AST.Function plusgtId [AST.IfaceVarDec aPar   elemTM,
+    plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar   elemTM,
                                        AST.IfaceVarDec vecPar vectorTM] vectorTM 
     -- variable res : fsvec_x (0 to vec'length);
     plusgtVar = 
@@ -209,13 +237,13 @@ genUnconsVectorFuns elemTM vectorTM  =
                (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
                 [AST.ToRange (AST.PrimLit "0")
                         (AST.PrimName (AST.NAttribute $ 
-                          AST.AttribName (AST.NSimple vecPar) lengthId Nothing))]))
+                          AST.AttribName (AST.NSimple vecPar) (mkVHDLExtId lengthId) Nothing))]))
              Nothing
     plusgtExpr = AST.NSimple resId AST.:= 
                    ((AST.PrimName $ AST.NSimple aPar) AST.:&: 
                     (AST.PrimName $ AST.NSimple vecPar))
     plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
-    emptySpec = AST.Function emptyId [] vectorTM
+    emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
     emptyVar = 
           AST.VarDec resId 
               (AST.SubtypeIn vectorTM
@@ -224,7 +252,7 @@ genUnconsVectorFuns elemTM vectorTM  =
                           (AST.PrimLit "-1")]))
               Nothing
     emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
-    singletonSpec = AST.Function singletonId [AST.IfaceVarDec aPar elemTM ] 
+    singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ] 
                                          vectorTM
     -- variable res : fsvec_x (0 to 0) := (others => a);
     singletonVar = 
@@ -235,7 +263,7 @@ genUnconsVectorFuns elemTM vectorTM  =
              (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others) 
                                           (AST.PrimName $ AST.NSimple aPar)])
     singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
-    copySpec = AST.Function copyId [AST.IfaceVarDec nPar   naturalTM,
+    copySpec = AST.Function (mkVHDLExtId copyId) [AST.IfaceVarDec nPar   naturalTM,
                                    AST.IfaceVarDec aPar   elemTM   ] vectorTM 
     -- variable res : fsvec_x (0 to n-1) := (others => a);
     copyVar = 

diff --git a/GlobalNameTable.hs b/GlobalNameTable.hs
index 45eed895d89970629dd15c8bf0f8a4a58cecf6ff..dda018c7fc1a41a7dcba431e6e7805f865d24965 100644 (file)
--- a/GlobalNameTable.hs
+++ b/GlobalNameTable.hs
@@ -17,21 +17,21 @@ mkGlobalNameTable = Map.fromList
 
 globalNameTable :: NameTable
 globalNameTable = mkGlobalNameTable
-  [ ("!"              , (2, Left $ genExprFCall exId                      ) )
-  , ("replace"        , (3, Left $ genExprFCall replaceId                 ) )
-  , ("head"           , (1, Left $ genExprFCall headId                    ) )
-  , ("last"           , (1, Left $ genExprFCall lastId                    ) )
-  , ("tail"           , (1, Left $ genExprFCall tailId                    ) )
-  , ("init"           , (1, Left $ genExprFCall initId                    ) )
-  , ("take"           , (2, Left $ genExprFCall takeId                    ) )
-  , ("drop"           , (2, Left $ genExprFCall dropId                    ) )
-  , ("+>"             , (2, Left $ genExprFCall plusgtId                  ) )
-  , ("map"            , (2, Right $ genMapCall                            ) )
-  , ("empty"          , (0, Left $ genExprFCall emptyId                   ) )
-  , ("singleton"      , (1, Left $ genExprFCall singletonId               ) )
-  , ("copy"           , (2, Left $ genExprFCall copyId                    ) )
-  , ("hwxor"          , (2, Left $ genExprOp2 AST.Xor                     ) )
-  , ("hwand"          , (2, Left $ genExprOp2 AST.And                     ) )
-  , ("hwor"           , (2, Left $ genExprOp2 AST.Or                      ) )
-  , ("hwnot"          , (1, Left $ genExprOp1 AST.Not                     ) )
+  [ (exId             , (2, Left $ genExprFCall exId                      ) )
+  , (replaceId        , (3, Left $ genExprFCall replaceId                 ) )
+  , (headId           , (1, Left $ genExprFCall headId                    ) )
+  , (lastId           , (1, Left $ genExprFCall lastId                    ) )
+  , (tailId           , (1, Left $ genExprFCall tailId                    ) )
+  , (initId           , (1, Left $ genExprFCall initId                    ) )
+  , (takeId           , (2, Left $ genExprFCall takeId                    ) )
+  , (dropId           , (2, Left $ genExprFCall dropId                    ) )
+  , (plusgtId         , (2, Left $ genExprFCall plusgtId                  ) )
+  , (mapId            , (2, Right $ genMapCall                            ) )
+  , (emptyId          , (0, Left $ genExprFCall emptyId                   ) )
+  , (singletonId      , (1, Left $ genExprFCall singletonId               ) )
+  , (copyId           , (2, Left $ genExprFCall copyId                    ) )
+  , (hwxorId          , (2, Left $ genExprOp2 AST.Xor                     ) )
+  , (hwandId          , (2, Left $ genExprOp2 AST.And                     ) )
+  , (hworId           , (2, Left $ genExprOp2 AST.Or                      ) )
+  , (hwnotId          , (1, Left $ genExprOp1 AST.Not                     ) )
   ]

diff --git a/VHDL.hs b/VHDL.hs
index f9367ef66da93f5a7217a7701d8fe40d1b296dee..76cb62f827d87c24faa2e48df4af4f7527566499 100644 (file)
--- a/VHDL.hs
+++ b/VHDL.hs
@@ -50,7 +50,7 @@ createDesignFiles binds =
     init_session = VHDLState Map.empty Map.empty Map.empty Map.empty
     (units, final_session) = 
       State.runState (createLibraryUnits binds) init_session
-    tyfun_decls = Map.elems (final_session ^.vsTypeFuns)
+    tyfun_decls = map snd $ Map.elems (final_session ^.vsTypeFuns)
     ty_decls = map mktydecl $ Map.elems (final_session ^. vsTypes)
     vec_decls = map (\(v_id, v_def) -> AST.PDITD $ AST.TypeDec v_id v_def) (Map.elems (final_session ^. vsElemTypes))
     tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def
@@ -66,9 +66,9 @@ createDesignFiles binds =
       : (mkUseAll ["work"]
       : ieee_context)
     type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ vec_decls ++ ty_decls ++ subProgSpecs)
-    type_package_body = AST.LUPackageBody $ AST.PackageBody typesId (concat tyfun_decls)
-    subProgSpecs = concat (map subProgSpec tyfun_decls)
-    subProgSpec = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec)
+    type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls
+    subProgSpecs = map subProgSpec tyfun_decls
+    subProgSpec = \(AST.SubProgBody spec _ _) -> AST.PDISS spec
     mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
     mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
     mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
@@ -301,7 +301,7 @@ mkConcSm (bndr, app@(CoreSyn.App _ _))= do
             case builder of
               Left funBuilder -> do
                 let sigs = map (varToVHDLExpr.exprToVar) valargs
-                func <- funBuilder sigs
+                func <- funBuilder bndr sigs
                 let src_wform = AST.Wform [AST.WformElem func Nothing]
                 let dst_name = AST.NSimple (mkVHDLExtId (varToString bndr))
                 let assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)

diff --git a/VHDLTypes.hs b/VHDLTypes.hs
index 3a8bce12f88e4fef661449443dd72a4d0c05e20a..d23daea033d77b38710b5fe6c09fcbfaae2be62f 100644 (file)
--- a/VHDLTypes.hs
+++ b/VHDLTypes.hs
@@ -48,8 +48,9 @@ type TypeMap = Map.Map OrdType (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn)
 -- A map of Elem types to the corresponding VHDL Id for the Vector
 type ElemTypeMap = Map.Map OrdType (AST.VHDLId, AST.TypeDef)
 
--- A map of a vector Core type to the coressponding VHDL functions
-type TypeFunMap = Map.Map OrdType [AST.SubProgBody]
+-- A map of a vector Core element type and function name to the coressponding
+-- VHDLId of the function and the function body.
+type TypeFunMap = Map.Map (OrdType, String) (AST.VHDLId, AST.SubProgBody)
 
 -- A map of a Haskell function to a hardware signature
 type SignatureMap = Map.Map CoreSyn.CoreBndr Entity
@@ -75,7 +76,7 @@ type VHDLSession = State.State VHDLState
 -- | A substate containing just the types
 type TypeState = State.State TypeMap
 
-type Builder = Either ([AST.Expr] -> VHDLSession AST.Expr) (Entity -> [CoreSyn.CoreBndr] -> VHDLSession AST.GenerateSm)
+type Builder = Either (CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr) (Entity -> [CoreSyn.CoreBndr] -> VHDLSession AST.GenerateSm)
 
 -- A map of a builtin function to VHDL function builder 
 type NameTable = Map.Map String (Int, Builder )