getEntity fname = Utils.makeCached fname tsEntities $ do
expr <- Normalize.getNormalized fname
- -- Strip off lambda's, these will be arguments
- let (args, letexpr) = CoreSyn.collectBinders expr
+ -- Split the normalized expression
+ let (args, binds, res) = Normalize.splitNormalized expr
-- Generate ports for all non-empty types
args' <- catMaybesM $ mapM mkMap args
- -- There must be a let at top level
- let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
-- 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
-- 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
getArchitecture fname = Utils.makeCached fname tsArchitectures $ do
expr <- Normalize.getNormalized fname
+ -- Split the normalized expression
+ let (args, binds, res) = Normalize.splitNormalized expr
+
+ -- Get the entity for this function
signature <- getEntity fname
let entity_id = ent_id signature
- -- Strip off lambda's, these will be arguments
- let (args, letexpr) = CoreSyn.collectBinders expr
- -- There must be a let at top level
- let (CoreSyn.Let (CoreSyn.Rec binds) (CoreSyn.Var res)) = letexpr
-- Create signal declarations for all binders in the let expression, except
-- for the output port (that will already have an output port declared in
let (in_state_maybes, out_state_maybes) = unzip state_vars
let (statementss, used_entitiess) = unzip sms
-- Create a state proc, if needed
- let state_proc = case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes) of
- ([in_state], [out_state]) -> [AST.CSPSm $ mkStateProcSm (in_state, out_state)]
- ([], []) -> []
+ state_proc <- case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes) of
+ ([in_state], [out_state]) -> mkStateProcSm (in_state, out_state)
+ ([], []) -> return []
(ins, outs) -> error $ "Weird use of state in " ++ show fname ++ ". In: " ++ show ins ++ " Out: " ++ show outs
-- Join the create statements and the (optional) state_proc
let statements = concat statementss ++ state_proc
-> 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)))
mkStateProcSm ::
(CoreSyn.CoreBndr, CoreSyn.CoreBndr) -- ^ The current and new state variables
- -> AST.ProcSm -- ^ The resulting statement
-mkStateProcSm (old, new) =
- AST.ProcSm label [clk] [statement]
+ -> TranslatorSession [AST.ConcSm] -- ^ The resulting statements
+mkStateProcSm (old, new) = do
+ nonempty <- hasNonEmptyType old
+ if nonempty
+ then return [AST.CSPSm $ AST.ProcSm label [clk] [statement]]
+ else return []
where
label = mkVHDLBasicId $ "state"
clk = mkVHDLBasicId "clock"
-- 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 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
-> [(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],[]))
(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) [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
, (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