From 459e7bd4622ea5bb8e90511b5fc6c7d8058dbd5f Mon Sep 17 00:00:00 2001 From: simonmar Date: Fri, 17 Nov 2000 16:53:28 +0000 Subject: [PATCH] [project @ 2000-11-17 16:53:27 by simonmar] Results of today's hacking: - We can now execute expressions from the GHCi prompt. However, a problem with the typechecker environment means that identifiers from outside the current module aren't resolved :-( - loading up a multi-module program in the interpreter seems to work. Interpreting is kinda slow (ok, very slow), but I'm hoping it'll get better when I compile the interpreter w/ optimisation. - :set sort of works - you can do ":set -dshow-passes", for example - lots of bugfixes, etc. --- ghc/compiler/compMan/CmLink.lhs | 12 ++-- ghc/compiler/compMan/CompManager.lhs | 58 +++++++++------ ghc/compiler/ghci/InteractiveUI.hs | 67 ++++++++++++------ ghc/compiler/ghci/StgInterp.lhs | 128 +++++++++++++++++++--------------- ghc/compiler/main/HscMain.lhs | 116 +++++++++++++++++++++--------- ghc/compiler/main/Interpreter.hs | 5 +- ghc/compiler/main/Main.hs | 3 +- ghc/compiler/rename/Rename.lhs | 7 +- ghc/compiler/simplCore/SimplCore.lhs | 4 +- ghc/compiler/stgSyn/CoreToStg.lhs | 28 ++++++-- ghc/compiler/utils/StringBuffer.lhs | 27 ++++++- 11 files changed, 300 insertions(+), 155 deletions(-) diff --git a/ghc/compiler/compMan/CmLink.lhs b/ghc/compiler/compMan/CmLink.lhs index c6619a6..44f9a89 100644 --- a/ghc/compiler/compMan/CmLink.lhs +++ b/ghc/compiler/compMan/CmLink.lhs @@ -12,7 +12,7 @@ module CmLink ( Linkable(..), Unlinked(..), link, unload, PersistentLinkerState{-abstractly!-}, emptyPLS, - lookupClosure + linkExpr ) where @@ -193,7 +193,7 @@ linkFinish pls mods ul_trees = do stuff = [ (trees,itbls) | Trees trees itbls <- ul_trees ] (ibinds, new_itbl_env, new_closure_env) <- - linkIModules closure_env' itbl_env' stuff + linkIModules itbl_env' closure_env' stuff let new_pls = PersistentLinkerState { closure_env = new_closure_env, @@ -206,10 +206,8 @@ linkFinish pls mods ul_trees = do unload :: PersistentLinkerState -> IO PersistentLinkerState unload pls = return pls{ closure_env = emptyFM, itbl_env = emptyFM } -lookupClosure :: RdrName -> PersistentLinkerState -> Maybe HValue -lookupClosure nm PersistentLinkerState{ closure_env = cenv } = - case lookupFM cenv nm of - Nothing -> Nothing - Just hv -> Just hv +linkExpr :: PersistentLinkerState -> UnlinkedIExpr -> IO HValue +linkExpr PersistentLinkerState{ itbl_env = ie, closure_env = ce } expr + = iExprToHValue ie ce expr #endif \end{code} diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index a653f34..ba72c97 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -4,27 +4,18 @@ \section[CompManager]{The Compilation Manager} \begin{code} -module CompManager ( cmInit, cmLoadModule, +module CompManager ( cmInit, cmLoadModule, cmGetExpr, cmRunExpr, - CmState, emptyCmState, -- abstract - cmLookupSymbol --tmp + CmState, emptyCmState -- abstract ) where #include "HsVersions.h" -import List ( nub ) -import Maybe ( catMaybes, fromMaybe ) -import Maybes ( maybeToBool ) -import Outputable -import UniqFM ( emptyUFM, lookupUFM, addToUFM, delListFromUFM, - UniqFM, listToUFM ) -import Unique ( Uniquable ) -import Digraph ( SCC(..), stronglyConnComp ) - import CmLink import CmTypes import HscTypes +import HscMain ( hscExpr ) import Interpreter ( HValue ) import Module ( ModuleName, moduleName, isModuleInThisPackage, moduleEnvElts, @@ -40,35 +31,59 @@ import Module import PrelNames ( mainName ) import HscMain ( initPersistentCompilerState ) import Finder ( findModule, emptyHomeDirCache ) +import UniqFM ( emptyUFM, lookupUFM, addToUFM, delListFromUFM, + UniqFM, listToUFM ) +import Unique ( Uniquable ) +import Digraph ( SCC(..), stronglyConnComp ) import DriverUtil ( BarfKind(..), splitFilename3 ) +import CmdLineOpts ( DynFlags ) import Util +import Outputable import Panic ( panic ) +-- lang import Exception ( throwDyn ) -import IO + +-- std import Time ( ClockTime ) import Directory ( getModificationTime, doesFileExist ) +import IO +import List ( nub ) +import Maybe ( catMaybes, fromMaybe, isJust ) +import PrelGHC ( unsafeCoerce# ) \end{code} - \begin{code} cmInit :: PackageConfigInfo -> GhciMode -> IO CmState cmInit raw_package_info gmode = emptyCmState raw_package_info gmode cmGetExpr :: CmState + -> DynFlags -> ModuleName -> String - -> IO (CmState, Either [SDoc] HValue) -cmGetExpr cmstate modhdl expr - = return (panic "cmGetExpr:unimp") + -> IO (CmState, Maybe HValue) +cmGetExpr cmstate dflags modname expr + = do (new_pcs, maybe_unlinked_iexpr) <- + hscExpr dflags hst hit pcs (mkModuleInThisPackage modname) expr + case maybe_unlinked_iexpr of + Nothing -> return (cmstate{ pcs=new_pcs }, Nothing) + Just uiexpr -> do + hValue <- linkExpr pls uiexpr + return (cmstate{ pcs=new_pcs }, Just hValue) + + -- ToDo: check that the module we passed in is sane/exists? + where + CmState{ pcs=pcs, pcms=pcms, pls=pls } = cmstate + PersistentCMState{ hst=hst, hit=hit } = pcms +-- The HValue should represent a value of type IO () (Perhaps IO a?) cmRunExpr :: HValue -> IO () cmRunExpr hval - = return (panic "cmRunExpr:unimp") - + = do unsafeCoerce# hval :: IO () + -- putStrLn "done." -- Persistent state just for CM, excluding link & compile subsystems data PersistentCMState @@ -312,7 +327,7 @@ findPartiallyCompletedCycles modsDone theGraph -- Does this ModDetails export Main.main? exports_main :: ModDetails -> Bool exports_main md - = maybeToBool (lookupNameEnv (md_types md) mainName) + = isJust (lookupNameEnv (md_types md) mainName) -- Add the given (LM-form) Linkables to the UI, overwriting previous @@ -620,7 +635,4 @@ summarise mod location return (Just time)) `catch` (\err -> return Nothing) - -cmLookupSymbol :: RdrName -> CmState -> Maybe HValue -cmLookupSymbol nm CmState{ pls = pls } = lookupClosure nm pls \end{code} diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 2aa1c67..4f16a56 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.3 2000/11/16 16:54:36 simonmar Exp $ +-- $Id: InteractiveUI.hs,v 1.4 2000/11/17 16:53:27 simonmar Exp $ -- -- GHC Interactive User Interface -- @@ -13,12 +13,11 @@ module InteractiveUI (interactiveUI) where import CompManager import CmStaticInfo +import DriverFlags import DriverUtil import DriverState import Linker import Module -import RdrName -- tmp -import OccName -- tmp import Panic import Util @@ -31,8 +30,6 @@ import Directory import IO import Char -import PrelGHC ( unsafeCoerce# ) - ----------------------------------------------------------------------------- ghciWelcomeMsg = "\ @@ -84,7 +81,7 @@ interactiveUI st = do #ifndef NO_READLINE Readline.initialize #endif - _ <- (unGHCi uiLoop) GHCiState{ current_module = mkModuleName "Prelude", + _ <- (unGHCi uiLoop) GHCiState{ current_module = mkModuleName "Main", target = Nothing, cmstate = st } return () @@ -107,26 +104,35 @@ uiLoop = do runCommand l uiLoop +-- Top level exception handler, just prints out the exception and carries on. runCommand c = - myCatchDyn (doCommand c) + ghciHandle ( \other_exception ->io (putStrLn (show other_exception) )) $ + ghciHandleDyn (\dyn -> case dyn of PhaseFailed phase code -> io ( putStrLn ("Phase " ++ phase ++ " failed (code " ++ show code ++ ")")) Interrupted -> io (putStrLn "Interrupted.") _ -> io (putStrLn (show (dyn :: BarfKind))) - ) + ) $ + doCommand c doCommand (':' : command) = specialCommand command doCommand expr = do st <- getGHCiState - io (hPutStrLn stdout ("Run expression: " ++ expr)) + dflags <- io (readIORef v_DynFlags) + (st, maybe_hvalue) <- + io (cmGetExpr (cmstate st) dflags (current_module st) expr) + case maybe_hvalue of + Nothing -> return () + Just hv -> io (cmRunExpr hv) +{- let (mod,'.':str) = break (=='.') expr case cmLookupSymbol (mkOrig varName (mkModuleName mod) (_PK_ str)) (cmstate st) of Nothing -> io (putStrLn "nothing.") - Just e -> io (do unsafeCoerce# e :: IO () - putStrLn "done.") + Just e -> io ( return () +-} specialCommand str = do let (cmd,rest) = break isSpace str @@ -144,8 +150,6 @@ noArgs c = io (hPutStrLn stdout ("command `:" ++ c ++ "' takes no arguments")) ----------------------------------------------------------------------------- -- Commands --- ToDo: don't forget to catch errors - help :: String -> GHCi () help _ = io (putStr helpText) @@ -155,8 +159,16 @@ changeDirectory = io . setCurrentDirectory loadModule :: String -> GHCi () loadModule path = do state <- getGHCiState - (new_cmstate, mod) <- io (cmLoadModule (cmstate state) ({-ToDo!!-}mkModuleName path)) - setGHCiState state{cmstate=new_cmstate, target=Just path} + (new_cmstate, mod) <- io (cmLoadModule (cmstate state) + ({-ToDo!!-}mkModuleName path)) + let new_state = GHCiState { + cmstate = new_cmstate, + current_module = case mod of + Nothing -> current_module state + Just m -> m, + target = Just path + } + setGHCiState new_state reloadModule :: String -> GHCi () reloadModule "" = do @@ -167,8 +179,25 @@ reloadModule "" = do setGHCiState state{cmstate=new_cmstate} reloadModule _ = noArgs ":reload" +-- set options in the interpreter. Syntax is exactly the same as the +-- ghc command line, except that certain options aren't available (-C, +-- -E etc.) +-- +-- This is pretty fragile: most options won't work as expected. ToDo: +-- figure out which ones & disallow them. setOptions :: String -> GHCi () -setOptions = panic "setOptions" +setOptions str = + io (do leftovers <- processArgs static_flags (words str) [] + dyn_flags <- readIORef v_InitDynFlags + writeIORef v_DynFlags dyn_flags + leftovers <- processArgs dynamic_flags leftovers [] + dyn_flags <- readIORef v_DynFlags + writeIORef v_InitDynFlags dyn_flags + if (not (null leftovers)) + then throwDyn (OtherError ("unrecognised flags: " ++ + unwords leftovers)) + else return () + ) typeOfExpr :: String -> GHCi () typeOfExpr = panic "typeOfExpr" @@ -200,9 +229,9 @@ setGHCiState s = GHCi $ \_ -> return (s,()) io m = GHCi $ \s -> m >>= \a -> return (s,a) -myCatch (GHCi m) h = GHCi $ \s -> +ghciHandle h (GHCi m) = GHCi $ \s -> Exception.catch (m s) (\e -> unGHCi (h e) s) -myCatchDyn (GHCi m) h = GHCi $ \s -> +ghciHandleDyn h (GHCi m) = GHCi $ \s -> Exception.catchDyn (m s) (\e -> unGHCi (h e) s) ----------------------------------------------------------------------------- @@ -232,5 +261,3 @@ findFile (d:ds) obj = do let path = d ++ '/':obj b <- doesFileExist path if b then return path else findFile ds obj - - diff --git a/ghc/compiler/ghci/StgInterp.lhs b/ghc/compiler/ghci/StgInterp.lhs index f328ec0..fdb7385 100644 --- a/ghc/compiler/ghci/StgInterp.lhs +++ b/ghc/compiler/ghci/StgInterp.lhs @@ -6,9 +6,26 @@ \begin{code} module StgInterp ( - ClosureEnv, ItblEnv, filterRdrNameEnv, - linkIModules, - stgToInterpSyn, + + ClosureEnv, ItblEnv, + filterRdrNameEnv, -- :: [ModuleName] -> FiniteMap RdrName a + -- -> FiniteMap RdrName 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 {- ----------------------------------------------------------------------------- @@ -65,9 +82,12 @@ import RdrName ( RdrName, rdrNameModule, rdrNameOcc ) import FiniteMap import Panic ( panic ) import OccName ( occNameString ) +import ErrUtils ( showPass ) +import CmdLineOpts ( DynFlags ) import Foreign import CTypes +import IO -- --------------------------------------------------------------------------- -- Environments needed by the linker @@ -83,63 +103,34 @@ filterRdrNameEnv mods env = filterFM (\n _ -> rdrNameModule n `notElem` mods) env -- --------------------------------------------------------------------------- --- Run our STG program through the interpreter +-- Turn an UnlinkedIExpr into a value we can run, for the interpreter -- --------------------------------------------------------------------------- -#if 0 --- To be nuked at some point soon. -runStgI :: [TyCon] -> [Class] -> [StgBinding] -> IO Int - --- the bindings need to have a binding for stgMain, and the --- body of it had better represent something of type Int# -> Int# -runStgI tycons classes stgbinds - = do - let unlinked_binds = concatMap (translateBind emptyUniqSet) stgbinds - -{- - let dbg_txt - = "-------------------- Unlinked Binds --------------------\n" - ++ showSDoc (vcat (map (\bind -> pprIBind bind $$ char ' ') - unlinked_binds)) - - hPutStr stderr dbg_txt --} - (linked_binds, ie, ce) <- - linkIModules emptyFM emptyFM [(tycons,unlinked_binds)] - - let dbg_txt - = "-------------------- Linked Binds --------------------\n" - ++ showSDoc (vcat (map (\bind -> pprIBind bind $$ char ' ') - linked_binds)) - - hPutStr stderr dbg_txt - - let stgMain - = case [rhs | IBind v rhs <- linked_binds, showSDoc (ppr v) == "stgMain"] of - (b:_) -> b - [] -> error "\n\nCan't find `stgMain'. Giving up.\n\n" - - let result - = I# (evalI (AppII stgMain (LitI 0#)) - emptyUFM{-initial de-} - ) - return result -#endif +iExprToHValue :: ItblEnv -> ClosureEnv -> UnlinkedIExpr -> IO HValue +iExprToHValue ie ce expr = return (interp (linkIExpr ie ce expr)) -- --------------------------------------------------------------------------- -- Convert STG to an unlinked interpretable -- --------------------------------------------------------------------------- -- visible from outside -stgToInterpSyn :: [StgBinding] - -> [TyCon] -> [Class] - -> IO ([UnlinkedIBind], ItblEnv) -stgToInterpSyn binds local_tycons local_classes - = do let ibinds = concatMap (translateBind emptyUniqSet) binds +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 itblenv <- mkITbls tycs return (ibinds, itblenv) +stgExprToInterpSyn :: DynFlags + -> StgExpr + -> IO UnlinkedIExpr +stgExprToInterpSyn dflags expr + = do showPass dflags "StgToInterp" + return (stg2expr emptyUniqSet expr) translateBind :: UniqSet Id -> StgBinding -> [UnlinkedIBind] translateBind ie (StgNonRec v e) = [IBind v (rhs2expr ie e)] @@ -227,6 +218,9 @@ primRep2Rep primRep ArrayRep -> RepP ByteArrayRep -> RepP + FloatRep -> RepF + DoubleRep -> RepD + other -> pprPanic "primRep2Rep" (ppr other) repOfStgExpr :: StgExpr -> Rep @@ -300,10 +294,11 @@ lit2expr lit -- Addr#. So, copy the string into C land and introduce a -- memory leak at the same time. let n = I# l in - case unsafePerformIO (do a <- mallocBytes (n+1); - strncpy a ba (fromIntegral n); - pokeByteOff a n '\0' - case a of { Ptr a -> return a }) + -- 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" @@ -352,7 +347,11 @@ stg2expr ie stgexpr (translateBind ie binds) (stg2expr (addListToUniqSet ie (map fst bs)) body) - other + -- treat let-no-escape just like let. + StgLetNoEscape _ _ binds body + -> stg2expr ie (StgLet binds body) + + other -> pprPanic "stg2expr" (ppr stgexpr) where doPrimAlt (lit,rhs) @@ -386,7 +385,12 @@ 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; RepP -> VarP } $ var + | var `elementOfUniqSet` ie = + (case rep of + RepI -> VarI + RepF -> VarF + RepD -> VarD + RepP -> VarP) var | otherwise = Native (toRdrName var) mkRec RepI = RecI @@ -414,11 +418,11 @@ id2VaaRep var = (var, repOfId var) -- Link interpretables into something we can run -- --------------------------------------------------------------------------- -linkIModules :: ClosureEnv -- incoming global closure env; returned updated - -> ItblEnv -- incoming global itbl env; returned updated +linkIModules :: ItblEnv -- incoming global itbl env; returned updated + -> ClosureEnv -- incoming global closure env; returned updated -> [([UnlinkedIBind], ItblEnv)] -> IO ([LinkedIBind], ItblEnv, ClosureEnv) -linkIModules gce gie mods = do +linkIModules gie gce mods = do let (bindss, ies) = unzip mods binds = concat bindss top_level_binders = map (toRdrName.binder) binds @@ -444,6 +448,7 @@ linkIBinds ie ce binds = map (linkIBind ie ce) binds linkIBind ie ce (IBind bndr expr) = IBind bndr (linkIExpr ie ce expr) +linkIExpr :: ItblEnv -> ClosureEnv -> UnlinkedIExpr -> LinkedIExpr linkIExpr ie ce expr = case expr of CaseAlgP bndr expr alts dflt -> @@ -563,6 +568,9 @@ linkDefault ie ce (Just expr) = Just (linkIExpr ie ce expr) -- Evaluator for things of boxed (pointer) representation -- --------------------------------------------------------------------------- +interp :: LinkedIExpr -> HValue +interp iexpr = unsafeCoerce# (evalP iexpr emptyUFM) + evalP :: LinkedIExpr -> UniqFM boxed -> boxed {- @@ -695,10 +703,12 @@ evalP other de -- 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# @@ -752,10 +762,12 @@ evalI other de -- 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# @@ -806,10 +818,12 @@ evalF other de -- 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# diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index a4209ae..74c7a87 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -4,7 +4,7 @@ \section[GHC_Main]{Main driver for Glasgow Haskell compiler} \begin{code} -module HscMain ( HscResult(..), hscMain, +module HscMain ( HscResult(..), hscMain, hscExpr, initPersistentCompilerState ) where #include "HsVersions.h" @@ -13,25 +13,27 @@ import Maybe ( isJust ) import IO ( hPutStrLn, stderr ) import HsSyn -import StringBuffer ( hGetStringBuffer ) +import StringBuffer ( hGetStringBuffer, + stringToStringBuffer, freeStringBuffer ) import Parser +import RdrHsSyn ( RdrNameHsExpr ) import Lex ( PState(..), ParseResult(..) ) import SrcLoc ( mkSrcLoc ) -import Rename ( renameModule, checkOldIface, closeIfaceDecls ) +import Rename import Rules ( emptyRuleBase ) import PrelInfo ( wiredInThingEnv, wiredInThings ) import PrelNames ( knownKeyNames ) import MkIface ( completeIface, mkModDetailsFromIface, mkModDetails, writeIface, pprIface ) -import TcModule ( TcResults(..), typecheckModule ) +import TcModule import InstEnv ( emptyInstEnv ) -import Desugar ( deSugar ) -import SimplCore ( core2core ) +import Desugar +import SimplCore import OccurAnal ( occurAnalyseBinds ) import CoreUtils ( coreBindsSize ) import CoreTidy ( tidyCorePgm ) -import CoreToStg ( topCoreBindsToStg ) +import CoreToStg ( topCoreBindsToStg, coreToStgExpr ) import StgSyn ( collectFinalStgBinders ) import SimplStg ( stg2stg ) import CodeGen ( codeGen ) @@ -45,7 +47,7 @@ import UniqSupply ( mkSplitUniqSupply ) import Bag ( emptyBag ) import Outputable -import Interpreter ( UnlinkedIBind, ItblEnv, stgToInterpSyn ) +import Interpreter import CmStaticInfo ( GhciMode(..) ) import HscStats ( ppSourceStats ) import HscTypes ( ModDetails, ModIface(..), PersistentCompilerState(..), @@ -95,12 +97,14 @@ hscMain hscMain ghci_mode dflags source_unchanged location maybe_old_iface hst hit pcs = do { - putStrLn ("CHECKING OLD IFACE for hs = " ++ show (ml_hs_file location) - ++ ", hspp = " ++ show (ml_hspp_file location)); + showPass dflags ("Checking old interface for hs = " + ++ show (ml_hs_file location) + ++ ", hspp = " ++ show (ml_hspp_file location)); (pcs_ch, errs_found, (recomp_reqd, maybe_checked_iface)) - <- checkOldIface dflags hit hst pcs (unJust (ml_hi_file location) "hscMain") - source_unchanged maybe_old_iface; + <- checkOldIface dflags hit hst pcs + (unJust (ml_hi_file location) "hscMain") + source_unchanged maybe_old_iface; if errs_found then return (HscFail pcs_ch) @@ -178,6 +182,7 @@ hscRecomp ghci_mode dflags location maybe_checked_iface hst hit pcs_ch ------------------- -- RENAME ------------------- + ; showPass dflags "Rename" ; (pcs_rn, maybe_rn_result) <- renameModule dflags hit hst pcs_ch this_mod rdr_module ; case maybe_rn_result of { @@ -187,6 +192,7 @@ hscRecomp ghci_mode dflags location maybe_checked_iface hst hit pcs_ch ------------------- -- TYPECHECK ------------------- + ; showPass dflags "Typecheck" ; maybe_tc_result <- typecheckModule dflags pcs_rn hst new_iface print_unqualified rn_hs_decls ; case maybe_tc_result of { @@ -286,7 +292,8 @@ restOfCodeGeneration dflags toInterp this_mod imported_module_names cost_centre_ hit pit -- these last two for mapping ModNames to Modules | toInterp = do (ibinds,itbl_env) - <- stgToInterpSyn (map fst stg_binds) local_tycons local_classes + <- stgBindsToInterpSyn dflags (map fst stg_binds) + local_tycons local_classes return (Nothing, Nothing, Just (ibinds,itbl_env)) | otherwise @@ -324,6 +331,7 @@ restOfCodeGeneration dflags toInterp this_mod imported_module_names cost_centre_ dsThenSimplThenTidy dflags pcs hst this_mod print_unqual is_exported tc_result = do -------------------------- Desugaring ---------------- + showPass dflags "DeSugar" -- _scc_ "DeSugar" (desugared, rules, h_code, c_code, fe_binders) <- deSugar dflags pcs hst this_mod print_unqual tc_result @@ -334,6 +342,7 @@ dsThenSimplThenTidy dflags pcs hst this_mod print_unqual is_exported tc_result <- core2core dflags pcs hst is_exported desugared rules -- Do the final tidy-up + showPass dflags "TidyCore" (tidy_binds, tidy_orphan_rules) <- tidyCorePgm dflags this_mod simplified orphan_rules @@ -342,7 +351,6 @@ dsThenSimplThenTidy dflags pcs hst this_mod print_unqual is_exported tc_result myCoreToStg dflags this_mod tidy_binds = do - c2s_uniqs <- mkSplitUniqSupply 'c' st_uniqs <- mkSplitUniqSupply 'g' let occ_anal_tidy_binds = occurAnalyseBinds tidy_binds @@ -351,9 +359,8 @@ myCoreToStg dflags this_mod tidy_binds -- simplifier, which for reasons I don't understand, persists -- thoroughout code generation - showPass dflags "Core2Stg" -- _scc_ "Core2Stg" - let stg_binds = topCoreBindsToStg c2s_uniqs occ_anal_tidy_binds + stg_binds <- topCoreBindsToStg dflags occ_anal_tidy_binds showPass dflags "Stg2Stg" -- _scc_ "Stg2Stg" @@ -370,6 +377,7 @@ myCoreToStg dflags this_mod tidy_binds %* * %************************************************************************ +\begin{code} hscExpr :: DynFlags -> HomeSymbolTable @@ -377,38 +385,78 @@ hscExpr -> PersistentCompilerState -- IN: persistent compiler state -> Module -- Context for compiling -> String -- The expression - -> IO HscResult + -> IO ( PersistentCompilerState, Maybe UnlinkedIExpr ) -hscExpr dflags hst hit pcs this_module expr +hscExpr dflags hst hit pcs0 this_module expr = do { -- Parse it - maybe_parsed <- myParseExpr dflags expr - ; case maybe_parsed of { - Nothing -> return (HscFail pcs_ch); + maybe_parsed <- hscParseExpr dflags expr; + case maybe_parsed of + Nothing -> return (pcs0, Nothing) Just parsed_expr -> do { -- Rename it - (new_pcs, maybe_renamed_expr) <- renameExpr dflags hit hst pcs this_module parsed_expr ; - ; case maybe_renamed_expr of { - Nothing -> FAIL - Just (print_unqual, rn_expr) -> + (pcs1, maybe_renamed_expr) <- + renameExpr dflags hit hst pcs0 this_module parsed_expr; + case maybe_renamed_expr of + Nothing -> return (pcs1, Nothing) + Just (print_unqual, rn_expr) -> do { -- Typecheck it - maybe_tc_expr <- typecheckExpr dflags pcs hst print_unqual rn_expr - ; case maybe_tc_expr of - Nothing -> FAIL - Just tc_expr -> + maybe_tc_expr <- typecheckExpr dflags pcs1 hst print_unqual rn_expr; + case maybe_tc_expr of + Nothing -> return (pcs1, Nothing) + Just tc_expr -> do { -- Desugar it - ; ds_expr <- deSugarExpr dflags pcs hst this_module print_unqual tc_expr + ds_expr <- deSugarExpr dflags pcs1 hst this_module + print_unqual tc_expr; -- Simplify it - ; simpl_expr <- simplifyExpr dflags pcs hst ds_expr + simpl_expr <- simplifyExpr dflags pcs1 hst ds_expr; - ; return I'M NOT SURE - } + -- Convert to STG + stg_expr <- coreToStgExpr dflags simpl_expr; - + -- ToDo: need to do StgVarInfo? or SRTs? + + -- Convert to InterpSyn + unlinked_iexpr <- stgExprToInterpSyn dflags stg_expr; + + return (pcs1, Just unlinked_iexpr); + }}}} + +hscParseExpr :: DynFlags -> String -> IO (Maybe RdrNameHsExpr) +hscParseExpr dflags str + = do -------------------------- Parser ---------------- + showPass dflags "Parser" + -- _scc_ "Parser" + buf <- stringToStringBuffer ("__expr " ++ str) + + -- glaexts is True for now (because of the daft __expr at the front + -- of the string...) + let glaexts = 1# + --let glaexts | dopt Opt_GlasgowExts dflags = 1# + -- | otherwise = 0# + + case parse buf PState{ bol = 0#, atbol = 1#, + context = [], glasgow_exts = glaexts, + loc = mkSrcLoc SLIT("") 0 } of { + + PFailed err -> do { freeStringBuffer buf + ; hPutStrLn stderr (showSDoc err) + ; return Nothing }; + + POk _ (PExpr rdr_expr) -> do { + + -- ToDo: + -- freeStringBuffer buf; + + dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_expr); + + return (Just rdr_expr) + }} +\end{code} %************************************************************************ %* * diff --git a/ghc/compiler/main/Interpreter.hs b/ghc/compiler/main/Interpreter.hs index c39f658..2e0f25b 100644 --- a/ghc/compiler/main/Interpreter.hs +++ b/ghc/compiler/main/Interpreter.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: Interpreter.hs,v 1.4 2000/11/16 15:57:05 simonmar Exp $ +-- $Id: Interpreter.hs,v 1.5 2000/11/17 16:53:27 simonmar Exp $ -- -- Interpreter subsystem wrapper -- @@ -18,7 +18,7 @@ module Interpreter ( linkIModules, stgToInterpSyn, HValue, - UnlinkedIBind, + UnlinkedIBind, UnlinkedIExpr, loadObjs, resolveObjs, #endif ) where @@ -50,6 +50,7 @@ emptyItblEnv = () type HValue = () data UnlinkedIBind = UnlinkedIBind +data UnlinkedIBind = UnlinkedIExpr instance Outputable UnlinkedIBind where ppr x = text "Can't output UnlinkedIBind" diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index d1a1636..e9c22d9 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -1,6 +1,6 @@ {-# OPTIONS -W -fno-warn-incomplete-patterns #-} ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.24 2000/11/16 15:57:06 simonmar Exp $ +-- $Id: Main.hs,v 1.25 2000/11/17 16:53:27 simonmar Exp $ -- -- GHC Driver program -- @@ -72,6 +72,7 @@ import Maybe -- reading the package configuration file is too slow -- -H, -K, -Rghc-timing -- hi-diffs +-- -ddump-all doesn't do anything ----------------------------------------------------------------------------- -- Differences vs. old driver: diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 841d7fc..afc43b6 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -110,7 +110,12 @@ renameExpr dflags hit hst pcs this_module expr ; renameSource dflags hit hst pcs this_module $ initRnMS rdr_env emptyLocalFixityEnv SourceMode $ - (rnExpr expr `thenRn` \ (e,_) -> returnRn (Just (print_unqual, e))) + ( rnExpr expr `thenRn` \ (e,_) -> + + doptRn Opt_D_dump_rn `thenRn` \ dump_rn -> + ioToRnM (dumpIfSet dump_rn "Renamer:" (ppr e)) `thenRn_` + + returnRn (Just (print_unqual, e))) } | otherwise diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 3fcfad5..b5ec550 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -94,13 +94,15 @@ core2core dflags pcs hst is_exported binds rules return (processed_binds, orphan_rules) -simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do +simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do -> PersistentCompilerState -> HomeSymbolTable -> CoreExpr -> IO CoreExpr simplifyExpr dflags pcs hst expr = do { + ; showPass dflags "Simplify" + ; us <- mkSplitUniqSupply 's' ; let (expr', counts) = initSmpl dflags sw_chkr us emptyVarSet black_list_all diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index c69ae37..e75d88d 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -10,7 +10,7 @@ Convert a @CoreSyntax@ program to a @StgSyntax@ program. \begin{code} -module CoreToStg ( topCoreBindsToStg ) where +module CoreToStg ( topCoreBindsToStg, coreToStgExpr ) where #include "HsVersions.h" @@ -39,6 +39,8 @@ import Type ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe, import UniqSupply -- all of it, really import BasicTypes ( TopLevelFlag(..), isNotTopLevel ) import UniqSet ( emptyUniqSet ) +import ErrUtils ( showPass ) +import CmdLineOpts ( DynFlags ) import Maybes import Outputable \end{code} @@ -177,12 +179,11 @@ bOGUS_FVs = [] \end{code} \begin{code} -topCoreBindsToStg :: UniqSupply -- name supply - -> [CoreBind] -- input - -> [StgBinding] -- output - -topCoreBindsToStg us core_binds - = initUs_ us (coreBindsToStg emptyVarEnv core_binds) +topCoreBindsToStg :: DynFlags -> [CoreBind] -> IO [StgBinding] +topCoreBindsToStg dflags core_binds + = do showPass dflags "Core2Stg" + us <- mkSplitUniqSupply 'c' + return (initUs_ us (coreBindsToStg emptyVarEnv core_binds)) where coreBindsToStg :: StgEnv -> [CoreBind] -> UniqSM [StgBinding] @@ -208,6 +209,19 @@ topCoreBindsToStg us core_binds returnUs new_bs \end{code} +%************************************************************************ +%* * +\subsection[coreToStgExpr]{Converting an expression (for the interpreter)} +%* * +%************************************************************************ + +\begin{code} +coreToStgExpr :: DynFlags -> CoreExpr -> IO StgExpr +coreToStgExpr dflags core_expr + = do showPass dflags "Core2Stg" + us <- mkSplitUniqSupply 'c' + return (initUs_ us (coreExprToStg emptyVarEnv core_expr)) +\end{code} %************************************************************************ %* * diff --git a/ghc/compiler/utils/StringBuffer.lhs b/ghc/compiler/utils/StringBuffer.lhs index 8fe48e0..eea0af2 100644 --- a/ghc/compiler/utils/StringBuffer.lhs +++ b/ghc/compiler/utils/StringBuffer.lhs @@ -11,8 +11,10 @@ module StringBuffer ( StringBuffer, - -- creation - hGetStringBuffer, -- :: FilePath -> IO StringBuffer + -- creation/destruction + hGetStringBuffer, -- :: FilePath -> IO StringBuffer + stringToStringBuffer, -- :: String -> IO StringBuffer + freeStringBuffer, -- :: StringBuffer -> IO () -- Lookup currentChar, -- :: StringBuffer -> Char @@ -175,6 +177,27 @@ unsafeWriteBuffer s@(StringBuffer a _ _ _) i# ch# = \end{code} ----------------------------------------------------------------------------- +-- Turn a String into a StringBuffer + +\begin{code} +stringToStringBuffer :: String -> IO StringBuffer +stringToStringBuffer str = + do let sz@(I# sz#) = length str + 1 + (Ptr a@(A# a#)) <- mallocBytes sz + fill_in str a + writeCharOffAddr a (sz-1) '\0' -- sentinel + return (StringBuffer a# sz# 0# 0#) + where + fill_in [] _ = return () + fill_in (c:cs) a = do + writeCharOffAddr a 0 c + fill_in cs (a `plusAddr` 1) + +freeStringBuffer :: StringBuffer -> IO () +freeStringBuffer (StringBuffer a# _ _ _) = Foreign.free (Ptr (A# a#)) +\end{code} + +----------------------------------------------------------------------------- This very disturbing bit of code is used for expanding the tabs in a file before we start parsing it. Expanding the tabs early makes the lexer a lot simpler: we only have to record the beginning of the line -- 1.7.10.4