From: Matthijs Kooijman Date: Wed, 3 Mar 2010 12:20:43 +0000 (+0100) Subject: Ignore all applications that have an empty result type. X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=605b2619859ef7a55017e86f11fb501c62bd9248;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Ignore all applications that have an empty result type. --- diff --git "a/c\316\273ash/CLasH/VHDL/Generate.hs" "b/c\316\273ash/CLasH/VHDL/Generate.hs" index 76547aa..1d8194d 100644 --- "a/c\316\273ash/CLasH/VHDL/Generate.hs" +++ "b/c\316\273ash/CLasH/VHDL/Generate.hs" @@ -1008,118 +1008,124 @@ genApplication :: -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]) -- ^ The corresponding VHDL concurrent statements and entities -- instantiated. -genApplication dst f args = - if Var.isGlobalId f then - case Var.idDetails f of - IdInfo.DataConWorkId dc -> case dst of - -- It's a datacon. Create a record from its arguments. - Left bndr -> do - -- We have the bndr, so we can get at the type - htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr) - let argsNostate = filter (\x -> not (either hasStateType (\x -> False) x)) args - case argsNostate of - [arg] -> do - [arg'] <- argsToVHDLExprs [arg] - return ([mkUncondAssign dst arg'], []) - otherwise -> - case htype of - Right (AggrType _ _) -> do - labels <- MonadState.lift tsType $ getFieldLabels (Var.varType bndr) - args' <- argsToVHDLExprs argsNostate - return (zipWith mkassign labels args', []) - where - mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm - mkassign label arg = - let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in - mkUncondAssign (Right sel_name) arg - _ -> do -- error $ "DIE!" - args' <- argsToVHDLExprs argsNostate - return ([mkUncondAssign dst (head args')], []) - Right _ -> error "\nGenerate.genApplication(DataConWorkId): Can't generate dataconstructor application without an original binder" - IdInfo.DataConWrapId dc -> case dst of - -- It's a datacon. Create a record from its arguments. - Left bndr -> - 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(DataConWrapId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args - Nothing -> error $ "\nGenerate.genApplication(DataConWrapId): Can't generate dataconwrapper: " ++ (show dc) - Right _ -> error "\nGenerate.genApplication(DataConWrapId): Can't generate dataconwrapper application without an original binder" - IdInfo.VanillaId -> - -- It's a global value imported from elsewhere. These can be builtin - -- functions. Look up the function name in the name table and execute - -- the associated builder if there is any and the argument count matches - -- (this should always be the case if it typechecks, but just to be - -- sure...). - 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(VanillaId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args - Nothing -> do - top <- isTopLevelBinder f - if top then - do - -- Local binder that references a top level binding. Generate a - -- component instantiation. - signature <- getEntity f - args' <- argsToVHDLExprs args - let entity_id = ent_id signature - -- TODO: Using show here isn't really pretty, but we'll need some - -- unique-ish value... - let label = "comp_ins_" ++ (either show prettyShow) dst - let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature - return ([mkComponentInst label entity_id portmaps], [f]) - else - -- Not a top level binder, so this must be a local variable reference. - -- It should have a representable type (and thus, no arguments) and a - -- signal should be generated for it. Just generate an unconditional - -- assignment here. - -- FIXME : I DONT KNOW IF THE ABOVE COMMENT HOLDS HERE, SO FOR NOW JUST ERROR! - -- f' <- MonadState.lift tsType $ varToVHDLExpr f - -- return $ ([mkUncondAssign dst f'], []) - do errtype <- case dst of - Left bndr -> do - htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr) - return (show htype) - Right vhd -> return $ show vhd - error ("\nGenerate.genApplication(VanillaId): Using function from another module that is not a known builtin: " ++ (pprString f) ++ "::" ++ errtype) - IdInfo.ClassOpId cls -> - -- 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 +genApplication dst f args = do + nonemptydst <- case dst of + Left bndr -> hasNonEmptyType bndr + Right _ -> return True + if nonemptydst + then + if Var.isGlobalId f then + case Var.idDetails f of + IdInfo.DataConWorkId dc -> case dst of + -- It's a datacon. Create a record from its arguments. + Left bndr -> do + -- We have the bndr, so we can get at the type + htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr) + let argsNostate = filter (\x -> not (either hasStateType (\x -> False) x)) args + case argsNostate of + [arg] -> do + [arg'] <- argsToVHDLExprs [arg] + return ([mkUncondAssign dst arg'], []) + otherwise -> + case htype of + Right (AggrType _ _) -> do + labels <- MonadState.lift tsType $ getFieldLabels (Var.varType bndr) + args' <- argsToVHDLExprs argsNostate + return (zipWith mkassign labels args', []) + where + mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm + mkassign label arg = + let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in + mkUncondAssign (Right sel_name) arg + _ -> do -- error $ "DIE!" + args' <- argsToVHDLExprs argsNostate + return ([mkUncondAssign dst (head args')], []) + Right _ -> error "\nGenerate.genApplication(DataConWorkId): Can't generate dataconstructor application without an original binder" + IdInfo.DataConWrapId dc -> case dst of + -- It's a datacon. Create a record from its arguments. + Left bndr -> + 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(DataConWrapId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args + Nothing -> error $ "\nGenerate.genApplication(DataConWrapId): Can't generate dataconwrapper: " ++ (show dc) + Right _ -> error "\nGenerate.genApplication(DataConWrapId): Can't generate dataconwrapper application without an original binder" + IdInfo.VanillaId -> + -- It's a global value imported from elsewhere. These can be builtin + -- functions. Look up the function name in the name table and execute + -- the associated builder if there is any and the argument count matches + -- (this should always be the case if it typechecks, but just to be + -- sure...). + 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(VanillaId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args + Nothing -> do + top <- isTopLevelBinder f + if top then + do + -- Local binder that references a top level binding. Generate a + -- component instantiation. + signature <- getEntity f + args' <- argsToVHDLExprs args + let entity_id = ent_id signature + -- TODO: Using show here isn't really pretty, but we'll need some + -- unique-ish value... + let label = "comp_ins_" ++ (either show prettyShow) dst + let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature + return ([mkComponentInst label entity_id portmaps], [f]) + else + -- Not a top level binder, so this must be a local variable reference. + -- It should have a representable type (and thus, no arguments) and a + -- signal should be generated for it. Just generate an unconditional + -- assignment here. + -- FIXME : I DONT KNOW IF THE ABOVE COMMENT HOLDS HERE, SO FOR NOW JUST ERROR! + -- f' <- MonadState.lift tsType $ varToVHDLExpr f + -- return $ ([mkUncondAssign dst f'], []) + do errtype <- case dst of + Left bndr -> do + htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr) + return (show htype) + Right vhd -> return $ show vhd + error ("\nGenerate.genApplication(VanillaId): Using function from another module that is not a known builtin: " ++ (pprString f) ++ "::" ++ errtype) + IdInfo.ClassOpId cls -> + -- 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 + else do + top <- isTopLevelBinder f + if top then + do + -- Local binder that references a top level binding. Generate a + -- component instantiation. + signature <- getEntity f + args' <- argsToVHDLExprs args + let entity_id = ent_id signature + -- TODO: Using show here isn't really pretty, but we'll need some + -- unique-ish value... + let label = "comp_ins_" ++ (either (prettyShow . varToVHDLName) prettyShow) dst + let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature + return ([mkComponentInst label entity_id portmaps], [f]) 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 - else do - top <- isTopLevelBinder f - if top then - do - -- Local binder that references a top level binding. Generate a - -- component instantiation. - signature <- getEntity f - args' <- argsToVHDLExprs args - let entity_id = ent_id signature - -- TODO: Using show here isn't really pretty, but we'll need some - -- unique-ish value... - let label = "comp_ins_" ++ (either (prettyShow . varToVHDLName) prettyShow) dst - let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature - return ([mkComponentInst label entity_id portmaps], [f]) - else - -- Not a top level binder, so this must be a local variable reference. - -- It should have a representable type (and thus, no arguments) and a - -- signal should be generated for it. Just generate an unconditional - -- assignment here. - do f' <- MonadState.lift tsType $ varToVHDLExpr f - return ([mkUncondAssign dst f'], []) - + -- Not a top level binder, so this must be a local variable reference. + -- It should have a representable type (and thus, no arguments) and a + -- signal should be generated for it. Just generate an unconditional + -- assignment here. + do f' <- MonadState.lift tsType $ varToVHDLExpr f + return ([mkUncondAssign dst f'], []) + else -- Destination has empty type, don't generate anything + return ([], []) ----------------------------------------------------------------------------- -- Functions to generate functions dealing with vectors. -----------------------------------------------------------------------------