_ -> 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
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.
let (tycon, args) = Type.splitTyConApp ty
let name = Name.getOccString (TyCon.tyConName tycon)
case name of
- "SizedInt" -> return $ AST.Neg arg1
+ "Signed" -> return $ AST.Neg arg1
otherwise -> error $ "\nGenerate.genNegation': Negation not allowed for type: " ++ show name
-- | Generate a function call from the destination binder, function name and a
; 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)
+ "Signed" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
+ "Unsigned" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
[Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
}
; 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 { ubound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
+ "Signed" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
+ "Unsigned" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
+ "Index" -> do { ubound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
; let bitsize = floor (logBase 2 (fromInteger (toInteger ubound)))
; return bitsize
}
}
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
- "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))]
-
- }
+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
+ "Signed" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
+ "Unsigned" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
+ "Index" -> 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 "Signed" -> toSignedId ; "Unsigned" -> toUnsignedId ; "Index" -> 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
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 {
projects / matthijs / master-project / cλash.git / blobdiff