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
+genFoldl' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
++-- Special case for an empty input vector, just assign start to res
++genFoldl' (Left res) _ [_, start, vec] | len == 0 = return [mkUncondAssign (Left res) (varToVHDLExpr start)]
++ where len = (tfvec_len . Var.varType) vec
+genFoldl' (Left res) f [folded_f, start, vec] = do
+ -- evec is (TFVec n), so it still needs an element type
+ let (nvec, _) = splitAppTy (Var.varType vec)
+ -- Put the type of the start value in nvec, this will be the type of our
+ -- temporary vector
+ let tmp_ty = Type.mkAppTy nvec (Var.varType start)
+ tmp_vhdl_ty <- vhdl_ty tmp_ty
-- Setup the generate scheme
- let len = (tfvec_len . Var.varType) inVec
- let genlabel = mkVHDLExtId ("foldlVector" ++ (varToString inVec))
- let blockLabel = mkVHDLExtId ("foldlVector" ++ (varToString startVal))
- let range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
- let genScheme = AST.ForGn (AST.unsafeVHDLBasicId "n") range
+ let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))
+ let block_label = mkVHDLExtId ("foldlVector" ++ (varToString start))
+ let gen_range = AST.ToRange (AST.PrimLit "0") len_min_expr
+ let gen_scheme = AST.ForGn n_id gen_range
-- Make the intermediate vector
- let tmpId = mkVHDLExtId "tmp"
- let tmpVec = AST.BDISD $ AST.SigDec tmpId vecType Nothing
- -- 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)
- -- Generate the output assignment
- let assign = [mkUncondAssign (Left resVal) (AST.PrimName (AST.NIndexed (AST.IndexedName
- (AST.NSimple tmpId) [AST.PrimLit $ show (len-1)])))]
- -- Return the generate functions
- let genSm = AST.CSGSm $ AST.GenerateSm genlabel genScheme []
- [ AST.CSGSm (genFirstCell (entity_id, argports, resport)
- [startVal, inVec, resVal])
- , AST.CSGSm (genOtherCell (entity_id, argports, resport)
- [startVal, inVec, resVal])
- ]
- return $ if len > 0 then
- [AST.CSBSm $ AST.BlockSm blockLabel [] (AST.PMapAspect []) [tmpVec] (genSm : assign)]
- else
- [mkUncondAssign (Left resVal) (AST.PrimName $ AST.NSimple (varToVHDLId startVal))]
+ let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
+ -- Create the generate statement
+ cells <- sequence [genFirstCell, genOtherCell]
+ let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
+ -- Assign tmp[len-1] to res
+ let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr (mkIndexedName tmp_name (AST.PrimLit $ show (len-1)))
+ let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
+ return [AST.CSBSm block]
where
- 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"
- -- Assign the ports
- inport1 = mkAssocElem (argports!!0) (varToString startVal)
- 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_id, argports, resport) [startVal, inVec, resVal] = cellGn
- where
- len = (tfvec_len . Var.varType) inVec
- cellLabel = mkVHDLExtId "othercell"
- cellGenScheme = AST.IfGn ((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"
- -- Assign the ports
- 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]
+ -- The vector length
+ len = (tfvec_len . Var.varType) vec
+ -- An id for the counter
+ n_id = mkVHDLBasicId "n"
+ n_expr = idToVHDLExpr n_id
+ -- An expression for n-1
+ n_min_expr = n_expr AST.:-: (AST.PrimLit "1")
+ -- An expression for len-1
+ len_min_expr = (AST.PrimLit $ show (len-1))
+ -- An id for the tmp result vector
+ tmp_id = mkVHDLBasicId "tmp"
+ tmp_name = AST.NSimple tmp_id
+ -- Generate parts of the fold
+ genFirstCell, genOtherCell :: VHDLSession AST.GenerateSm
+ genFirstCell = do
+ let cond_label = mkVHDLExtId "firstcell"
+ -- if n == 0
+ let cond_scheme = AST.IfGn $ n_expr AST.:=: (AST.PrimLit "0")
+ -- Output to tmp[n]
+ let resname = mkIndexedName tmp_name n_expr
+ -- Input from start
+ let argexpr1 = varToVHDLExpr start
+ -- Input from vec[n]
+ let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_expr
+ app_concsms <- genApplication (Right resname) folded_f [Right argexpr1, Right argexpr2]
+ -- Return the conditional generate part
+ return $ AST.GenerateSm cond_label cond_scheme [] app_concsms
+
+ genOtherCell = do
+ let cond_label = mkVHDLExtId "othercell"
+ -- if n > 0
+ let cond_scheme = AST.IfGn $ n_expr AST.:>: (AST.PrimLit "0")
+ -- Output to tmp[n]
+ let resname = mkIndexedName tmp_name n_expr
+ -- Input from tmp[n-1]
+ let argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_min_expr
+ -- Input from vec[n]
+ let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_expr
+ app_concsms <- genApplication (Right resname) folded_f [Right argexpr1, Right argexpr2]
+ -- Return the conditional generate part
+ return $ AST.GenerateSm cond_label cond_scheme [] app_concsms
++{-
+ genFoldr :: BuiltinBuilder
+ genFoldr = genVarArgs genFoldr'
+ genFoldr' 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
+ -- Setup the generate scheme
+ let len = (tfvec_len . Var.varType) inVec
+ let genlabel = mkVHDLExtId ("foldrVector" ++ (varToString inVec))
+ let blockLabel = mkVHDLExtId ("foldrVector" ++ (varToString startVal))
+ let range = AST.DownRange (AST.PrimLit $ show (len-1)) (AST.PrimLit "0")
+ let genScheme = AST.ForGn (AST.unsafeVHDLBasicId "n") range
+ -- Make the intermediate vector
+ let tmpId = mkVHDLExtId "tmp"
+ let tmpVec = AST.BDISD $ AST.SigDec tmpId vecType Nothing
+ -- 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)
+ -- Generate the output assignment
+ let assign = [mkUncondAssign (Left resVal) (AST.PrimName (AST.NIndexed (AST.IndexedName
+ (AST.NSimple tmpId) [AST.PrimLit "0"])))]
+ -- Return the generate functions
+ let genSm = AST.CSGSm $ AST.GenerateSm genlabel genScheme []
+ [ AST.CSGSm (genFirstCell len (entity_id, argports, resport)
+ [startVal, inVec, resVal])
+ , AST.CSGSm (genOtherCell len (entity_id, argports, resport)
+ [startVal, inVec, resVal])
+ ]
+ return $ if len > 0 then
+ [AST.CSBSm $ AST.BlockSm blockLabel [] (AST.PMapAspect []) [tmpVec] (genSm : assign)]
+ else
+ [mkUncondAssign (Left resVal) (AST.PrimName $ AST.NSimple (varToVHDLId startVal))]
+ where
+ genFirstCell len (entity_id, argports, resport) [startVal, inVec, resVal] = cellGn
+ where
+ cellLabel = mkVHDLExtId "firstcell"
+ cellGenScheme = AST.IfGn ((AST.PrimName $ AST.NSimple nPar) AST.:=: (AST.PrimLit $ show (len-1)))
+ tmpId = mkVHDLExtId "tmp"
+ nPar = AST.unsafeVHDLBasicId "n"
+ -- Assign the ports
+ inport1 = mkAssocElem (argports!!0) (varToString startVal)
+ 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 len (entity_id, argports, resport) [startVal, inVec, resVal] = cellGn
+ where
+ len = (tfvec_len . Var.varType) inVec
+ cellLabel = mkVHDLExtId "othercell"
+ cellGenScheme = AST.IfGn ((AST.PrimName $ AST.NSimple nPar) AST.:/=: (AST.PrimLit $ show (len-1)))
+ -- ((AST.PrimName $ AST.NSimple nPar) AST.:<: (AST.PrimLit $ show (len-1)))
+ tmpId = mkVHDLExtId "tmp"
+ nPar = AST.unsafeVHDLBasicId "n"
+ -- Assign the ports
+ 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]
+
++-}
++
++
+-----------------------------------------------------------------------------
+-- Function to generate VHDL for applications
+-----------------------------------------------------------------------------
+genApplication ::
+ (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ Where to store the result?
+ -> CoreSyn.CoreBndr -- ^ The function to apply
+ -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply
+ -> VHDLSession [AST.ConcSm] -- ^ The resulting concurrent statements
+genApplication dst f args =
+ case Var.globalIdVarDetails f of
+ IdInfo.DataConWorkId dc -> case dst of
+ -- It's a datacon. Create a record from its arguments.
+ Left bndr -> do
+ -- We have the bndr, so we can get at the type
+ labels <- getFieldLabels (Var.varType bndr)
+ return $ zipWith mkassign labels $ map (either exprToVHDLExpr id) args
+ where
+ mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
+ mkassign label arg =
+ let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
+ mkUncondAssign (Right sel_name) arg
+ Right _ -> error $ "Generate.genApplication Can't generate dataconstructor application without an original binder"
+ IdInfo.VanillaGlobal -> do
+ -- It's a global value imported from elsewhere. These can be builtin
+ -- functions. Look up the function name in the name table and execute
+ -- the associated builder if there is any and the argument count matches
+ -- (this should always be the case if it typechecks, but just to be
+ -- sure...).
+ case (Map.lookup (varToString f) globalNameTable) of
+ Just (arg_count, builder) ->
+ if length args == arg_count then
+ builder dst f args
+ else
+ error $ "Generate.genApplication Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
+ Nothing -> error $ "Using function from another module that is not a known builtin: " ++ pprString f
+ IdInfo.NotGlobalId -> do
+ signatures <- getA vsSignatures
+ -- This is a local id, so it should be a function whose definition we
+ -- have and which can be turned into a component instantiation.
+ let
+ signature = Maybe.fromMaybe
+ (error $ "Using function '" ++ (varToString f) ++ "' without signature? This should not happen!")
+ (Map.lookup f signatures)
+ entity_id = ent_id signature
+ -- TODO: Using show here isn't really pretty, but we'll need some
+ -- unique-ish value...
+ label = "comp_ins_" ++ (either show show) dst
+ portmaps = mkAssocElems (map (either exprToVHDLExpr id) args) ((either varToVHDLName id) dst) signature
+ in
+ return [mkComponentInst label entity_id portmaps]
+ details -> error $ "Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
+
+-----------------------------------------------------------------------------
+-- Functions to generate functions dealing with vectors.
+-----------------------------------------------------------------------------
+
-- 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
(AST.PrimName $ AST.NSimple aPar)])
-- return res
copyExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
+
+-----------------------------------------------------------------------------
+-- A table of builtin functions
+-----------------------------------------------------------------------------
+
+-- | The builtin functions we support. Maps a name to an argument count and a
+-- builder function.
+globalNameTable :: NameTable
+globalNameTable = Map.fromList
+ [ (exId , (2, genFCall ) )
+ , (replaceId , (3, genFCall ) )
+ , (headId , (1, genFCall ) )
+ , (lastId , (1, genFCall ) )
+ , (tailId , (1, genFCall ) )
+ , (initId , (1, genFCall ) )
+ , (takeId , (2, genFCall ) )
+ , (dropId , (2, genFCall ) )
+ , (plusgtId , (2, genFCall ) )
+ , (mapId , (2, genMap ) )
+ , (zipWithId , (3, genZipWith ) )
+ , (foldlId , (3, genFoldl ) )
++ --, (foldrId , (3, genFoldr ) )
+ , (emptyId , (0, genFCall ) )
+ , (singletonId , (1, genFCall ) )
+ , (copyId , (2, genFCall ) )
+ , (hwxorId , (2, genOperator2 AST.Xor ) )
+ , (hwandId , (2, genOperator2 AST.And ) )
+ , (hworId , (2, genOperator2 AST.Or ) )
+ , (hwnotId , (1, genOperator1 AST.Not ) )
+ ]
projects / matthijs / master-project / cλash.git / commitdiff