From: Matthijs Kooijman Date: Wed, 3 Mar 2010 11:54:52 +0000 (+0100) Subject: Ignore selector cases selecting empty typed values. X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=b0c68f6de8cf59fbddb9aabb9ff10d6dabe68bf8;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Ignore selector cases selecting empty typed values. This occurse when you use unzip in combination with a vector of substates. --- diff --git "a/c\316\273ash/CLasH/VHDL/Generate.hs" "b/c\316\273ash/CLasH/VHDL/Generate.hs" index c302bf0..76547aa 100644 --- "a/c\316\273ash/CLasH/VHDL/Generate.hs" +++ "b/c\316\273ash/CLasH/VHDL/Generate.hs" @@ -236,29 +236,35 @@ mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt])) | otherwise = case alt of (CoreSyn.DataAlt dc, bndrs, (CoreSyn.Var sel_bndr)) -> do - bndrs' <- Monad.filterM hasNonEmptyType bndrs - case List.elemIndex sel_bndr bndrs' of - Just i -> do - htypeScrt <- MonadState.lift tsType $ mkHTypeEither (Var.varType scrut) - htypeBndr <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr) - case htypeScrt == htypeBndr of - True -> do - let sel_name = varToVHDLName scrut - let sel_expr = AST.PrimName sel_name - return ([mkUncondAssign (Left bndr) sel_expr], []) - otherwise -> - case htypeScrt of - Right (AggrType _ _) -> do - labels <- MonadState.lift tsType $ getFieldLabels (Id.idType scrut) - let label = labels!!i - let sel_name = mkSelectedName (varToVHDLName scrut) label - let sel_expr = AST.PrimName sel_name - return ([mkUncondAssign (Left bndr) sel_expr], []) - _ -> do -- error $ "DIE!" + nonemptysel <- hasNonEmptyType sel_bndr + if nonemptysel + then do + bndrs' <- Monad.filterM hasNonEmptyType bndrs + case List.elemIndex sel_bndr bndrs' of + Just i -> do + htypeScrt <- MonadState.lift tsType $ mkHTypeEither (Var.varType scrut) + htypeBndr <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr) + case htypeScrt == htypeBndr of + True -> do let sel_name = varToVHDLName scrut let sel_expr = AST.PrimName sel_name return ([mkUncondAssign (Left bndr) sel_expr], []) - Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr) + otherwise -> + case htypeScrt of + Right (AggrType _ _) -> do + labels <- MonadState.lift tsType $ getFieldLabels (Id.idType scrut) + let label = labels!!i + let sel_name = mkSelectedName (varToVHDLName scrut) label + let sel_expr = AST.PrimName sel_name + return ([mkUncondAssign (Left bndr) sel_expr], []) + _ -> do -- error $ "DIE!" + let sel_name = varToVHDLName scrut + let sel_expr = AST.PrimName sel_name + return ([mkUncondAssign (Left bndr) sel_expr], []) + Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case: result is not one of the binders\n" ++ (pprString expr) + else + -- A selector case that selects a state value, ignore it. + return ([], []) _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)