Merge branch 'cλash' of http://git.stderr.nl/matthijs/projects/master-project

* 'cλash' of http://git.stderr.nl/matthijs/projects/master-project:
  Generate vector functions on demand.

Conflicts:
	Generate.hs
	GlobalNameTable.hs

diff --cc Generate.hs
index cc65979615bf67aa9a7b08e8164124e48434c909,de8c1a6604699320024636b3d5e32a5eab7c576d..cc3cb675b3a405fd7a10cb1d1d973c86195f3742
--- 1/Generate.hs
--- 2/Generate.hs
+++ b/Generate.hs
@@@ -60,51 -65,46 +65,74 @@@ genMapCall entity [arg, res] = return 
      compins     = mkComponentInst mapLabel entity_id portassigns
      -- Return the generate functions
      genSm       = AST.GenerateSm label genScheme [] [compins]
 +    
 +genZipWithCall ::
 +  Entity
 +  -> [CoreSyn.CoreBndr]
 +  -> VHDLSession AST.GenerateSm
 +genZipWithCall entity [arg1, arg2, res] = return $ genSm
 +  where
 +    -- Setup the generate scheme
 +    len         = (tfvec_len . Var.varType) res
 +    label       = mkVHDLExtId ("zipWithVector" ++ (varToString res))
 +    nPar        = AST.unsafeVHDLBasicId "n"
 +    range       = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
 +    genScheme   = AST.ForGn nPar range
 +    -- Get the entity name and port names
 +    entity_id   = ent_id entity
 +    argports    = map (Monad.liftM fst) (ent_args entity)
 +    resport     = (Monad.liftM fst) (ent_res entity)
 +    -- Assign the ports
 +    inport1     = mkAssocElemIndexed (argports!!0) (varToString arg1) nPar
 +    inport2     = mkAssocElemIndexed (argports!!1) (varToString arg2) nPar 
 +    outport     = mkAssocElemIndexed resport (varToString res) nPar
 +    clk_port    = mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
 +    portassigns = Maybe.catMaybes [inport1,inport2,outport,clk_port]
 +    -- Generate the portmap
 +    mapLabel    = "zipWith" ++ (AST.fromVHDLId entity_id)
 +    compins     = mkComponentInst mapLabel entity_id portassigns
 +    -- 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.SPCD 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])
++  , (emptyId, AST.SubProgBody emptySpec   [AST.SPCD emptyVar] [emptyExpr])
+   , (singletonId, AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet])
+   , (copyId, AST.SubProgBody copySpec    [AST.SPVD copyVar]      [copyExpr])
    ]
    where 
      ixPar   = AST.unsafeVHDLBasicId "ix"
@@@ -243,13 -243,16 +271,13 @@@
                     ((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
 -                (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
 -                 [AST.ToRange (AST.PrimLit "0")
 -                          (AST.PrimLit "-1")]))
 -              Nothing
 +          AST.ConstDec resId 
 +              (AST.SubtypeIn vectorTM Nothing)
 +              (Just $ AST.PrimLit "\"\"")
      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 = 

diff --cc GlobalNameTable.hs
index aa7462890e94b15885a2fb3588b87894a96ff98b,dda018c7fc1a41a7dcba431e6e7805f865d24965..feea40170e750e69ec32390abda99bbaa33ed68d
--- 1/GlobalNameTable.hs
--- 2/GlobalNameTable.hs
+++ b/GlobalNameTable.hs
@@@ -17,22 -17,21 +17,22 @@@ mkGlobalNameTable = Map.fromLis
  
  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                            ) )
-   , ("zipWith"        , (3, Right $ genZipWithCall                        ) )
-   , ("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                            ) )
++  , (zipWithId        , (3, Right $ genZipWithCall                        ) )
+   , (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                     ) )
    ]