| 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)
}
genResize' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+genTimes :: BuiltinBuilder
+genTimes = genNoInsts $ genExprArgs $ genExprRes genTimes'
+genTimes' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
+genTimes' (Left res) f [arg1,arg2] = do {
+ ; let { ty = Var.varType res
+ ; (tycon, args) = Type.splitTyConApp ty
+ ; name = Name.getOccString (TyCon.tyConName tycon)
+ } ;
+ ; len <- case name of
+ "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
+ "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
+ "RangedWord" -> do { ubound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
+ ; let bitsize = floor (logBase 2 (fromInteger (toInteger ubound)))
+ ; return bitsize
+ }
+ ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
+ [Nothing AST.:=>: AST.ADExpr (arg1 AST.:*: arg2), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
+ }
+genTimes' (Right name) _ _ = error $ "\nGenerate.genTimes': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+
-- FIXME: I'm calling genLitArgs which is very specific function,
-- which needs to be fixed as well
genFromInteger :: BuiltinBuilder
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'
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)
, (boolOrId , (2, genOperator2 AST.Or ) )
, (boolAndId , (2, genOperator2 AST.And ) )
, (plusId , (2, genOperator2 (AST.:+:) ) )
- , (timesId , (2, genOperator2 (AST.:*:) ) )
+ , (timesId , (2, genTimes ) )
, (negateId , (1, genNegation ) )
, (minusId , (2, genOperator2 (AST.:-:) ) )
, (fromSizedWordId , (1, genFromSizedWord ) )
projects / matthijs / master-project / cλash.git / blobdiff