X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Generate.hs;h=97b8bef7ff8c92ebb3738aeaafd64f035e1f20af;hb=8782caddd5cc4df0c68e4025266c9b558e32eb48;hp=55f015608de743e03540a18e52633d66dfbead5f;hpb=c2f45d330f40225e7e5a1b6606665a16c2883d41;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/Generate.hs b/Generate.hs index 55f0156..97b8bef 100644 --- a/Generate.hs +++ b/Generate.hs @@ -6,6 +6,7 @@ import qualified Data.Map as Map import qualified Maybe import qualified Data.Either as Either import Data.Accessor +import Data.Accessor.MonadState as MonadState import Debug.Trace -- ForSyDe @@ -71,16 +72,26 @@ genOperator1' op _ f [arg] = return $ op arg -- | 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 - id <- vectorFunId el_ty fname + 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 + -- | Generate a generate statement for the builtin function "map" genMap :: BuiltinBuilder @@ -155,7 +166,7 @@ genFold' left (Left res) f [folded_f, start, vec] = do -- temporary vector let tmp_ty = Type.mkAppTy nvec (Var.varType start) let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty - tmp_vhdl_ty <- vhdl_ty error_msg tmp_ty + tmp_vhdl_ty <- MonadState.lift vsType $ vhdl_ty error_msg tmp_ty -- Setup the generate scheme let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec)) let block_label = mkVHDLExtId ("foldlVector" ++ (varToString start)) @@ -245,7 +256,7 @@ genZip' (Left res) f args@[arg1, arg2] = argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr in do - labels <- getFieldLabels (tfvec_elem (Var.varType res)) + labels <- MonadState.lift vsType $ getFieldLabels (tfvec_elem (Var.varType res)) let resnameA = mkSelectedName resname' (labels!!0) let resnameB = mkSelectedName resname' (labels!!1) let resA_assign = mkUncondAssign (Right resnameA) argexpr1 @@ -270,8 +281,8 @@ genUnzip' (Left res) f args@[arg] = resname' = varToVHDLName res argexpr' = mkIndexedName (varToVHDLName arg) n_expr in do - reslabels <- getFieldLabels (Var.varType res) - arglabels <- getFieldLabels (tfvec_elem (Var.varType arg)) + reslabels <- MonadState.lift vsType $ getFieldLabels (Var.varType res) + arglabels <- MonadState.lift vsType $ getFieldLabels (tfvec_elem (Var.varType arg)) let resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr let resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr let argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0) @@ -346,7 +357,7 @@ genIterateOrGenerate' iter (Left res) f [app_f, start] = do -- -- temporary vector let tmp_ty = Var.varType res let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty - tmp_vhdl_ty <- vhdl_ty error_msg tmp_ty + tmp_vhdl_ty <- MonadState.lift vsType $ vhdl_ty error_msg tmp_ty -- Setup the generate scheme let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start)) let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res)) @@ -420,7 +431,7 @@ genApplication dst f args = -- It's a datacon. Create a record from its arguments. Left bndr -> do -- We have the bndr, so we can get at the type - labels <- getFieldLabels (Var.varType bndr) + labels <- MonadState.lift vsType $ getFieldLabels (Var.varType bndr) return $ zipWith mkassign labels $ map (either exprToVHDLExpr id) args where mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm @@ -439,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 @@ -456,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 ----------------------------------------------------------------------------- @@ -464,7 +485,7 @@ genApplication dst f args = -- Returns the VHDLId of the vector function with the given name for the given -- element type. Generates -- this function if needed. -vectorFunId :: Type.Type -> String -> VHDLSession AST.VHDLId +vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId vectorFunId el_ty fname = do let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty elemTM <- vhdl_ty error_msg el_ty @@ -874,42 +895,47 @@ 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, genOperator1 AST.Not ) ) + , (minusId , (2, genOperator2 (AST.:-:) ) ) + , (fromSizedWordId , (1, genFromSizedWord ) ) ]