X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FVHDL%2FGenerate.hs;h=83404334e01d8c4c1c26e3f067b32bf5142e16b8;hb=6b25abd35ae3cfe2fe42b9d0446d35d0dd118f98;hp=46f20679e89e10d8a5836a864ad06fc28db8176c;hpb=0e45b79dac5dd4bf4b340a515b61a03953f673a2;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 46f2067..8340433 100644
--- "a/c\316\273ash/CLasH/VHDL/Generate.hs"
+++ "b/c\316\273ash/CLasH/VHDL/Generate.hs"
@@ -41,7 +41,7 @@ getEntity ::
   -> TranslatorSession Entity -- ^ The resulting entity
 
 getEntity fname = makeCached fname tsEntities $ do
-      expr <- Normalize.getNormalized fname
+      expr <- Normalize.getNormalized False fname
       -- Split the normalized expression
       let (args, binds, res) = Normalize.splitNormalized expr
       -- Generate ports for all non-empty types
@@ -109,7 +109,7 @@ getArchitecture ::
   -- ^ The architecture for this function
 
 getArchitecture fname = makeCached fname tsArchitectures $ do
-  expr <- Normalize.getNormalized fname
+  expr <- Normalize.getNormalized False fname
   -- Split the normalized expression
   let (args, binds, res) = Normalize.splitNormalized expr
   
@@ -278,19 +278,11 @@ mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt]))
       
     _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
 
--- Multiple case alt are be conditional assignments and have only wild
+-- Multiple case alt become conditional assignments and have only wild
 -- 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
---   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"
+mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) _ _ (alt:alts))) = do
   scrut' <- MonadState.lift tsType $ varToVHDLExpr scrut
   -- Omit first condition, which is the default
   altcons <- MonadState.lift tsType $ mapM (altconToVHDLExpr . (\(con,_,_) -> con)) alts
@@ -299,7 +291,7 @@ mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) _ _ (alt:alts))) = do --error
   exprs <- MonadState.lift tsType $ mapM (varToVHDLExpr . (\(_,_,CoreSyn.Var expr) -> expr)) (alts ++ [alt])
   return ([mkAltsAssign (Left bndr) cond_exprs exprs], [])
 
-mkConcSm (_, CoreSyn.Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
+mkConcSm (_, CoreSyn.Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement does not have a simple variable as scrutinee"
 mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
 
 -----------------------------------------------------------------------------
@@ -342,26 +334,22 @@ genNoInsts wrap dst func args = do
 genVarArgs ::
   (dst -> func -> [Var.Var] -> res)
   -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
-genVarArgs wrap dst func args = wrap dst func args'
+genVarArgs wrap = genCoreArgs $ \dst func args -> let
+    args' = map exprToVar args
+  in
+    wrap dst func args'
+
+-- | A function to wrap a builder-like function that expects its arguments to
+-- be core expressions.
+genCoreArgs ::
+  (dst -> func -> [CoreSyn.CoreExpr] -> res)
+  -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
+genCoreArgs wrap dst func args = wrap dst func args'
   where
-    args' = map exprToVar args''
     -- Check (rather crudely) that all arguments are CoreExprs
-    args'' = case Either.partitionEithers args of 
+    args' = case Either.partitionEithers args of 
       (exprargs, []) -> exprargs
-      (exprsargs, rest) -> error $ "\nGenerate.genVarArgs: expect varargs but found ast exprs:" ++ (show rest)
-
--- | A function to wrap a builder-like function that expects its arguments to
--- be Literals
-genLitArgs ::
-  (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 $ MonadState.get tsHscEnv
-  let (exprargs, []) = Either.partitionEithers args
-  -- FIXME: Check if we were passed an CoreSyn.App
-  let litargs = concatMap (getLiterals hscenv) exprargs
-  let args' = map exprToLit litargs
-  wrap dst func args'   
+      (exprsargs, rest) -> error $ "\nGenerate.genCoreArgs: expect core expression arguments but found ast exprs:" ++ (show rest)
 
 -- | A function to wrap a builder-like function that produces an expression
 -- and expects it to be assigned to the destination.
@@ -471,28 +459,29 @@ genTimes' (Left res) f [arg1,arg2] = do {
   }
 genTimes' (Right name) _ _ = error $ "\nGenerate.genTimes': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
 
--- FIXME: I'm calling genLitArgs which is very specific function,
--- which needs to be fixed as well
+-- fromInteger turns an Integer into a Num instance. Since Integer is
+-- not representable and is only allowed for literals, the actual
+-- Integer should be inlined entirely into the fromInteger argument.
 genFromInteger :: BuiltinBuilder
-genFromInteger = genNoInsts $ genLitArgs $ genExprRes genFromInteger'
-genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [Literal.Literal] -> TranslatorSession AST.Expr
-genFromInteger' (Left res) f lits = do {
-  ; let { ty = Var.varType res
-        ; (tycon, args) = Type.splitTyConApp ty
-        ; name = Name.getOccString (TyCon.tyConName tycon)
-        } ;
-  ; len <- case name of
+genFromInteger = genNoInsts $ genCoreArgs $ genExprRes genFromInteger'
+genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [CoreSyn.CoreExpr] -> TranslatorSession AST.Expr
+genFromInteger' (Left res) f args = do
+  let ty = Var.varType res
+  let (tycon, tyargs) = Type.splitTyConApp ty
+  let name = Name.getOccString (TyCon.tyConName tycon)
+  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))]
-
-  }
+    "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
+  case args of
+    [integer] -> do -- The type and dictionary arguments are removed by genApplication
+      literal <- getIntegerLiteral integer
+      return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
+              [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show literal)), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
+    _ -> error $ "\nGenerate.genFromInteger': Wrong number of arguments to genInteger. Applying " ++ pprString f ++ " to " ++ pprString args
 
 genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
 
@@ -500,6 +489,10 @@ genSizedInt :: BuiltinBuilder
 genSizedInt = genFromInteger
 
 {-
+-- This function is useful for use with vectorTH, since that generates
+-- explicit references to the TFVec constructor (which is normally
+-- hidden). Below implementation is probably not current anymore, but
+-- kept here in case we start using vectorTH again.
 -- | Generate a Builder for the builtin datacon TFVec
 genTFVec :: BuiltinBuilder
 genTFVec (Left res) f [Left (CoreSyn.Let (CoreSyn.Rec letBinders) letRes)] = do {