Start support on initial state. Substates currently break
[matthijs/master-project/cλash.git] / cλash / CLasH / VHDL / Generate.hs
index dee2a794694394b371f26129a1e79c54ae6c5da2..7c604d6d732f0b7fc8e4997f67dd3fa68b08b059 100644 (file)
@@ -129,16 +129,21 @@ getArchitecture fname = Utils.makeCached fname tsArchitectures $ do
   (state_vars, sms) <- Monad.mapAndUnzipM dobind binds
   let (in_state_maybes, out_state_maybes) = unzip state_vars
   let (statementss, used_entitiess) = unzip sms
+  -- Get initial state, if it's there
+  initSmap <- getA tsInitStates
+  let init_state = Map.lookup fname initSmap
   -- Create a state proc, if needed
-  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
+  (state_proc, resbndr) <- case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes, init_state) of
+        ([in_state], [out_state], Nothing) -> error $ "No initial state defined for: " ++ show fname
+        ([in_state], [out_state], Just resetval) -> mkStateProcSm (in_state, out_state,resetval)
+        ([], [], Just _) -> error $ "Initial state defined for state-less function: " ++ show fname
+        ([], [], Nothing) -> return ([],[])
+        (ins, outs, res) -> 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
   -- Create the architecture
   let arch = AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) statements
-  let used_entities = concat used_entitiess
+  let used_entities = (concat used_entitiess) ++ resbndr
   return (arch, used_entities)
   where
     dobind :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The bind to process
@@ -162,24 +167,44 @@ getArchitecture fname = Utils.makeCached fname tsArchitectures $ do
       return ((Nothing, Nothing), sms)
 
 mkStateProcSm :: 
-  (CoreSyn.CoreBndr, CoreSyn.CoreBndr) -- ^ The current and new state variables
-  -> TranslatorSession [AST.ConcSm] -- ^ The resulting statements
-mkStateProcSm (old, new) = do
-  nonempty <- hasNonEmptyType old 
+  (CoreSyn.CoreBndr, CoreSyn.CoreBndr, CoreSyn.CoreBndr) -- ^ The current state, new state and reset variables
+  -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]) -- ^ The resulting statements
+mkStateProcSm (old, new, res) = do
+  nonempty <- hasNonEmptyType old  
   if nonempty 
-    then return [AST.CSPSm $ AST.ProcSm label [clockId,resetId] [statement]]
-    else return []
-  where
-    label       = mkVHDLBasicId $ "state"
-    rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
-    wform       = AST.Wform [AST.WformElem (AST.PrimName $ varToVHDLName new) 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
-
+    then do
+      let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString res 
+      type_mark_old_maybe <- MonadState.lift tsType $ vhdl_ty error_msg (Var.varType old)
+      let type_mark_old = Maybe.fromJust type_mark_old_maybe
+      type_mark_res_maybe <- MonadState.lift tsType $ vhdl_ty error_msg (Var.varType res)
+      let type_mark_res' = Maybe.fromJust type_mark_res_maybe
+      let type_mark_res = if type_mark_old == type_mark_res' then
+                            type_mark_res'
+                          else 
+                            error $ "Initial state has different type than state type, state type: " ++ show type_mark_old ++ ", init type: "  ++ show type_mark_res'    
+      let resvalid  = mkVHDLBasicId $ varToString res ++ "val"
+      let resvaldec = AST.BDISD $ AST.SigDec resvalid type_mark_res Nothing
+      let reswform  = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple resvalid) Nothing]
+      let res_assign = AST.SigAssign (varToVHDLName old) reswform
+      let blocklabel       = mkVHDLBasicId $ "state"
+      let statelabel  = mkVHDLBasicId $ "stateupdate"
+      let rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
+      let wform       = AST.Wform [AST.WformElem (AST.PrimName $ varToVHDLName new) Nothing]
+      let clk_assign      = AST.SigAssign (varToVHDLName old) wform
+      let rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clockId)]
+      let resetn_is_low  = (AST.PrimName $ AST.NSimple resetId) AST.:=: (AST.PrimLit "'0'")
+      signature <- getEntity res
+      let entity_id = ent_id signature
+      let reslabel = "resetval_" ++ ((prettyShow . varToVHDLName) res)
+      let portmaps = mkAssocElems [] (AST.NSimple resvalid) signature
+      let reset_statement = mkComponentInst reslabel entity_id portmaps
+      let clk_statement = [AST.ElseIf rising_edge_clk [clk_assign]]
+      let statement   = AST.IfSm resetn_is_low [res_assign] clk_statement Nothing
+      let stateupdate = AST.CSPSm $ AST.ProcSm statelabel [clockId,resetId] [statement]
+      let block = AST.CSBSm $ AST.BlockSm blocklabel [] (AST.PMapAspect []) [resvaldec] [reset_statement,stateupdate]
+      return ([block],[res])
+    else 
+      return ([],[])
 
 -- | Transforms a core binding into a VHDL concurrent statement
 mkConcSm ::
@@ -232,14 +257,23 @@ mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt]))
 -- binders in the alts and only variables in the case values and a variable
 -- for a scrutinee. We check the constructor of the second alt, since the
 -- first is the default case, if there is any.
-mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) b ty [(_, _, CoreSyn.Var false), (con, _, CoreSyn.Var true)])) = do
+
+-- mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) b ty [(_, _, CoreSyn.Var false), (con, _, CoreSyn.Var true)])) = do
+--   scrut' <- MonadState.lift tsType $ varToVHDLExpr scrut
+--   altcon <- MonadState.lift tsType $ altconToVHDLExpr con
+--   let cond_expr = scrut' AST.:=: altcon
+--   true_expr <- MonadState.lift tsType $ varToVHDLExpr true
+--   false_expr <- MonadState.lift tsType $ varToVHDLExpr false
+--   return ([mkCondAssign (Left bndr) cond_expr true_expr false_expr], [])
+mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) _ _ (alt:alts))) = do --error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
   scrut' <- MonadState.lift tsType $ varToVHDLExpr scrut
-  let cond_expr = scrut' AST.:=: (altconToVHDLExpr con)
-  true_expr <- MonadState.lift tsType $ varToVHDLExpr true
-  false_expr <- MonadState.lift tsType $ varToVHDLExpr false
-  return ([mkCondAssign (Left bndr) cond_expr true_expr false_expr], [])
+  -- Omit first condition, which is the default
+  altcons <- MonadState.lift tsType $ mapM (altconToVHDLExpr . (\(con,_,_) -> con)) alts
+  let cond_exprs = map (\x -> scrut' AST.:=: x) altcons
+  -- Rotate expressions to the left, so that the expression related to the default case is the last
+  exprs <- MonadState.lift tsType $ mapM (varToVHDLExpr . (\(_,_,CoreSyn.Var expr) -> expr)) (alts ++ [alt])
+  return ([mkAltsAssign (Left bndr) cond_exprs exprs], [])
 
-mkConcSm (_, (CoreSyn.Case (CoreSyn.Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
 mkConcSm (_, CoreSyn.Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
 mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
 
@@ -336,7 +370,7 @@ genNegation' _ f [arg] = do
   let name = Name.getOccString (TyCon.tyConName tycon)
   case name of
     "SizedInt" -> return $ AST.Neg arg1
-    otherwise -> error $ "\nGenerate.genNegation': Negation allowed for type: " ++ show name 
+    otherwise -> error $ "\nGenerate.genNegation': Negation not allowed for type: " ++ show name 
 
 -- | Generate a function call from the destination binder, function name and a
 -- list of expressions (its arguments)
@@ -884,7 +918,32 @@ genBlockRAM' (Left res) f args@[data_in,rdaddr,wraddr,wrenable] = do
         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
-
+        
+genSplit :: BuiltinBuilder
+genSplit = genNoInsts $ genVarArgs genSplit'
+
+genSplit' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
+genSplit' (Left res) f args@[vecIn] = do {
+  ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
+  ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vecIn
+  ; let { block_label = mkVHDLExtId ("split" ++ (varToString vecIn))
+        ; halflen   = round ((fromIntegral len) / 2)
+        ; rangeL    = vecSlice (AST.PrimLit "0") (AST.PrimLit $ show (halflen - 1))
+        ; rangeR    = vecSlice (AST.PrimLit $ show halflen) (AST.PrimLit $ show (len - 1))
+        ; resname   = varToVHDLName res
+        ; resnameL  = mkSelectedName resname (labels!!0)
+        ; resnameR  = mkSelectedName resname (labels!!1)
+        ; argexprL  = vhdlNameToVHDLExpr rangeL
+        ; argexprR  = vhdlNameToVHDLExpr rangeR
+        ; out_assignL = mkUncondAssign (Right resnameL) argexprL
+        ; out_assignR = mkUncondAssign (Right resnameR) argexprR
+        ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [out_assignL, out_assignR]
+        }
+  ; return [AST.CSBSm block]
+  }
+  where
+    vecSlice init last =  AST.NSlice (AST.SliceName (varToVHDLName res) 
+                            (AST.ToRange init last))
 -----------------------------------------------------------------------------
 -- Function to generate VHDL for applications
 -----------------------------------------------------------------------------
@@ -1006,7 +1065,7 @@ vectorFunId el_ty fname = do
   -- the VHDLState or something.
   let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
   typefuns <- getA tsTypeFuns
-  case Map.lookup (OrdType el_ty, fname) typefuns of
+  case Map.lookup (StdType $ OrdType el_ty, fname) typefuns of
     -- Function already generated, just return it
     Just (id, _) -> return id
     -- Function not generated yet, generate it
@@ -1014,7 +1073,7 @@ vectorFunId el_ty fname = do
       let functions = genUnconsVectorFuns elemTM vectorTM
       case lookup fname functions of
         Just body -> do
-          modA tsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, (fst body))
+          modA tsTypeFuns $ Map.insert (StdType $ OrdType el_ty, fname) (function_id, (fst body))
           mapM_ (vectorFunId el_ty) (snd body)
           return function_id
         Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname
@@ -1460,12 +1519,14 @@ globalNameTable = Map.fromList
   , (minusId          , (2, genOperator2 (AST.:-:)  ) )
   , (fromSizedWordId  , (1, genFromSizedWord        ) )
   , (fromIntegerId    , (1, genFromInteger          ) )
-  , (resizeId         , (1, genResize               ) )
+  , (resizeWordId     , (1, genResize               ) )
+  , (resizeIntId      , (1, genResize               ) )
   , (sizedIntId       , (1, genSizedInt             ) )
   , (smallIntegerId   , (1, genFromInteger          ) )
   , (fstId            , (1, genFst                  ) )
   , (sndId            , (1, genSnd                  ) )
   , (blockRAMId       , (5, genBlockRAM             ) )
+  , (splitId          , (1, genSplit                ) )
   --, (tfvecId          , (1, genTFVec                ) )
   , (minimumId        , (2, error $ "\nFunction name: \"minimum\" is used internally, use another name"))
   ]