183 lines
6.2 KiB
Plaintext
183 lines
6.2 KiB
Plaintext
%include polycode.fmt
|
|
|
|
%if false
|
|
Error: DSL for error definition
|
|
|
|
Copyright (c) 2009 ETH Zurich.
|
|
All rights reserved.
|
|
|
|
This file is distributed under the terms in the attached LICENSE file.
|
|
If you do not find this file, copies can be found by writing to:
|
|
ETH Zurich D-INFK, Universitaetstrasse 6, CH-8092 Zurich. Attn: Systems Group.
|
|
%endif
|
|
|
|
%if false
|
|
|
|
> {-# LANGUAGE BangPatterns #-}
|
|
|
|
> module HamletAst where
|
|
|
|
> import Debug.Trace
|
|
> import Prelude hiding ((<>))
|
|
> import Text.PrettyPrint.HughesPJ as Pprinter
|
|
> import Data.List
|
|
|
|
%endif
|
|
|
|
|
|
> class Pretty a where
|
|
> pretty :: a -> Doc
|
|
|
|
> data Capabilities = Capabilities { defines :: ![Define],
|
|
> capabilities :: ![Capability],
|
|
> abstractCapabilities :: ![Capability] }
|
|
> deriving Show
|
|
|
|
> vcat' :: [Doc] -> Doc
|
|
> vcat' = foldr ($+$) empty
|
|
|
|
|
|
> instance Pretty Capabilities where
|
|
> pretty (Capabilities defs caps absCaps) =
|
|
> text "Capabilities:" $+$
|
|
> nest 4 ( text "Defines:" $+$
|
|
> nest 4 (vcat' $ map pretty defs) $+$
|
|
> text "Caps:" $+$
|
|
> nest 4 (vcat' $ map pretty caps) $+$
|
|
> text "Abstract Caps:" $+$
|
|
> nest 4 (vcat' $ map pretty absCaps))
|
|
|
|
|
|
> data Define = Define !String !Int
|
|
> deriving Show
|
|
|
|
> instance Pretty Define where
|
|
> pretty (Define name val) = text name <+> char '=' <+> int val
|
|
|
|
> mkDefineList :: [Define] -> [(String, Int)]
|
|
> mkDefineList = map (\(Define s i) -> (s, i))
|
|
|
|
> data Capability = Capability { name :: !CapName,
|
|
> generalEquality :: !(Maybe Bool),
|
|
> from :: !(Maybe CapName),
|
|
> fromSelf :: Bool,
|
|
> multiRetype :: Bool,
|
|
> fields :: ![CapField],
|
|
> rangeExpr :: !(Maybe (AddressExpr, SizeExpr)),
|
|
> eqFields :: ![NameField],
|
|
> abstract :: Bool,
|
|
> needsType :: Bool,
|
|
> inherit :: !(Maybe CapName) }
|
|
> deriving Show
|
|
|
|
> instance Pretty Capability where
|
|
> pretty (Capability (CapName name)
|
|
> genEq
|
|
> from
|
|
> fromSelf
|
|
> multiRetype
|
|
> fields
|
|
> rangeExpr
|
|
> eqFields
|
|
> abstract
|
|
> needsType
|
|
> inherit) =
|
|
> text name $+$
|
|
> nest 4 (text "General Equality:" <+> text (show genEq) $+$
|
|
> case from of
|
|
> Nothing -> text $ if fromSelf then "From self" else "From nothing"
|
|
> Just (CapName fromName) ->
|
|
> text "From:" <+> text fromName <> text (if fromSelf then " and self" else "")
|
|
> $+$
|
|
> case abstract of
|
|
> True -> text " abstract "
|
|
> False -> text ""
|
|
> $+$
|
|
> case needsType of
|
|
> True -> text " needsType "
|
|
> False -> text ""
|
|
> $+$
|
|
> case inherit of
|
|
> Nothing -> text ""
|
|
> Just (CapName inheritName) ->
|
|
> text "inherit " <+> text inheritName
|
|
> $+$
|
|
> text "Fields:" <> text (if null fields then " None" else "") $+$
|
|
> text (if multiRetype then "Can be retyped multiple times." else "") $+$
|
|
> nest 4 (vcat' (map pretty fields)) $+$
|
|
> (case rangeExpr of
|
|
> Nothing -> text "Not addressable"
|
|
> Just (addressExpr, sizeExprE) ->
|
|
> (text "Address expr:" <+> pretty addressExpr $+$
|
|
> text "Size expr:" <+> (pretty sizeExprE)))
|
|
> $+$
|
|
> text "Equality fields:" <+> (text $ intercalate ", " $ map (\(NameField n) -> n) eqFields))
|
|
|
|
> data CapName = CapName !String
|
|
> deriving (Show, Eq)
|
|
|
|
> data CapField = CapField !Type !NameField
|
|
> deriving Show
|
|
> instance Pretty CapField where
|
|
> pretty (CapField typ (NameField name)) =
|
|
> text (show typ) <+> text name
|
|
|
|
> data NameField = NameField !String
|
|
> deriving Show
|
|
|
|
> data Type = UInt8
|
|
> | UInt16
|
|
> | UInt32
|
|
> | UInt64
|
|
> | Int
|
|
> | GenPAddr
|
|
> | GenSize
|
|
> | LPAddr
|
|
> | GenVAddr
|
|
> | LVAddr
|
|
> | CAddr
|
|
> | Pointer String
|
|
> | CapRights
|
|
> | CoreId
|
|
> | PasId
|
|
> deriving Show
|
|
|
|
> instance Read Type where
|
|
> readsPrec _ s
|
|
> | s == "uint8" = [(UInt8, "")]
|
|
> | s == "uint16" = [(UInt16, "")]
|
|
> | s == "uint32" = [(UInt32, "")]
|
|
> | s == "uint64" = [(UInt64, "")]
|
|
> | s == "int" = [(Int, "")]
|
|
> | s == "genpaddr" = [(GenPAddr, "")]
|
|
> | s == "gensize" = [(GenSize, "")]
|
|
> | s == "lpaddr" = [(LPAddr, "")]
|
|
> | s == "genvaddr" = [(GenVAddr, "")]
|
|
> | s == "lvaddr" = [(LVAddr, "")]
|
|
> | s == "caddr" = [(CAddr, "")]
|
|
> | s == "caprights" = [(CapRights, "")]
|
|
> | s == "coreid" = [(CoreId, "")]
|
|
> | s == "pasid" = [(PasId, "")]
|
|
> | otherwise = [(Pointer s, "")]
|
|
|
|
> data AddressExpr = AddressExpr Expr | MemToPhysOp Expr | GetAddrOp Expr
|
|
> deriving Show
|
|
> instance Pretty AddressExpr where
|
|
> pretty (AddressExpr e) = pretty e
|
|
> pretty (MemToPhysOp e) = text "mem_to_phys(" <> pretty e <> text ")"
|
|
> pretty (GetAddrOp e) = text "get_address(" <> pretty e <> text ")"
|
|
|
|
> data SizeExpr = ZeroSize | SizeExpr Expr | SizeBitsExpr Expr
|
|
> deriving Show
|
|
> instance Pretty SizeExpr where
|
|
> pretty (ZeroSize) = text "0"
|
|
> pretty (SizeExpr e) = pretty e
|
|
> pretty (SizeBitsExpr e) = text "2^(" <> pretty e <> char ')'
|
|
|
|
> data Expr = AddExpr String String | NameExpr String
|
|
> deriving Show
|
|
> instance Pretty Expr where
|
|
> pretty (AddExpr l r) = text $ concat ["(", l, " + ", r, ")"]
|
|
> pretty (NameExpr n) = text n
|
|
|