From: Christiaan Baaij Date: Mon, 22 Jun 2009 10:22:31 +0000 (+0200) Subject: Added subtype declarations to TypeMap, removed SubtypeMap. X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=ef589dec9b04aa3d0a30a2b0787c50d07c320563;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Added subtype declarations to TypeMap, removed SubtypeMap. Merge branch 'cλash' of http://git.stderr.nl/matthijs/projects/master-project * 'cλash' of http://git.stderr.nl/matthijs/projects/master-project: (32 commits) Support application of dataconstructors. Make mkAssign support assigning to a VHDLName as well. Split off record field selection AST construction. Only try to generate builtin functions for global binders. Never try to normalize global binders. Split off assignment generating code. Support single-alt selector case expressions. Add pprString convenience method. Support single-constructor algebraic types. Move type registration out of construct_vhdl_ty. Split off the VHDL type generating code. Actually use the introduced let from a few commits back... Error out when normalizing polymorphic functions. Add an empty let before starting normalization. Add and use a mkFunction utility function. Make beta reduction of Case expressions work for type arguments. Add function propagation transform. Improve debug output timing. Don't propagate types with free tyvars. Add is_applicable predicate. ... Conflicts: VHDL.hs --- ef589dec9b04aa3d0a30a2b0787c50d07c320563 diff --cc VHDL.hs index f838cba,f0bd3c4..fcfd911 --- a/VHDL.hs +++ b/VHDL.hs @@@ -52,12 -56,10 +56,11 @@@ createDesignFiles binds map (Arrow.second $ AST.DesignFile full_context) units where - init_session = VHDLSession Map.empty Map.empty Map.empty builtin_funcs globalNameTable + init_session = VHDLSession Map.empty Map.empty builtin_funcs globalNameTable (units, final_session) = State.runState (createLibraryUnits binds) init_session - ty_decls = Map.elems (final_session ^. vsTypes) - subty_decls = Map.elems (final_session ^. vsSubTypes) - ty_decls = map (uncurry AST.TypeDec) $ Map.elems (final_session ^. vsTypes) + tyfun_decls = Map.elems (final_session ^.vsTypeFuns) ++ ty_decls = map mktydecl $ Map.elems (final_session ^. vsTypes) ieee_context = [ AST.Library $ mkVHDLBasicId "IEEE", mkUseAll ["IEEE", "std_logic_1164"], @@@ -66,12 -68,7 +69,13 @@@ full_context = mkUseAll ["work", "types"] : ieee_context - type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (packageTypeDecs ++ packageSubtypeDecs ++ subProgSpecs) - type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (map AST.PDITD ty_decls) ++ type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (ty_decls ++ subProgSpecs) + type_package_body = AST.LUPackageBody $ AST.PackageBody typesId (concat tyfun_decls) - packageTypeDecs = map (AST.PDITD . snd) ty_decls - packageSubtypeDecs = map (AST.PDISD . snd) subty_decls + subProgSpecs = concat (map subProgSpec tyfun_decls) + subProgSpec = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec) ++ mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem ++ mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def ++ mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def -- Create a use foo.bar.all statement. Takes a list of components in the used -- name. Must contain at least two components @@@ -308,6 -341,71 +348,71 @@@ mkConcSm (bndr, (Case (Var scrut) b ty mkConcSm (_, (Case (Var _) _ _ alts)) = error "VHDL.mkConcSm Not in normal form: Case statement with more than two alternatives" mkConcSm (_, Case _ _ _ _) = error "VHDL.mkConcSm Not in normal form: Case statement has does not have a simple variable as scrutinee" + -- Create an unconditional assignment statement + mkUncondAssign :: + Either CoreBndr AST.VHDLName -- ^ The signal to assign to + -> AST.Expr -- ^ The expression to assign + -> AST.ConcSm -- ^ The resulting concurrent statement + mkUncondAssign dst expr = mkAssign dst Nothing expr + + -- Create a conditional assignment statement + mkCondAssign :: + Either CoreBndr AST.VHDLName -- ^ The signal to assign to + -> AST.Expr -- ^ The condition + -> AST.Expr -- ^ The value when true + -> AST.Expr -- ^ The value when false + -> AST.ConcSm -- ^ The resulting concurrent statement + mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false + + -- Create a conditional or unconditional assignment statement + mkAssign :: + Either CoreBndr AST.VHDLName -> -- ^ The signal to assign to + Maybe (AST.Expr , AST.Expr) -> -- ^ Optionally, the condition to test for + -- and the value to assign when true. + AST.Expr -> -- ^ The value to assign when false or no condition + AST.ConcSm -- ^ The resulting concurrent statement + + mkAssign dst cond false_expr = + let + -- I'm not 100% how this assignment AST works, but this gets us what we + -- want... + whenelse = case cond of + Just (cond_expr, true_expr) -> + let + true_wform = AST.Wform [AST.WformElem true_expr Nothing] + in + [AST.WhenElse true_wform cond_expr] + Nothing -> [] + false_wform = AST.Wform [AST.WformElem false_expr Nothing] + dst_name = case dst of + Left bndr -> AST.NSimple (bndrToVHDLId bndr) + Right name -> name + assign = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing) + in + AST.CSSASm assign + + -- Create a record field selector that selects the given label from the record + -- stored in the given binder. + mkSelectedName :: CoreBndr -> AST.VHDLId -> AST.VHDLName + mkSelectedName bndr label = + let + sel_prefix = AST.NSimple $ bndrToVHDLId bndr + sel_suffix = AST.SSimple $ label + in + AST.NSelected $ sel_prefix AST.:.: sel_suffix + + -- Finds the field labels for VHDL type generated for the given Core type, + -- which must result in a record type. + getFieldLabels :: Type.Type -> VHDLState [AST.VHDLId] + getFieldLabels ty = do + -- Ensure that the type is generated (but throw away it's VHDLId) + vhdl_ty ty + -- Get the types map, lookup and unpack the VHDL TypeDef + types <- getA vsTypes + case Map.lookup (OrdType ty) types of - Just (_, AST.TDR (AST.RecordTypeDef elems)) -> return $ map (\(AST.ElementDec id _) -> id) elems ++ Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems + _ -> error $ "VHDL.getFieldLabels Type not found or not a record type? This should not happen! Type: " ++ (show ty) + -- Turn a variable reference into a AST expression varToVHDLExpr :: Var.Var -> AST.Expr varToVHDLExpr var = AST.PrimName $ AST.NSimple $ bndrToVHDLId var @@@ -443,19 -541,59 +548,62 @@@ vhdl_ty ty = d Just t -> return t -- No type yet, try to construct it Nothing -> do - let new_ty = do - -- Use the Maybe Monad for failing when one of these fails - (tycon, args) <- Type.splitTyConApp_maybe ty - let name = Name.getOccString (TyCon.tyConName tycon) - case name of - "TFVec" -> Just $ mk_vector_ty (tfvec_len ty) ty - "SizedWord" -> Just $ mk_vector_ty (sized_word_len ty) ty - "RangedWord" -> Just $ mk_natural_ty 0 (ranged_word_bound ty) ty - otherwise -> Nothing - -- Return new_ty when a new type was successfully created - Maybe.fromMaybe - (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty)) - new_ty + newty_maybe <- (construct_vhdl_ty ty) + case newty_maybe of + Just (ty_id, ty_def) -> do + -- TODO: Check name uniqueness + modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_def)) + return ty_id + Nothing -> error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty) + + -- Construct a new VHDL type for the given Haskell type. -construct_vhdl_ty :: Type.Type -> VHDLState (Maybe (AST.TypeMark, AST.TypeDef)) ++construct_vhdl_ty :: Type.Type -> VHDLState (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)) + construct_vhdl_ty ty = do + case Type.splitTyConApp_maybe ty of + Just (tycon, args) -> do + let name = Name.getOccString (TyCon.tyConName tycon) + case name of + "TFVec" -> do + res <- mk_vector_ty (tfvec_len ty) ty - return $ Just res ++ return $ Just $ (Arrow.second Left) res + "SizedWord" -> do + res <- mk_vector_ty (sized_word_len ty) ty - return $ Just res ++ return $ Just $ (Arrow.second Left) res ++ "RangedWord" -> do ++ res <- mk_natural_ty 0 (ranged_word_bound ty) ty ++ return $ Just $ (Arrow.second Right) res + -- Create a custom type from this tycon + otherwise -> mk_tycon_ty tycon args + Nothing -> return $ Nothing + + -- | Create VHDL type for a custom tycon -mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLState (Maybe (AST.TypeMark, AST.TypeDef)) ++mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLState (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)) + mk_tycon_ty tycon args = + case TyCon.tyConDataCons tycon of + -- Not an algebraic type + [] -> error $ "Only custom algebraic types are supported: " ++ (showSDoc $ ppr tycon) + [dc] -> do + let arg_tys = DataCon.dataConRepArgTys dc + -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a + -- violation? Or does it only mean not to apply it again to the same + -- subject? + let real_arg_tys = map (CoreSubst.substTy subst) arg_tys + elem_tys <- mapM vhdl_ty real_arg_tys + let elems = zipWith AST.ElementDec recordlabels elem_tys + -- For a single construct datatype, build a record with one field for + -- each argument. + -- TODO: Add argument type ids to this, to ensure uniqueness + -- TODO: Special handling for tuples? + let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon) + let ty_def = AST.TDR $ AST.RecordTypeDef elems - return $ Just (ty_id, ty_def) ++ return $ Just (ty_id, Left ty_def) + dcs -> error $ "Only single constructor datatypes supported: " ++ (showSDoc $ ppr tycon) + where + -- Create a subst that instantiates all types passed to the tycon + -- TODO: I'm not 100% sure that this is the right way to do this. It seems + -- to work so far, though.. + tyvars = TyCon.tyConTyVars tycon + subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args) -- | Create a VHDL vector type mk_vector_ty :: @@@ -469,25 -607,9 +617,19 @@@ mk_vector_ty len ty = d -- TODO: Use el_ty let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))] let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty - let ty_dec = AST.TypeDec ty_id ty_def - -- TODO: Check name uniqueness - --State.modify (Map.insert (OrdType ty) (ty_id, ty_dec)) - modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_dec)) modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns std_logic_ty ty_id)) - return ty_id + return (ty_id, ty_def) +mk_natural_ty :: + Int -- ^ The minimum bound (> 0) + -> Int -- ^ The maximum bound (> minimum bound) + -> Type.Type -- ^ The Haskell type to create a VHDL type for - -> VHDLState AST.TypeMark -- The typemark created. ++ -> VHDLState (AST.TypeMark, AST.SubtypeIn) -- The typemark created. +mk_natural_ty min_bound max_bound ty = do + let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound) + let ty_def = AST.SubtypeIn naturalTM (Nothing) - let ty_dec = AST.SubtypeDec ty_id ty_def - modA vsSubTypes (Map.insert (OrdType ty) (ty_id, ty_dec)) - return ty_id ++ return (ty_id, ty_def) + builtin_types = Map.fromList [ diff --cc VHDLTypes.hs index 9b48579,5b6807b..cc84289 --- a/VHDLTypes.hs +++ b/VHDLTypes.hs @@@ -43,10 -43,7 +43,7 @@@ instance Ord OrdType wher compare (OrdType a) (OrdType b) = Type.tcCmpType a b -- A map of a Core type to the corresponding type name - type TypeMap = Map.Map OrdType (AST.VHDLId, AST.TypeDec) - - -- A map of a Core type to the corresponding VHDL subtype - type SubTypeMap = Map.Map OrdType (AST.VHDLId, AST.SubtypeDec) -type TypeMap = Map.Map OrdType (AST.VHDLId, AST.TypeDef) ++type TypeMap = Map.Map OrdType (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -- A map of a vector Core type to the coressponding VHDL functions type TypeFunMap = Map.Map OrdType [AST.SubProgBody]