summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorsewardj <unknown>2000-12-18 12:43:04 +0000
committersewardj <unknown>2000-12-18 12:43:04 +0000
commit870bb1e805c60dcff9321fcccca000fd6466d31e (patch)
tree02560e5a4e59d2d135ba22009dc90789b738ef93
parent342852c9c31aa1747880df42cbfc33ad61ecc67a (diff)
downloadhaskell-870bb1e805c60dcff9321fcccca000fd6466d31e.tar.gz
[project @ 2000-12-18 12:43:04 by sewardj]
Wire in the bytecode interpreter and delete the old one.
Diffstat
-rw-r--r--ghc/compiler/Makefile16
-rw-r--r--ghc/compiler/compMan/CmLink.lhs12
-rw-r--r--ghc/compiler/compMan/CmTypes.lhs12
-rw-r--r--ghc/compiler/compMan/CompManager.lhs16
-rw-r--r--ghc/compiler/ghci/ByteCodeGen.lhs97
-rw-r--r--ghc/compiler/ghci/InteractiveUI.hs4
-rw-r--r--ghc/compiler/ghci/InterpSyn.lhs355
-rw-r--r--ghc/compiler/ghci/StgInterp.lhs1425
-rw-r--r--ghc/compiler/main/DriverPipeline.hs6
-rw-r--r--ghc/compiler/main/HscMain.lhs53
-rw-r--r--ghc/compiler/main/Interpreter.hs8
11 files changed, 138 insertions, 1866 deletions
diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile
index d28fdeae5b..5861468ca6 100644
--- a/ghc/compiler/Makefile
+++ b/ghc/compiler/Makefile
@@ -1,5 +1,5 @@
# -----------------------------------------------------------------------------
-# $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
diff --git a/ghc/compiler/compMan/CmLink.lhs b/ghc/compiler/compMan/CmLink.lhs
index 0932a02e2e..8bce437c4b 100644
--- a/ghc/compiler/compMan/CmLink.lhs
+++ b/ghc/compiler/compMan/CmLink.lhs
@@ -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}
diff --git a/ghc/compiler/compMan/CmTypes.lhs b/ghc/compiler/compMan/CmTypes.lhs
index 8bf11a9694..f9e251b42b 100644
--- a/ghc/compiler/compMan/CmTypes.lhs
+++ b/ghc/compiler/compMan/CmTypes.lhs
@@ -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]
diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs
index dfd6e03cb4..c930b5899d 100644
--- a/ghc/compiler/compMan/CompManager.lhs
+++ b/ghc/compiler/compMan/CompManager.lhs
@@ -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))
diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs
index 0a77cbf800..32f83e9f9e 100644
--- a/ghc/compiler/ghci/ByteCodeGen.lhs
+++ b/ghc/compiler/ghci/ByteCodeGen.lhs
@@ -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
diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs
index 45a3e18d70..499998d00b 100644
--- a/ghc/compiler/ghci/InteractiveUI.hs
+++ b/ghc/compiler/ghci/InteractiveUI.hs
@@ -1,5 +1,5 @@
-----------------------------------------------------------------------------
--- $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
diff --git a/ghc/compiler/ghci/InterpSyn.lhs b/ghc/compiler/ghci/InterpSyn.lhs
deleted file mode 100644
index ccb6963d28..0000000000
--- a/ghc/compiler/ghci/InterpSyn.lhs
+++ /dev/null
@@ -1,355 +0,0 @@
-%
-% (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
- doConApp repstr itbl args
- = text "Con" <> text repstr
- <+> char '[' <> hsep (map pprIExpr args) <> char ']'
-
- doPrimOp repchar op args
- = char repchar <> ppr op <+> char '[' <> hsep (map pprIExpr args) <> char ']'
-
- doNonRec repchr bind body
- = vcat [text "let" <> char repchr <+> pprIBind bind, text "in", pprIExpr body]
-
- doRec repchr binds body
- = vcat [text "letrec" <> char repchr <+> vcat (map pprIBind binds),
- text "in", pprIExpr body]
-
- doCasePrim repchr b sc alts def
- = sep [text "CasePrim" <> char repchr
- <+> pprIExpr sc <+> text "of" <+> ppr b <+> char '{',
- nest 2 (vcat (map pprAltPrim alts) $$ pprDefault def),
- char '}'
- ]
-
- doCaseAlg repchr b sc alts def
- = sep [text "CaseAlg" <> char repchr
- <+> pprIExpr sc <+> text "of" <+> ppr b <+> char '{',
- nest 2 (vcat (map pprAltAlg alts) $$ pprDefault def),
- char '}'
- ]
-
- doApp repstr f a
- = text "(@" <> text repstr <+> pprIExpr f <+> pprIExpr a <> char ')'
- doLam repstr v e
- = (char '\\' <> text repstr <+> ppr v <+> text "->") $$ pprIExpr e
-
-\end{code}
diff --git a/ghc/compiler/ghci/StgInterp.lhs b/ghc/compiler/ghci/StgInterp.lhs
deleted file mode 100644
index 8428814268..0000000000
--- a/ghc/compiler/ghci/StgInterp.lhs
+++ /dev/null
@@ -1,1425 +0,0 @@
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-2000
-%
-\section[StgInterp]{Translates STG syntax to interpretable form, and run it}
-
-\begin{code}
-
-module StgInterp (
-
- ClosureEnv, ItblEnv,
- filterNameMap, -- :: [ModuleName] -> FiniteMap Name a
- -- -> FiniteMap Name a
-
- linkIModules, -- :: ItblEnv -> ClosureEnv
- -- -> [([UnlinkedIBind], ItblEnv)]
- -- -> IO ([LinkedIBind], ItblEnv, ClosureEnv)
-
- iExprToHValue, -- :: ItblEnv -> ClosureEnv
- -- -> UnlinkedIExpr -> HValue
-
- stgBindsToInterpSyn,-- :: [StgBinding]
- -- -> [TyCon] -> [Class]
- -- -> IO ([UnlinkedIBind], ItblEnv)
-
- stgExprToInterpSyn, -- :: StgExpr
- -- -> IO UnlinkedIExpr
-
- interp -- :: LinkedIExpr -> HValue
- ) where
-
-{- -----------------------------------------------------------------------------
-
- ToDo:
- - link should be in the IO monad, so it can modify the symtabs as it
- goes along
-
- - need a way to remove the bindings for a module from the symtabs.
- maybe the symtabs should be indexed by module first.
-
- - change the representation to something less verbose (?).
-
- - converting string literals to Addr# is horrible and introduces
- a memory leak. See if something can be done about this.
-
- - lots of assumptions about word size vs. double size etc.
-
------------------------------------------------------------------------------ -}
-
-#include "HsVersions.h"
-
-
-
-import Linker
-import Id ( Id, idPrimRep )
-import Outputable
-import Var
-import PrimOp ( PrimOp(..) )
-import PrimRep ( PrimRep(..) )
-import Literal ( Literal(..) )
-import Type ( Type, typePrimRep, deNoteType, repType, funResultTy )
-import DataCon ( DataCon, dataConTag, dataConRepArgTys )
-import ClosureInfo ( mkVirtHeapOffsets )
-import Module ( ModuleName, moduleName )
-import RdrName
-import Name hiding (filterNameEnv)
-import Util
-import UniqFM
-import UniqSet
-
---import {-# SOURCE #-} MCI_make_constr
-
-import FastString
-import GlaExts ( Int(..) )
-import Module ( moduleNameFS )
-
-import TyCon ( TyCon, isDataTyCon, tyConDataCons, tyConFamilySize )
-import Class ( Class, classTyCon )
-import InterpSyn
-import StgSyn
-import FiniteMap
-import OccName ( occNameString )
-import ErrUtils ( showPass, dumpIfSet_dyn )
-import CmdLineOpts ( DynFlags, DynFlag(..) )
-import Panic ( panic )
-
-import IOExts
-import Addr
-import Bits
-import Foreign
-import CTypes
-
-import IO
-
-import PrelGHC --( unsafeCoerce#, dataToTag#,
- -- indexPtrOffClosure#, indexWordOffClosure# )
-import PrelAddr ( Addr(..) )
-import PrelFloat ( Float(..), Double(..) )
-
-
-#if 1
-interp = panic "interp"
-stgExprToInterpSyn = panic "stgExprToInterpSyn"
-stgBindsToInterpSyn = panic "stgBindsToInterpSyn"
-iExprToHValue = panic "iExprToHValue"
-linkIModules = panic "linkIModules"
-filterNameMap = panic "filterNameMap"
-type ItblEnv = FiniteMap Name (Ptr StgInfoTable)
-type ClosureEnv = FiniteMap Name HValue
-data StgInfoTable = StgInfoTable {
- ptrs :: Word16,
- nptrs :: Word16,
- srtlen :: Word16,
- tipe :: Word16,
- code0, code1, code2, code3, code4, code5, code6, code7 :: Word8
-}
-
-#else
-
--- ---------------------------------------------------------------------------
--- Environments needed by the linker
--- ---------------------------------------------------------------------------
-
-type ItblEnv = FiniteMap Name (Ptr StgInfoTable)
-type ClosureEnv = FiniteMap Name HValue
-emptyClosureEnv = emptyFM
-
--- 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
-
--- ---------------------------------------------------------------------------
--- Turn an UnlinkedIExpr into a value we can run, for the interpreter
--- ---------------------------------------------------------------------------
-
-iExprToHValue :: ItblEnv -> ClosureEnv -> UnlinkedIExpr -> IO HValue
-iExprToHValue ie ce expr
- = do linked_expr <- linkIExpr ie ce expr
- return (interp linked_expr)
-
--- ---------------------------------------------------------------------------
--- Convert STG to an unlinked interpretable
--- ---------------------------------------------------------------------------
-
--- visible from outside
-stgBindsToInterpSyn :: DynFlags
- -> [StgBinding]
- -> [TyCon] -> [Class]
- -> IO ([UnlinkedIBind], ItblEnv)
-stgBindsToInterpSyn dflags binds local_tycons local_classes
- = do showPass dflags "StgToInterp"
- let ibinds = concatMap (translateBind emptyUniqSet) binds
- let tycs = local_tycons ++ map classTyCon local_classes
- dumpIfSet_dyn dflags Opt_D_dump_InterpSyn
- "Convert To InterpSyn" (vcat (map pprIBind ibinds))
- itblenv <- mkITbls tycs
- return (ibinds, itblenv)
-
-stgExprToInterpSyn :: DynFlags
- -> StgExpr
- -> IO UnlinkedIExpr
-stgExprToInterpSyn dflags expr
- = do showPass dflags "StgToInterp"
- let iexpr = stg2expr emptyUniqSet expr
- dumpIfSet_dyn dflags Opt_D_dump_InterpSyn
- "Convert To InterpSyn" (pprIExpr iexpr)
- return iexpr
-
-translateBind :: UniqSet Id -> StgBinding -> [UnlinkedIBind]
-translateBind ie (StgNonRec v e) = [IBind v (rhs2expr ie e)]
-translateBind ie (StgRec vs_n_es) = [IBind v (rhs2expr ie' e) | (v,e) <- vs_n_es]
- where ie' = addListToUniqSet ie (map fst vs_n_es)
-
-isRec (StgNonRec _ _) = False
-isRec (StgRec _) = True
-
-rhs2expr :: UniqSet Id -> StgRhs -> UnlinkedIExpr
-rhs2expr ie (StgRhsClosure ccs binfo srt fvs uflag args rhs)
- = mkLambdas args
- where
- rhsExpr = stg2expr (addListToUniqSet ie args) rhs
- rhsRep = repOfStgExpr rhs
- mkLambdas [] = rhsExpr
- mkLambdas [v] = mkLam (repOfId v) rhsRep v rhsExpr
- mkLambdas (v:vs) = mkLam (repOfId v) RepP v (mkLambdas vs)
-rhs2expr ie (StgRhsCon ccs dcon args)
- = conapp2expr ie dcon args
-
-conapp2expr :: UniqSet Id -> DataCon -> [StgArg] -> UnlinkedIExpr
-conapp2expr ie dcon args
- = mkConApp con_rdrname reps exprs
- where
- con_rdrname = getName dcon
- exprs = map (arg2expr ie) inHeapOrder
- reps = map repOfArg inHeapOrder
- inHeapOrder = toHeapOrder args
-
- toHeapOrder :: [StgArg] -> [StgArg]
- toHeapOrder args
- = let (_, _, rearranged_w_offsets) = mkVirtHeapOffsets getArgPrimRep args
- (rearranged, offsets) = unzip rearranged_w_offsets
- in
- rearranged
-
--- Handle most common cases specially; do the rest with a generic
--- mechanism (deferred till later :)
-mkConApp :: Name -> [Rep] -> [UnlinkedIExpr] -> UnlinkedIExpr
-mkConApp nm [] [] = ConApp nm
-mkConApp nm [RepI] [a1] = ConAppI nm a1
-mkConApp nm [RepP] [a1] = ConAppP nm a1
-mkConApp nm [RepP,RepP] [a1,a2] = ConAppPP nm a1 a2
-mkConApp nm reps args = ConAppGen nm args
-
-mkLam RepP RepP = LamPP
-mkLam RepI RepP = LamIP
-mkLam RepP RepI = LamPI
-mkLam RepI RepI = LamII
-mkLam repa repr = pprPanic "StgInterp.mkLam" (ppr repa <+> ppr repr)
-
-mkApp RepP RepP = AppPP
-mkApp RepI RepP = AppIP
-mkApp RepP RepI = AppPI
-mkApp RepI RepI = AppII
-mkApp repa repr = pprPanic "StgInterp.mkApp" (ppr repa <+> ppr repr)
-
-repOfId :: Id -> Rep
-repOfId = primRep2Rep . idPrimRep
-
-primRep2Rep primRep
- = case primRep of
-
- -- genuine lifted types
- PtrRep -> RepP
-
- -- all these are unboxed, fit into a word, and we assume they
- -- all have the same call/return convention.
- IntRep -> RepI
- CharRep -> RepI
- WordRep -> RepI
- AddrRep -> RepI
- WeakPtrRep -> RepI
- StablePtrRep -> RepI
-
- -- these are pretty dodgy: really pointers, but
- -- we can't let the compiler build thunks with these reps.
- ForeignObjRep -> RepP
- StableNameRep -> RepP
- ThreadIdRep -> RepP
- ArrayRep -> RepP
- ByteArrayRep -> RepP
-
- FloatRep -> RepF
- DoubleRep -> RepD
-
- other -> pprPanic "primRep2Rep" (ppr other)
-
-repOfStgExpr :: StgExpr -> Rep
-repOfStgExpr stgexpr
- = case stgexpr of
- StgLit lit
- -> repOfLit lit
- StgCase scrut live liveR bndr srt alts
- -> case altRhss alts of
- (a:_) -> repOfStgExpr a
- [] -> panic "repOfStgExpr: no alts"
- StgApp var []
- -> repOfId var
- StgApp var args
- -> repOfApp ((deNoteType.repType.idType) var) (length args)
-
- StgPrimApp op args res_ty
- -> (primRep2Rep.typePrimRep) res_ty
-
- StgLet binds body -> repOfStgExpr body
- StgLetNoEscape live liveR binds body -> repOfStgExpr body
-
- StgConApp con args -> RepP -- by definition
-
- other
- -> pprPanic "repOfStgExpr" (ppr other)
- where
- altRhss (StgAlgAlts tycon alts def)
- = [rhs | (dcon,bndrs,uses,rhs) <- alts] ++ defRhs def
- altRhss (StgPrimAlts tycon alts def)
- = [rhs | (lit,rhs) <- alts] ++ defRhs def
- defRhs StgNoDefault
- = []
- defRhs (StgBindDefault rhs)
- = [rhs]
-
- -- returns the Rep of the result of applying ty to n args.
- repOfApp :: Type -> Int -> Rep
- repOfApp ty 0 = (primRep2Rep.typePrimRep) ty
- repOfApp ty n = repOfApp (funResultTy ty) (n-1)
-
-
-
-repOfLit lit
- = case lit of
- MachInt _ -> RepI
- MachWord _ -> RepI
- MachAddr _ -> RepI
- MachChar _ -> RepI
- MachFloat _ -> RepF
- MachDouble _ -> RepD
- MachStr _ -> RepI -- because it's a ptr outside the heap
- other -> pprPanic "repOfLit" (ppr lit)
-
-lit2expr :: Literal -> UnlinkedIExpr
-lit2expr lit
- = case lit of
- MachInt i -> case fromIntegral i of I# i -> LitI i
- MachWord i -> case fromIntegral i of I# i -> LitI i
- MachAddr i -> case fromIntegral i of I# i -> LitI i
- MachChar i -> case fromIntegral i of I# i -> LitI i
- MachFloat f -> case fromRational f of F# f -> LitF f
- MachDouble f -> case fromRational f of D# f -> LitD f
- MachStr s ->
- case s of
- CharStr s i -> LitI (addr2Int# s)
-
- FastString _ l ba ->
- -- sigh, a string in the heap is no good to us. We need a
- -- static C pointer, since the type of a string literal is
- -- Addr#. So, copy the string into C land and introduce a
- -- memory leak at the same time.
- let n = I# l in
- -- CAREFUL! Chars are 32 bits in ghc 4.09+
- case unsafePerformIO (do a@(Ptr addr) <- mallocBytes (n+1)
- strncpy a ba (fromIntegral n)
- writeCharOffAddr addr n '\0'
- return addr)
- of A# a -> LitI (addr2Int# a)
-
- _ -> error "StgInterp.lit2expr: unhandled string constant type"
-
- other -> pprPanic "lit2expr" (ppr lit)
-
-stg2expr :: UniqSet Id -> StgExpr -> UnlinkedIExpr
-stg2expr ie stgexpr
- = case stgexpr of
- StgApp var []
- -> mkVar ie (repOfId var) var
-
- StgApp var args
- -> mkAppChain ie (repOfStgExpr stgexpr) (mkVar ie (repOfId var) var) args
- StgLit lit
- -> lit2expr lit
-
- StgCase scrut live liveR bndr srt (StgPrimAlts ty alts def)
- | repOfStgExpr scrut /= RepP
- -> mkCasePrim (repOfStgExpr stgexpr)
- bndr (stg2expr ie scrut)
- (map (doPrimAlt ie') alts)
- (def2expr ie' def)
- | otherwise ->
- pprPanic "stg2expr(StgCase,prim)" (ppr (repOfStgExpr scrut) $$ (case scrut of (StgApp v _) -> ppr v <+> ppr (idType v) <+> ppr (idPrimRep v)) $$ ppr stgexpr)
- where ie' = addOneToUniqSet ie bndr
-
- StgCase scrut live liveR bndr srt (StgAlgAlts tycon alts def)
- | repOfStgExpr scrut == RepP
- -> mkCaseAlg (repOfStgExpr stgexpr)
- bndr (stg2expr ie scrut)
- (map (doAlgAlt ie') alts)
- (def2expr ie' def)
- where ie' = addOneToUniqSet ie bndr
-
-
- StgPrimApp op args res_ty
- -> mkPrimOp (repOfStgExpr stgexpr) op (map (arg2expr ie) args)
-
- StgConApp dcon args
- -> conapp2expr ie dcon args
-
- StgLet binds@(StgNonRec v e) body
- -> mkNonRec (repOfStgExpr stgexpr)
- (head (translateBind ie binds))
- (stg2expr (addOneToUniqSet ie v) body)
-
- StgLet binds@(StgRec bs) body
- -> mkRec (repOfStgExpr stgexpr)
- (translateBind ie binds)
- (stg2expr (addListToUniqSet ie (map fst bs)) body)
-
- -- treat let-no-escape just like let.
- StgLetNoEscape _ _ binds body
- -> stg2expr ie (StgLet binds body)
-
- other
- -> pprPanic "stg2expr" (ppr stgexpr)
- where
- doPrimAlt ie (lit,rhs)
- = AltPrim (lit2expr lit) (stg2expr ie rhs)
- doAlgAlt ie (dcon,vars,uses,rhs)
- = AltAlg (dataConTag dcon - 1)
- (map id2VaaRep (toHeapOrder vars))
- (stg2expr (addListToUniqSet ie vars) rhs)
-
- toHeapOrder vars
- = let (_,_,rearranged_w_offsets) = mkVirtHeapOffsets idPrimRep vars
- (rearranged,offsets) = unzip rearranged_w_offsets
- in
- rearranged
-
- def2expr ie StgNoDefault = Nothing
- def2expr ie (StgBindDefault rhs) = Just (stg2expr ie rhs)
-
- mkAppChain ie result_rep so_far []
- = panic "mkAppChain"
- mkAppChain ie result_rep so_far [a]
- = mkApp (repOfArg a) result_rep so_far (arg2expr ie a)
- mkAppChain ie result_rep so_far (a:as)
- = mkAppChain ie result_rep (mkApp (repOfArg a) RepP so_far (arg2expr ie a)) as
-
-mkCasePrim RepI = CasePrimI
-mkCasePrim RepP = CasePrimP
-
-mkCaseAlg RepI = CaseAlgI
-mkCaseAlg RepP = CaseAlgP
-
--- any var that isn't in scope is turned into a Native
-mkVar ie rep var
- | var `elementOfUniqSet` ie =
- (case rep of
- RepI -> VarI
- RepF -> VarF
- RepD -> VarD
- RepP -> VarP) var
- | otherwise = Native (getName var)
-
-mkRec RepI = RecI
-mkRec RepP = RecP
-mkNonRec RepI = NonRecI
-mkNonRec RepP = NonRecP
-
-mkPrimOp RepI = PrimOpI
-mkPrimOp RepP = PrimOpP
-
-arg2expr :: UniqSet Id -> StgArg -> UnlinkedIExpr
-arg2expr ie (StgVarArg v) = mkVar ie (repOfId v) v
-arg2expr ie (StgLitArg lit) = lit2expr lit
-arg2expr ie (StgTypeArg ty) = pprPanic "arg2expr" (ppr ty)
-
-repOfArg :: StgArg -> Rep
-repOfArg (StgVarArg v) = repOfId v
-repOfArg (StgLitArg lit) = repOfLit lit
-repOfArg (StgTypeArg ty) = pprPanic "repOfArg" (ppr ty)
-
-id2VaaRep var = (var, repOfId var)
-
-
--- ---------------------------------------------------------------------------
--- Link interpretables into something we can run
--- ---------------------------------------------------------------------------
-
-GLOBAL_VAR(cafTable, [], [HValue])
-
-addCAF :: HValue -> IO ()
-addCAF x = do xs <- readIORef cafTable; writeIORef cafTable (x:xs)
-
-linkIModules :: ItblEnv -- incoming global itbl env; returned updated
- -> ClosureEnv -- incoming global closure env; returned updated
- -> [([UnlinkedIBind], ItblEnv)]
- -> IO ([LinkedIBind], ItblEnv, ClosureEnv)
-linkIModules gie gce mods = do
- let (bindss, ies) = unzip mods
- binds = concat bindss
- top_level_binders = map (getName.binder) binds
- final_gie = foldr plusFM gie ies
-
- (new_binds, new_gce) <-
- fixIO (\ ~(new_binds, new_gce) -> do
-
- new_binds <- linkIBinds final_gie new_gce binds
-
- let new_rhss = map (\b -> evalP (bindee b) emptyUFM) new_binds
- let new_gce = addListToFM gce (zip top_level_binders new_rhss)
-
- return (new_binds, new_gce))
-
- return (new_binds, final_gie, new_gce)
-
-
--- We're supposed to augment the environments with the values of any
--- external functions/info tables we need as we go along, but that's a
--- lot of hassle so for now I'll look up external things as they crop
--- up and not cache them in the source symbol tables. The interpreted
--- code will still be referenced in the source symbol tables.
-
-linkIBinds :: ItblEnv -> ClosureEnv -> [UnlinkedIBind] -> IO [LinkedIBind]
-linkIBinds ie ce binds = mapM (linkIBind ie ce) binds
-
-linkIBind ie ce (IBind bndr expr)
- = do expr <- linkIExpr ie ce expr
- return (IBind bndr expr)
-
-linkIExpr :: ItblEnv -> ClosureEnv -> UnlinkedIExpr -> IO LinkedIExpr
-linkIExpr ie ce expr = case expr of
-
- CaseAlgP bndr expr alts dflt -> linkAlgCase ie ce bndr expr alts dflt CaseAlgP
- CaseAlgI bndr expr alts dflt -> linkAlgCase ie ce bndr expr alts dflt CaseAlgI
- CaseAlgF bndr expr alts dflt -> linkAlgCase ie ce bndr expr alts dflt CaseAlgF
- CaseAlgD bndr expr alts dflt -> linkAlgCase ie ce bndr expr alts dflt CaseAlgD
-
- CasePrimP bndr expr alts dflt -> linkPrimCase ie ce bndr expr alts dflt CasePrimP
- CasePrimI bndr expr alts dflt -> linkPrimCase ie ce bndr expr alts dflt CasePrimI
- CasePrimF bndr expr alts dflt -> linkPrimCase ie ce bndr expr alts dflt CasePrimF
- CasePrimD bndr expr alts dflt -> linkPrimCase ie ce bndr expr alts dflt CasePrimD
-
- ConApp con -> lookupNullaryCon ie con
-
- ConAppI con arg0 -> do
- con' <- lookupCon ie con
- arg' <- linkIExpr ie ce arg0
- return (ConAppI con' arg')
-
- ConAppP con arg0 -> do
- con' <- lookupCon ie con
- arg' <- linkIExpr ie ce arg0
- return (ConAppP con' arg')
-
- ConAppPP con arg0 arg1 -> do
- con' <- lookupCon ie con
- arg0' <- linkIExpr ie ce arg0
- arg1' <- linkIExpr ie ce arg1
- return (ConAppPP con' arg0' arg1')
-
- ConAppGen con args -> do
- con <- lookupCon ie con
- args <- mapM (linkIExpr ie ce) args
- return (ConAppGen con args)
-
- PrimOpI op args -> linkPrimOp ie ce PrimOpI op args
- PrimOpP op args -> linkPrimOp ie ce PrimOpP op args
-
- NonRecP bind expr -> linkNonRec ie ce NonRecP bind expr
- NonRecI bind expr -> linkNonRec ie ce NonRecI bind expr
- NonRecF bind expr -> linkNonRec ie ce NonRecF bind expr
- NonRecD bind expr -> linkNonRec ie ce NonRecD bind expr
-
- RecP binds expr -> linkRec ie ce RecP binds expr
- RecI binds expr -> linkRec ie ce RecI binds expr
- RecF binds expr -> linkRec ie ce RecF binds expr
- RecD binds expr -> linkRec ie ce RecD binds expr
-
- LitI i -> return (LitI i)
- LitF i -> return (LitF i)
- LitD i -> return (LitD i)
-
- Native var -> lookupNative ce var
-
- VarP v -> lookupVar ce VarP v
- VarI v -> lookupVar ce VarI v
- VarF v -> lookupVar ce VarF v
- VarD v -> lookupVar ce VarD v
-
- LamPP bndr expr -> linkLam ie ce LamPP bndr expr
- LamPI bndr expr -> linkLam ie ce LamPI bndr expr
- LamPF bndr expr -> linkLam ie ce LamPF bndr expr
- LamPD bndr expr -> linkLam ie ce LamPD bndr expr
- LamIP bndr expr -> linkLam ie ce LamIP bndr expr
- LamII bndr expr -> linkLam ie ce LamII bndr expr
- LamIF bndr expr -> linkLam ie ce LamIF bndr expr
- LamID bndr expr -> linkLam ie ce LamID bndr expr
- LamFP bndr expr -> linkLam ie ce LamFP bndr expr
- LamFI bndr expr -> linkLam ie ce LamFI bndr expr
- LamFF bndr expr -> linkLam ie ce LamFF bndr expr
- LamFD bndr expr -> linkLam ie ce LamFD bndr expr
- LamDP bndr expr -> linkLam ie ce LamDP bndr expr
- LamDI bndr expr -> linkLam ie ce LamDI bndr expr
- LamDF bndr expr -> linkLam ie ce LamDF bndr expr
- LamDD bndr expr -> linkLam ie ce LamDD bndr expr
-
- AppPP fun arg -> linkApp ie ce AppPP fun arg
- AppPI fun arg -> linkApp ie ce AppPI fun arg
- AppPF fun arg -> linkApp ie ce AppPF fun arg
- AppPD fun arg -> linkApp ie ce AppPD fun arg
- AppIP fun arg -> linkApp ie ce AppIP fun arg
- AppII fun arg -> linkApp ie ce AppII fun arg
- AppIF fun arg -> linkApp ie ce AppIF fun arg
- AppID fun arg -> linkApp ie ce AppID fun arg
- AppFP fun arg -> linkApp ie ce AppFP fun arg
- AppFI fun arg -> linkApp ie ce AppFI fun arg
- AppFF fun arg -> linkApp ie ce AppFF fun arg
- AppFD fun arg -> linkApp ie ce AppFD fun arg
- AppDP fun arg -> linkApp ie ce AppDP fun arg
- AppDI fun arg -> linkApp ie ce AppDI fun arg
- AppDF fun arg -> linkApp ie ce AppDF fun arg
- AppDD fun arg -> linkApp ie ce AppDD fun arg
-
-linkAlgCase ie ce bndr expr alts dflt con
- = do expr <- linkIExpr ie ce expr
- alts <- mapM (linkAlgAlt ie ce) alts
- dflt <- linkDefault ie ce dflt
- return (con bndr expr alts dflt)
-
-linkPrimCase ie ce bndr expr alts dflt con
- = do expr <- linkIExpr ie ce expr
- alts <- mapM (linkPrimAlt ie ce) alts
- dflt <- linkDefault ie ce dflt
- return (con bndr expr alts dflt)
-
-linkAlgAlt ie ce (AltAlg tag args rhs)
- = do rhs <- linkIExpr ie ce rhs
- return (AltAlg tag args rhs)
-
-linkPrimAlt ie ce (AltPrim lit rhs)
- = do rhs <- linkIExpr ie ce rhs
- lit <- linkIExpr ie ce lit
- return (AltPrim lit rhs)
-
-linkDefault ie ce Nothing = return Nothing
-linkDefault ie ce (Just expr)
- = do expr <- linkIExpr ie ce expr
- return (Just expr)
-
-linkNonRec ie ce con bind expr
- = do expr <- linkIExpr ie ce expr
- bind <- linkIBind ie ce bind
- return (con bind expr)
-
-linkRec ie ce con binds expr
- = do expr <- linkIExpr ie ce expr
- binds <- linkIBinds ie ce binds
- return (con binds expr)
-
-linkLam ie ce con bndr expr
- = do expr <- linkIExpr ie ce expr
- return (con bndr expr)
-
-linkApp ie ce con fun arg
- = do fun <- linkIExpr ie ce fun
- arg <- linkIExpr ie ce arg
- return (con fun arg)
-
-linkPrimOp ie ce con op args
- = do args <- mapM (linkIExpr ie ce) args
- return (con op args)
-
-lookupCon ie con =
- case lookupFM ie con of
- Just (Ptr addr) -> return addr
- Nothing -> do
- -- try looking up in the object files.
- m <- lookupSymbol (nameToCLabel con "con_info")
- case m of
- Just addr -> return addr
- Nothing -> pprPanic "linkIExpr" (ppr con)
-
--- nullary constructors don't have normal _con_info tables.
-lookupNullaryCon ie con =
- case lookupFM ie con of
- Just (Ptr addr) -> return (ConApp addr)
- Nothing -> do
- -- try looking up in the object files.
- m <- lookupSymbol (nameToCLabel con "closure")
- case m of
- Just (A# addr) -> return (Native (unsafeCoerce# addr))
- Nothing -> pprPanic "lookupNullaryCon" (ppr con)
-
-
-lookupNative ce var =
- unsafeInterleaveIO (do
- case lookupFM ce var of
- Just e -> return (Native e)
- Nothing -> do
- -- try looking up in the object files.
- let lbl = (nameToCLabel var "closure")
- m <- lookupSymbol lbl
- case m of
- Just (A# addr)
- -> do addCAF (unsafeCoerce# addr)
- return (Native (unsafeCoerce# addr))
- Nothing -> pprPanic "linkIExpr" (ppr var)
- )
-
--- some VarI/VarP refer to top-level interpreted functions; we change
--- them into Natives here.
-lookupVar ce f v =
- unsafeInterleaveIO (
- case lookupFM ce (getName v) of
- Nothing -> return (f v)
- Just e -> return (Native e)
- )
-
--- HACK!!! ToDo: cleaner
-nameToCLabel :: Name -> String{-suffix-} -> String
-nameToCLabel n suffix =
- _UNPK_(moduleNameFS (rdrNameModule rn))
- ++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix
- where rn = toRdrName n
-
--- ---------------------------------------------------------------------------
--- The interpreter proper
--- ---------------------------------------------------------------------------
-
--- The dynamic environment contains everything boxed.
--- eval* functions which look up values in it will know the
--- representation of the thing they are looking up, so they
--- can cast/unbox it as necessary.
-
--- ---------------------------------------------------------------------------
--- Evaluator for things of boxed (pointer) representation
--- ---------------------------------------------------------------------------
-
-interp :: LinkedIExpr -> HValue
-interp iexpr = unsafeCoerce# (evalP iexpr emptyUFM)
-
-evalP :: LinkedIExpr -> UniqFM boxed -> boxed
-
-{-
-evalP expr de
--- | trace ("evalP: " ++ showExprTag expr) False
- | trace ("evalP:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
- = error "evalP: ?!?!"
--}
-
-evalP (Native p) de = unsafeCoerce# p
-
--- First try the dynamic env. If that fails, assume it's a top-level
--- binding and look in the static env. That gives an Expr, which we
--- must convert to a boxed thingy by applying evalP to it. Because
--- top-level bindings are always ptr-rep'd (either lambdas or boxed
--- CAFs), it's always safe to use evalP.
-evalP (VarP v) de
- = case lookupUFM de v of
- Just xx -> xx
- Nothing -> error ("evalP: lookupUFM " ++ show v)
-
--- Deal with application of a function returning a pointer rep
--- to arguments of any persuasion. Note that the function itself
--- always has pointer rep.
-evalP (AppIP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalI e2 de)
-evalP (AppPP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalP e2 de)
-evalP (AppFP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalF e2 de)
-evalP (AppDP e1 e2) de = unsafeCoerce# (evalP e1 de) (evalD e2 de)
-
--- Lambdas always return P-rep, but we need to do different things
--- depending on both the argument and result representations.
-evalP (LamPP x b) de
- = unsafeCoerce# (\ xP -> evalP b (addToUFM de x xP))
-evalP (LamPI x b) de
- = unsafeCoerce# (\ xP -> evalI b (addToUFM de x xP))
-evalP (LamPF x b) de
- = unsafeCoerce# (\ xP -> evalF b (addToUFM de x xP))
-evalP (LamPD x b) de
- = unsafeCoerce# (\ xP -> evalD b (addToUFM de x xP))
-evalP (LamIP x b) de
- = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (I# xI))))
-evalP (LamII x b) de
- = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (I# xI))))
-evalP (LamIF x b) de
- = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (I# xI))))
-evalP (LamID x b) de
- = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (I# xI))))
-evalP (LamFP x b) de
- = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (F# xI))))
-evalP (LamFI x b) de
- = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (F# xI))))
-evalP (LamFF x b) de
- = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (F# xI))))
-evalP (LamFD x b) de
- = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (F# xI))))
-evalP (LamDP x b) de
- = unsafeCoerce# (\ xI -> evalP b (addToUFM de x (unsafeCoerce# (D# xI))))
-evalP (LamDI x b) de
- = unsafeCoerce# (\ xI -> evalI b (addToUFM de x (unsafeCoerce# (D# xI))))
-evalP (LamDF x b) de
- = unsafeCoerce# (\ xI -> evalF b (addToUFM de x (unsafeCoerce# (D# xI))))
-evalP (LamDD x b) de
- = unsafeCoerce# (\ xI -> evalD b (addToUFM de x (unsafeCoerce# (D# xI))))
-
-
--- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
--- except in the sense that we go on and evaluate the body with whichever
--- evaluator was used for the expression as a whole.
-evalP (NonRecP bind e) de
- = evalP e (augment_nonrec bind de)
-evalP (RecP binds b) de
- = evalP b (augment_rec binds de)
-evalP (CaseAlgP bndr expr alts def) de
- = case helper_caseAlg bndr expr alts def de of
- (rhs, de') -> evalP rhs de'
-evalP (CasePrimP bndr expr alts def) de
- = case helper_casePrim bndr expr alts def de of
- (rhs, de') -> evalP rhs de'
-
-evalP (ConApp (A# itbl)) de
- = mci_make_constr0 itbl
-
-evalP (ConAppI (A# itbl) a1) de
- = case evalI a1 de of i1 -> mci_make_constrI itbl i1
-
-evalP (ConAppP (A# itbl) a1) de
- = evalP (ConAppGen (A# itbl) [a1]) de
--- = let p1 = evalP a1 de
--- in mci_make_constrP itbl p1
-
-evalP (ConAppPP (A# itbl) a1 a2) de
- = let p1 = evalP a1 de
- p2 = evalP a2 de
- in mci_make_constrPP itbl p1 p2
-
-evalP (ConAppGen itbl args) de
- = let c = case itbl of A# a# -> mci_make_constr a# in
- c `seq` loop c 1#{-leave room for hdr-} args
- where
- loop :: a{-closure-} -> Int# -> [LinkedIExpr] -> a
- loop c off [] = c
- loop c off (a:as)
- = case repOf a of
- RepP -> let c' = setPtrOffClosure c off (evalP a de)
- in c' `seq` loop c' (off +# 1#) as
- RepI -> case evalI a de of { i# ->
- let c' = setIntOffClosure c off i#
- in c' `seq` loop c' (off +# 1#) as }
- RepF -> case evalF a de of { f# ->
- let c' = setFloatOffClosure c off f#
- in c' `seq` loop c' (off +# 1#) as }
- RepD -> case evalD a de of { d# ->
- let c' = setDoubleOffClosure c off d#
- in c' `seq` loop c' (off +# 2#) as }
-
-evalP (PrimOpP IntEqOp [e1,e2]) de
- = case evalI e1 de of
- i1# -> case evalI e2 de of
- i2# -> unsafeCoerce# (i1# ==# i2#)
-
-evalP (PrimOpP primop _) de
- = error ("evalP: unhandled primop: " ++ showSDoc (ppr primop))
-evalP other de
- = error ("evalP: unhandled case: " ++ showExprTag other)
-
---------------------------------------------------------
---- Evaluator for things of Int# representation
---------------------------------------------------------
-
--- Evaluate something which has an unboxed Int rep
-evalI :: LinkedIExpr -> UniqFM boxed -> Int#
-
-{-
-evalI expr de
--- | trace ("evalI: " ++ showExprTag expr) False
- | trace ("evalI:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
- = error "evalI: ?!?!"
--}
-
-evalI (LitI i#) de = i#
-
-evalI (VarI v) de =
- case lookupUFM de v of
- Just e -> case unsafeCoerce# e of I# i -> i
- Nothing -> error ("evalI: lookupUFM " ++ show v)
-
--- Deal with application of a function returning an Int# rep
--- to arguments of any persuasion. Note that the function itself
--- always has pointer rep.
-evalI (AppII e1 e2) de
- = unsafeCoerce# (evalP e1 de) (evalI e2 de)
-evalI (AppPI e1 e2) de
- = unsafeCoerce# (evalP e1 de) (evalP e2 de)
-evalI (AppFI e1 e2) de
- = unsafeCoerce# (evalP e1 de) (evalF e2 de)
-evalI (AppDI e1 e2) de
- = unsafeCoerce# (evalP e1 de) (evalD e2 de)
-
--- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
--- except in the sense that we go on and evaluate the body with whichever
--- evaluator was used for the expression as a whole.
-evalI (NonRecI bind b) de
- = evalI b (augment_nonrec bind de)
-evalI (RecI binds b) de
- = evalI b (augment_rec binds de)
-evalI (CaseAlgI bndr expr alts def) de
- = case helper_caseAlg bndr expr alts def de of
- (rhs, de') -> evalI rhs de'
-evalI (CasePrimI bndr expr alts def) de
- = case helper_casePrim bndr expr alts def de of
- (rhs, de') -> evalI rhs de'
-
--- evalI can't be applied to a lambda term, by defn, since those
--- are ptr-rep'd.
-
-evalI (PrimOpI IntAddOp [e1,e2]) de = evalI e1 de +# evalI e2 de
-evalI (PrimOpI IntSubOp [e1,e2]) de = evalI e1 de -# evalI e2 de
-evalI (PrimOpI DataToTagOp [e1]) de = dataToTag# (evalP e1 de)
-
-evalI (PrimOpI primop _) de
- = error ("evalI: unhandled primop: " ++ showSDoc (ppr primop))
-
---evalI (NonRec (IBind v e) b) de
--- = evalI b (augment de v (eval e de))
-
-evalI other de
- = error ("evalI: unhandled case: " ++ showExprTag other)
-
---------------------------------------------------------
---- Evaluator for things of Float# representation
---------------------------------------------------------
-
--- Evaluate something which has an unboxed Int rep
-evalF :: LinkedIExpr -> UniqFM boxed -> Float#
-
-{-
-evalF expr de
--- | trace ("evalF: " ++ showExprTag expr) False
- | trace ("evalF:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
- = error "evalF: ?!?!"
--}
-
-evalF (LitF f#) de = f#
-
-evalF (VarF v) de =
- case lookupUFM de v of
- Just e -> case unsafeCoerce# e of F# i -> i
- Nothing -> error ("evalF: lookupUFM " ++ show v)
-
--- Deal with application of a function returning an Int# rep
--- to arguments of any persuasion. Note that the function itself
--- always has pointer rep.
-evalF (AppIF e1 e2) de
- = unsafeCoerce# (evalP e1 de) (evalI e2 de)
-evalF (AppPF e1 e2) de
- = unsafeCoerce# (evalP e1 de) (evalP e2 de)
-evalF (AppFF e1 e2) de
- = unsafeCoerce# (evalP e1 de) (evalF e2 de)
-evalF (AppDF e1 e2) de
- = unsafeCoerce# (evalP e1 de) (evalD e2 de)
-
--- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
--- except in the sense that we go on and evaluate the body with whichever
--- evaluator was used for the expression as a whole.
-evalF (NonRecF bind b) de
- = evalF b (augment_nonrec bind de)
-evalF (RecF binds b) de
- = evalF b (augment_rec binds de)
-evalF (CaseAlgF bndr expr alts def) de
- = case helper_caseAlg bndr expr alts def de of
- (rhs, de') -> evalF rhs de'
-evalF (CasePrimF bndr expr alts def) de
- = case helper_casePrim bndr expr alts def de of
- (rhs, de') -> evalF rhs de'
-
--- evalF can't be applied to a lambda term, by defn, since those
--- are ptr-rep'd.
-
-evalF (PrimOpF op _) de
- = error ("evalF: unhandled primop: " ++ showSDoc (ppr op))
-
-evalF other de
- = error ("evalF: unhandled case: " ++ showExprTag other)
-
---------------------------------------------------------
---- Evaluator for things of Double# representation
---------------------------------------------------------
-
--- Evaluate something which has an unboxed Int rep
-evalD :: LinkedIExpr -> UniqFM boxed -> Double#
-
-{-
-evalD expr de
--- | trace ("evalD: " ++ showExprTag expr) False
- | trace ("evalD:\n" ++ showSDoc (pprIExpr expr) ++ "\n") False
- = error "evalD: ?!?!"
--}
-
-evalD (LitD d#) de = d#
-
-evalD (VarD v) de =
- case lookupUFM de v of
- Just e -> case unsafeCoerce# e of D# i -> i
- Nothing -> error ("evalD: lookupUFM " ++ show v)
-
--- Deal with application of a function returning an Int# rep
--- to arguments of any persuasion. Note that the function itself
--- always has pointer rep.
-evalD (AppID e1 e2) de
- = unsafeCoerce# (evalP e1 de) (evalI e2 de)
-evalD (AppPD e1 e2) de
- = unsafeCoerce# (evalP e1 de) (evalP e2 de)
-evalD (AppFD e1 e2) de
- = unsafeCoerce# (evalP e1 de) (evalF e2 de)
-evalD (AppDD e1 e2) de
- = unsafeCoerce# (evalP e1 de) (evalD e2 de)
-
--- NonRec, Rec, CaseAlg and CasePrim are the same for all result reps,
--- except in the sense that we go on and evaluate the body with whichever
--- evaluator was used for the expression as a whole.
-evalD (NonRecD bind b) de
- = evalD b (augment_nonrec bind de)
-evalD (RecD binds b) de
- = evalD b (augment_rec binds de)
-evalD (CaseAlgD bndr expr alts def) de
- = case helper_caseAlg bndr expr alts def de of
- (rhs, de') -> evalD rhs de'
-evalD (CasePrimD bndr expr alts def) de
- = case helper_casePrim bndr expr alts def de of
- (rhs, de') -> evalD rhs de'
-
--- evalD can't be applied to a lambda term, by defn, since those
--- are ptr-rep'd.
-
-evalD (PrimOpD op _) de
- = error ("evalD: unhandled primop: " ++ showSDoc (ppr op))
-
-evalD other de
- = error ("evalD: unhandled case: " ++ showExprTag other)
-
---------------------------------------------------------
---- Helper bits and pieces
---------------------------------------------------------
-
--- Find the Rep of any Expr
-repOf :: LinkedIExpr -> Rep
-
-repOf (LamPP _ _) = RepP
-repOf (LamPI _ _) = RepP
-repOf (LamPF _ _) = RepP
-repOf (LamPD _ _) = RepP
-repOf (LamIP _ _) = RepP
-repOf (LamII _ _) = RepP
-repOf (LamIF _ _) = RepP
-repOf (LamID _ _) = RepP
-repOf (LamFP _ _) = RepP
-repOf (LamFI _ _) = RepP
-repOf (LamFF _ _) = RepP
-repOf (LamFD _ _) = RepP
-repOf (LamDP _ _) = RepP
-repOf (LamDI _ _) = RepP
-repOf (LamDF _ _) = RepP
-repOf (LamDD _ _) = RepP
-
-repOf (AppPP _ _) = RepP
-repOf (AppPI _ _) = RepI
-repOf (AppPF _ _) = RepF
-repOf (AppPD _ _) = RepD
-repOf (AppIP _ _) = RepP
-repOf (AppII _ _) = RepI
-repOf (AppIF _ _) = RepF
-repOf (AppID _ _) = RepD
-repOf (AppFP _ _) = RepP
-repOf (AppFI _ _) = RepI
-repOf (AppFF _ _) = RepF
-repOf (AppFD _ _) = RepD
-repOf (AppDP _ _) = RepP
-repOf (AppDI _ _) = RepI
-repOf (AppDF _ _) = RepF
-repOf (AppDD _ _) = RepD
-
-repOf (NonRecP _ _) = RepP
-repOf (NonRecI _ _) = RepI
-repOf (NonRecF _ _) = RepF
-repOf (NonRecD _ _) = RepD
-
-repOf (RecP _ _) = RepP
-repOf (RecI _ _) = RepI
-repOf (RecF _ _) = RepF
-repOf (RecD _ _) = RepD
-
-repOf (LitI _) = RepI
-repOf (LitF _) = RepF
-repOf (LitD _) = RepD
-
-repOf (Native _) = RepP
-
-repOf (VarP _) = RepP
-repOf (VarI _) = RepI
-repOf (VarF _) = RepF
-repOf (VarD _) = RepD
-
-repOf (PrimOpP _ _) = RepP
-repOf (PrimOpI _ _) = RepI
-repOf (PrimOpF _ _) = RepF
-repOf (PrimOpD _ _) = RepD
-
-repOf (ConApp _) = RepP
-repOf (ConAppI _ _) = RepP
-repOf (ConAppP _ _) = RepP
-repOf (ConAppPP _ _ _) = RepP
-repOf (ConAppGen _ _) = RepP
-
-repOf (CaseAlgP _ _ _ _) = RepP
-repOf (CaseAlgI _ _ _ _) = RepI
-repOf (CaseAlgF _ _ _ _) = RepF
-repOf (CaseAlgD _ _ _ _) = RepD
-
-repOf (CasePrimP _ _ _ _) = RepP
-repOf (CasePrimI _ _ _ _) = RepI
-repOf (CasePrimF _ _ _ _) = RepF
-repOf (CasePrimD _ _ _ _) = RepD
-
-repOf other
- = error ("repOf: unhandled case: " ++ showExprTag other)
-
--- how big (in words) is one of these
-repSizeW :: Rep -> Int
-repSizeW RepI = 1
-repSizeW RepP = 1
-
-
--- Evaluate an expression, using the appropriate evaluator,
--- then box up the result. Note that it's only safe to use this
--- to create values to put in the environment. You can't use it
--- to create a value which might get passed to native code since that
--- code will have no idea that unboxed things have been boxed.
-eval :: LinkedIExpr -> UniqFM boxed -> boxed
-eval expr de
- = case repOf expr of
- RepI -> unsafeCoerce# (I# (evalI expr de))
- RepP -> evalP expr de
- RepF -> unsafeCoerce# (F# (evalF expr de))
- RepD -> unsafeCoerce# (D# (evalD expr de))
-
--- Evaluate the scrutinee of a case, select an alternative,
--- augment the environment appropriately, and return the alt
--- and the augmented environment.
-helper_caseAlg :: Id -> LinkedIExpr -> [LinkedAltAlg] -> Maybe LinkedIExpr
- -> UniqFM boxed
- -> (LinkedIExpr, UniqFM boxed)
-helper_caseAlg bndr expr alts def de
- = let exprEv = evalP expr de
- in
- exprEv `seq` -- vitally important; otherwise exprEv is never eval'd
- case select_altAlg (tagOf exprEv) alts def of
- (vars,rhs) -> (rhs, augment_from_constr (addToUFM de bndr exprEv)
- exprEv (vars,1))
-
-helper_casePrim :: Var -> LinkedIExpr -> [LinkedAltPrim] -> Maybe LinkedIExpr
- -> UniqFM boxed
- -> (LinkedIExpr, UniqFM boxed)
-helper_casePrim bndr expr alts def de
- = case repOf expr of
- RepI -> case evalI expr de of
- i# -> (select_altPrim alts def (LitI i#),
- addToUFM de bndr (unsafeCoerce# (I# i#)))
- RepF -> case evalF expr de of
- f# -> (select_altPrim alts def (LitF f#),
- addToUFM de bndr (unsafeCoerce# (F# f#)))
- RepD -> case evalD expr de of
- d# -> (select_altPrim alts def (LitD d#),
- addToUFM de bndr (unsafeCoerce# (D# d#)))
-
-
-augment_from_constr :: UniqFM boxed -> a -> ([(Id,Rep)],Int) -> UniqFM boxed
-augment_from_constr de con ([],offset)
- = de
-augment_from_constr de con ((v,rep):vs,offset)
- = let v_binding
- = case rep of
- RepP -> indexPtrOffClosure con offset
- RepI -> unsafeCoerce# (I# (indexIntOffClosure con offset))
- RepF -> unsafeCoerce# (F# (indexFloatOffClosure con offset))
- RepD -> unsafeCoerce# (D# (indexDoubleOffClosure con offset))
- in
- augment_from_constr (addToUFM de v v_binding) con
- (vs,offset + repSizeW rep)
-
--- Augment the environment for a non-recursive let.
-augment_nonrec :: LinkedIBind -> UniqFM boxed -> UniqFM boxed
-augment_nonrec (IBind v e) de = addToUFM de v (eval e de)
-
--- Augment the environment for a recursive let.
-augment_rec :: [LinkedIBind] -> UniqFM boxed -> UniqFM boxed
-augment_rec binds de
- = let vars = map binder binds
- rhss = map bindee binds
- rhs_vs = map (\rhs -> eval rhs de') rhss
- de' = addListToUFM de (zip vars rhs_vs)
- in
- de'
-
--- a must be a constructor?
-tagOf :: a -> Int
-tagOf x = I# (dataToTag# x)
-
-select_altAlg :: Int -> [LinkedAltAlg] -> Maybe LinkedIExpr -> ([(Id,Rep)],LinkedIExpr)
-select_altAlg tag [] Nothing = error "select_altAlg: no match and no default?!"
-select_altAlg tag [] (Just def) = ([],def)
-select_altAlg tag ((AltAlg tagNo vars rhs):alts) def
- = if tag == tagNo
- then (vars,rhs)
- else select_altAlg tag alts def
-
--- literal may only be a literal, not an arbitrary expression
-select_altPrim :: [LinkedAltPrim] -> Maybe LinkedIExpr -> LinkedIExpr -> LinkedIExpr
-select_altPrim [] Nothing literal = error "select_altPrim: no match and no default?!"
-select_altPrim [] (Just def) literal = def
-select_altPrim ((AltPrim lit rhs):alts) def literal
- = if eqLits lit literal
- then rhs
- else select_altPrim alts def literal
-
-eqLits (LitI i1#) (LitI i2#) = i1# ==# i2#
-
--- ----------------------------------------------------------------------
--- Grotty inspection and creation of closures
--- ----------------------------------------------------------------------
-
--- a is a constructor
-indexPtrOffClosure :: a -> Int -> b
-indexPtrOffClosure con (I# offset)
- = case indexPtrOffClosure# con offset of (# x #) -> x
-
-indexIntOffClosure :: a -> Int -> Int#
-indexIntOffClosure con (I# offset)
- = case wordToInt (W# (indexWordOffClosure# con offset)) of I# i# -> i#
-
-indexFloatOffClosure :: a -> Int -> Float#
-indexFloatOffClosure con (I# offset)
- = unsafeCoerce# (indexWordOffClosure# con offset)
- -- TOCK TOCK TOCK! Those GHC developers are crazy.
-
-indexDoubleOffClosure :: a -> Int -> Double#
-indexDoubleOffClosure con (I# offset)
- = unsafeCoerce# (panic "indexDoubleOffClosure")
-
-setPtrOffClosure :: a -> Int# -> b -> a
-setPtrOffClosure a i b = case setPtrOffClosure# a i b of (# c #) -> c
-
-setIntOffClosure :: a -> Int# -> Int# -> a
-setIntOffClosure a i b = case setWordOffClosure# a i (int2Word# b) of (# c #) -> c
-
-setFloatOffClosure :: a -> Int# -> Float# -> a
-setFloatOffClosure a i b = case setWordOffClosure# a i (unsafeCoerce# b) of (# c #) -> c
-
-setDoubleOffClosure :: a -> Int# -> Double# -> a
-setDoubleOffClosure a i b = unsafeCoerce# (panic "setDoubleOffClosure")
-
-------------------------------------------------------------------------
---- Manufacturing of info tables for DataCons defined in this module ---
-------------------------------------------------------------------------
-
-#if __GLASGOW_HASKELL__ <= 408
-type ItblPtr = Addr
-#else
-type ItblPtr = Ptr StgInfoTable
-#endif
-
--- Make info tables for the data decls in this module
-mkITbls :: [TyCon] -> IO ItblEnv
-mkITbls [] = return emptyFM
-mkITbls (tc:tcs) = do itbls <- mkITbl tc
- itbls2 <- mkITbls tcs
- return (itbls `plusFM` itbls2)
-
-mkITbl :: TyCon -> IO ItblEnv
-mkITbl tc
--- | trace ("TYCON: " ++ showSDoc (ppr tc)) False
--- = error "?!?!"
- | not (isDataTyCon tc)
- = return emptyFM
- | n == length dcs -- paranoia; this is an assertion.
- = make_constr_itbls dcs
- where
- dcs = tyConDataCons tc
- n = tyConFamilySize tc
-
-cONSTR :: Int
-cONSTR = 1 -- as defined in ghc/includes/ClosureTypes.h
-
--- Assumes constructors are numbered from zero, not one
-make_constr_itbls :: [DataCon] -> IO ItblEnv
-make_constr_itbls cons
- | length cons <= 8
- = do is <- mapM mk_vecret_itbl (zip cons [0..])
- return (listToFM is)
- | otherwise
- = do is <- mapM mk_dirret_itbl (zip cons [0..])
- return (listToFM is)
- where
- mk_vecret_itbl (dcon, conNo)
- = mk_itbl dcon conNo (vecret_entry conNo)
- mk_dirret_itbl (dcon, conNo)
- = mk_itbl dcon conNo mci_constr_entry
-
- mk_itbl :: DataCon -> Int -> Addr -> IO (Name,ItblPtr)
- mk_itbl dcon conNo entry_addr
- = let (tot_wds, ptr_wds, _)
- = mkVirtHeapOffsets typePrimRep (dataConRepArgTys dcon)
- ptrs = ptr_wds
- nptrs = tot_wds - ptr_wds
- itbl = StgInfoTable {
- ptrs = fromIntegral ptrs, nptrs = fromIntegral nptrs,
- tipe = fromIntegral cONSTR,
- srtlen = fromIntegral conNo,
- code0 = fromIntegral code0, code1 = fromIntegral code1,
- code2 = fromIntegral code2, code3 = fromIntegral code3,
- code4 = fromIntegral code4, code5 = fromIntegral code5,
- code6 = fromIntegral code6, code7 = fromIntegral code7
- }
- -- Make a piece of code to jump to "entry_label".
- -- This is the only arch-dependent bit.
- -- On x86, if entry_label has an address 0xWWXXYYZZ,
- -- emit movl $0xWWXXYYZZ,%eax ; jmp *%eax
- -- which is
- -- B8 ZZ YY XX WW FF E0
- (code0,code1,code2,code3,code4,code5,code6,code7)
- = (0xB8, byte 0 entry_addr_w, byte 1 entry_addr_w,
- byte 2 entry_addr_w, byte 3 entry_addr_w,
- 0xFF, 0xE0,
- 0x90 {-nop-})
-
- entry_addr_w :: Word32
- entry_addr_w = fromIntegral (addrToInt entry_addr)
- in
- do addr <- malloc
- --putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
- --putStrLn ("# ptrs of itbl is " ++ show ptrs)
- --putStrLn ("# nptrs of itbl is " ++ show nptrs)
- poke addr itbl
- return (getName dcon, addr `plusPtr` 8)
-
-
-byte :: Int -> Word32 -> Word32
-byte 0 w = w .&. 0xFF
-byte 1 w = (w `shiftR` 8) .&. 0xFF
-byte 2 w = (w `shiftR` 16) .&. 0xFF
-byte 3 w = (w `shiftR` 24) .&. 0xFF
-
-
-vecret_entry 0 = mci_constr1_entry
-vecret_entry 1 = mci_constr2_entry
-vecret_entry 2 = mci_constr3_entry
-vecret_entry 3 = mci_constr4_entry
-vecret_entry 4 = mci_constr5_entry
-vecret_entry 5 = mci_constr6_entry
-vecret_entry 6 = mci_constr7_entry
-vecret_entry 7 = mci_constr8_entry
-
--- entry point for direct returns for created constr itbls
-foreign label "stg_mci_constr_entry" mci_constr_entry :: Addr
--- and the 8 vectored ones
-foreign label "stg_mci_constr1_entry" mci_constr1_entry :: Addr
-foreign label "stg_mci_constr2_entry" mci_constr2_entry :: Addr
-foreign label "stg_mci_constr3_entry" mci_constr3_entry :: Addr
-foreign label "stg_mci_constr4_entry" mci_constr4_entry :: Addr
-foreign label "stg_mci_constr5_entry" mci_constr5_entry :: Addr
-foreign label "stg_mci_constr6_entry" mci_constr6_entry :: Addr
-foreign label "stg_mci_constr7_entry" mci_constr7_entry :: Addr
-foreign label "stg_mci_constr8_entry" mci_constr8_entry :: Addr
-
-
-
-data Constructor = Constructor Int{-ptrs-} Int{-nptrs-}
-
-
--- Ultra-minimalist version specially for constructors
-data StgInfoTable = StgInfoTable {
- ptrs :: Word16,
- nptrs :: Word16,
- srtlen :: Word16,
- tipe :: Word16,
- code0, code1, code2, code3, code4, code5, code6, code7 :: Word8
-}
-
-
-instance Storable StgInfoTable where
-
- sizeOf itbl
- = (sum . map (\f -> f itbl))
- [fieldSz ptrs, fieldSz nptrs, fieldSz srtlen, fieldSz tipe,
- fieldSz code0, fieldSz code1, fieldSz code2, fieldSz code3,
- fieldSz code4, fieldSz code5, fieldSz code6, fieldSz code7]
-
- alignment itbl
- = (sum . map (\f -> f itbl))
- [fieldAl ptrs, fieldAl nptrs, fieldAl srtlen, fieldAl tipe,
- fieldAl code0, fieldAl code1, fieldAl code2, fieldAl code3,
- fieldAl code4, fieldAl code5, fieldAl code6, fieldAl code7]
-
- poke a0 itbl
- = do a1 <- store (ptrs itbl) (castPtr a0)
- a2 <- store (nptrs itbl) a1
- a3 <- store (tipe itbl) a2
- a4 <- store (srtlen itbl) a3
- a5 <- store (code0 itbl) a4
- a6 <- store (code1 itbl) a5
- a7 <- store (code2 itbl) a6
- a8 <- store (code3 itbl) a7
- a9 <- store (code4 itbl) a8
- aA <- store (code5 itbl) a9
- aB <- store (code6 itbl) aA
- aC <- store (code7 itbl) aB
- return ()
-
- peek a0
- = do (a1,ptrs) <- load (castPtr a0)
- (a2,nptrs) <- load a1
- (a3,tipe) <- load a2
- (a4,srtlen) <- load a3
- (a5,code0) <- load a4
- (a6,code1) <- load a5
- (a7,code2) <- load a6
- (a8,code3) <- load a7
- (a9,code4) <- load a8
- (aA,code5) <- load a9
- (aB,code6) <- load aA
- (aC,code7) <- load aB
- return StgInfoTable { ptrs = ptrs, nptrs = nptrs,
- srtlen = srtlen, tipe = tipe,
- code0 = code0, code1 = code1, code2 = code2,
- code3 = code3, code4 = code4, code5 = code5,
- code6 = code6, code7 = code7 }
-
-fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
-fieldSz sel x = sizeOf (sel x)
-
-fieldAl :: (Storable a, Storable b) => (a -> b) -> a -> Int
-fieldAl sel x = alignment (sel x)
-
-store :: Storable a => a -> Ptr a -> IO (Ptr b)
-store x addr = do poke addr x
- return (castPtr (addr `plusPtr` sizeOf x))
-
-load :: Storable a => Ptr a -> IO (Ptr b, a)
-load addr = do x <- peek addr
- return (castPtr (addr `plusPtr` sizeOf x), x)
-
------------------------------------------------------------------------------q
-
-foreign import "strncpy" strncpy :: Ptr a -> ByteArray# -> CInt -> IO ()
-#endif
-
-\end{code}
-
diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs
index 55082a7d9a..1733d639f7 100644
--- a/ghc/compiler/main/DriverPipeline.hs
+++ b/ghc/compiler/main/DriverPipeline.hs
@@ -1,5 +1,5 @@
-----------------------------------------------------------------------------
--- $Id: DriverPipeline.hs,v 1.41 2000/12/12 14:35:08 simonmar Exp $
+-- $Id: DriverPipeline.hs,v 1.42 2000/12/18 12:43:04 sewardj Exp $
--
-- GHC Driver
--
@@ -827,8 +827,8 @@ compile ghci_mode summary source_unchanged old_iface hst hit pcs = do
-- as our "unlinked" object.
HscInterpreted ->
case maybe_interpreted_code of
- Just (code,itbl_env) -> do tm <- getClockTime
- return ([Trees code itbl_env], tm)
+ Just (bcos,itbl_env) -> do tm <- getClockTime
+ return ([BCOs bcos itbl_env], tm)
Nothing -> panic "compile: no interpreted code"
-- we're in batch mode: finish the compilation pipeline.
diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index 9c01b767f4..a20ad02558 100644
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -15,7 +15,6 @@ module HscMain ( HscResult(..), hscMain,
#ifdef GHCI
import RdrHsSyn ( RdrNameHsExpr )
import Rename ( renameExpr )
-import CoreToStg ( coreExprToStg )
import StringBuffer ( stringToStringBuffer, freeStringBuffer )
import Unique ( Uniquable(..) )
import Type ( Type, splitTyConApp_maybe )
@@ -72,7 +71,6 @@ import Module ( Module, lookupModuleEnvByName )
import Monad ( when )
import Maybe ( isJust )
import IO
-import List ( intersperse )
\end{code}
@@ -96,7 +94,7 @@ data HscResult
ModIface -- new iface (if any compilation was done)
(Maybe String) -- generated stub_h filename (in /tmp)
(Maybe String) -- generated stub_c filename (in /tmp)
- (Maybe ([UnlinkedIBind],ItblEnv)) -- interpreted code, if any
+ (Maybe ([UnlinkedBCO],ItblEnv)) -- interpreted code, if any
-- no errors or warnings; the individual passes
@@ -236,24 +234,18 @@ hscRecomp ghci_mode dflags location maybe_checked_iface hst hit pcs_ch
maybe_checked_iface new_iface new_details
-------------------
- -- CONVERT TO STG
+ -- CONVERT TO STG and COMPLETE CODE GENERATION
-------------------
- ; (stg_binds, cost_centre_info)
- <- myCoreToStg dflags this_mod tidy_binds env_tc
-
- -------------------
- -- COMPLETE CODE GENERATION
- -------------------
- ; (maybe_stub_h_filename, maybe_stub_c_filename, maybe_ibinds)
+ ; (maybe_stub_h_filename, maybe_stub_c_filename, maybe_bcos)
<- restOfCodeGeneration dflags toInterp this_mod
(map ideclName (hsModuleImports rdr_module))
- cost_centre_info foreign_stuff env_tc stg_binds tidy_binds
+ foreign_stuff env_tc tidy_binds
hit (pcs_PIT pcs_simpl)
-- and the answer is ...
; return (HscRecomp pcs_simpl new_details final_iface
maybe_stub_h_filename maybe_stub_c_filename
- maybe_ibinds)
+ maybe_bcos)
}}}}}}}
@@ -313,7 +305,7 @@ simplThenTidy dflags pcs hst this_mod is_exported binds rules
<- core2core dflags pcs hst is_exported binds rules
-- Do saturation and convert to A-normal form
- -- NOTE: future passes cannot transform the syntax, only annotate it
+ -- NOTE: subsequent passes may not transform the syntax, only annotate it
saturated <- coreSatPgm dflags simplified
-- Do the final tidy-up
@@ -323,17 +315,21 @@ simplThenTidy dflags pcs hst this_mod is_exported binds rules
return (pcs', tidy_binds, tidy_orphan_rules)
-restOfCodeGeneration dflags toInterp this_mod imported_module_names cost_centre_info
- foreign_stuff env_tc stg_binds tidy_binds
+restOfCodeGeneration dflags toInterp this_mod imported_module_names
+ foreign_stuff env_tc tidy_binds
hit pit -- these last two for mapping ModNames to Modules
| toInterp
- = do (ibinds,itbl_env)
- <- stgBindsToInterpSyn dflags (map fst stg_binds)
- local_tycons local_classes
- return (Nothing, Nothing, Just (ibinds,itbl_env))
+ = do (bcos,itbl_env)
+ <- byteCodeGen dflags tidy_binds local_tycons local_classes
+ return (Nothing, Nothing, Just (bcos,itbl_env))
| otherwise
- = do -------------------------- Code generation -------------------------------
+ = do
+ -------------------------- Convert to STG -------------------------------
+ (stg_binds, cost_centre_info)
+ <- myCoreToStg dflags this_mod tidy_binds env_tc
+
+ -------------------------- Code generation -------------------------------
-- _scc_ "CodeGen"
abstractC <- codeGen dflags this_mod imported_modules
cost_centre_info fe_binders
@@ -403,7 +399,7 @@ hscExpr
-> Module -- Context for compiling
-> String -- The expression
-> IO ( PersistentCompilerState,
- Maybe (UnlinkedIExpr, PrintUnqualified, Type) )
+ Maybe (UnlinkedBCOExpr, PrintUnqualified, Type) )
hscExpr dflags hst hit pcs0 this_module expr
= do {
@@ -439,8 +435,8 @@ hscExpr dflags hst hit pcs0 this_module expr
("print (" ++ expr ++ ")")
case maybe_stuff of
Nothing -> return (new_pcs, maybe_stuff)
- Just (expr, _, _) ->
- return (new_pcs, Just (expr, print_unqual, ty))
+ Just (bcos, _, _) ->
+ return (new_pcs, Just (bcos, print_unqual, ty))
else do
-- Desugar it
@@ -453,15 +449,12 @@ hscExpr dflags hst hit pcs0 this_module expr
-- Saturate it
sat_expr <- coreSatExpr dflags simpl_expr;
- -- Convert to STG
- let stg_expr = coreExprToStg sat_expr;
-
-- ToDo: need to do SRTs?
- -- Convert to InterpSyn
- unlinked_iexpr <- stgExprToInterpSyn dflags stg_expr;
+ -- Convert to BCOs
+ bcos <- coreExprToBCOs dflags sat_expr
- return (pcs2, Just (unlinked_iexpr, print_unqual, ty));
+ return (pcs2, Just (bcos, print_unqual, ty));
}}}}
hscParseExpr :: DynFlags -> String -> IO (Maybe RdrNameHsExpr)
diff --git a/ghc/compiler/main/Interpreter.hs b/ghc/compiler/main/Interpreter.hs
index 2945115ebb..8ecb257e2d 100644
--- a/ghc/compiler/main/Interpreter.hs
+++ b/ghc/compiler/main/Interpreter.hs
@@ -1,5 +1,5 @@
-----------------------------------------------------------------------------
--- $Id: Interpreter.hs,v 1.8 2000/11/20 16:28:29 simonmar Exp $
+-- $Id: Interpreter.hs,v 1.9 2000/12/18 12:43:04 sewardj Exp $
--
-- Interpreter subsystem wrapper
--
@@ -9,8 +9,7 @@
module Interpreter (
#ifdef GHCI
- module StgInterp,
- module InterpSyn,
+ module ByteCodeGen,
module Linker
#else
ClosureEnv, emptyClosureEnv,
@@ -29,8 +28,7 @@ module Interpreter (
-- YES! We have an interpreter
---------------------------------------------
-import StgInterp
-import InterpSyn
+import ByteCodeGen
import Linker
#else
View Lorry Controller Status