X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=c%CE%BBash%2FCLasH%2FVHDL%2FGenerate.hs;h=76547aa96e63f990388888165d0f6ce4d120aeec;hb=b0c68f6de8cf59fbddb9aabb9ff10d6dabe68bf8;hp=897c22a53623b4cd69749c87ad78574f468b12be;hpb=a22be9b8daa77ed2da9b1d9046bdac1e7da932ca;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git "a/c\316\273ash/CLasH/VHDL/Generate.hs" "b/c\316\273ash/CLasH/VHDL/Generate.hs" index 897c22a..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) @@ -752,30 +758,50 @@ genSnd' (Left res) f args@[arg] = do { genUnzip :: BuiltinBuilder genUnzip = genNoInsts $ genVarArgs genUnzip' genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm] -genUnzip' (Left res) f args@[arg] = do { - -- Setup the generate scheme - ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg - -- TODO: Use something better than varToString - ; let { label = mkVHDLExtId ("unzipVector" ++ (varToString res)) - ; n_id = mkVHDLBasicId "n" - ; n_expr = idToVHDLExpr n_id - ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1)) - ; genScheme = AST.ForGn n_id range - ; resname' = varToVHDLName res - ; argexpr' = mkIndexedName (varToVHDLName arg) n_expr - } ; - ; reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res) - ; arglabels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType arg)) - ; let { resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr - ; resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr - ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0) - ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1) - ; resA_assign = mkUncondAssign (Right resnameA) argexprA - ; resB_assign = mkUncondAssign (Right resnameB) argexprB - } ; - -- Return the generate functions - ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]] - } +genUnzip' (Left res) f args@[arg] = do + let error_msg = "\nGenerate.genUnzip: Cannot generate unzip call: " ++ pprString res ++ " = " ++ pprString f ++ " " ++ pprString arg + htype <- MonadState.lift tsType $ mkHType error_msg (Var.varType arg) + -- Prepare a unconditional assignment, for the case when either part + -- of the unzip is a state variable, which will disappear in the + -- resulting VHDL, making the the unzip no longer required. + case htype of + -- A normal vector containing two-tuples + VecType _ (AggrType _ [_, _]) -> do { + -- Setup the generate scheme + ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg + -- TODO: Use something better than varToString + ; let { label = mkVHDLExtId ("unzipVector" ++ (varToString res)) + ; n_id = mkVHDLBasicId "n" + ; n_expr = idToVHDLExpr n_id + ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1)) + ; genScheme = AST.ForGn n_id range + ; resname' = varToVHDLName res + ; argexpr' = mkIndexedName (varToVHDLName arg) n_expr + } ; + ; reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res) + ; arglabels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType arg)) + ; let { resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr + ; resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr + ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0) + ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1) + ; resA_assign = mkUncondAssign (Right resnameA) argexprA + ; resB_assign = mkUncondAssign (Right resnameB) argexprB + } ; + -- Return the generate functions + ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]] + } + -- Both elements of the tuple were state, so they've disappeared. No + -- need to do anything + VecType _ (AggrType _ []) -> return [] + -- A vector containing aggregates with more than two elements? + VecType _ (AggrType _ _) -> error $ "Unzipping a value that is not a vector of two-tuples? Value: " ++ pprString arg ++ "\nType: " ++ pprString (Var.varType arg) + -- One of the elements of the tuple was state, so there won't be a + -- tuple (record) in the VHDL output. We can just do a plain + -- assignment, then. + VecType _ _ -> do + argexpr <- MonadState.lift tsType $ varToVHDLExpr arg + return [mkUncondAssign (Left res) argexpr] + _ -> error $ "Unzipping a value that is not a vector? Value: " ++ pprString arg ++ "\nType: " ++ pprString (Var.varType arg) ++ "\nhtype: " ++ show htype genCopy :: BuiltinBuilder genCopy = genNoInsts $ genVarArgs genCopy' @@ -1104,7 +1130,10 @@ 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 -- TODO: Handle the Nothing case? - Just elemTM <- vhdlTy error_msg el_ty + elemTM_maybe <- vhdlTy error_msg el_ty + let elemTM = Maybe.fromMaybe + (error $ "\nGenerate.vectorFunId: Cannot generate vector function \"" ++ fname ++ "\" for the empty type \"" ++ (pprString el_ty) ++ "\"") + elemTM_maybe -- 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)