import CLasH.VHDL.Constants
import CLasH.VHDL.VHDLTypes
import CLasH.VHDL.VHDLTools
-import qualified CLasH.Utils as Utils
+import CLasH.Utils as Utils
import CLasH.Utils.Core.CoreTools
import CLasH.Utils.Pretty
import qualified CLasH.Normalize as Normalize
expr <- Normalize.getNormalized fname
-- Strip off lambda's, these will be arguments
let (args, letexpr) = CoreSyn.collectBinders expr
- args' <- mapM mkMap args
+ -- Generate ports for all non-state types
+ args' <- catMaybesM $ mapM mkMap args
-- There must be a let at top level
let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
- res' <- mkMap res
+ -- TODO: Handle Nothing
+ Just res' <- mkMap res
let vhdl_id = mkVHDLBasicId $ varToString fname ++ "_" ++ varToStringUniq fname
let ent_decl = createEntityAST vhdl_id args' res'
let signature = Entity vhdl_id args' res' ent_decl
mkMap ::
--[(SignalId, SignalInfo)]
CoreSyn.CoreBndr
- -> TranslatorSession Port
+ -> TranslatorSession (Maybe Port)
mkMap = (\bndr ->
let
--info = Maybe.fromMaybe
ty = Var.varType bndr
error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr
in do
- type_mark <- MonadState.lift tsType $ vhdl_ty error_msg ty
- return (id, type_mark)
+ type_mark_maybe <- MonadState.lift tsType $ vhdl_ty error_msg ty
+ case type_mark_maybe of
+ Just type_mark -> return $ Just (id, type_mark)
+ Nothing -> return Nothing
)
-- | Create the VHDL AST for an entity
-- A single alt case must be a selector. This means thee scrutinee is a simple
-- variable, the alternative is a dataalt with a single non-wild binder that
-- is also returned.
-mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt])) =
+mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt]))
+ -- Don't generate VHDL for substate extraction
+ | hasStateType bndr = return ([], [])
+ | otherwise =
case alt of
(CoreSyn.DataAlt dc, bndrs, (CoreSyn.Var sel_bndr)) -> do
- case List.elemIndex sel_bndr bndrs of
+ bndrs' <- Monad.filterM hasNonEmptyType bndrs
+ case List.elemIndex sel_bndr bndrs' of
Just i -> do
labels <- MonadState.lift tsType $ getFieldLabels (Id.idType scrut)
let label = labels!!i
-- | A function to wrap a builder-like function that expects its arguments to
-- be expressions.
genExprArgs wrap dst func args = do
- args' <- eitherCoreOrExprArgs args
+ args' <- argsToVHDLExprs args
wrap dst func args'
-eitherCoreOrExprArgs :: [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.Expr]
-eitherCoreOrExprArgs args = mapM (Either.either ((MonadState.lift tsType) . varToVHDLExpr . exprToVar) return) args
+-- | Turn the all lefts into VHDL Expressions.
+argsToVHDLExprs :: [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.Expr]
+argsToVHDLExprs = catMaybesM . (mapM argToVHDLExpr)
+
+argToVHDLExpr :: Either CoreSyn.CoreExpr AST.Expr -> TranslatorSession (Maybe AST.Expr)
+argToVHDLExpr (Left expr) = MonadState.lift tsType $ do
+ let errmsg = "Generate.argToVHDLExpr: Using non-representable type? Should not happen!"
+ ty_maybe <- vhdl_ty errmsg expr
+ case ty_maybe of
+ Just _ -> do
+ vhdl_expr <- varToVHDLExpr $ exprToVar expr
+ return $ Just vhdl_expr
+ Nothing -> return $ Nothing
+
+argToVHDLExpr (Right expr) = return $ Just expr
-- A function to wrap a builder-like function that generates no component
-- instantiations
-- temporary vector
let tmp_ty = Type.mkAppTy nvec (Var.varType start)
let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
- tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty
+ -- TODO: Handle Nothing
+ Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty
-- Setup the generate scheme
let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))
let block_label = mkVHDLExtId ("foldlVector" ++ (varToString res))
-- -- temporary vector
let tmp_ty = Var.varType res
let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
- tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty
+ -- TODO: Handle Nothing
+ Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty
-- Setup the generate scheme
let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start))
let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))
-- Local binder that references a top level binding. Generate a
-- component instantiation.
signature <- getEntity f
- args' <- eitherCoreOrExprArgs args
+ args' <- argsToVHDLExprs args
let entity_id = ent_id signature
-- TODO: Using show here isn't really pretty, but we'll need some
-- unique-ish value...
let label = "comp_ins_" ++ (either show prettyShow) dst
- let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
+ portmaps <- mkAssocElems args' ((either varToVHDLName id) dst) signature
return ([mkComponentInst label entity_id portmaps], [f])
False -> do
-- Not a top level binder, so this must be a local variable reference.
Left bndr -> do
-- We have the bndr, so we can get at the type
labels <- MonadState.lift tsType $ getFieldLabels (Var.varType bndr)
- args' <- eitherCoreOrExprArgs args
+ args' <- argsToVHDLExprs args
return $ (zipWith mkassign labels $ args', [])
where
mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
if length args == arg_count then
builder dst f args
else
- error $ "\nGenerate.genApplication(VanillaGlobal): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
- Nothing -> error $ ("\nGenerate.genApplication(VanillaGlobal): Using function from another module that is not a known builtin: " ++ (pprString f))
+ error $ "\nGenerate.genApplication(VanillaId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
+ Nothing -> do
+ top <- isTopLevelBinder f
+ case top of
+ True -> do
+ -- Local binder that references a top level binding. Generate a
+ -- component instantiation.
+ signature <- getEntity f
+ args' <- argsToVHDLExprs args
+ let entity_id = ent_id signature
+ -- TODO: Using show here isn't really pretty, but we'll need some
+ -- unique-ish value...
+ let label = "comp_ins_" ++ (either show prettyShow) dst
+ portmaps <- mkAssocElems args' ((either varToVHDLName id) dst) signature
+ return ([mkComponentInst label entity_id portmaps], [f])
+ False -> do
+ -- Not a top level binder, so this must be a local variable reference.
+ -- It should have a representable type (and thus, no arguments) and a
+ -- signal should be generated for it. Just generate an unconditional
+ -- assignment here.
+ -- FIXME : I DONT KNOW IF THE ABOVE COMMENT HOLDS HERE, SO FOR NOW JUST ERROR!
+ -- f' <- MonadState.lift tsType $ varToVHDLExpr f
+ -- return $ ([mkUncondAssign dst f'], [])
+ error $ ("\nGenerate.genApplication(VanillaId): Using function from another module that is not a known builtin: " ++ (pprString f))
IdInfo.ClassOpId cls -> do
-- FIXME: Not looking for what instance this class op is called for
-- Is quite stupid of course.
vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
vectorFunId el_ty fname = do
let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
- elemTM <- vhdl_ty error_msg el_ty
+ -- TODO: Handle the Nothing case?
+ Just elemTM <- vhdl_ty error_msg 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)
, (takeId, (AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet],[minimumId]))
, (dropId, (AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet],[]))
, (plusgtId, (AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
- , (emptyId, (AST.SubProgBody emptySpec [AST.SPCD emptyVar] [emptyExpr],[]))
+ , (emptyId, (AST.SubProgBody emptySpec [AST.SPVD emptyVar] [emptyExpr],[]))
, (singletonId, (AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet],[]))
, (copynId, (AST.SubProgBody copynSpec [AST.SPVD copynVar] [copynExpr],[]))
, (selId, (AST.SubProgBody selSpec [AST.SPVD selVar] [selFor, selRet],[]))
plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
emptyVar =
- AST.ConstDec resId
- (AST.SubtypeIn vectorTM Nothing)
- (Just $ AST.PrimLit "\"\"")
+ AST.VarDec resId
+ (AST.SubtypeIn vectorTM
+ (Just $ AST.ConstraintIndex $ AST.IndexConstraint
+ [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "-1")]))
+ Nothing
emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ]
vectorTM
, (fromIntegerId , (1, genFromInteger ) )
, (resizeId , (1, genResize ) )
, (sizedIntId , (1, genSizedInt ) )
+ , (smallIntegerId , (1, genFromInteger ) )
--, (tfvecId , (1, genTFVec ) )
, (minimumId , (2, error $ "\nFunction name: \"minimum\" is used internally, use another name"))
]