-> 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
-- ^ 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
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
-----------------------------------------------------------------------------
genVarArgs ::
(dst -> func -> [Var.Var] -> res)
-> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
-genVarArgs wrap dst func args = wrap dst func args'
- where
- args' = map exprToVar exprargs
- -- Check (rather crudely) that all arguments are CoreExprs
- (exprargs, []) = Either.partitionEithers 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 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'
+-- 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
+ -- Check (rather crudely) that all arguments are CoreExprs
+ args' = case Either.partitionEithers args of
+ (exprargs, []) -> exprargs
+ (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.
-- map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+genFromRangedWord :: BuiltinBuilder
+genFromRangedWord = genNoInsts $ genExprArgs $ genExprRes genFromRangedWord'
+genFromRangedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
+genFromRangedWord' (Left res) f [arg] = do {
+ ; let { ty = Var.varType res
+ ; (tycon, args) = Type.splitTyConApp ty
+ ; name = Name.getOccString (TyCon.tyConName tycon)
+ } ;
+ ; len <- 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))]
+ }
+genFromRangedWord' (Right name) _ _ = error $ "\nGenerate.genFromRangedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+
genResize :: BuiltinBuilder
genResize = genNoInsts $ genExprArgs $ genExprRes genResize'
genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
}
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
type NameTable = Map.Map String (Int, BuiltinBuilder )
-- | The builtin functions we support. Maps a name to an argument count and a
--- builder function.
+-- builder function. If you add a name to this map, don't forget to add
+-- it to VHDL.Constants/builtinIds as well.
globalNameTable :: NameTable
globalNameTable = Map.fromList
[ (exId , (2, genFCall True ) )
, (negateId , (1, genNegation ) )
, (minusId , (2, genOperator2 (AST.:-:) ) )
, (fromSizedWordId , (1, genFromSizedWord ) )
+ , (fromRangedWordId , (1, genFromRangedWord ) )
, (fromIntegerId , (1, genFromInteger ) )
, (resizeWordId , (1, genResize ) )
, (resizeIntId , (1, genResize ) )
projects / matthijs / master-project / cλash.git / blobdiff