Commit 5bf22f06 authored by Austin Seipp's avatar Austin Seipp

Remove external core

Signed-off-by: default avatarAustin Seipp <austin@well-typed.com>
parent a05f8dd1
......@@ -875,7 +875,7 @@ else
fi;
changequote([, ])dnl
])
if test ! -f compiler/parser/Parser.hs || test ! -f compiler/cmm/CmmParse.hs || test ! -f compiler/parser/ParserCore.hs
if test ! -f compiler/parser/Parser.hs || test ! -f compiler/cmm/CmmParse.hs
then
FP_COMPARE_VERSIONS([$fptools_cv_happy_version],[-lt],[1.19],
[AC_MSG_ERROR([Happy version 1.19 or later is required to compile GHC.])])[]
......
%
% (c) The University of Glasgow 2001-2006
%
\begin{code}
module ExternalCore where
import Data.Word
data Module
= Module Mname [Tdef] [Vdefg]
data Tdef
= Data (Qual Tcon) [Tbind] [Cdef]
| Newtype (Qual Tcon) (Qual Tcon) [Tbind] Ty
data Cdef
= Constr (Qual Dcon) [Tbind] [Ty]
| GadtConstr (Qual Dcon) Ty
data Vdefg
= Rec [Vdef]
| Nonrec Vdef
-- Top-level bindings are qualified, so that the printer doesn't have to pass
-- around the module name.
type Vdef = (Bool,Qual Var,Ty,Exp)
data Exp
= Var (Qual Var)
| Dcon (Qual Dcon)
| Lit Lit
| App Exp Exp
| Appt Exp Ty
| Lam Bind Exp
| Let Vdefg Exp
| Case Exp Vbind Ty [Alt] {- non-empty list -}
| Cast Exp Coercion
| Tick String Exp {- XXX probably wrong -}
| External String String Ty {- target name, convention, and type -}
| DynExternal String Ty {- convention and type (incl. Addr# of target as first arg) -}
| Label String
data Bind
= Vb Vbind
| Tb Tbind
data Alt
= Acon (Qual Dcon) [Tbind] [Vbind] Exp
| Alit Lit Exp
| Adefault Exp
type Vbind = (Var,Ty)
type Tbind = (Tvar,Kind)
data Ty
= Tvar Tvar
| Tcon (Qual Tcon)
| Tapp Ty Ty
| Tforall Tbind Ty
data Coercion
-- We distinguish primitive coercions because External Core treats
-- them specially, so we have to print them out with special syntax.
= ReflCoercion Role Ty
| SymCoercion Coercion
| TransCoercion Coercion Coercion
| TyConAppCoercion Role (Qual Tcon) [Coercion]
| AppCoercion Coercion Coercion
| ForAllCoercion Tbind Coercion
| CoVarCoercion Var
| UnivCoercion Role Ty Ty
| InstCoercion Coercion Ty
| NthCoercion Int Coercion
| AxiomCoercion (Qual Tcon) Int [Coercion]
| LRCoercion LeftOrRight Coercion
| SubCoercion Coercion
data Role = Nominal | Representational | Phantom
data LeftOrRight = CLeft | CRight
data Kind
= Klifted
| Kunlifted
| Kunboxed
| Kopen
| Karrow Kind Kind
data Lit
= Lint Integer Ty
| Lrational Rational Ty
| Lchar Char Ty
| Lstring [Word8] Ty
type Mname = Id
type Var = Id
type Tvar = Id
type Tcon = Id
type Dcon = Id
type Qual t = (Mname,t)
type Id = String
primMname :: Mname
-- For truly horrible reasons, this must be z-encoded.
-- With any hope, the z-encoding will die soon.
primMname = "ghczmprim:GHCziPrim"
tcArrow :: Qual Tcon
tcArrow = (primMname, "(->)")
\end{code}
% (c) The University of Glasgow 2001-2006
%
\begin{code}
module MkExternalCore (
emitExternalCore
) where
#include "HsVersions.h"
import qualified ExternalCore as C
import Module
import CoreSyn
import HscTypes
import TyCon
import CoAxiom
-- import Class
import TypeRep
import Type
import Kind
import PprExternalCore () -- Instances
import DataCon
import Coercion
import Var
import IdInfo
import Literal
import Name
import Outputable
import Encoding
import ForeignCall
import DynFlags
import FastString
import Exception
import Control.Applicative (Applicative(..))
import Control.Monad
import qualified Data.ByteString as BS
import Data.Char
import System.IO
emitExternalCore :: DynFlags -> FilePath -> CgGuts -> IO ()
emitExternalCore dflags extCore_filename cg_guts
| gopt Opt_EmitExternalCore dflags
= (do handle <- openFile extCore_filename WriteMode
hPutStrLn handle (show (mkExternalCore dflags cg_guts))
hClose handle)
`catchIO` (\_ -> pprPanic "Failed to open or write external core output file"
(text extCore_filename))
emitExternalCore _ _ _
| otherwise
= return ()
-- Reinventing the Reader monad; whee.
newtype CoreM a = CoreM (CoreState -> (CoreState, a))
data CoreState = CoreState {
cs_dflags :: DynFlags,
cs_module :: Module
}
instance Functor CoreM where
fmap = liftM
instance Applicative CoreM where
pure = return
(<*>) = ap
instance Monad CoreM where
(CoreM m) >>= f = CoreM (\ s -> case m s of
(s',r) -> case f r of
CoreM f' -> f' s')
return x = CoreM (\ s -> (s, x))
runCoreM :: CoreM a -> CoreState -> a
runCoreM (CoreM f) s = snd $ f s
ask :: CoreM CoreState
ask = CoreM (\ s -> (s,s))
instance HasDynFlags CoreM where
getDynFlags = liftM cs_dflags ask
mkExternalCore :: DynFlags -> CgGuts -> C.Module
-- The ModGuts has been tidied, but the implicit bindings have
-- not been injected, so we have to add them manually here
-- We don't include the strange data-con *workers* because they are
-- implicit in the data type declaration itself
mkExternalCore dflags (CgGuts {cg_module=this_mod, cg_tycons = tycons,
cg_binds = binds})
{- Note that modules can be mutually recursive, but even so, we
print out dependency information within each module. -}
= C.Module (mname dflags) tdefs (runCoreM (mapM (make_vdef True) binds) initialState)
where
initialState = CoreState {
cs_dflags = dflags,
cs_module = this_mod
}
mname dflags = make_mid dflags this_mod
tdefs = foldr (collect_tdefs dflags) [] tycons
collect_tdefs :: DynFlags -> TyCon -> [C.Tdef] -> [C.Tdef]
collect_tdefs dflags tcon tdefs
| isAlgTyCon tcon = tdef: tdefs
where
tdef | isNewTyCon tcon =
C.Newtype (qtc dflags tcon)
(qcc dflags (newTyConCo tcon))
(map make_tbind tyvars)
(make_ty dflags (snd (newTyConRhs tcon)))
| otherwise =
C.Data (qtc dflags tcon) (map make_tbind tyvars)
(map (make_cdef dflags) (tyConDataCons tcon))
tyvars = tyConTyVars tcon
collect_tdefs _ _ tdefs = tdefs
qtc :: DynFlags -> TyCon -> C.Qual C.Tcon
qtc dflags = make_con_qid dflags . tyConName
qcc :: DynFlags -> CoAxiom br -> C.Qual C.Tcon
qcc dflags = make_con_qid dflags . co_ax_name
make_cdef :: DynFlags -> DataCon -> C.Cdef
make_cdef dflags dcon = C.Constr dcon_name existentials tys
where
dcon_name = make_qid dflags False False (dataConName dcon)
existentials = map make_tbind ex_tyvars
ex_tyvars = dataConExTyVars dcon
tys = map (make_ty dflags) (dataConRepArgTys dcon)
make_tbind :: TyVar -> C.Tbind
make_tbind tv = (make_var_id (tyVarName tv), make_kind (tyVarKind tv))
make_vbind :: DynFlags -> Var -> C.Vbind
make_vbind dflags v = (make_var_id (Var.varName v), make_ty dflags (varType v))
make_vdef :: Bool -> CoreBind -> CoreM C.Vdefg
make_vdef topLevel b =
case b of
NonRec v e -> f (v,e) >>= (return . C.Nonrec)
Rec ves -> mapM f ves >>= (return . C.Rec)
where
f :: (CoreBndr,CoreExpr) -> CoreM C.Vdef
f (v,e) = do
localN <- isALocal vName
let local = not topLevel || localN
rhs <- make_exp e
-- use local flag to determine where to add the module name
dflags <- getDynFlags
return (local, make_qid dflags local True vName, make_ty dflags (varType v),rhs)
where vName = Var.varName v
make_exp :: CoreExpr -> CoreM C.Exp
make_exp (Var v) = do
let vName = Var.varName v
isLocal <- isALocal vName
dflags <- getDynFlags
return $
case idDetails v of
FCallId (CCall (CCallSpec (StaticTarget nm _ True) callconv _))
-> C.External (unpackFS nm) (showPpr dflags callconv) (make_ty dflags (varType v))
FCallId (CCall (CCallSpec (StaticTarget _ _ False) _ _)) ->
panic "make_exp: FFI values not supported"
FCallId (CCall (CCallSpec DynamicTarget callconv _))
-> C.DynExternal (showPpr dflags callconv) (make_ty dflags (varType v))
-- Constructors are always exported, so make sure to declare them
-- with qualified names
DataConWorkId _ -> C.Var (make_var_qid dflags False vName)
DataConWrapId _ -> C.Var (make_var_qid dflags False vName)
_ -> C.Var (make_var_qid dflags isLocal vName)
make_exp (Lit (MachLabel s _ _)) = return $ C.Label (unpackFS s)
make_exp (Lit l) = do dflags <- getDynFlags
return $ C.Lit (make_lit dflags l)
make_exp (App e (Type t)) = do b <- make_exp e
dflags <- getDynFlags
return $ C.Appt b (make_ty dflags t)
make_exp (App _e (Coercion _co)) = error "make_exp (App _ (Coercion _))" -- TODO
make_exp (App e1 e2) = do
rator <- make_exp e1
rand <- make_exp e2
return $ C.App rator rand
make_exp (Lam v e) | isTyVar v = make_exp e >>= (\ b ->
return $ C.Lam (C.Tb (make_tbind v)) b)
make_exp (Lam v e) | otherwise = do b <- make_exp e
dflags <- getDynFlags
return $ C.Lam (C.Vb (make_vbind dflags v)) b
make_exp (Cast e co) = do b <- make_exp e
dflags <- getDynFlags
return $ C.Cast b (make_co dflags co)
make_exp (Let b e) = do
vd <- make_vdef False b
body <- make_exp e
return $ C.Let vd body
make_exp (Case e v ty alts) = do
scrut <- make_exp e
newAlts <- mapM make_alt alts
dflags <- getDynFlags
return $ C.Case scrut (make_vbind dflags v) (make_ty dflags ty) newAlts
make_exp (Tick _ e) = make_exp e >>= (return . C.Tick "SCC") -- temporary
make_exp _ = error "MkExternalCore died: make_exp"
make_alt :: CoreAlt -> CoreM C.Alt
make_alt (DataAlt dcon, vs, e) = do
newE <- make_exp e
dflags <- getDynFlags
return $ C.Acon (make_con_qid dflags (dataConName dcon))
(map make_tbind tbs)
(map (make_vbind dflags) vbs)
newE
where (tbs,vbs) = span isTyVar vs
make_alt (LitAlt l,_,e) = do x <- make_exp e
dflags <- getDynFlags
return $ C.Alit (make_lit dflags l) x
make_alt (DEFAULT,[],e) = make_exp e >>= (return . C.Adefault)
-- This should never happen, as the DEFAULT alternative binds no variables,
-- but we might as well check for it:
make_alt a@(DEFAULT,_ ,_) = pprPanic ("MkExternalCore: make_alt: DEFAULT "
++ "alternative had a non-empty var list") (ppr a)
make_lit :: DynFlags -> Literal -> C.Lit
make_lit dflags l =
case l of
-- Note that we need to check whether the character is "big".
-- External Core only allows character literals up to '\xff'.
MachChar i | i <= chr 0xff -> C.Lchar i t
-- For a character bigger than 0xff, we represent it in ext-core
-- as an int lit with a char type.
MachChar i -> C.Lint (fromIntegral $ ord i) t
MachStr s -> C.Lstring (BS.unpack s) t
MachNullAddr -> C.Lint 0 t
MachInt i -> C.Lint i t
MachInt64 i -> C.Lint i t
MachWord i -> C.Lint i t
MachWord64 i -> C.Lint i t
MachFloat r -> C.Lrational r t
MachDouble r -> C.Lrational r t
LitInteger i _ -> C.Lint i t
_ -> pprPanic "MkExternalCore died: make_lit" (ppr l)
where
t = make_ty dflags (literalType l)
-- Expand type synonyms, then convert.
make_ty :: DynFlags -> Type -> C.Ty -- Be sure to expand types recursively!
-- example: FilePath ~> String ~> [Char]
make_ty dflags t | Just expanded <- tcView t = make_ty dflags expanded
make_ty dflags t = make_ty' dflags t
-- note calls to make_ty so as to expand types recursively
make_ty' :: DynFlags -> Type -> C.Ty
make_ty' _ (TyVarTy tv) = C.Tvar (make_var_id (tyVarName tv))
make_ty' dflags (AppTy t1 t2) = C.Tapp (make_ty dflags t1) (make_ty dflags t2)
make_ty' dflags (FunTy t1 t2) = make_ty dflags (TyConApp funTyCon [t1,t2])
make_ty' dflags (ForAllTy tv t) = C.Tforall (make_tbind tv) (make_ty dflags t)
make_ty' dflags (TyConApp tc ts) = make_tyConApp dflags tc ts
make_ty' _ (LitTy {}) = panic "MkExernalCore can't do literal types yet"
-- Newtypes are treated just like any other type constructor; not expanded
-- Reason: predTypeRep does substitution and, while substitution deals
-- correctly with name capture, it's only correct if you see the uniques!
-- If you just see occurrence names, name capture may occur.
-- Example: newtype A a = A (forall b. b -> a)
-- test :: forall q b. q -> A b
-- test _ = undefined
-- Here the 'a' gets substituted by 'b', which is captured.
-- Another solution would be to expand newtypes before tidying; but that would
-- expose the representation in interface files, which definitely isn't right.
-- Maybe CoreTidy should know whether to expand newtypes or not?
make_tyConApp :: DynFlags -> TyCon -> [Type] -> C.Ty
make_tyConApp dflags tc ts =
foldl C.Tapp (C.Tcon (qtc dflags tc))
(map (make_ty dflags) ts)
make_kind :: Kind -> C.Kind
make_kind (FunTy k1 k2) = C.Karrow (make_kind k1) (make_kind k2)
make_kind k
| isLiftedTypeKind k = C.Klifted
| isUnliftedTypeKind k = C.Kunlifted
| isOpenTypeKind k = C.Kopen
make_kind _ = error "MkExternalCore died: make_kind"
{- Id generation. -}
make_id :: Bool -> Name -> C.Id
-- include uniques for internal names in order to avoid name shadowing
make_id _is_var nm = ((occNameString . nameOccName) nm)
++ (if isInternalName nm then (show . nameUnique) nm else "")
make_var_id :: Name -> C.Id
make_var_id = make_id True
-- It's important to encode the module name here, because in External Core,
-- base:GHC.Base => base:GHCziBase
-- We don't do this in pprExternalCore because we
-- *do* want to keep the package name (we don't want baseZCGHCziBase,
-- because that would just be ugly.)
-- SIGH.
-- We encode the package name as well.
make_mid :: DynFlags -> Module -> C.Id
-- Super ugly code, but I can't find anything else that does quite what I
-- want (encodes the hierarchical module name without encoding the colon
-- that separates the package name from it.)
make_mid dflags m
= showSDoc dflags $
(text $ zEncodeString $ packageIdString $ modulePackageId m)
<> text ":"
<> (pprEncoded $ pprModuleName $ moduleName m)
where pprEncoded = pprCode CStyle
make_qid :: DynFlags -> Bool -> Bool -> Name -> C.Qual C.Id
make_qid dflags force_unqual is_var n = (mname,make_id is_var n)
where mname =
case nameModule_maybe n of
Just m | not force_unqual -> make_mid dflags m
_ -> ""
make_var_qid :: DynFlags -> Bool -> Name -> C.Qual C.Id
make_var_qid dflags force_unqual = make_qid dflags force_unqual True
make_con_qid :: DynFlags -> Name -> C.Qual C.Id
make_con_qid dflags = make_qid dflags False False
make_co :: DynFlags -> Coercion -> C.Coercion
make_co dflags (Refl r ty) = C.ReflCoercion (make_role r) $ make_ty dflags ty
make_co dflags (TyConAppCo r tc cos) = C.TyConAppCoercion (make_role r) (qtc dflags tc) (map (make_co dflags) cos)
make_co dflags (AppCo c1 c2) = C.AppCoercion (make_co dflags c1) (make_co dflags c2)
make_co dflags (ForAllCo tv co) = C.ForAllCoercion (make_tbind tv) (make_co dflags co)
make_co _ (CoVarCo cv) = C.CoVarCoercion (make_var_id (coVarName cv))
make_co dflags (AxiomInstCo cc ind cos) = C.AxiomCoercion (qcc dflags cc) ind (map (make_co dflags) cos)
make_co dflags (UnivCo r t1 t2) = C.UnivCoercion (make_role r) (make_ty dflags t1) (make_ty dflags t2)
make_co dflags (SymCo co) = C.SymCoercion (make_co dflags co)
make_co dflags (TransCo c1 c2) = C.TransCoercion (make_co dflags c1) (make_co dflags c2)
make_co dflags (NthCo d co) = C.NthCoercion d (make_co dflags co)
make_co dflags (LRCo lr co) = C.LRCoercion (make_lr lr) (make_co dflags co)
make_co dflags (InstCo co ty) = C.InstCoercion (make_co dflags co) (make_ty dflags ty)
make_co dflags (SubCo co) = C.SubCoercion (make_co dflags co)
make_co _ (AxiomRuleCo {}) = panic "make_co AxiomRuleCo: not yet implemented"
make_lr :: LeftOrRight -> C.LeftOrRight
make_lr CLeft = C.CLeft
make_lr CRight = C.CRight
make_role :: Role -> C.Role
make_role Nominal = C.Nominal
make_role Representational = C.Representational
make_role Phantom = C.Phantom
-------
isALocal :: Name -> CoreM Bool
isALocal vName = do
modName <- liftM cs_module ask
return $ case nameModule_maybe vName of
-- Not sure whether isInternalName corresponds to "local"ness
-- in the External Core sense; need to re-read the spec.
Just m | m == modName -> isInternalName vName
_ -> False
\end{code}
%
% (c) The University of Glasgow 2001-2006
%
\begin{code}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module PprExternalCore () where
import Encoding
import ExternalCore
import Pretty
import Data.Char
import Data.Ratio
instance Show Module where
showsPrec _ m = shows (pmodule m)
instance Show Tdef where
showsPrec _ t = shows (ptdef t)
instance Show Cdef where
showsPrec _ c = shows (pcdef c)
instance Show Vdefg where
showsPrec _ v = shows (pvdefg v)
instance Show Exp where
showsPrec _ e = shows (pexp e)
instance Show Alt where
showsPrec _ a = shows (palt a)
instance Show Ty where
showsPrec _ t = shows (pty t)
instance Show Kind where
showsPrec _ k = shows (pkind k)
instance Show Lit where
showsPrec _ l = shows (plit l)
indent :: Doc -> Doc
indent = nest 2
pmodule :: Module -> Doc
pmodule (Module mname tdefs vdefgs) =
(text "%module" <+> text mname)
$$ indent ((vcat (map ((<> char ';') . ptdef) tdefs))
$$ (vcat (map ((<> char ';') . pvdefg) vdefgs)))
ptdef :: Tdef -> Doc
ptdef (Data tcon tbinds cdefs) =
(text "%data" <+> pqname tcon <+> (hsep (map ptbind tbinds)) <+> char '=')
$$ indent (braces ((vcat (punctuate (char ';') (map pcdef cdefs)))))
ptdef (Newtype tcon coercion tbinds rep) =
text "%newtype" <+> pqname tcon <+> pqname coercion
<+> (hsep (map ptbind tbinds)) $$ indent repclause
where repclause = char '=' <+> pty rep
pcdef :: Cdef -> Doc
pcdef (Constr dcon tbinds tys) =
(pqname dcon) <+> (sep [hsep (map pattbind tbinds),sep (map paty tys)])
pcdef (GadtConstr dcon ty) =
(pqname dcon) <+> text "::" <+> pty ty
pname :: Id -> Doc
pname id = text (zEncodeString id)
pqname :: Qual Id -> Doc
pqname ("",id) = pname id
pqname (m,id) = text m <> char '.' <> pname id
ptbind, pattbind :: Tbind -> Doc
ptbind (t,Klifted) = pname t
ptbind (t,k) = parens (pname t <> text "::" <> pkind k)
pattbind (t,k) = char '@' <> ptbind (t,k)
pakind, pkind :: Kind -> Doc
pakind (Klifted) = char '*'
pakind (Kunlifted) = char '#'
pakind (Kopen) = char '?'
pakind k = parens (pkind k)
pkind (Karrow k1 k2) = parens (pakind k1 <> text "->" <> pkind k2)
pkind k = pakind k
paty, pbty, pty :: Ty -> Doc
-- paty: print in parens, if non-atomic (like a name)
-- pbty: print in parens, if arrow (used only for lhs of arrow)
-- pty: not in parens
paty (Tvar n) = pname n
paty (Tcon c) = pqname c
paty t = parens (pty t)
pbty (Tapp(Tapp(Tcon tc) t1) t2) | tc == tcArrow = parens(fsep [pbty t1, text "->",pty t2])
pbty t = paty t
pty (Tapp(Tapp(Tcon tc) t1) t2) | tc == tcArrow = fsep [pbty t1, text "->",pty t2]
pty (Tforall tb t) = text "%forall" <+> pforall [tb] t
pty ty@(Tapp {}) = pappty ty []
pty ty@(Tvar {}) = paty ty
pty ty@(Tcon {}) = paty ty
pappty :: Ty -> [Ty] -> Doc
pappty (Tapp t1 t2) ts = pappty t1 (t2:ts)
pappty t ts = sep (map paty (t:ts))
pforall :: [Tbind] -> Ty -> Doc
pforall tbs (Tforall tb t) = pforall (tbs ++ [tb]) t
pforall tbs t = hsep (map ptbind tbs) <+> char '.' <+> pty t
paco, pbco, pco :: Coercion -> Doc
paco (ReflCoercion r ty) = char '<' <> pty ty <> text ">_" <> prole r
paco (TyConAppCoercion r qtc []) = pqname qtc <> char '_' <> prole r
paco (AxiomCoercion qtc i []) = pqname qtc <> char '[' <> int i <> char ']'
paco (CoVarCoercion cv) = pname cv
paco c = parens (pco c)
pbco (TyConAppCoercion _ arr [co1, co2])
| arr == tcArrow
= parens (fsep [pbco co1, text "->", pco co2])
pbco co = paco co
pco c@(ReflCoercion {}) = paco c
pco (SymCoercion co) = sep [text "%sub", paco co]
pco (TransCoercion co1 co2) = sep [text "%trans", paco co1, paco co2]
pco (TyConAppCoercion _ arr [co1, co2])
| arr == tcArrow = fsep [pbco co1, text "->", pco co2]
pco (TyConAppCoercion r qtc cos) = parens (pqname qtc <+> sep (map paco cos)) <> char '_' <> prole r
pco co@(AppCoercion {}) = pappco co []
pco (ForAllCoercion tb co) = text "%forall" <+> pforallco [tb] co
pco co@(CoVarCoercion {}) = paco co
pco (UnivCoercion r ty1 ty2) = sep [text "%univ", prole r, paty ty1, paty ty2]
pco (InstCoercion co ty) = sep [text "%inst", paco co, paty ty]
pco (NthCoercion i co) = sep [text "%nth", int i, paco co]
pco (AxiomCoercion qtc i cos) = pqname qtc <> char '[' <> int i <> char ']' <+> sep (map paco cos)
pco (LRCoercion CLeft co) = sep [text "%left", paco co]
pco (LRCoercion CRight co) = sep [text "%right", paco co]
pco (SubCoercion co) = sep [text "%sub", paco co]
pappco :: Coercion -> [Coercion ] -> Doc
pappco (AppCoercion co1 co2) cos = pappco co1 (co2:cos)
pappco co cos = sep (map paco (co:cos))
pforallco :: [Tbind] -> Coercion -> Doc
pforallco tbs (ForAllCoercion tb co) = pforallco (tbs ++ [tb]) co
pforallco tbs co = hsep (map ptbind tbs) <+> char '.' <+> pco co
prole :: Role -> Doc
prole Nominal = char 'N'
prole Representational = char 'R'
prole Phantom = char 'P'
pvdefg :: Vdefg -> Doc
pvdefg (Rec vdefs) = text "%rec" $$ braces (indent (vcat (punctuate (char ';') (map pvdef vdefs))))
pvdefg (Nonrec vdef) = pvdef vdef
pvdef :: Vdef -> Doc
-- TODO: Think about whether %local annotations are actually needed.
-- Right now, the local flag is never used, because the Core doc doesn't