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

* 'cλash' of http://git.stderr.nl/matthijs/projects/master-project:
  Unify all BuiltinBuilder functions.
  Give HighOrdAlu an and operation.
  Let tfvec_len and tfvec_elem give a proper error message.
  No longer use a view pattern in HsTools.

Conflicts:
	Generate.hs

diff --combined Generate.hs
index 17c3d494e6f74aae3dbc8b491fa98a37287eec65,7de216129dfbed6cf4d55fb4e415d00fbc746c19..7b8dcf0894fb0ca41296f08addd659d07868b651
--- 1/Generate.hs
--- 2/Generate.hs
+++ b/Generate.hs
@@@ -5,6 -5,7 +5,7 @@@ import qualified Control.Monad as Mona
  import qualified Data.Map as Map
  import qualified Maybe
  import Data.Accessor
+ import Debug.Trace
  
  -- ForSyDe
  import qualified ForSyDe.Backend.VHDL.AST as AST
@@@ -19,32 -20,67 +20,67 @@@ import Constant
  import VHDLTypes
  import VHDLTools
  import CoreTools
+ import Pretty
+ 
+ -- | A function to wrap a builder-like function that expects its arguments to
+ -- be expressions.
+ genExprArgs ::
+   (dst -> func -> [AST.Expr] -> res)
+   -> (dst -> func -> [CoreSyn.CoreExpr] -> res)
+ genExprArgs wrap dst func args = wrap dst func args'
+   where args' = map (varToVHDLExpr.exprToVar) args
+   
+ -- | A function to wrap a builder-like function that expects its arguments to
+ -- be variables.
+ genVarArgs ::
+   (dst -> func -> [Var.Var] -> res)
+   -> (dst -> func -> [CoreSyn.CoreExpr] -> res)
+ genVarArgs wrap dst func args = wrap dst func args'
+   where args' = map exprToVar args
+ 
+ -- | A function to wrap a builder-like function that produces an expression
+ -- and expects it to be assigned to the destination.
+ genExprRes ::
+   (CoreSyn.CoreBndr -> func -> [arg] -> VHDLSession AST.Expr)
+   -> (CoreSyn.CoreBndr -> func -> [arg] -> VHDLSession [AST.ConcSm])
+ genExprRes wrap dst func args = do
+   expr <- wrap dst func args
+   return $ [mkUncondAssign (Left dst) expr]
  
  -- | 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) -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
- genExprOp2 op res [arg1, arg2] = return $ op arg1 arg2
+ genOperator2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder 
+ genOperator2 op = genExprArgs $ genExprRes (genOperator2' op)
+ genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> CoreSyn.CoreBndr -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
+ genOperator2' op res f [arg1, arg2] = return $ op arg1 arg2
  
  -- | Generate a unary operator application
- genExprOp1 :: (AST.Expr -> AST.Expr) -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
- genExprOp1 op res [arg] = return $ op arg
+ genOperator1 :: (AST.Expr -> AST.Expr) -> BuiltinBuilder 
+ genOperator1 op = genExprArgs $ genExprRes (genOperator1' op)
+ genOperator1' :: (AST.Expr -> AST.Expr) -> CoreSyn.CoreBndr -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
+ genOperator1' op res f [arg] = return $ op arg
  
  -- | 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
+ genFCall :: BuiltinBuilder 
+ genFCall = genExprArgs $ genExprRes genFCall'
+ genFCall' :: CoreSyn.CoreBndr -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
+ genFCall' res f args = do
+   let fname = varToString f
    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"
- genMapCall :: 
-   Entity -- | The entity to map
-   -> [CoreSyn.CoreBndr] -- | The vectors
-   -> VHDLSession AST.ConcSm -- | The resulting generate statement
- genMapCall entity [arg, res] = return $ genSm
-   where
+ genMap :: BuiltinBuilder
+ genMap = genVarArgs genMap'
+ genMap' res f [mapped_f, arg] = do
+   signatures <- getA vsSignatures
+   let entity = Maybe.fromMaybe
+         (error $ "Using function '" ++ (varToString mapped_f) ++ "' without signature? This should not happen!") 
+         (Map.lookup mapped_f signatures)
+   let
      -- Setup the generate scheme
      len         = (tfvec_len . Var.varType) res
      label       = mkVHDLExtId ("mapVector" ++ (varToString res))
@@@ -56,21 -92,26 +92,25 @@@
      argports   = map (Monad.liftM fst) (ent_args entity)
      resport     = (Monad.liftM fst) (ent_res entity)
      -- Assign the ports
 -    inport      = mkAssocElemIndexed (argports!!0) (varToString arg) nPar
 -    outport     = mkAssocElemIndexed resport (varToString res) nPar
 -    clk_port    = mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
 -    portassigns = Maybe.catMaybes [inport,outport,clk_port]
 +    inport      = mkAssocElemIndexed (argports!!0) (varToVHDLId arg) nPar
 +    outport     = mkAssocElemIndexed resport (varToVHDLId res) nPar
 +    portassigns = Maybe.catMaybes [inport,outport]
      -- Generate the portmap
      mapLabel    = "map" ++ (AST.fromVHDLId entity_id)
      compins     = mkComponentInst mapLabel entity_id portassigns
      -- Return the generate functions
      genSm       = AST.CSGSm $ AST.GenerateSm label genScheme [] [compins]
+     in
+       return $ [genSm]
      
- genZipWithCall ::
-   Entity
-   -> [CoreSyn.CoreBndr]
-   -> VHDLSession AST.ConcSm
- genZipWithCall entity [arg1, arg2, res] = return $ genSm
-   where
+ genZipWith :: BuiltinBuilder
+ genZipWith = genVarArgs genZipWith'
+ genZipWith' res f args@[zipped_f, arg1, arg2] = do
+   signatures <- getA vsSignatures
+   let entity = Maybe.fromMaybe
+         (error $ "Using function '" ++ (varToString zipped_f) ++ "' without signature? This should not happen!") 
+         (Map.lookup zipped_f signatures)
+   let
      -- Setup the generate scheme
      len         = (tfvec_len . Var.varType) res
      label       = mkVHDLExtId ("zipWithVector" ++ (varToString res))
@@@ -82,21 -123,26 +122,25 @@@
      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]
 +    inport1     = mkAssocElemIndexed (argports!!0) (varToVHDLId arg1) nPar
 +    inport2     = mkAssocElemIndexed (argports!!1) (varToVHDLId arg2) nPar 
 +    outport     = mkAssocElemIndexed resport (varToVHDLId res) nPar
 +    portassigns = Maybe.catMaybes [inport1,inport2,outport]
      -- Generate the portmap
      mapLabel    = "zipWith" ++ (AST.fromVHDLId entity_id)
      compins     = mkComponentInst mapLabel entity_id portassigns
      -- Return the generate functions
      genSm       = AST.CSGSm $ AST.GenerateSm label genScheme [] [compins]
+     in
+       return $ [genSm]
  
- genFoldlCall ::
-   Entity
-   -> [CoreSyn.CoreBndr]
-   -> VHDLSession AST.ConcSm
- genFoldlCall entity [startVal, inVec, resVal] = do
+ genFoldl :: BuiltinBuilder
+ genFoldl = genVarArgs genFoldl'
+ genFoldl' resVal f [folded_f, startVal, inVec] = do
+   signatures <- getA vsSignatures
+   let entity = Maybe.fromMaybe
+         (error $ "Using function '" ++ (varToString folded_f) ++ "' without signature? This should not happen!") 
+         (Map.lookup folded_f signatures)
    let (vec, _) = splitAppTy (Var.varType inVec)
    let vecty = Type.mkAppTy vec (Var.varType startVal)
    vecType <- vhdl_ty vecty
@@@ -104,77 -150,85 +148,77 @@@
    let  len         = (tfvec_len . Var.varType) inVec
    let  genlabel       = mkVHDLExtId ("foldlVector" ++ (varToString inVec))
    let  blockLabel  = mkVHDLExtId ("foldlVector" ++ (varToString startVal))
 -  let  nPar        = AST.unsafeVHDLBasicId "n"
    let  range       = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
 -  let  genScheme   = AST.ForGn nPar range
 +  let  genScheme   = AST.ForGn (AST.unsafeVHDLBasicId "n") range
    -- Make the intermediate vector
    let  tmpVec      = AST.BDISD $ AST.SigDec (mkVHDLExtId "tmp") vecType Nothing
 -    -- Return the generate functions
 -  let genSm       = AST.GenerateSm genlabel genScheme []  [ AST.CSGSm (genFirstCell entity [startVal, inVec, resVal])
 -                                                          , AST.CSGSm (genOtherCell entity [startVal, inVec, resVal])
 -                                                          , AST.CSGSm (genLastCell entity [startVal, inVec, resVal])
 -                                                          ]
 -  return [AST.CSBSm $ AST.BlockSm blockLabel [] (AST.PMapAspect []) [tmpVec] [AST.CSGSm genSm]]
 +  -- Get the entity name and port names
 +  let entity_id   = ent_id entity
 +  let argports    = map (Monad.liftM fst) (ent_args entity)
 +  let resport     = (Monad.liftM fst) (ent_res entity)
-     -- Return the generate functions
++  -- Return the generate functions
 +  let genSm       = AST.GenerateSm genlabel genScheme [] 
 +                      [ AST.CSGSm (genFirstCell (entity_id, argports, resport) 
 +                                    [startVal, inVec, resVal])
 +                      , AST.CSGSm (genOtherCell (entity_id, argports, resport) 
 +                                    [startVal, inVec, resVal])
 +                      , AST.CSGSm (genLastCell (entity_id, argports, resport) 
 +                                    [startVal, inVec, resVal])
 +                      ]
-   return $ AST.CSBSm $ AST.BlockSm blockLabel [] (AST.PMapAspect []) [tmpVec] [AST.CSGSm genSm]
++  return $ [AST.CSBSm $ AST.BlockSm blockLabel [] (AST.PMapAspect []) [tmpVec] [AST.CSGSm genSm]]
    where
 -    genFirstCell :: Entity -> [CoreSyn.CoreBndr] -> AST.GenerateSm 
 -    genFirstCell entity [startVal, inVec, resVal] = cellGn
 +    genFirstCell (entity_id, argports, resport) [startVal, inVec, resVal] = cellGn
        where
          cellLabel    = mkVHDLExtId "firstcell"
          cellGenScheme = AST.IfGn ((AST.PrimName $ AST.NSimple nPar)  AST.:=: (AST.PrimLit "0"))
 +        tmpId       = mkVHDLExtId "tmp"
          nPar        = AST.unsafeVHDLBasicId "n"
 -        -- 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     = mkAssocElem (argports!!0) (varToString startVal)
 -        inport2     = mkAssocElemIndexed (argports!!1) (varToString inVec) nPar 
 -        outport     = mkAssocElemIndexed resport "tmp" nPar
 -        clk_port    = mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
 -        portassigns = Maybe.catMaybes [inport1,inport2,outport,clk_port]
 +        inport2     = mkAssocElemIndexed (argports!!1) (varToVHDLId inVec) nPar 
 +        outport     = mkAssocElemIndexed resport tmpId nPar
 +        portassigns = Maybe.catMaybes [inport1,inport2,outport]
          -- Generate the portmap
          mapLabel    = "cell" ++ (AST.fromVHDLId entity_id)
          compins     = mkComponentInst mapLabel entity_id portassigns
          -- Return the generate functions
          cellGn       = AST.GenerateSm cellLabel cellGenScheme [] [compins]
 -    genOtherCell :: Entity -> [CoreSyn.CoreBndr] -> AST.GenerateSm
 -    genOtherCell entity [startVal, inVec, resVal] = cellGn
 +    genOtherCell (entity_id, argports, resport) [startVal, inVec, resVal] = cellGn
        where
          len         = (tfvec_len . Var.varType) inVec
          cellLabel    = mkVHDLExtId "othercell"
          cellGenScheme = AST.IfGn $ AST.And ((AST.PrimName $ AST.NSimple nPar)  AST.:>: (AST.PrimLit "0"))
                                  ((AST.PrimName $ AST.NSimple nPar)  AST.:<: (AST.PrimLit $ show (len-1)))
 +        tmpId       = mkVHDLExtId "tmp"
          nPar        = AST.unsafeVHDLBasicId "n"
 -        -- 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) "tmp" (AST.unsafeVHDLBasicId "n-1")
 -        inport2     = mkAssocElemIndexed (argports!!1) (varToString inVec) nPar 
 -        outport     = mkAssocElemIndexed resport "tmp" nPar
 -        clk_port    = mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
 -        portassigns = Maybe.catMaybes [inport1,inport2,outport,clk_port]
 +        inport1     = mkAssocElemIndexed (argports!!0) tmpId (AST.unsafeVHDLBasicId "n-1")
 +        inport2     = mkAssocElemIndexed (argports!!1) (varToVHDLId inVec) nPar 
 +        outport     = mkAssocElemIndexed resport tmpId nPar
 +        portassigns = Maybe.catMaybes [inport1,inport2,outport]
          -- Generate the portmap
          mapLabel    = "cell" ++ (AST.fromVHDLId entity_id)
          compins     = mkComponentInst mapLabel entity_id portassigns
          -- Return the generate functions
          cellGn      = AST.GenerateSm cellLabel cellGenScheme [] [compins]
 -    genLastCell :: Entity -> [CoreSyn.CoreBndr] -> AST.GenerateSm
 -    genLastCell entity [startVal, inVec, resVal] = cellGn
 +    genLastCell (entity_id, argports, resport) [startVal, inVec, resVal] = cellGn
        where
          len         = (tfvec_len . Var.varType) inVec
          cellLabel    = mkVHDLExtId "lastCell"
          cellGenScheme = AST.IfGn ((AST.PrimName $ AST.NSimple nPar)  AST.:=: (AST.PrimLit $ show (len-1)))
 +        tmpId       = mkVHDLExtId "tmp"
          nPar        = AST.unsafeVHDLBasicId "n"
 -        -- 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) "tmp" (AST.unsafeVHDLBasicId "n-1")
 -        inport2     = mkAssocElemIndexed (argports!!1) (varToString inVec) nPar 
 -        outport     = mkAssocElemIndexed resport "tmp" nPar
 -        clk_port    = mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
 -        portassigns = Maybe.catMaybes [inport1,inport2,outport,clk_port]
 +        inport1     = mkAssocElemIndexed (argports!!0) tmpId (AST.unsafeVHDLBasicId "n-1")
 +        inport2     = mkAssocElemIndexed (argports!!1) (varToVHDLId inVec) nPar 
 +        outport     = mkAssocElemIndexed resport tmpId nPar
 +        portassigns = Maybe.catMaybes [inport1,inport2,outport]
          -- Generate the portmap
          mapLabel    = "cell" ++ (AST.fromVHDLId entity_id)
          compins     = mkComponentInst mapLabel entity_id portassigns
          -- Generate the output assignment
          assign      = mkUncondAssign (Left resVal) (AST.PrimName (AST.NIndexed (AST.IndexedName 
 -                              (AST.NSimple (mkVHDLExtId "tmp")) [AST.PrimLit $ show (len-1)])))
 +                              (AST.NSimple tmpId) [AST.PrimLit $ show (len-1)])))
          -- Return the generate functions
          cellGn      = AST.GenerateSm cellLabel cellGenScheme [] [compins,assign]
  

diff --combined VHDL.hs
index 998efb476669c8518fa2b29dc904e2bd93cfc6c3,920b83ed6be5de1f96c84f7d7fdf26ac8feeec20..4b69df5106071bc28c5c22ec343784f0610509d9
--- 1/VHDL.hs
--- 2/VHDL.hs
+++ b/VHDL.hs
@@@ -12,6 -12,7 +12,7 @@@ import qualified Control.Arrow as Arro
  import qualified Control.Monad.Trans.State as State
  import qualified Data.Monoid as Monoid
  import Data.Accessor
+ import Debug.Trace
  
  -- ForSyDe
  import qualified ForSyDe.Backend.VHDL.AST as AST
@@@ -298,22 -299,7 +299,7 @@@ mkConcSm (bndr, app@(CoreSyn.App _ _))
        case (Map.lookup (varToString f) globalNameTable) of
          Just (arg_count, builder) ->
            if length valargs == arg_count then
-             case builder of
-               Left funBuilder -> do
-                 let sigs = map (varToVHDLExpr.exprToVar) valargs
-                 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)
-                 return [AST.CSSASm assign]
-               Right genBuilder -> do
-                 let sigs = map exprToVar valargs
-                 let signature = Maybe.fromMaybe
-                       (error $ "Using function '" ++ (varToString (head sigs)) ++ "' without signature? This should not happen!") 
-                       (Map.lookup (head sigs) signatures)
-                 let arg = tail sigs
-                 genSm <- genBuilder signature (arg ++ [bndr])  
-                 return [genSm]
+             builder bndr f valargs
            else
              error $ "VHDL.mkConcSm Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ pprString valargs
          Nothing -> error $ "Using function from another module that is not a known builtin: " ++ pprString f
@@@ -329,9 -315,9 +315,9 @@@
          label = "comp_ins_" ++ varToString bndr
          -- Add a clk port if we have state
          --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
 -        clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
 +        --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
          --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
 -        portmaps = clk_port : mkAssocElems args bndr signature
 +        portmaps = mkAssocElems args bndr signature
          in
            return [mkComponentInst label entity_id portmaps]
      details -> error $ "Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details