X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FVHDL%2FGenerate.hs;h=7faeb01429628714edcea5c095d8a94d2aaf3fec;hb=65215495d0faf2aac6f53f06e539f62deb31185f;hp=0be4f60be94c58bec17826191353d832ad83482a;hpb=4e12174b5b6515c056d4f83edcc18b991c71465d;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git

diff --git "a/c\316\273ash/CLasH/VHDL/Generate.hs" "b/c\316\273ash/CLasH/VHDL/Generate.hs"
index 0be4f60..7faeb01 100644
--- "a/c\316\273ash/CLasH/VHDL/Generate.hs"
+++ "b/c\316\273ash/CLasH/VHDL/Generate.hs"
@@ -144,12 +144,12 @@ getArchitecture fname = Utils.makeCached fname tsArchitectures $ do
               -> 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))) 
@@ -839,6 +839,40 @@ genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do
       -- 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
@@ -863,7 +897,7 @@ genApplication dst f args = do
           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
@@ -1422,6 +1456,7 @@ globalNameTable = Map.fromList
   , (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"))
   ]