Commit 870bb1e8 authored by sewardj's avatar sewardj

[project @ 2000-12-18 12:43:04 by sewardj]

Wire in the bytecode interpreter and delete the old one.
parent 342852c9
# -----------------------------------------------------------------------------
# $Id: Makefile,v 1.118 2000/12/11 16:42:26 sewardj Exp $
# $Id: Makefile,v 1.119 2000/12/18 12:43:04 sewardj Exp $
TOP = ..
include $(TOP)/mk/boilerplate.mk
......@@ -189,9 +189,7 @@ SRC_HC_OPTS += -recomp $(GhcHcOpts)
# Was 6m with 2.10
absCSyn/PprAbsC_HC_OPTS = -H10m
basicTypes/IdInfo_HC_OPTS = -K2m
codeGen/CgCase_HC_OPTS = -fno-prune-tydecls
hsSyn/HsExpr_HC_OPTS = -K2m
main/Main_HC_OPTS = -fvia-C
ifneq "$(GhcWithHscBuiltViaC)" "YES"
......@@ -200,25 +198,19 @@ main/Main_HC_OPTS += -syslib misc -DREPORT_TO_MOTHERLODE
endif
endif
main/CmdLineOpts_HC_OPTS = -K6m
nativeGen/PprMach_HC_OPTS = -K2m
nativeGen/MachMisc_HC_OPTS = -K2m
nativeGen/MachCode_HC_OPTS = -H10m
# Avoids Bug in 3.02, it seems
usageSP/UsageSPInf_HC_OPTS = -Onot
prelude/PrimOp_HC_OPTS = -H12m -K3m -no-recomp
prelude/PrimOp_HC_OPTS = -H12m -no-recomp
# because the NCG can't handle the 64-bit math in here
prelude/PrelRules_HC_OPTS = -fvia-C
parser/Lex_HC_OPTS = -K2m -H16m
parser/Ctype_HC_OPTS = -K2m
rename/ParseIface_HC_OPTS += -Onot -H45m -fno-warn-incomplete-patterns
rename/ParseIface_HC_OPTS += -Onot -H45m -K2m -fno-warn-incomplete-patterns
parser/Parser_HC_OPTS += -Onot -H80m -optCrts-M80m -K2m -fno-warn-incomplete-patterns
parser/Parser_HC_OPTS += -Onot -H80m -fno-warn-incomplete-patterns
ifeq "$(TARGETPLATFORM)" "hppa1.1-hp-hpux9"
rename/RnMonad_HC_OPTS = -O2 -O2-for-C
......
......@@ -24,9 +24,7 @@ import CmTypes
import CmStaticInfo ( GhciMode(..) )
import Outputable ( SDoc )
import Digraph ( SCC(..), flattenSCC )
import DriverUtil
import Module ( ModuleName )
import RdrName
import FiniteMap
import Outputable
import ErrUtils ( showPass )
......@@ -203,11 +201,11 @@ invalidLinkable = throwDyn (OtherError "linkable doesn't contain entirely object
-- link all the interpreted code in one go. We first remove from the
-- various environments any previous versions of these modules.
linkFinish pls mods ul_trees = do
linkFinish pls mods ul_bcos = do
resolveObjs
let itbl_env' = filterNameMap mods (itbl_env pls)
closure_env' = filterNameMap mods (closure_env pls)
stuff = [ (trees,itbls) | Trees trees itbls <- ul_trees ]
stuff = [ (bcos,itbls) | BCOs bcos itbls <- ul_bcos ]
(ibinds, new_itbl_env, new_closure_env) <-
linkIModules itbl_env' closure_env' stuff
......@@ -222,8 +220,8 @@ linkFinish pls mods ul_trees = do
unload :: PersistentLinkerState -> IO PersistentLinkerState
unload pls = return pls{ closure_env = emptyFM, itbl_env = emptyFM }
linkExpr :: PersistentLinkerState -> UnlinkedIExpr -> IO HValue
linkExpr PersistentLinkerState{ itbl_env = ie, closure_env = ce } expr
= iExprToHValue ie ce expr
linkExpr :: PersistentLinkerState -> UnlinkedBCOExpr -> IO HValue
linkExpr PersistentLinkerState{ itbl_env = ie, closure_env = ce } bcos
= linkIExpr ie ce bcos
#endif
\end{code}
......@@ -13,7 +13,7 @@ module CmTypes (
import Interpreter
import HscTypes
import Module
import CmStaticInfo
--import CmStaticInfo
import Outputable
import Time ( ClockTime )
......@@ -23,14 +23,14 @@ data Unlinked
= DotO FilePath
| DotA FilePath
| DotDLL FilePath
| Trees [UnlinkedIBind] ItblEnv -- bunch of interpretable bindings, +
-- a mapping from DataCons to their itbls
| BCOs [UnlinkedBCO] ItblEnv -- bunch of interpretable bindings, +
-- a mapping from DataCons to their itbls
instance Outputable Unlinked where
ppr (DotO path) = text "DotO" <+> text path
ppr (DotA path) = text "DotA" <+> text path
ppr (DotDLL path) = text "DotDLL" <+> text path
ppr (Trees binds _) = text "Trees" <+> ppr binds
ppr (BCOs bcos _) = text "BCOs" <+> vcat (map ppr bcos)
isObject (DotO _) = True
isObject (DotA _) = True
......@@ -41,8 +41,8 @@ nameOfObject (DotO fn) = fn
nameOfObject (DotA fn) = fn
nameOfObject (DotDLL fn) = fn
isInterpretable (Trees _ _) = True
isInterpretable _ = False
isInterpretable (BCOs _ _) = True
isInterpretable _ = False
data Linkable
= LM ClockTime ModuleName [Unlinked]
......
......@@ -17,21 +17,17 @@ where
import CmLink
import CmTypes
import HscTypes
import Module ( ModuleName, moduleName,
isHomeModule, moduleEnvElts,
moduleNameUserString )
import Module ( Module, ModuleName, moduleName, isHomeModule,
mkHomeModule, mkModuleName, moduleNameUserString )
import CmStaticInfo ( GhciMode(..) )
import DriverPipeline
import GetImports
import HscTypes ( HomeSymbolTable, HomeIfaceTable,
PersistentCompilerState, ModDetails(..) )
import Name ( lookupNameEnv )
import Module
import PrelNames ( mainName )
import HscMain ( initPersistentCompilerState )
import Finder
import UniqFM ( emptyUFM, lookupUFM, addToUFM, delListFromUFM,
UniqFM, listToUFM, eltsUFM )
UniqFM, listToUFM )
import Unique ( Uniquable )
import Digraph ( SCC(..), stronglyConnComp, flattenSCC )
import DriverFlags ( getDynFlags )
......@@ -60,7 +56,7 @@ import Directory ( getModificationTime, doesFileExist )
import IO
import Monad
import List ( nub )
import Maybe ( catMaybes, fromMaybe, isJust, maybeToList )
import Maybe ( catMaybes, fromMaybe, maybeToList )
\end{code}
......@@ -80,8 +76,8 @@ cmGetExpr cmstate dflags modname expr
hscExpr dflags hst hit pcs (mkHomeModule modname) expr
case maybe_stuff of
Nothing -> return (cmstate{ pcs=new_pcs }, Nothing)
Just (uiexpr, print_unqual, ty) -> do
hValue <- linkExpr pls uiexpr
Just (bcos, print_unqual, ty) -> do
hValue <- linkExpr pls bcos
return (cmstate{ pcs=new_pcs },
Just (hValue, print_unqual, ty))
......
......@@ -4,16 +4,20 @@
\section[ByteCodeGen]{Generate bytecode from Core}
\begin{code}
module ByteCodeGen ( byteCodeGen, linkIModules ) where
module ByteCodeGen ( UnlinkedBCO, UnlinkedBCOExpr, ItblEnv, ClosureEnv, HValue,
filterNameMap,
byteCodeGen, coreExprToBCOs,
linkIModules, linkIExpr
) where
#include "HsVersions.h"
import Outputable
import Name ( Name, getName )
import Name ( Name, getName, nameModule )
import Id ( Id, idType, isDataConId_maybe )
import OrdList ( OrdList, consOL, snocOL, appOL, unitOL,
nilOL, toOL, concatOL, fromOL )
import FiniteMap ( FiniteMap, addListToFM, listToFM,
import FiniteMap ( FiniteMap, addListToFM, listToFM, filterFM,
addToFM, lookupFM, fmToList, emptyFM, plusFM )
import CoreSyn
import PprCore ( pprCoreExpr, pprCoreAlt )
......@@ -33,6 +37,7 @@ import Constants ( wORD_SIZE )
import CmdLineOpts ( DynFlags, DynFlag(..) )
import ErrUtils ( showPass, dumpIfSet_dyn )
import ClosureInfo ( mkVirtHeapOffsets )
import Module ( ModuleName, moduleName )
import List ( intersperse )
import Monad ( foldM )
......@@ -54,12 +59,17 @@ import IOExts ( IORef, readIORef, writeIORef, fixIO )
import ArrayBase
import PrelArr ( Array(..) )
import PrelIOBase ( IO(..) )
\end{code}
Entry point.
%************************************************************************
%* *
\subsection{Functions visible from outside this module.}
%* *
%************************************************************************
\begin{code}
-- visible from outside
byteCodeGen :: DynFlags
-> [CoreBind]
-> [TyCon] -> [Class]
......@@ -84,6 +94,35 @@ byteCodeGen dflags binds local_tycons local_classes
return (bcos, itblenv)
-- Returns: (the root BCO for this expression,
-- a list of auxilary BCOs resulting from compiling closures)
coreExprToBCOs :: DynFlags
-> CoreExpr
-> IO UnlinkedBCOExpr
coreExprToBCOs dflags expr
= do showPass dflags "ByteCodeGen"
let invented_id = panic "invented_id" :: Id
(BcM_State all_proto_bcos final_ctr)
= runBc (BcM_State [] 0)
(schemeR (invented_id, freeVars expr))
dumpIfSet_dyn dflags Opt_D_dump_InterpSyn
"Proto-bcos" (vcat (intersperse (char ' ') (map ppr all_proto_bcos)))
let invented_name = getName invented_id
let root_proto_bco
= case filter ((== invented_name).nameOfProtoBCO) all_proto_bcos of
[root_bco] -> root_bco
auxiliary_proto_bcos
= filter ((/= invented_name).nameOfProtoBCO) all_proto_bcos
auxiliary_bcos <- mapM assembleBCO auxiliary_proto_bcos
root_bco <- assembleBCO root_proto_bco
return (root_bco, auxiliary_bcos)
data UnlinkedBCO
= UnlinkedBCO Name
Int (IOUArray Int Word16) -- insns
......@@ -93,14 +132,30 @@ data UnlinkedBCO
nameOfUnlinkedBCO (UnlinkedBCO nm _ _ _ _ _ _ _ _) = nm
-- needs a proper home
-- When translating expressions, we need to distinguish the root
-- BCO for the expression
type UnlinkedBCOExpr = (UnlinkedBCO, [UnlinkedBCO])
instance Outputable UnlinkedBCO where
ppr (UnlinkedBCO nm n_insns insns n_lits lits n_ptrs ptrs n_itbls itbls)
= sep [text "BCO", ppr nm, text "with",
int n_insns, text "insns",
int n_lits, text "lits",
int n_ptrs, text "ptrs",
int n_itbls, text "itbls"]
-- these need a proper home
type ItblEnv = FiniteMap Name (Ptr StgInfoTable)
type ClosureEnv = FiniteMap Name HValue
data HValue = HValue -- dummy type, actually a pointer to some Real Code.
data HValue = HValue -- dummy type, actually a pointer to some Real Code.
-- remove all entries for a given set of modules from the environment
filterNameMap :: [ModuleName] -> FiniteMap Name a -> FiniteMap Name a
filterNameMap mods env
= filterFM (\n _ -> moduleName (nameModule n) `notElem` mods) env
\end{code}
%************************************************************************
%* *
\subsection{Bytecodes, and Outputery.}
......@@ -214,6 +269,8 @@ data ProtoBCO a
(Either [AnnAlt Id VarSet]
(AnnExpr Id VarSet))
nameOfProtoBCO (ProtoBCO nm insns origin) = nm
type Sequel = Int -- back off to this depth before ENTER
......@@ -1130,6 +1187,12 @@ GLOBAL_VAR(v_cafTable, [], [HValue])
addCAF :: HValue -> IO ()
addCAF x = do xs <- readIORef v_cafTable; writeIORef v_cafTable (x:xs)
bcosToHValue :: ItblEnv -> ClosureEnv -> UnlinkedBCOExpr -> IO HValue
bcosToHValue ie ce (root_bco, other_bcos)
= do linked_expr <- linkIExpr ie ce (root_bco, other_bcos)
return linked_expr
linkIModules :: ItblEnv -- incoming global itbl env; returned updated
-> ClosureEnv -- incoming global closure env; returned updated
-> [([UnlinkedBCO], ItblEnv)]
......@@ -1142,16 +1205,28 @@ linkIModules gie gce mods = do
(new_bcos, new_gce) <-
fixIO (\ ~(new_bcos, new_gce) -> do
new_bcos <- linkBCOs final_gie new_gce bcos
let new_gce = addListToFM gce (zip top_level_binders new_bcos)
return (new_bcos, new_gce))
return (new_bcos, final_gie, new_gce)
linkIExpr :: ItblEnv -> ClosureEnv -> UnlinkedBCOExpr
-> IO HValue -- IO BCO# really
linkIExpr ie ce (root_ul_bco, aux_ul_bcos)
= do let aux_ul_binders = map nameOfUnlinkedBCO aux_ul_bcos
(aux_bcos, aux_ce)
<- fixIO
(\ ~(aux_bcos, new_ce)
-> do new_bcos <- linkBCOs ie new_ce aux_ul_bcos
let new_ce = addListToFM ce (zip aux_ul_binders new_bcos)
return (new_bcos, new_ce)
)
[root_bco]
<- linkBCOs ie aux_ce [root_ul_bco]
return root_bco
linkBCOs :: ItblEnv -> ClosureEnv -> [UnlinkedBCO]
-> IO [HValue] -- IO [BCO#] really
......
-----------------------------------------------------------------------------
-- $Id: InteractiveUI.hs,v 1.23 2000/12/13 12:18:40 sewardj Exp $
-- $Id: InteractiveUI.hs,v 1.24 2000/12/18 12:43:04 sewardj Exp $
--
-- GHC Interactive User Interface
--
......@@ -20,7 +20,7 @@ import Linker
import Module
import Outputable
import Util
import TypeRep {- instance Outputable Type; do not delete -}
import PprType {- instance Outputable Type; do not delete -}
import Panic ( GhcException(..) )
import Exception
......
%
% (c) The University of Glasgow 2000
%
\section[InterpSyn]{Abstract syntax for interpretable trees}
\begin{code}
module InterpSyn {- Todo: ( ... ) -} where
#include "HsVersions.h"
import Id
import Name
import PrimOp
import Outputable
import PrelAddr -- tmp
import PrelGHC -- tmp
import GlaExts ( Int(..) )
-----------------------------------------------------------------------------
-- The interpretable expression type
data HValue = HValue -- dummy type, actually a pointer to some Real Code.
data IBind con var = IBind Id (IExpr con var)
binder (IBind v e) = v
bindee (IBind v e) = e
data AltAlg con var = AltAlg Int{-tagNo-} [(Id,Rep)] (IExpr con var)
data AltPrim con var = AltPrim (Lit con var) (IExpr con var)
-- HACK ALERT! A Lit may *only* be one of LitI, LitL, LitF, LitD
type Lit con var = IExpr con var
data Rep
= RepI
| RepP
| RepF
| RepD
-- we're assuming that Char# is sufficiently compatible with Int# that
-- we only need one rep for both.
{- Not yet:
| RepV -- void rep
| RepI8
| RepI64
-}
deriving Eq
-- index???OffClosure needs to traverse indirection nodes.
-- You can always tell the representation of an IExpr by examining
-- its root node.
data IExpr con var
= CaseAlgP Id (IExpr con var) [AltAlg con var] (Maybe (IExpr con var))
| CaseAlgI Id (IExpr con var) [AltAlg con var] (Maybe (IExpr con var))
| CaseAlgF Id (IExpr con var) [AltAlg con var] (Maybe (IExpr con var))
| CaseAlgD Id (IExpr con var) [AltAlg con var] (Maybe (IExpr con var))
| CasePrimP Id (IExpr con var) [AltPrim con var] (Maybe (IExpr con var))
| CasePrimI Id (IExpr con var) [AltPrim con var] (Maybe (IExpr con var))
| CasePrimF Id (IExpr con var) [AltPrim con var] (Maybe (IExpr con var))
| CasePrimD Id (IExpr con var) [AltPrim con var] (Maybe (IExpr con var))
-- saturated constructor apps; args are in heap order.
-- The Addrs are the info table pointers. Descriptors refer to the
-- arg reps; all constructor applications return pointer rep.
| ConApp con
| ConAppI con (IExpr con var)
| ConAppP con (IExpr con var)
| ConAppPP con (IExpr con var) (IExpr con var)
| ConAppGen con [IExpr con var]
| PrimOpP PrimOp [(IExpr con var)]
| PrimOpI PrimOp [(IExpr con var)]
| PrimOpF PrimOp [(IExpr con var)]
| PrimOpD PrimOp [(IExpr con var)]
| NonRecP (IBind con var) (IExpr con var)
| NonRecI (IBind con var) (IExpr con var)
| NonRecF (IBind con var) (IExpr con var)
| NonRecD (IBind con var) (IExpr con var)
| RecP [IBind con var] (IExpr con var)
| RecI [IBind con var] (IExpr con var)
| RecF [IBind con var] (IExpr con var)
| RecD [IBind con var] (IExpr con var)
| LitI Int#
| LitF Float#
| LitD Double#
{- not yet:
| LitB Int8#
| LitL Int64#
-}
| Native var -- pointer to a Real Closure
| VarP Id
| VarI Id
| VarF Id
| VarD Id
-- LamXY indicates a function of reps X -> Y
-- ie var rep = X, result rep = Y
-- NOTE: repOf (LamXY _ _) = RepI regardless of X and Y
--
| LamPP Id (IExpr con var)
| LamPI Id (IExpr con var)
| LamPF Id (IExpr con var)
| LamPD Id (IExpr con var)
| LamIP Id (IExpr con var)
| LamII Id (IExpr con var)
| LamIF Id (IExpr con var)
| LamID Id (IExpr con var)
| LamFP Id (IExpr con var)
| LamFI Id (IExpr con var)
| LamFF Id (IExpr con var)
| LamFD Id (IExpr con var)
| LamDP Id (IExpr con var)
| LamDI Id (IExpr con var)
| LamDF Id (IExpr con var)
| LamDD Id (IExpr con var)
-- AppXY means apply a fn (always of Ptr rep) to
-- an arg of rep X giving result of Rep Y
-- therefore: repOf (AppXY _ _) = RepY
| AppPP (IExpr con var) (IExpr con var)
| AppPI (IExpr con var) (IExpr con var)
| AppPF (IExpr con var) (IExpr con var)
| AppPD (IExpr con var) (IExpr con var)
| AppIP (IExpr con var) (IExpr con var)
| AppII (IExpr con var) (IExpr con var)
| AppIF (IExpr con var) (IExpr con var)
| AppID (IExpr con var) (IExpr con var)
| AppFP (IExpr con var) (IExpr con var)
| AppFI (IExpr con var) (IExpr con var)
| AppFF (IExpr con var) (IExpr con var)
| AppFD (IExpr con var) (IExpr con var)
| AppDP (IExpr con var) (IExpr con var)
| AppDI (IExpr con var) (IExpr con var)
| AppDF (IExpr con var) (IExpr con var)
| AppDD (IExpr con var) (IExpr con var)
showExprTag :: IExpr c v -> String
showExprTag expr
= case expr of
CaseAlgP _ _ _ _ -> "CaseAlgP"
CaseAlgI _ _ _ _ -> "CaseAlgI"
CaseAlgF _ _ _ _ -> "CaseAlgF"
CaseAlgD _ _ _ _ -> "CaseAlgD"
CasePrimP _ _ _ _ -> "CasePrimP"
CasePrimI _ _ _ _ -> "CasePrimI"
CasePrimF _ _ _ _ -> "CasePrimF"
CasePrimD _ _ _ _ -> "CasePrimD"
ConApp _ -> "ConApp"
ConAppI _ _ -> "ConAppI"
ConAppP _ _ -> "ConAppP"
ConAppPP _ _ _ -> "ConAppPP"
ConAppGen _ _ -> "ConAppGen"
PrimOpP _ _ -> "PrimOpP"
PrimOpI _ _ -> "PrimOpI"
PrimOpF _ _ -> "PrimOpF"
PrimOpD _ _ -> "PrimOpD"
NonRecP _ _ -> "NonRecP"
NonRecI _ _ -> "NonRecI"
NonRecF _ _ -> "NonRecF"
NonRecD _ _ -> "NonRecD"
RecP _ _ -> "RecP"
RecI _ _ -> "RecI"
RecF _ _ -> "RecF"
RecD _ _ -> "RecD"
LitI _ -> "LitI"
LitF _ -> "LitF"
LitD _ -> "LitD"
Native _ -> "Native"
VarP _ -> "VarP"
VarI _ -> "VarI"
VarF _ -> "VarF"
VarD _ -> "VarD"
LamPP _ _ -> "LamPP"
LamPI _ _ -> "LamPI"
LamPF _ _ -> "LamPF"
LamPD _ _ -> "LamPD"
LamIP _ _ -> "LamIP"
LamII _ _ -> "LamII"
LamIF _ _ -> "LamIF"
LamID _ _ -> "LamID"
LamFP _ _ -> "LamFP"
LamFI _ _ -> "LamFI"
LamFF _ _ -> "LamFF"
LamFD _ _ -> "LamFD"
LamDP _ _ -> "LamDP"
LamDI _ _ -> "LamDI"
LamDF _ _ -> "LamDF"
LamDD _ _ -> "LamDD"
AppPP _ _ -> "AppPP"
AppPI _ _ -> "AppPI"
AppPF _ _ -> "AppPF"
AppPD _ _ -> "AppPD"
AppIP _ _ -> "AppIP"
AppII _ _ -> "AppII"
AppIF _ _ -> "AppIF"
AppID _ _ -> "AppID"
AppFP _ _ -> "AppFP"
AppFI _ _ -> "AppFI"
AppFF _ _ -> "AppFF"
AppFD _ _ -> "AppFD"
AppDP _ _ -> "AppDP"
AppDI _ _ -> "AppDI"
AppDF _ _ -> "AppDF"
AppDD _ _ -> "AppDD"
other -> "(showExprTag:unhandled case)"
-----------------------------------------------------------------------------
-- Instantiations of the IExpr type
type UnlinkedIExpr = IExpr Name Name
type LinkedIExpr = IExpr Addr HValue
type UnlinkedIBind = IBind Name Name
type LinkedIBind = IBind Addr HValue
type UnlinkedAltAlg = AltAlg Name Name
type LinkedAltAlg = AltAlg Addr HValue
type UnlinkedAltPrim = AltPrim Name Name
type LinkedAltPrim = AltPrim Addr HValue
-----------------------------------------------------------------------------
-- Pretty printing
instance Outputable HValue where
ppr x = text (show (A# (unsafeCoerce# x :: Addr#)))
-- ptext SLIT("<O>") -- unidentified lurking object
instance (Outputable var, Outputable con) => Outputable (IBind con var) where
ppr ibind = pprIBind ibind
pprIBind :: (Outputable var, Outputable con) => IBind con var -> SDoc
pprIBind (IBind v e) = ppr v <+> char '=' <+> pprIExpr e
pprAltAlg (AltAlg tag vars rhs)
= text "Tag_" <> int tag <+> hsep (map ppr vars)
<+> text "->" <+> pprIExpr rhs
pprAltPrim (AltPrim tag rhs)
= pprIExpr tag <+> text "->" <+> pprIExpr rhs
instance Outputable Rep where
ppr RepP = text "P"
ppr RepI = text "I"
ppr RepF = text "F"
ppr RepD = text "D"
instance Outputable Addr where
ppr addr = text (show addr)
pprDefault Nothing = text "NO_DEFAULT"
pprDefault (Just e) = text "DEFAULT ->" $$ nest 2 (pprIExpr e)
pprIExpr :: (Outputable var, Outputable con) => IExpr con var -> SDoc
pprIExpr (expr:: IExpr con var)
= case expr of
PrimOpI op args -> doPrimOp 'I' op args
PrimOpP op args -> doPrimOp 'P' op args
VarI v -> ppr v
VarP v -> ppr v
LitI i# -> int (I# i#) <> char '#'
LamPP v e -> doLam "PP" v e
LamPI v e -> doLam "PI" v e
LamIP v e -> doLam "IP" v e
LamII v e -> doLam "II" v e
AppPP f a -> doApp "PP" f a
AppPI f a -> doApp "PI" f a
AppIP f a -> doApp "IP" f a
AppII f a -> doApp "II" f a
Native v -> ptext SLIT("Native") <+> ppr v
CasePrimI b sc alts def -> doCasePrim 'I' b sc alts def
CasePrimP b sc alts def -> doCasePrim 'P' b sc alts def
CaseAlgI b sc alts def -> doCaseAlg 'I' b sc alts def
CaseAlgP b sc alts def -> doCaseAlg 'P' b sc alts def
NonRecP bind body -> doNonRec 'P' bind body
NonRecI bind body -> doNonRec 'I' bind body
RecP binds body -> doRec 'P' binds body
RecI binds body -> doRec 'I' binds body
ConApp i -> doConApp "" i ([] :: [IExpr con var])
ConAppI i a1 -> doConApp "" i [a1]
ConAppP i a1 -> doConApp "" i [a1]
ConAppPP i a1 a2 -> doConApp "" i [a1,a2]
ConAppGen i args -> doConApp "" i args
other -> text "pprIExpr: unimplemented tag:"
<+> text (showExprTag other)
where