X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Generate.hs;h=a72cc62d409205bdd6a36d2c11b64af46cef5330;hb=7eb34cb0e082185b256b7231ee84cb04e006f51c;hp=6b19bb5d729806ee0eb18e8f3a9faaa2e269ee93;hpb=afd269e5653952394495a7a14ad1bfc0c0146b39;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/Generate.hs b/Generate.hs index 6b19bb5..a72cc62 100644 --- a/Generate.hs +++ b/Generate.hs @@ -17,6 +17,9 @@ import CoreSyn import Type import qualified Var import qualified IdInfo +import qualified Literal +import qualified Name +import qualified TyCon -- Local imports import Constants @@ -48,6 +51,18 @@ genVarArgs wrap dst func args = wrap dst func args' -- Check (rather crudely) that all arguments are CoreExprs (exprargs, []) = Either.partitionEithers args +-- | A function to wrap a builder-like function that expects its arguments to +-- be Literals +genLitArgs :: + (dst -> func -> [Literal.Literal] -> res) + -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res) +genLitArgs wrap dst func args = wrap dst func args' + where + args' = map exprToLit litargs + -- FIXME: Check if we were passed an CoreSyn.App + litargs = concat (map getLiterals exprargs) + (exprargs, []) = Either.partitionEithers args + -- | A function to wrap a builder-like function that produces an expression -- and expects it to be assigned to the destination. genExprRes :: @@ -70,18 +85,62 @@ genOperator1 op = genExprArgs $ genExprRes (genOperator1' op) genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr genOperator1' op _ f [arg] = return $ op arg +-- | Generate a unary operator application +genNegation :: BuiltinBuilder +genNegation = genVarArgs $ genExprRes genNegation' +genNegation' :: dst -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession AST.Expr +genNegation' _ f [arg] = return $ op (varToVHDLExpr arg) + where + ty = Var.varType arg + (tycon, args) = Type.splitTyConApp ty + name = Name.getOccString (TyCon.tyConName tycon) + op = case name of + "SizedInt" -> AST.Neg + otherwise -> error $ "\nGenerate.genNegation': Negation allowed for type: " ++ show name + -- | Generate a function call from the destination binder, function name and a -- list of expressions (its arguments) -genFCall :: BuiltinBuilder -genFCall = genExprArgs $ genExprRes genFCall' -genFCall' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr -genFCall' (Left res) f args = do +genFCall :: Bool -> BuiltinBuilder +genFCall switch = genExprArgs $ genExprRes (genFCall' switch) +genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr +genFCall' switch (Left res) f args = do let fname = varToString f - let el_ty = (tfvec_elem . Var.varType) res + let el_ty = if switch then (Var.varType res) else ((tfvec_elem . Var.varType) res) id <- MonadState.lift vsType $ vectorFunId el_ty fname return $ AST.PrimFCall $ AST.FCall (AST.NSimple id) $ 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 +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 + +-- FIXME: I'm calling genLitArgs which is very specific function, +-- which needs to be fixed as well +genFromInteger :: BuiltinBuilder +genFromInteger = genLitArgs $ genExprRes genFromInteger' +genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [Literal.Literal] -> VHDLSession AST.Expr +genFromInteger' (Left res) f lits = + 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))] + where + ty = Var.varType res + (tycon, args) = Type.splitTyConApp ty + name = Name.getOccString (TyCon.tyConName tycon) + len = case name of + "SizedInt" -> sized_int_len ty + "SizedWord" -> sized_word_len ty + fname = case name of + "SizedInt" -> toSignedId + "SizedWord" -> toUnsignedId + +genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name + -- | Generate a generate statement for the builtin function "map" genMap :: BuiltinBuilder @@ -440,8 +499,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 +516,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 ----------------------------------------------------------------------------- @@ -875,42 +944,48 @@ genUnconsVectorFuns elemTM vectorTM = -- builder function. globalNameTable :: NameTable globalNameTable = Map.fromList - [ (exId , (2, genFCall ) ) - , (replaceId , (3, genFCall ) ) - , (headId , (1, genFCall ) ) - , (lastId , (1, genFCall ) ) - , (tailId , (1, genFCall ) ) - , (initId , (1, genFCall ) ) - , (takeId , (2, genFCall ) ) - , (dropId , (2, genFCall ) ) - , (selId , (4, genFCall ) ) - , (plusgtId , (2, genFCall ) ) - , (ltplusId , (2, genFCall ) ) - , (plusplusId , (2, genFCall ) ) + [ (exId , (2, genFCall False ) ) + , (replaceId , (3, genFCall False ) ) + , (headId , (1, genFCall True ) ) + , (lastId , (1, genFCall True ) ) + , (tailId , (1, genFCall False ) ) + , (initId , (1, genFCall False ) ) + , (takeId , (2, genFCall False ) ) + , (dropId , (2, genFCall False ) ) + , (selId , (4, genFCall False ) ) + , (plusgtId , (2, genFCall False ) ) + , (ltplusId , (2, genFCall False ) ) + , (plusplusId , (2, genFCall False ) ) , (mapId , (2, genMap ) ) , (zipWithId , (3, genZipWith ) ) , (foldlId , (3, genFoldl ) ) , (foldrId , (3, genFoldr ) ) , (zipId , (2, genZip ) ) , (unzipId , (1, genUnzip ) ) - , (shiftlId , (2, genFCall ) ) - , (shiftrId , (2, genFCall ) ) - , (rotlId , (1, genFCall ) ) - , (rotrId , (1, genFCall ) ) + , (shiftlId , (2, genFCall False ) ) + , (shiftrId , (2, genFCall False ) ) + , (rotlId , (1, genFCall False ) ) + , (rotrId , (1, genFCall False ) ) , (concatId , (1, genConcat ) ) - , (reverseId , (1, genFCall ) ) + , (reverseId , (1, genFCall False ) ) , (iteratenId , (3, genIteraten ) ) , (iterateId , (2, genIterate ) ) , (generatenId , (3, genGeneraten ) ) , (generateId , (2, genGenerate ) ) - , (emptyId , (0, genFCall ) ) - , (singletonId , (1, genFCall ) ) - , (copynId , (2, genFCall ) ) + , (emptyId , (0, genFCall False ) ) + , (singletonId , (1, genFCall False ) ) + , (copynId , (2, genFCall False ) ) , (copyId , (1, genCopy ) ) - , (lengthTId , (1, genFCall ) ) - , (nullId , (1, genFCall ) ) + , (lengthTId , (1, genFCall False ) ) + , (nullId , (1, genFCall False ) ) , (hwxorId , (2, genOperator2 AST.Xor ) ) , (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, genNegation ) ) + , (minusId , (2, genOperator2 (AST.:-:) ) ) + , (fromSizedWordId , (1, genFromSizedWord ) ) + , (fromIntegerId , (1, genFromInteger ) ) ]