X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FVHDL%2FGenerate.hs;h=83404334e01d8c4c1c26e3f067b32bf5142e16b8;hb=6b25abd35ae3cfe2fe42b9d0446d35d0dd118f98;hp=2258d974f21d512bb0ceaf89f9825ab3dfe2c994;hpb=6a943c79c8f7d6247e0b3336046b8a41c88e72f1;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 2258d97..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,24 +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' - 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. @@ -419,6 +409,20 @@ genFromSizedWord' (Left res) f args@[arg] = -- 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 @@ -455,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 @@ -484,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 { @@ -1610,6 +1619,7 @@ globalNameTable = Map.fromList , (negateId , (1, genNegation ) ) , (minusId , (2, genOperator2 (AST.:-:) ) ) , (fromSizedWordId , (1, genFromSizedWord ) ) + , (fromRangedWordId , (1, genFromRangedWord ) ) , (fromIntegerId , (1, genFromInteger ) ) , (resizeWordId , (1, genResize ) ) , (resizeIntId , (1, genResize ) )