X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=Generate.hs;h=14589194e04dd95ba4a00788a3ca08ef1f392db9;hb=ce7380ad772e2a81c0329c6ee495e18fa0a62280;hp=3e3a21d1fa356b8c20a403de4e90283a2600c37f;hpb=bdaeea7a42e08a5a2bc88b44a9cf320266cb2b73;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/Generate.hs b/Generate.hs index 3e3a21d..1458919 100644 --- a/Generate.hs +++ b/Generate.hs @@ -80,13 +80,15 @@ genFCall' (Left res) f args = do id <- vectorFunId el_ty fname return $ AST.PrimFCall $ AST.FCall (AST.NSimple id) $ map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args -genFCall' (Right name) _ _ = error $ "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 -- | Generate a generate statement for the builtin function "map" genMap :: BuiltinBuilder -genMap = genVarArgs genMap' -genMap' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm] -genMap' (Left res) f [mapped_f, arg] = +genMap (Left res) f [Left mapped_f, Left (Var arg)] = + -- mapped_f must be a CoreExpr (since we can't represent functions as VHDL + -- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since + -- we must index it (which we couldn't if it was a VHDL Expr, since only + -- VHDLNames can be indexed). let -- Setup the generate scheme len = (tfvec_len . Var.varType) res @@ -102,11 +104,13 @@ genMap' (Left res) f [mapped_f, arg] = resname = mkIndexedName (varToVHDLName res) n_expr argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr in do - app_concsms <- genApplication (Right resname) mapped_f [Right argexpr] + let (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs mapped_f + let valargs = get_val_args (Var.varType real_f) already_mapped_args + app_concsms <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr]) -- Return the generate statement return [AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms] -genMap' (Right name) _ _ = error $ "Cannot generate map function call assigned to a VHDLName: " ++ show name +genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name genZipWith :: BuiltinBuilder genZipWith = genVarArgs genZipWith' @@ -150,7 +154,8 @@ genFold' left (Left res) f [folded_f, start, vec] = do -- Put the type of the start value in nvec, this will be the type of our -- temporary vector let tmp_ty = Type.mkAppTy nvec (Var.varType start) - tmp_vhdl_ty <- vhdl_ty tmp_ty + 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 -- Setup the generate scheme let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec)) let block_label = mkVHDLExtId ("foldlVector" ++ (varToString start)) @@ -276,6 +281,19 @@ genUnzip' (Left res) f args@[arg] = -- Return the generate functions return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]] +genCopy :: BuiltinBuilder +genCopy = genVarArgs genCopy' +genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm] +genCopy' (Left res) f args@[arg] = + let + resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others) + (AST.PrimName $ (varToVHDLName arg))] + out_assign = mkUncondAssign (Left res) resExpr + in + return [out_assign] + + + ----------------------------------------------------------------------------- -- Function to generate VHDL for applications ----------------------------------------------------------------------------- @@ -297,7 +315,7 @@ genApplication dst f args = mkassign label arg = let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in mkUncondAssign (Right sel_name) arg - Right _ -> error $ "Generate.genApplication Can't generate dataconstructor application without an original binder" + Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconstructor application without an original binder" IdInfo.VanillaGlobal -> do -- It's a global value imported from elsewhere. These can be builtin -- functions. Look up the function name in the name table and execute @@ -309,15 +327,15 @@ genApplication dst f args = if length args == arg_count then builder dst f args else - error $ "Generate.genApplication Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args - Nothing -> error $ "Using function from another module that is not a known builtin: " ++ pprString f + 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 IdInfo.NotGlobalId -> do signatures <- getA vsSignatures -- This is a local id, so it should be a function whose definition we -- have and which can be turned into a component instantiation. let signature = Maybe.fromMaybe - (error $ "Using function '" ++ (varToString f) ++ "' without signature? This should not happen!") + (error $ "\nGenerate.genApplication: Using function '" ++ (varToString f) ++ "' without signature? This should not happen!") (Map.lookup f signatures) entity_id = ent_id signature -- TODO: Using show here isn't really pretty, but we'll need some @@ -326,7 +344,7 @@ genApplication dst f args = portmaps = mkAssocElems (map (either exprToVHDLExpr id) args) ((either varToVHDLName id) dst) signature in return [mkComponentInst label entity_id portmaps] - details -> error $ "Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details + details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details ----------------------------------------------------------------------------- -- Functions to generate functions dealing with vectors. @@ -336,7 +354,8 @@ genApplication dst f args = -- element type. Generates -- this function if needed. vectorFunId :: Type.Type -> String -> VHDLSession AST.VHDLId vectorFunId el_ty fname = do - elemTM <- vhdl_ty el_ty + let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty + elemTM <- vhdl_ty error_msg el_ty -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in -- the VHDLState or something. let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM) @@ -351,7 +370,7 @@ vectorFunId el_ty fname = do Just body -> do modA vsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, body) return function_id - Nothing -> error $ "I don't know how to generate vector function " ++ fname + Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname where function_id = mkVHDLExtId fname @@ -370,7 +389,7 @@ genUnconsVectorFuns elemTM vectorTM = , (plusgtId, AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet]) , (emptyId, AST.SubProgBody emptySpec [AST.SPCD emptyVar] [emptyExpr]) , (singletonId, AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet]) - , (copyId, AST.SubProgBody copySpec [AST.SPVD copyVar] [copyExpr]) + , (copynId, AST.SubProgBody copynSpec [AST.SPVD copynVar] [copynExpr]) , (selId, AST.SubProgBody selSpec [AST.SPVD selVar] [selFor, selRet]) , (ltplusId, AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet] ) , (plusplusId, AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet]) @@ -534,10 +553,10 @@ genUnconsVectorFuns elemTM vectorTM = (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others) (AST.PrimName $ AST.NSimple aPar)]) singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId) - copySpec = AST.Function (mkVHDLExtId copyId) [AST.IfaceVarDec nPar naturalTM, + copynSpec = AST.Function (mkVHDLExtId copynId) [AST.IfaceVarDec nPar naturalTM, AST.IfaceVarDec aPar elemTM ] vectorTM -- variable res : fsvec_x (0 to n-1) := (others => a); - copyVar = + copynVar = AST.VarDec resId (AST.SubtypeIn vectorTM (Just $ AST.ConstraintIndex $ AST.IndexConstraint @@ -547,7 +566,7 @@ genUnconsVectorFuns elemTM vectorTM = (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others) (AST.PrimName $ AST.NSimple aPar)]) -- return res - copyExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId) + copynExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId) selSpec = AST.Function (mkVHDLExtId selId) [AST.IfaceVarDec fPar naturalTM, AST.IfaceVarDec sPar naturalTM, AST.IfaceVarDec nPar naturalTM, @@ -611,7 +630,7 @@ genUnconsVectorFuns elemTM vectorTM = lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)) - + ----------------------------------------------------------------------------- -- A table of builtin functions ----------------------------------------------------------------------------- @@ -640,7 +659,8 @@ globalNameTable = Map.fromList , (unzipId , (1, genUnzip ) ) , (emptyId , (0, genFCall ) ) , (singletonId , (1, genFCall ) ) - , (copyId , (2, genFCall ) ) + , (copynId , (2, genFCall ) ) + , (copyId , (1, genCopy ) ) , (lengthTId , (1, genFCall ) ) , (hwxorId , (2, genOperator2 AST.Xor ) ) , (hwandId , (2, genOperator2 AST.And ) )