From 8663a3e3f2776039a31528c3087ef5725d401932 Mon Sep 17 00:00:00 2001 From: Matthijs Kooijman Date: Tue, 13 Apr 2010 14:40:17 +0200 Subject: [PATCH] Rewrite fromInteger and literal generation. Literals are less of a hack now and should work more reliably. --- "c\316\273ash/CLasH/Utils/Core/CoreTools.hs" | 37 ++++++++------ "c\316\273ash/CLasH/VHDL/Generate.hs" | 52 ++++++++------------ 2 files changed, 42 insertions(+), 47 deletions(-) diff --git "a/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" "b/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" index 9ac0fdf..0959570 100644 --- "a/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" +++ "b/c\316\273ash/CLasH/Utils/Core/CoreTools.hs" @@ -9,6 +9,7 @@ module CLasH.Utils.Core.CoreTools where import qualified Maybe import qualified System.IO.Unsafe import qualified Data.Map as Map +import qualified Data.Accessor.Monad.Trans.State as MonadState -- GHC API import qualified GHC @@ -261,21 +262,27 @@ get_val_args ty args = drop n args -- arguments, to get at the value arguments. n = length tyvars + length predtypes -getLiterals :: HscTypes.HscEnv -> CoreSyn.CoreExpr -> [CoreSyn.CoreExpr] -getLiterals _ app@(CoreSyn.App _ _) = literals - where - (CoreSyn.Var f, args) = CoreSyn.collectArgs app - literals = filter (is_lit) args - -getLiterals _ lit@(CoreSyn.Lit _) = [lit] - -getLiterals hscenv letrec@(CoreSyn.Let (CoreSyn.NonRec letBind (letExpr)) letRes) = [lit] - where - ty = Var.varType letBind - litInt = eval_tfp_int hscenv ty - lit = CoreSyn.Lit (Literal.mkMachInt (toInteger litInt)) - -getLiterals _ expr = error $ "\nCoreTools.getLiterals: Not a known Lit: " ++ pprString expr +-- Finds out what literal Integer this expression represents. +getIntegerLiteral :: CoreSyn.CoreExpr -> TranslatorSession Integer +getIntegerLiteral expr = + case CoreSyn.collectArgs expr of + (CoreSyn.Var f, [CoreSyn.Lit (Literal.MachInt integer)]) + | getFullString f == "GHC.Integer.smallInteger" -> return integer + (CoreSyn.Var f, [CoreSyn.Lit (Literal.MachInt64 integer)]) + | getFullString f == "GHC.Integer.int64ToInteger" -> return integer + (CoreSyn.Var f, [CoreSyn.Lit (Literal.MachWord integer)]) + | getFullString f == "GHC.Integer.wordToInteger" -> return integer + (CoreSyn.Var f, [CoreSyn.Lit (Literal.MachWord64 integer)]) + | getFullString f == "GHC.Integer.word64ToInteger" -> return integer + -- fromIntegerT returns the integer corresponding to the type of its + -- (third) argument. Since it is polymorphic, the type of that + -- argument is passed as the first argument, so we can just use that + -- one. + (CoreSyn.Var f, [CoreSyn.Type dec_ty, dec_dict, CoreSyn.Type num_ty, num_dict, arg]) + | getFullString f == "Types.Data.Num.Ops.fromIntegerT" -> do + int <- MonadState.lift tsType $ tfp_to_int dec_ty + return $ toInteger int + _ -> error $ "CoreTools.getIntegerLiteral: Unsupported Integer literal: " ++ pprString expr reduceCoreListToHsList :: [HscTypes.CoreModule] -- ^ The modules where parts of the list are hidden diff --git "a/c\316\273ash/CLasH/VHDL/Generate.hs" "b/c\316\273ash/CLasH/VHDL/Generate.hs" index 07cf0e8..0c1f2d7 100644 --- "a/c\316\273ash/CLasH/VHDL/Generate.hs" +++ "b/c\316\273ash/CLasH/VHDL/Generate.hs" @@ -359,19 +359,6 @@ genCoreArgs wrap dst func args = wrap dst func args' (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 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' - -- | A function to wrap a builder-like function that produces an expression -- and expects it to be assigned to the destination. genExprRes :: @@ -480,28 +467,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 -- 2.30.2