From: Christiaan Baaij Date: Tue, 7 Jul 2009 12:39:16 +0000 (+0200) Subject: Started adding numeric operations X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=8782caddd5cc4df0c68e4025266c9b558e32eb48;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Started adding numeric operations --- diff --git a/Adders.hs b/Adders.hs index 94184b0..aca64d3 100644 --- a/Adders.hs +++ b/Adders.hs @@ -13,6 +13,8 @@ import Language.Haskell.Syntax import Types import Data.Param.TFVec import Data.RangedWord +import Data.SizedInt +import Data.SizedWord mainIO f = Sim.simulateIO (Sim.stateless f) () @@ -176,8 +178,8 @@ highordtest = \x -> xand a b = hwand a b -functiontest :: TFVec D4 (TFVec D3 Bit) -> (TFVec D12 Bit, TFVec D3 Bit) -functiontest = \v -> let r = (concat v, head v) in r +functiontest :: SizedWord D8 -> RangedWord D255 +functiontest = \a -> let r = fromSizedWord a in r xhwnot x = hwnot x diff --git a/Constants.hs b/Constants.hs index af8c324..e8b0840 100644 --- a/Constants.hs +++ b/Constants.hs @@ -224,6 +224,31 @@ hwandId = "hwand" lengthTId :: String lengthTId = "lengthT" +-- Numeric Operations + +-- | plus operation identifier +plusId :: String +plusId = "+" + +-- | times operation identifier +timesId :: String +timesId = "*" + +-- | negate operation identifier +negateId :: String +negateId = "negate" + +-- | minus operation identifier +minusId :: String +minusId = "-" + +-- | convert sizedword to ranged +fromSizedWordId :: String +fromSizedWordId = "fromSizedWord" + +toIntegerId :: String +toIntegerId = "to_integer" + ------------------ -- VHDL type marks ------------------ @@ -251,3 +276,11 @@ naturalTM = AST.unsafeVHDLBasicId "natural" -- | integer TypeMark integerTM :: AST.TypeMark integerTM = AST.unsafeVHDLBasicId "integer" + +-- | signed TypeMark +signedTM :: AST.TypeMark +signedTM = AST.unsafeVHDLBasicId "signed" + +-- | unsigned TypeMark +unsignedTM :: AST.TypeMark +unsignedTM = AST.unsafeVHDLBasicId "unsigned" diff --git a/Generate.hs b/Generate.hs index b3045de..97b8bef 100644 --- a/Generate.hs +++ b/Generate.hs @@ -83,6 +83,16 @@ genFCall' switch (Left res) f args = do map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name +genFromSizedWord :: BuiltinBuilder +genFromSizedWord = genExprArgs $ genExprRes genFromSizedWord' +genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr +genFromSizedWord' (Left res) f args = do + let fname = varToString f + return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId)) $ + 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 + + -- | Generate a generate statement for the builtin function "map" genMap :: BuiltinBuilder genMap (Left res) f [Left mapped_f, Left (Var arg)] = @@ -440,8 +450,8 @@ genApplication dst f args = if length args == arg_count then builder dst f args else - error $ "\nGenerate.genApplication: Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args - Nothing -> error $ "\nGenerate.genApplication: Using function from another module that is not a known builtin: " ++ pprString f + error $ "\nGenerate.genApplication(VanillaGlobal): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args + Nothing -> error $ "\nGenerate.genApplication(VanillaGlobal): Using function from another module that is not a known builtin: " ++ pprString f IdInfo.NotGlobalId -> do signatures <- getA vsSignatures -- This is a local id, so it should be a function whose definition we @@ -457,6 +467,16 @@ genApplication dst f args = portmaps = mkAssocElems (map (either exprToVHDLExpr id) args) ((either varToVHDLName id) dst) signature in return [mkComponentInst label entity_id portmaps] + IdInfo.ClassOpId cls -> do + -- FIXME: Not looking for what instance this class op is called for + -- Is quite stupid of course. + case (Map.lookup (varToString f) globalNameTable) of + Just (arg_count, builder) -> + if length args == arg_count then + builder dst f args + else + error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args + Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details ----------------------------------------------------------------------------- @@ -913,4 +933,9 @@ globalNameTable = Map.fromList , (hwandId , (2, genOperator2 AST.And ) ) , (hworId , (2, genOperator2 AST.Or ) ) , (hwnotId , (1, genOperator1 AST.Not ) ) + , (plusId , (2, genOperator2 (AST.:+:) ) ) + , (timesId , (2, genOperator2 (AST.:*:) ) ) + , (negateId , (1, genOperator1 AST.Not ) ) + , (minusId , (2, genOperator2 (AST.:-:) ) ) + , (fromSizedWordId , (1, genFromSizedWord ) ) ] diff --git a/VHDLTools.hs b/VHDLTools.hs index e4aad6f..3a6060d 100644 --- a/VHDLTools.hs +++ b/VHDLTools.hs @@ -314,9 +314,7 @@ construct_vhdl_ty ty = do let name = Name.getOccString (TyCon.tyConName tycon) case name of "TFVec" -> mk_vector_ty ty - -- "SizedWord" -> do - -- res <- mk_vector_ty (sized_word_len ty) ty - -- return $ Just $ (Arrow.second Left) res + "SizedWord" -> mk_unsigned_ty ty "RangedWord" -> mk_natural_ty 0 (ranged_word_bound ty) -- Create a custom type from this tycon otherwise -> mk_tycon_ty tycon args @@ -408,6 +406,16 @@ mk_natural_ty min_bound max_bound = do let ty_def = AST.SubtypeIn naturalTM (Just range) return (Right (ty_id, Right ty_def)) +mk_unsigned_ty :: + Type.Type -- ^ Haskell type of the signed integer + -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)) +mk_unsigned_ty ty = do + let size = sized_word_len ty + let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1) + let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))] + let ty_def = AST.SubtypeIn signedTM (Just range) + return (Right (ty_id, Right ty_def)) + -- Finds the field labels for VHDL type generated for the given Core type, -- which must result in a record type. getFieldLabels :: Type.Type -> TypeSession [AST.VHDLId] @@ -454,6 +462,8 @@ mkHType ty = do Left err -> return $ Left $ "VHDLTools.mkHType: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n" ++ err + "SizedWord" -> return $ Right $ StdType $ OrdType ty + "RangedWord" -> return $ Right $ StdType $ OrdType ty otherwise -> do mkTyConHType tycon args Nothing -> return $ Right $ StdType $ OrdType ty