Fail again when we try translate a DEFAULT condition

[matthijs/master-project/cλash.git] / cλash / CLasH / VHDL / Generate.hs

diff --git a/cλash/CLasH/VHDL/Generate.hs b/cλash/CLasH/VHDL/Generate.hs
index 048a711a1e58e6f6d455651d742b84dfad6fb720..99f798f47e72a91a23cb28c2610e06f05b2bde4c 100644 (file)
--- a/cλash/CLasH/VHDL/Generate.hs
+++ b/cλash/CLasH/VHDL/Generate.hs
@@ -232,14 +232,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
 
@@ -292,14 +301,16 @@ genVarArgs wrap dst func args = wrap dst func args'
 -- | A function to wrap a builder-like function that expects its arguments to
 -- be Literals
 genLitArgs ::
-  (dst -> func -> [Literal.Literal] -> res)
-  -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
-genLitArgs wrap dst func args = wrap dst func args'
-  where
-    args' = map exprToLit litargs
-    -- FIXME: Check if we were passed an CoreSyn.App
-    litargs = concat (map getLiterals exprargs)
-    (exprargs, []) = Either.partitionEithers args
+  (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 $ getA tsHscEnv
+  let (exprargs, []) = Either.partitionEithers args
+  -- FIXME: Check if we were passed an CoreSyn.App
+  let litargs = concat (map (getLiterals hscenv) exprargs)
+  let args' = map exprToLit litargs
+  concsms <- wrap dst func args'
+  return concsms    
 
 -- | A function to wrap a builder-like function that produces an expression
 -- and expects it to be assigned to the destination.
@@ -1446,6 +1457,10 @@ globalNameTable = Map.fromList
   , (hwnotId          , (1, genOperator1 AST.Not    ) )
   , (equalityId       , (2, genOperator2 (AST.:=:)  ) )
   , (inEqualityId     , (2, genOperator2 (AST.:/=:) ) )
+  , (ltId             , (2, genOperator2 (AST.:<:)  ) )
+  , (lteqId           , (2, genOperator2 (AST.:<=:) ) )
+  , (gtId             , (2, genOperator2 (AST.:>:)  ) )
+  , (gteqId           , (2, genOperator2 (AST.:>=:) ) )
   , (boolOrId         , (2, genOperator2 AST.Or     ) )
   , (boolAndId        , (2, genOperator2 AST.And    ) )
   , (plusId           , (2, genOperator2 (AST.:+:)  ) )