args' <- catMaybesM $ mapM mkMap args
-- TODO: Handle Nothing
res' <- mkMap res
- let vhdl_id = mkVHDLBasicId $ varToString fname ++ "_" ++ varToStringUniq fname
+ count <- getA tsEntityCounter
+ let vhdl_id = mkVHDLBasicId $ varToString fname ++ "Component_" ++ show count
+ putA tsEntityCounter (count + 1)
let ent_decl = createEntityAST vhdl_id args' res'
let signature = Entity vhdl_id args' res' ent_decl
return signature
-> TranslatorSession ((Maybe CoreSyn.CoreBndr, Maybe CoreSyn.CoreBndr), ([AST.ConcSm], [CoreSyn.CoreBndr]))
-- ^ ((Input state variable, output state variable), (statements, used entities))
-- newtype unpacking is just a cast
- dobind (bndr, (CoreSyn.Cast expr coercion))
- | hasStateType expr
+ dobind (bndr, unpacked@(CoreSyn.Cast packed coercion))
+ | hasStateType packed && not (hasStateType unpacked)
= return ((Just bndr, Nothing), ([], []))
-- With simplCore, newtype packing is just a cast
- dobind (bndr, expr@(CoreSyn.Cast (CoreSyn.Var state) coercion))
- | hasStateType expr
+ dobind (bndr, packed@(CoreSyn.Cast unpacked@(CoreSyn.Var state) coercion))
+ | hasStateType packed && not (hasStateType unpacked)
= return ((Nothing, Just state), ([], []))
-- Without simplCore, newtype packing uses a data constructor
dobind (bndr, (CoreSyn.App (CoreSyn.App (CoreSyn.Var con) (CoreSyn.Type _)) (CoreSyn.Var state)))
-- 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.
-- Return the generate functions
; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
}
+
+-- | Generate a generate statement for the builtin function "fst"
+genFst :: BuiltinBuilder
+genFst = genNoInsts $ genVarArgs genFst'
+genFst' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
+genFst' (Left res) f args@[arg] = do {
+ ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType arg)
+ ; let { argexpr' = varToVHDLName arg
+ ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (labels!!0)
+ ; assign = mkUncondAssign (Left res) argexprA
+ } ;
+ -- Return the generate functions
+ ; return [assign]
+ }
+
+-- | Generate a generate statement for the builtin function "snd"
+genSnd :: BuiltinBuilder
+genSnd = genNoInsts $ genVarArgs genSnd'
+genSnd' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
+genSnd' (Left res) f args@[arg] = do {
+ ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType arg)
+ ; let { argexpr' = varToVHDLName arg
+ ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (labels!!1)
+ ; assign = mkUncondAssign (Left res) argexprB
+ } ;
+ -- Return the generate functions
+ ; return [assign]
+ }
-- | Generate a generate statement for the builtin function "unzip"
genUnzip :: BuiltinBuilder
-- 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 argexpr = vhdlNameToVHDLExpr $ mkIndexedName (AST.NSimple ram_id) rdaddr
+ 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"
+ ramloc = mkIndexedName (AST.NSimple ram_id) wraddr
+ 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 AST.:=: AST.PrimLit "'1'")) [ramassign] [] Nothing
-----------------------------------------------------------------------------
-- Function to generate VHDL for applications
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 label = "comp_ins_" ++ (either (prettyShow . varToVHDLName) prettyShow) dst
let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
return ([mkComponentInst label entity_id portmaps], [f])
False -> do
, (hwandId , (2, genOperator2 AST.And ) )
, (hworId , (2, genOperator2 AST.Or ) )
, (hwnotId , (1, genOperator1 AST.Not ) )
+ , (equalityId , (2, genOperator2 (AST.:=:) ) )
+ , (inEqualityId , (2, genOperator2 (AST.:/=:) ) )
+ , (boolOrId , (2, genOperator2 AST.Or ) )
+ , (boolAndId , (2, genOperator2 AST.And ) )
, (plusId , (2, genOperator2 (AST.:+:) ) )
, (timesId , (2, genOperator2 (AST.:*:) ) )
, (negateId , (1, genNegation ) )
, (resizeId , (1, genResize ) )
, (sizedIntId , (1, genSizedInt ) )
, (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"))
]
projects / matthijs / master-project / cλash.git / blobdiff