-- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
ports = map (mkIfaceSigDec AST.In) args
++ (Maybe.maybeToList res_port)
- ++ [clk_port]
+ ++ [clk_port,resetn_port]
-- Add a clk port if we have state
clk_port = AST.IfaceSigDec clockId AST.In std_logicTM
+ resetn_port = AST.IfaceSigDec resetId AST.In std_logicTM
res_port = fmap (mkIfaceSigDec AST.Out) res
-- | Create a port declaration
mkStateProcSm (old, new) = do
nonempty <- hasNonEmptyType old
if nonempty
- then return [AST.CSPSm $ AST.ProcSm label [clk] [statement]]
+ then return [AST.CSPSm $ AST.ProcSm label [clockId,resetId] [statement]]
else return []
where
label = mkVHDLBasicId $ "state"
- clk = mkVHDLBasicId "clock"
rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
wform = AST.Wform [AST.WformElem (AST.PrimName $ varToVHDLName new) Nothing]
- assign = AST.SigAssign (varToVHDLName old) wform
- rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
- statement = AST.IfSm rising_edge_clk [assign] [] Nothing
+ clk_assign = AST.SigAssign (varToVHDLName old) wform
+ rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clockId)]
+ resetn_is_low = (AST.PrimName $ AST.NSimple resetId) AST.:=: (AST.PrimLit "'0'")
+ reset_statement = []
+ clk_statement = [AST.ElseIf rising_edge_clk [clk_assign]]
+ statement = AST.IfSm resetn_is_low reset_statement clk_statement Nothing
-- | Transforms a core binding into a VHDL concurrent statement
-- Ignore Cast expressions, they should not longer have any meaning as long as
--- the type works out.
+-- the type works out. Throw away state repacking
+mkConcSm (bndr, to@(CoreSyn.Cast from ty))
+ | hasStateType to && hasStateType from
+ = return ([],[])
mkConcSm (bndr, CoreSyn.Cast expr ty) = mkConcSm (bndr, expr)
-- Simple a = b assignments are just like applications, but without arguments.
-- | A function to wrap a builder-like function that expects its arguments to
-- be Literals
genLitArgs ::
- (dst -> func -> [Literal.Literal] -> res)
- -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
-genLitArgs wrap dst func args = wrap dst func args'
- where
- args' = map exprToLit litargs
- -- FIXME: Check if we were passed an CoreSyn.App
- litargs = concat (map getLiterals exprargs)
- (exprargs, []) = Either.partitionEithers args
+ (dst -> func -> [Literal.Literal] -> TranslatorSession [AST.ConcSm])
+ -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.ConcSm])
+genLitArgs wrap dst func args = do
+ hscenv <- MonadState.lift tsType $ getA tsHscEnv
+ let (exprargs, []) = Either.partitionEithers args
+ -- FIXME: Check if we were passed an CoreSyn.App
+ let litargs = concat (map (getLiterals hscenv) exprargs)
+ let args' = map exprToLit litargs
+ concsms <- wrap dst func args'
+ return concsms
-- | A function to wrap a builder-like function that produces an expression
-- and expects it to be assigned to the destination.
genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
genFromSizedWord :: BuiltinBuilder
-genFromSizedWord = genNoInsts $ genExprArgs $ genExprRes genFromSizedWord'
-genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
-genFromSizedWord' (Left res) f args = do
- let fname = varToString f
- return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId)) $
- map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
+genFromSizedWord = genNoInsts $ genExprArgs genFromSizedWord'
+genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession [AST.ConcSm]
+genFromSizedWord' (Left res) f args@[arg] = do
+ return $ [mkUncondAssign (Left res) arg]
+ -- let fname = varToString f
+ -- return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId)) $
+ -- map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
genResize :: BuiltinBuilder
; (tycon, args) = Type.splitTyConApp ty
; name = Name.getOccString (TyCon.tyConName tycon)
} ;
- ; case name of
- "RangedWord" -> return $ AST.PrimLit (show (last lits))
- otherwise -> do {
- ; len <- case name of
- "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
- "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
- "RangedWord" -> MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
- ; let fname = case name of "SizedInt" -> toSignedId ; "SizedWord" -> toUnsignedId
- ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
- [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show (last lits))), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
+ ; len <- case name of
+ "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
+ "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
+ "RangedWord" -> do {
+ ; bound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
+ ; return $ floor (logBase 2 (fromInteger (toInteger (bound)))) + 1
}
+ ; let fname = case name of "SizedInt" -> toSignedId ; "SizedWord" -> toUnsignedId ; "RangedWord" -> toUnsignedId
+ ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
+ [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show (last lits))), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
+
}
genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
-- Return the conditional generate part
return $ (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
+genBlockRAM :: BuiltinBuilder
+genBlockRAM = genNoInsts $ genExprArgs genBlockRAM'
+
+genBlockRAM' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession [AST.ConcSm]
+genBlockRAM' (Left res) f args@[data_in,rdaddr,wraddr,wrenable] = do
+ -- Get the ram type
+ let (tup,data_out) = Type.splitAppTy (Var.varType res)
+ let (tup',ramvec) = Type.splitAppTy tup
+ let Just realram = Type.coreView ramvec
+ let Just (tycon, types) = Type.splitTyConApp_maybe realram
+ Just ram_vhdl_ty <- MonadState.lift tsType $ vhdl_ty "wtf" (head types)
+ -- Make the intermediate vector
+ let ram_dec = AST.BDISD $ AST.SigDec ram_id ram_vhdl_ty Nothing
+ -- Get the data_out name
+ reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
+ let resname' = varToVHDLName res
+ let resname = mkSelectedName resname' (reslabels!!0)
+ let rdaddr_int = genExprFCall (mkVHDLBasicId toIntegerId) rdaddr
+ let argexpr = vhdlNameToVHDLExpr $ mkIndexedName (AST.NSimple ram_id) rdaddr_int
+ let assign = mkUncondAssign (Right resname) argexpr
+ let block_label = mkVHDLExtId ("blockRAM" ++ (varToString res))
+ let block = AST.BlockSm block_label [] (AST.PMapAspect []) [ram_dec] [assign, mkUpdateProcSm]
+ return [AST.CSBSm block]
+ where
+ ram_id = mkVHDLBasicId "ram"
+ mkUpdateProcSm :: AST.ConcSm
+ mkUpdateProcSm = AST.CSPSm $ AST.ProcSm proclabel [clockId] [statement]
+ where
+ proclabel = mkVHDLBasicId "updateRAM"
+ rising_edge = mkVHDLBasicId "rising_edge"
+ wraddr_int = genExprFCall (mkVHDLBasicId toIntegerId) wraddr
+ ramloc = mkIndexedName (AST.NSimple ram_id) wraddr_int
+ wform = AST.Wform [AST.WformElem data_in Nothing]
+ ramassign = AST.SigAssign ramloc wform
+ rising_edge_clk = genExprFCall rising_edge (AST.PrimName $ AST.NSimple clockId)
+ statement = AST.IfSm (AST.And rising_edge_clk wrenable) [ramassign] [] Nothing
-----------------------------------------------------------------------------
-- Function to generate VHDL for applications
-> [(String, (AST.SubProgBody, [String]))]
genUnconsVectorFuns elemTM vectorTM =
[ (exId, (AST.SubProgBody exSpec [] [exExpr],[]))
- , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet],[]))
+ , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr1,replaceExpr2,replaceRet],[]))
, (lastId, (AST.SubProgBody lastSpec [] [lastExpr],[]))
, (initId, (AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet],[]))
, (minimumId, (AST.SubProgBody minimumSpec [] [minimumExpr],[]))
sPar = AST.unsafeVHDLBasicId "s"
resId = AST.unsafeVHDLBasicId "res"
exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
- AST.IfaceVarDec ixPar naturalTM] elemTM
+ AST.IfaceVarDec ixPar unsignedTM] elemTM
exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
- (AST.IndexedName (AST.NSimple vecPar) [AST.PrimName $
- AST.NSimple ixPar]))
+ (AST.IndexedName (AST.NSimple vecPar) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ ixPar)]))
replaceSpec = AST.Function (mkVHDLExtId replaceId) [ AST.IfaceVarDec vecPar vectorTM
- , AST.IfaceVarDec iPar naturalTM
+ , AST.IfaceVarDec iPar unsignedTM
, AST.IfaceVarDec aPar elemTM
] vectorTM
-- variable res : fsvec_x (0 to vec'length-1);
(AST.PrimLit "1")) ]))
Nothing
-- res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
- replaceExpr = AST.NSimple resId AST.:=
- (vecSlice (AST.PrimLit "0") (AST.PrimName (AST.NSimple iPar) AST.:-: AST.PrimLit "1") AST.:&:
- 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) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
- AST.:-: AST.PrimLit "1"))
+ replaceExpr1 = AST.NSimple resId AST.:= AST.PrimName (AST.NSimple vecPar)
+ replaceExpr2 = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ iPar)]) AST.:= AST.PrimName (AST.NSimple aPar)
replaceRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
vecSlice init last = AST.PrimName (AST.NSlice
(AST.SliceName
, (hwnotId , (1, genOperator1 AST.Not ) )
, (equalityId , (2, genOperator2 (AST.:=:) ) )
, (inEqualityId , (2, genOperator2 (AST.:/=:) ) )
+ , (ltId , (2, genOperator2 (AST.:<:) ) )
+ , (lteqId , (2, genOperator2 (AST.:<=:) ) )
+ , (gtId , (2, genOperator2 (AST.:>:) ) )
+ , (gteqId , (2, genOperator2 (AST.:>=:) ) )
, (boolOrId , (2, genOperator2 AST.Or ) )
, (boolAndId , (2, genOperator2 AST.And ) )
, (plusId , (2, genOperator2 (AST.:+:) ) )
, (smallIntegerId , (1, genFromInteger ) )
, (fstId , (1, genFst ) )
, (sndId , (1, genSnd ) )
+ , (blockRAMId , (5, genBlockRAM ) )
--, (tfvecId , (1, genTFVec ) )
, (minimumId , (2, error $ "\nFunction name: \"minimum\" is used internally, use another name"))
]