Rationalise GhcMode, HscTarget and GhcLink

This patch cleans up the GHC API, and adds some functionality: we can
now compile to object code inside GHCi.

Previously we had:

  data GhcMode
    = BatchCompile
    | Interactive
    | OneShot
    | JustTypecheck
    | MkDepend

  data HscTarget
    = HscC
    | HscAsm
    | HscJava
    | HscInterpreted
    | HscNothing

There was redundancy here; if GhcMode is Interactive, then only
HscInterpreted makes sense, and JustTypecheck required HscNothing.
Now we have:

  data GhcMode
    = CompManager       -- ^ --make, GHCi, etc.
    | OneShot           -- ^ ghc -c Foo.hs
    | MkDepend          -- ^ ghc -M, see Finder for why we need this

and HscTarget remains as before.

Previously GhcLink looked like this:

  data GhcLink = NoLink | StaticLink

Now we have:

  data GhcLink = NoLink | LinkBinary | LinkInMemory

The idea being that you can have an HscTarget of HscAsm (for example)
and still link in memory.

There are two new flags:

  -fobject-code selects object code as the target (selects
                either -fasm or -fvia-C, whichever is the default)
                This can be usd with ':set' in GHCi, or on the command line.

  -fbyte-code   sets byte-code as the target.  Only works in GHCi.
                One day maybe this could save the byte code in a file
                when used outside GHCi.

  (names chosen for consistency with -fno-code).

Changes to the GHC API: newSession no longer takes the GhcMode
argument.  The GhcMode defaults to CompManager, which is usually what
you want.  To do JustTypecheck now, just set hscTarget to HscNothing.

diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index 0801b1c..9da049d 100644 (file)
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -78,14 +78,17 @@ deSugar hsc_env
                            tcg_rules        = rules,
                            tcg_insts        = insts,
                            tcg_fam_insts    = fam_insts })
                            tcg_rules        = rules,
                            tcg_insts        = insts,
                            tcg_fam_insts    = fam_insts })

-  = do { showPass dflags "Desugar"
+
+  = do { let dflags = hsc_dflags hsc_env
+        ; showPass dflags "Desugar"

 
        -- Desugar the program
         ; let export_set = availsToNameSet exports
        ; let auto_scc = mkAutoScc mod export_set
         ; let noDbgSites = []
 
        -- Desugar the program
         ; let export_set = availsToNameSet exports
        ; let auto_scc = mkAutoScc mod export_set
         ; let noDbgSites = []

-       ; mb_res <- case ghcMode dflags of
-                    JustTypecheck -> return (Just ([], [], NoStubs, noHpcInfo, noDbgSites))
+        ; let target = hscTarget dflags
+       ; mb_res <- case target of
+                    HscNothing -> return (Just ([], [], NoStubs, noHpcInfo, noDbgSites))

                      _        -> do (binds_cvr,ds_hpc_info) 
                                              <- if opt_Hpc
                                                  then addCoverageTicksToBinds dflags mod mod_loc binds
                      _        -> do (binds_cvr,ds_hpc_info) 
                                              <- if opt_Hpc
                                                  then addCoverageTicksToBinds dflags mod mod_loc binds

@@ -107,7 +110,7 @@ deSugar hsc_env
 
        {       -- Add export flags to bindings
          keep_alive <- readIORef keep_var
 
        {       -- Add export flags to bindings
          keep_alive <- readIORef keep_var

-       ; let final_prs = addExportFlags ghci_mode export_set
+       ; let final_prs = addExportFlags target export_set

                                  keep_alive all_prs ds_rules
              ds_binds  = [Rec final_prs]
        -- Notice that we put the whole lot in a big Rec, even the foreign binds
                                  keep_alive all_prs ds_rules
              ds_binds  = [Rec final_prs]
        -- Notice that we put the whole lot in a big Rec, even the foreign binds

@@ -178,10 +181,6 @@ deSugar hsc_env
         ; return (Just mod_guts)
        }}}
 
         ; return (Just mod_guts)
        }}}
 

-  where
-    dflags    = hsc_dflags hsc_env
-    ghci_mode = ghcMode (hsc_dflags hsc_env)
-

 mkAutoScc :: Module -> NameSet -> AutoScc
 mkAutoScc mod exports
   | not opt_SccProfilingOn     -- No profiling
 mkAutoScc :: Module -> NameSet -> AutoScc
 mkAutoScc mod exports
   | not opt_SccProfilingOn     -- No profiling

@@ -233,7 +232,7 @@ deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
 -- it's just because the type checker is rather busy already and
 -- I didn't want to pass in yet another mapping.
 
 -- it's just because the type checker is rather busy already and
 -- I didn't want to pass in yet another mapping.
 

-addExportFlags ghci_mode exports keep_alive prs rules
+addExportFlags target exports keep_alive prs rules

   = [(add_export bndr, rhs) | (bndr,rhs) <- prs]
   where
     add_export bndr
   = [(add_export bndr, rhs) | (bndr,rhs) <- prs]
   where
     add_export bndr

@@ -262,7 +261,7 @@ addExportFlags ghci_mode exports keep_alive prs rules
        -- isExternalName separates the user-defined top-level names from those
        -- introduced by the type checker.
     is_exported :: Name -> Bool
        -- isExternalName separates the user-defined top-level names from those
        -- introduced by the type checker.
     is_exported :: Name -> Bool

-    is_exported | ghci_mode == Interactive = isExternalName
+    is_exported | target == HscInterpreted = isExternalName

                | otherwise                = (`elemNameSet` exports)
 
 ppr_ds_rules [] = empty
                | otherwise                = (`elemNameSet` exports)
 
 ppr_ds_rules [] = empty

diff --git a/compiler/deSugar/DsBreakpoint.lhs b/compiler/deSugar/DsBreakpoint.lhs
index 0282d6d..c6a090e 100644 (file)
--- a/compiler/deSugar/DsBreakpoint.lhs
+++ b/compiler/deSugar/DsBreakpoint.lhs
@@ -166,9 +166,10 @@ debug_enabled = do
 breakpoints_enabled = do
     ghcMode            <- getGhcModeDs
     currentModule      <- getModuleDs
 breakpoints_enabled = do
     ghcMode            <- getGhcModeDs
     currentModule      <- getModuleDs

+    dflags             <- getDOptsDs

     ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints
     return ( not ignore_breakpoints 
     ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints
     return ( not ignore_breakpoints 

-          && ghcMode == Interactive 
+          && hscTarget dflags == HscInterpreted

           && currentModule /= iNTERACTIVE )
 
 maybeInsertBreakpoint lhsexpr@(L loc _) ty = do 
           && currentModule /= iNTERACTIVE )
 
 maybeInsertBreakpoint lhsexpr@(L loc _) ty = do 

diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index a02f449..b74c233 100644 (file)
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -832,9 +832,8 @@ check_old_iface hsc_env mod_summary source_unchanged maybe_iface
 
      -- If the source has changed and we're in interactive mode, avoid reading
      -- an interface; just return the one we might have been supplied with.
 
      -- If the source has changed and we're in interactive mode, avoid reading
      -- an interface; just return the one we might have been supplied with.

-    ; ghc_mode <- getGhcMode
-    ; if (ghc_mode == Interactive || ghc_mode == JustTypecheck) 
-        && not source_unchanged then
+    ; let dflags = hsc_dflags hsc_env
+    ; if not (isObjectTarget (hscTarget dflags)) && not source_unchanged then

          return (outOfDate, maybe_iface)
       else
       case maybe_iface of {
          return (outOfDate, maybe_iface)
       else
       case maybe_iface of {

diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 67ef57d..b1a8189 100644 (file)
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -250,7 +250,7 @@ compileStub dflags mod location = do
 -- ---------------------------------------------------------------------------
 -- Link
 
 -- ---------------------------------------------------------------------------
 -- Link
 

-link :: GhcMode                        -- interactive or batch
+link :: GhcLink                        -- interactive or batch

      -> DynFlags               -- dynamic flags
      -> Bool                   -- attempt linking in batch mode?
      -> HomePackageTable       -- what to link
      -> DynFlags               -- dynamic flags
      -> Bool                   -- attempt linking in batch mode?
      -> HomePackageTable       -- what to link

@@ -264,15 +264,15 @@ link :: GhcMode                   -- interactive or batch
 -- will succeed.
 
 #ifdef GHCI
 -- will succeed.
 
 #ifdef GHCI

-link Interactive dflags batch_attempt_linking hpt
+link LinkInMemory dflags batch_attempt_linking hpt

     = do -- Not Linking...(demand linker will do the job)
         return Succeeded
 #endif
 
     = do -- Not Linking...(demand linker will do the job)
         return Succeeded
 #endif
 

-link JustTypecheck dflags batch_attempt_linking hpt
+link NoLink dflags batch_attempt_linking hpt

    = return Succeeded
 
    = return Succeeded
 

-link BatchCompile dflags batch_attempt_linking hpt
+link LinkBinary dflags batch_attempt_linking hpt

    | batch_attempt_linking
    = do 
        let 
    | batch_attempt_linking
    = do 
        let 

@@ -317,7 +317,7 @@ link BatchCompile dflags batch_attempt_linking hpt
        -- Don't showPass in Batch mode; doLink will do that for us.
        let link = case ghcLink dflags of
                MkDLL       -> doMkDLL
        -- Don't showPass in Batch mode; doLink will do that for us.
        let link = case ghcLink dflags of
                MkDLL       -> doMkDLL

-               StaticLink  -> staticLink
+               LinkBinary  -> staticLink

        link dflags obj_files pkg_deps
 
         debugTraceMsg dflags 3 (text "link: done")
        link dflags obj_files pkg_deps
 
         debugTraceMsg dflags 3 (text "link: done")

@@ -377,7 +377,7 @@ doLink dflags stop_phase o_files
   | otherwise
   = case ghcLink dflags of
        NoLink     -> return ()
   | otherwise
   = case ghcLink dflags of
        NoLink     -> return ()

-       StaticLink -> staticLink dflags o_files link_pkgs
+       LinkBinary -> staticLink dflags o_files link_pkgs

        MkDLL      -> doMkDLL dflags o_files link_pkgs
   where
    -- Always link in the haskell98 package for static linking.  Other
        MkDLL      -> doMkDLL dflags o_files link_pkgs
   where
    -- Always link in the haskell98 package for static linking.  Other

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index da22688..f10d2f9 100644 (file)
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -1,3 +1,4 @@
+

 {-# OPTIONS -fno-warn-missing-fields #-}
 -----------------------------------------------------------------------------
 --
 {-# OPTIONS -fno-warn-missing-fields #-}
 -----------------------------------------------------------------------------
 --

@@ -16,7 +17,7 @@ module DynFlags (
        -- Dynamic flags
        DynFlag(..),
        DynFlags(..),
        -- Dynamic flags
        DynFlag(..),
        DynFlags(..),

-       HscTarget(..),
+       HscTarget(..), isObjectTarget,

        GhcMode(..), isOneShot,
        GhcLink(..), isNoLink,
        PackageFlag(..),
        GhcMode(..), isOneShot,
        GhcLink(..), isNoLink,
        PackageFlag(..),

@@ -335,24 +336,35 @@ data HscTarget
   | HscNothing
   deriving (Eq, Show)
 
   | HscNothing
   deriving (Eq, Show)
 

+-- | will this target result in an object file on the disk?
+isObjectTarget :: HscTarget -> Bool
+isObjectTarget HscC     = True
+isObjectTarget HscAsm   = True
+isObjectTarget _        = False
+
+-- | The 'GhcMode' tells us whether we're doing multi-module
+-- compilation (controlled via the "GHC" API) or one-shot
+-- (single-module) compilation.  This makes a difference primarily to
+-- the "Finder": in one-shot mode we look for interface files for
+-- imported modules, but in multi-module mode we look for source files
+-- in order to check whether they need to be recompiled.

 data GhcMode
 data GhcMode

-  = BatchCompile       -- | @ghc --make Main@
-  | Interactive                -- | @ghc --interactive@
-  | OneShot            -- | @ghc -c Foo.hs@
-  | JustTypecheck      -- | Development environemnts, refactorer, etc.
-  | MkDepend
+  = CompManager         -- ^ --make, GHCi, etc.
+  | OneShot            -- ^ ghc -c Foo.hs
+  | MkDepend            -- ^ ghc -M, see Finder for why we need this

   deriving Eq
 
 isOneShot :: GhcMode -> Bool
 isOneShot OneShot = True
 isOneShot _other  = False
 
   deriving Eq
 
 isOneShot :: GhcMode -> Bool
 isOneShot OneShot = True
 isOneShot _other  = False
 

+-- | What kind of linking to do.

 data GhcLink   -- What to do in the link step, if there is one
 data GhcLink   -- What to do in the link step, if there is one

-  =            -- Only relevant for modes
-               --      DoMake and StopBefore StopLn
-    NoLink             -- Don't link at all
-  | StaticLink         -- Ordinary linker [the default]
+  = NoLink             -- Don't link at all
+  | LinkBinary         -- Link object code into a binary
+  | LinkInMemory        -- Use the in-memory dynamic linker

   | MkDLL              -- Make a DLL
   | MkDLL              -- Make a DLL

+  deriving Eq

 
 isNoLink :: GhcLink -> Bool
 isNoLink NoLink = True
 
 isNoLink :: GhcLink -> Bool
 isNoLink NoLink = True

@@ -381,8 +393,8 @@ initDynFlags dflags = do
 
 defaultDynFlags =
      DynFlags {
 
 defaultDynFlags =
      DynFlags {

-       ghcMode                 = OneShot,
-       ghcLink                 = StaticLink,
+       ghcMode                 = CompManager,
+       ghcLink                 = LinkBinary,

        coreToDo                = Nothing,
        stgToDo                 = Nothing, 
        hscTarget               = defaultHscTarget, 
        coreToDo                = Nothing,
        stgToDo                 = Nothing, 
        hscTarget               = defaultHscTarget, 

@@ -995,10 +1007,13 @@ dynamic_flags = [
 
         ------ Compiler flags -----------------------------------------------
 
 
         ------ Compiler flags -----------------------------------------------
 

+  ,  ( "fasm",         AnySuffix (\_ -> setObjTarget HscAsm) )
+  ,  ( "fvia-c",       NoArg (setObjTarget HscC) )
+  ,  ( "fvia-C",       NoArg (setObjTarget HscC) )
+

   ,  ( "fno-code",     NoArg (setTarget HscNothing))
   ,  ( "fno-code",     NoArg (setTarget HscNothing))

-  ,  ( "fasm",         AnySuffix (\_ -> setTarget HscAsm) )
-  ,  ( "fvia-c",       NoArg (setTarget HscC) )
-  ,  ( "fvia-C",       NoArg (setTarget HscC) )
+  ,  ( "fbyte-code",    NoArg (setTarget HscInterpreted) )
+  ,  ( "fobject-code",  NoArg (setTarget defaultHscTarget) )

 
   ,  ( "fglasgow-exts",    NoArg (mapM_ setDynFlag   glasgowExtsFlags) )
   ,  ( "fno-glasgow-exts", NoArg (mapM_ unSetDynFlag glasgowExtsFlags) )
 
   ,  ( "fglasgow-exts",    NoArg (mapM_ setDynFlag   glasgowExtsFlags) )
   ,  ( "fno-glasgow-exts", NoArg (mapM_ unSetDynFlag glasgowExtsFlags) )

@@ -1133,12 +1148,23 @@ setPackageName p
   where
         pid = stringToPackageId p
 
   where
         pid = stringToPackageId p
 

--- we can only switch between HscC, and HscAsmm with dynamic flags 
--- (-fvia-C, -fasm, -filx respectively).
-setTarget l = upd (\dfs -> case hscTarget dfs of
-                                       HscC   -> dfs{ hscTarget = l }
-                                       HscAsm -> dfs{ hscTarget = l }
-                                       _      -> dfs)
+-- If we're linking a binary, then only targets that produce object
+-- code are allowed (requests for other target types are ignored).
+setTarget l = upd set
+  where 
+   set dfs 
+     | ghcLink dfs /= LinkBinary || isObjectTarget l  = dfs{ hscTarget = l }
+     | otherwise = dfs
+
+-- Changes the target only if we're compiling object code.  This is
+-- used by -fasm and -fvia-C, which switch from one to the other, but
+-- not from bytecode to object-code.  The idea is that -fasm/-fvia-C
+-- can be safely used in an OPTIONS_GHC pragma.
+setObjTarget l = upd set
+  where 
+   set dfs 
+     | isObjectTarget (hscTarget dfs) = dfs { hscTarget = l }
+     | otherwise = dfs

 
 setOptLevel :: Int -> DynFlags -> DynFlags
 setOptLevel n dflags
 
 setOptLevel :: Int -> DynFlags -> DynFlags
 setOptLevel n dflags

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index d34b0f3..eb2ca8e 100644 (file)
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -14,7 +14,8 @@ module GHC (
        newSession,
 
        -- * Flags and settings
        newSession,
 
        -- * Flags and settings

-       DynFlags(..), DynFlag(..), Severity(..), GhcMode(..), HscTarget(..), dopt,
+       DynFlags(..), DynFlag(..), Severity(..), HscTarget(..), dopt,
+        GhcMode(..), GhcLink(..),

        parseDynamicFlags,
        getSessionDynFlags,
        setSessionDynFlags,
        parseDynamicFlags,
        getSessionDynFlags,
        setSessionDynFlags,

@@ -356,10 +357,8 @@ GLOBAL_VAR(v_bkptLinkEnv, [], [(Name, HValue)])
 
 -- | Starts a new session.  A session consists of a set of loaded
 -- modules, a set of options (DynFlags), and an interactive context.
 
 -- | Starts a new session.  A session consists of a set of loaded
 -- modules, a set of options (DynFlags), and an interactive context.

--- ToDo: GhcMode should say "keep typechecked code" and\/or "keep renamed
--- code".
-newSession :: GhcMode -> Maybe FilePath -> IO Session
-newSession mode mb_top_dir = do
+newSession :: Maybe FilePath -> IO Session
+newSession mb_top_dir = do

   -- catch ^C
   main_thread <- myThreadId
   modifyMVar_ interruptTargetThread (return . (main_thread :))
   -- catch ^C
   main_thread <- myThreadId
   modifyMVar_ interruptTargetThread (return . (main_thread :))

@@ -367,7 +366,7 @@ newSession mode mb_top_dir = do
 
   dflags0 <- initSysTools mb_top_dir defaultDynFlags
   dflags  <- initDynFlags dflags0
 
   dflags0 <- initSysTools mb_top_dir defaultDynFlags
   dflags  <- initDynFlags dflags0

-  env <- newHscEnv dflags{ ghcMode=mode }
+  env <- newHscEnv dflags

   ref <- newIORef env
   return (Session ref)
 
   ref <- newIORef env
   return (Session ref)
 

@@ -528,10 +527,9 @@ depanal (Session ref) excluded_mods allow_dup_roots = do
         old_graph = hsc_mod_graph hsc_env
        
   showPass dflags "Chasing dependencies"
         old_graph = hsc_mod_graph hsc_env
        
   showPass dflags "Chasing dependencies"

-  when (gmode == BatchCompile) $
-       debugTraceMsg dflags 2 (hcat [
-                    text "Chasing modules from: ",
-                       hcat (punctuate comma (map pprTarget targets))])
+  debugTraceMsg dflags 2 (hcat [
+            text "Chasing modules from: ",
+            hcat (punctuate comma (map pprTarget targets))])

 
   r <- downsweep hsc_env old_graph excluded_mods allow_dup_roots
   case r of
 
   r <- downsweep hsc_env old_graph excluded_mods allow_dup_roots
   case r of

@@ -610,8 +608,7 @@ load2 s@(Session ref) how_much mod_graph = do
        let
            -- check the stability property for each module.
            stable_mods@(stable_obj,stable_bco)
        let
            -- check the stability property for each module.
            stable_mods@(stable_obj,stable_bco)

-               | BatchCompile <- ghci_mode = ([],[])
-               | otherwise = checkStability hpt1 mg2_with_srcimps all_home_mods
+               = checkStability hpt1 mg2_with_srcimps all_home_mods

 
            -- prune bits of the HPT which are definitely redundant now,
            -- to save space.
 
            -- prune bits of the HPT which are definitely redundant now,
            -- to save space.

@@ -719,13 +716,16 @@ load2 s@(Session ref) how_much mod_graph = do
                a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
                do_linking = a_root_is_Main || no_hs_main
 
                a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
                do_linking = a_root_is_Main || no_hs_main
 

-             when (ghci_mode == BatchCompile && isJust ofile && not do_linking) $
-               debugTraceMsg dflags 1 (text ("Warning: output was redirected with -o, " ++
-                                             "but no output will be generated\n" ++
-                                             "because there is no " ++ moduleNameString (moduleName main_mod) ++ " module."))
+             when (ghcLink dflags == LinkBinary 
+                    && isJust ofile && not do_linking) $
+               debugTraceMsg dflags 1 $
+                    text ("Warning: output was redirected with -o, " ++
+                          "but no output will be generated\n" ++
+                         "because there is no " ++ 
+                          moduleNameString (moduleName main_mod) ++ " module.")

 
              -- link everything together
 
              -- link everything together

-              linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env1)
+              linkresult <- link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)

 
              loadFinish Succeeded linkresult ref hsc_env1
 
 
              loadFinish Succeeded linkresult ref hsc_env1
 

@@ -755,7 +755,7 @@ load2 s@(Session ref) how_much mod_graph = do
                        (eltsUFM (hsc_HPT hsc_env))) do
        
              -- Link everything together
                        (eltsUFM (hsc_HPT hsc_env))) do
        
              -- Link everything together

-              linkresult <- link ghci_mode dflags False hpt4
+              linkresult <- link (ghcLink dflags) dflags False hpt4

 
              let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 }
              loadFinish Failed linkresult ref hsc_env4
 
              let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 }
              loadFinish Failed linkresult ref hsc_env4

@@ -868,15 +868,13 @@ checkModule session@(Session ref) mod = do
 
 unload :: HscEnv -> [Linkable] -> IO ()
 unload hsc_env stable_linkables        -- Unload everthing *except* 'stable_linkables'
 
 unload :: HscEnv -> [Linkable] -> IO ()
 unload hsc_env stable_linkables        -- Unload everthing *except* 'stable_linkables'

-  = case ghcMode (hsc_dflags hsc_env) of
-       BatchCompile  -> return ()
-       JustTypecheck -> return ()
+  = case ghcLink (hsc_dflags hsc_env) of

 #ifdef GHCI
 #ifdef GHCI

-       Interactive -> Linker.unload (hsc_dflags hsc_env) stable_linkables
+       LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables

 #else
 #else

-       Interactive -> panic "unload: no interpreter"
+       LinkInMemory -> panic "unload: no interpreter"

 #endif
 #endif

-       other -> panic "unload: strange mode"
+       other -> return ()

 
 -- -----------------------------------------------------------------------------
 -- checkStability
 
 -- -----------------------------------------------------------------------------
 -- checkStability

@@ -893,9 +891,6 @@ unload hsc_env stable_linkables     -- Unload everthing *except* 'stable_linkables'
      module.  So we need to know that we will definitely not be recompiling
      any of these modules, and we can use the object code.
 
      module.  So we need to know that we will definitely not be recompiling
      any of these modules, and we can use the object code.
 

-  NB. stability is of no importance to BatchCompile at all, only Interactive.
-  (ToDo: what about JustTypecheck?)
-

   The stability check is as follows.  Both stableObject and
   stableBCO are used during the upsweep phase later.
 
   The stability check is as follows.  Both stableObject and
   stableBCO are used during the upsweep phase later.
 

@@ -914,7 +909,7 @@ unload hsc_env stable_linkables     -- Unload everthing *except* 'stable_linkables'
 
   These properties embody the following ideas:
 
 
   These properties embody the following ideas:
 

-    - if a module is stable:
+    - if a module is stable, then:

        - if it has been compiled in a previous pass (present in HPT)
          then it does not need to be compiled or re-linked.
         - if it has not been compiled in a previous pass,
        - if it has been compiled in a previous pass (present in HPT)
          then it does not need to be compiled or re-linked.
         - if it has not been compiled in a previous pass,

@@ -1125,95 +1120,133 @@ upsweep_mod :: HscEnv
             -> IO (Maybe HomeModInfo)  -- Nothing => Failed
 
 upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
             -> IO (Maybe HomeModInfo)  -- Nothing => Failed
 
 upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods

-   = do 
-        let 
-           this_mod_name = ms_mod_name summary
+   =    let 
+                   this_mod_name = ms_mod_name summary

            this_mod    = ms_mod summary
            mb_obj_date = ms_obj_date summary
            obj_fn      = ml_obj_file (ms_location summary)
            hs_date     = ms_hs_date summary
 
            this_mod    = ms_mod summary
            mb_obj_date = ms_obj_date summary
            obj_fn      = ml_obj_file (ms_location summary)
            hs_date     = ms_hs_date summary
 

+           is_stable_obj = this_mod_name `elem` stable_obj
+           is_stable_bco = this_mod_name `elem` stable_bco
+
+           old_hmi = lookupUFM old_hpt this_mod_name
+
+            -- We're using the dflags for this module now, obtained by
+            -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.
+            dflags = ms_hspp_opts summary
+            prevailing_target = hscTarget (hsc_dflags hsc_env)
+            local_target      = hscTarget dflags
+
+            -- If OPTIONS_GHC contains -fasm or -fvia-C, be careful that
+            -- we don't do anything dodgy: these should only work to change
+            -- from -fvia-C to -fasm and vice-versa, otherwise we could 
+            -- end up trying to link object code to byte code.
+            target = if prevailing_target /= local_target
+                        && (not (isObjectTarget prevailing_target)
+                            || not (isObjectTarget local_target))
+                        then prevailing_target
+                        else local_target 
+
+            -- store the corrected hscTarget into the summary
+            summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } }
+
+           -- The old interface is ok if
+           --  a) we're compiling a source file, and the old HPT
+           --     entry is for a source file
+           --  b) we're compiling a hs-boot file
+           -- Case (b) allows an hs-boot file to get the interface of its
+           -- real source file on the second iteration of the compilation
+           -- manager, but that does no harm.  Otherwise the hs-boot file
+           -- will always be recompiled
+            
+            mb_old_iface 
+               = case old_hmi of
+                    Nothing                              -> Nothing
+                    Just hm_info | isBootSummary summary -> Just iface
+                                 | not (mi_boot iface)   -> Just iface
+                                 | otherwise             -> Nothing
+                                  where 
+                                    iface = hm_iface hm_info
+

            compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo)
            compile_it  = upsweep_compile hsc_env old_hpt this_mod_name 
            compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo)
            compile_it  = upsweep_compile hsc_env old_hpt this_mod_name 

-                               summary mod_index nmods
-
-       case ghcMode (hsc_dflags hsc_env) of
-           BatchCompile ->
-               case () of
-                  -- Batch-compilating is easy: just check whether we have
-                  -- an up-to-date object file.  If we do, then the compiler
-                  -- needs to do a recompilation check.
-                  _ | Just obj_date <- mb_obj_date, obj_date >= hs_date -> do
-                          linkable <- 
-                               findObjectLinkable this_mod obj_fn obj_date
-                          compile_it (Just linkable)
-
-                    | otherwise ->
-                          compile_it Nothing
-
-           interactive ->
-               case () of
-                   _ | is_stable_obj, isJust old_hmi ->
-                          return old_hmi
+                               summary' mod_index nmods mb_old_iface
+
+            compile_it_discard_iface 
+                        = upsweep_compile hsc_env old_hpt this_mod_name 
+                               summary' mod_index nmods Nothing
+
+        in
+       case target of
+
+            _any
+                -- Regardless of whether we're generating object code or
+                -- byte code, we can always use an existing object file
+                -- if it is *stable* (see checkStability).
+               | is_stable_obj, isJust old_hmi ->
+                       return old_hmi

                        -- object is stable, and we have an entry in the
                        -- old HPT: nothing to do
 
                        -- object is stable, and we have an entry in the
                        -- old HPT: nothing to do
 

-                     | is_stable_obj, isNothing old_hmi -> do
-                          linkable <-
-                               findObjectLinkable this_mod obj_fn 
+               | is_stable_obj, isNothing old_hmi -> do
+                       linkable <- findObjectLinkable this_mod obj_fn 

                                        (expectJust "upseep1" mb_obj_date)
                                        (expectJust "upseep1" mb_obj_date)

-                          compile_it (Just linkable)
+                       compile_it (Just linkable)

                        -- object is stable, but we need to load the interface
                        -- off disk to make a HMI.
 
                        -- object is stable, but we need to load the interface
                        -- off disk to make a HMI.
 

-                     | is_stable_bco -> 
-                          ASSERT(isJust old_hmi) -- must be in the old_hpt
-                          return old_hmi
+            HscInterpreted
+               | is_stable_bco -> 
+                       ASSERT(isJust old_hmi) -- must be in the old_hpt
+                       return old_hmi

                        -- BCO is stable: nothing to do
 
                        -- BCO is stable: nothing to do
 

-                     | Just hmi <- old_hmi,
-                       Just l <- hm_linkable hmi, not (isObjectLinkable l),
-                       linkableTime l >= ms_hs_date summary ->
-                          compile_it (Just l)
+               | Just hmi <- old_hmi,
+                 Just l <- hm_linkable hmi, not (isObjectLinkable l),
+                 linkableTime l >= ms_hs_date summary ->
+                       compile_it (Just l)

                        -- we have an old BCO that is up to date with respect
                        -- to the source: do a recompilation check as normal.
 
                        -- we have an old BCO that is up to date with respect
                        -- to the source: do a recompilation check as normal.
 

-                     | otherwise ->
-                         compile_it Nothing
+               | otherwise -> 
+                        compile_it Nothing

                        -- no existing code at all: we must recompile.
                        -- no existing code at all: we must recompile.

-                  where
-                   is_stable_obj = this_mod_name `elem` stable_obj
-                   is_stable_bco = this_mod_name `elem` stable_bco

 
 

-                   old_hmi = lookupUFM old_hpt this_mod_name
+              -- When generating object code, if there's an up-to-date
+              -- object file on the disk, then we can use it.
+              -- However, if the object file is new (compared to any
+              -- linkable we had from a previous compilation), then we
+              -- must discard any in-memory interface, because this
+              -- means the user has compiled the source file
+              -- separately and generated a new interface, that we must
+              -- read from the disk.
+              --
+            obj | isObjectTarget obj,
+                 Just obj_date <- mb_obj_date, obj_date >= hs_date -> do
+                     case old_hmi of
+                        Just hmi 
+                          | Just l <- hm_linkable hmi,
+                            isObjectLinkable l && linkableTime l == obj_date
+                            -> compile_it (Just l)
+                        _otherwise -> do
+                         linkable <- findObjectLinkable this_mod obj_fn obj_date
+                          compile_it_discard_iface (Just linkable)
+
+           _otherwise ->
+                 compile_it Nothing
+

 
 -- Run hsc to compile a module
 upsweep_compile hsc_env old_hpt this_mod summary
                 mod_index nmods
 
 -- Run hsc to compile a module
 upsweep_compile hsc_env old_hpt this_mod summary
                 mod_index nmods

-                mb_old_linkable = do
-  let
-       -- The old interface is ok if it's in the old HPT 
-       --      a) we're compiling a source file, and the old HPT
-       --         entry is for a source file
-       --      b) we're compiling a hs-boot file
-       -- Case (b) allows an hs-boot file to get the interface of its
-       -- real source file on the second iteration of the compilation
-       -- manager, but that does no harm.  Otherwise the hs-boot file
-       -- will always be recompiled
-
-        mb_old_iface 
-               = case lookupUFM old_hpt this_mod of
-                    Nothing                              -> Nothing
-                    Just hm_info | isBootSummary summary -> Just iface
-                                 | not (mi_boot iface)   -> Just iface
-                                 | otherwise             -> Nothing
-                                  where 
-                                    iface = hm_iface hm_info
-
-  compresult <- compile hsc_env summary mb_old_linkable mb_old_iface
+                mb_old_iface
+                mb_old_linkable
+ = do
+   compresult <- compile hsc_env summary mb_old_linkable mb_old_iface

                         mod_index nmods
 
                         mod_index nmods
 

-  case compresult of
+   case compresult of

         -- Compilation failed.  Compile may still have updated the PCS, tho.
         CompErrs -> return Nothing
 
         -- Compilation failed.  Compile may still have updated the PCS, tho.
         CompErrs -> return Nothing
 

@@ -2253,7 +2286,7 @@ reinstallBreakpointHandlers :: Session -> IO ()
 reinstallBreakpointHandlers session = do
   dflags <- getSessionDynFlags session
   let mode = ghcMode dflags
 reinstallBreakpointHandlers session = do
   dflags <- getSessionDynFlags session
   let mode = ghcMode dflags

-  when (mode == Interactive) $ do 
+  when (ghcLink dflags == LinkInMemory) $ do

     linkEnv <- readIORef v_bkptLinkEnv
     initDynLinker dflags 
     extendLinkEnv linkEnv
     linkEnv <- readIORef v_bkptLinkEnv
     initDynLinker dflags 
     extendLinkEnv linkEnv

diff --git a/compiler/main/Main.hs b/compiler/main/Main.hs
index 758451f..048eee8 100644 (file)
--- a/compiler/main/Main.hs
+++ b/compiler/main/Main.hs
@@ -13,7 +13,8 @@ module Main (main) where
 
 -- The official GHC API
 import qualified GHC
 
 -- The official GHC API
 import qualified GHC

-import GHC             ( Session, DynFlags(..), GhcMode(..), HscTarget(..),
+import GHC             ( Session, DynFlags(..), HscTarget(..), 
+                          GhcMode(..), GhcLink(..),

                          LoadHowMuch(..), dopt, DynFlag(..) )
 import CmdLineParser
 
                          LoadHowMuch(..), dopt, DynFlag(..) )
 import CmdLineParser
 

@@ -90,29 +91,27 @@ main =
                           exitWith ExitSuccess
     _               -> return ()
 
                           exitWith ExitSuccess
     _               -> return ()
 

-  let mode = case cli_mode of
-               DoInteractive   -> Interactive
-               DoEval _        -> Interactive
-               DoMake          -> BatchCompile
-               DoMkDependHS    -> MkDepend
-               _               -> OneShot
-

   -- start our GHC session
   -- start our GHC session

-  session <- GHC.newSession mode mbMinusB
+  session <- GHC.newSession mbMinusB

 
   dflags0 <- GHC.getSessionDynFlags session
 
 
   dflags0 <- GHC.getSessionDynFlags session
 

-  -- set the default HscTarget.  The HscTarget can be further
-  -- adjusted on a module by module basis, using only the -fvia-C and
-  -- -fasm flags.  If the default HscTarget is not HscC or HscAsm,
-  -- -fvia-C and -fasm have no effect.
-  let lang = case cli_mode of 
-                DoInteractive  -> HscInterpreted
-                DoEval _       -> HscInterpreted
-                _other         -> hscTarget dflags0
-
-  let dflags1 = dflags0{ ghcMode = mode,
-                        hscTarget  = lang,
+  -- set the default GhcMode, HscTarget and GhcLink.  The HscTarget
+  -- can be further adjusted on a module by module basis, using only
+  -- the -fvia-C and -fasm flags.  If the default HscTarget is not
+  -- HscC or HscAsm, -fvia-C and -fasm have no effect.
+  let dflt_target = hscTarget dflags0
+      (mode, lang, link)
+         = case cli_mode of
+               DoInteractive   -> (CompManager, HscInterpreted, LinkInMemory)
+               DoEval _        -> (CompManager, HscInterpreted, LinkInMemory)
+               DoMake          -> (CompManager, dflt_target,    LinkBinary)
+               DoMkDependHS    -> (MkDepend,    dflt_target,    LinkBinary)
+               _               -> (OneShot,     dflt_target,    LinkBinary)
+
+  let dflags1 = dflags0{ ghcMode   = mode,
+                        hscTarget = lang,
+                         ghcLink   = link,

                         -- leave out hscOutName for now
                         hscOutName = panic "Main.main:hscOutName not set",
                         verbosity = case cli_mode of
                         -- leave out hscOutName for now
                         hscOutName = panic "Main.main:hscOutName not set",
                         verbosity = case cli_mode of

diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs
index 70150ca..253d262 100644 (file)
--- a/compiler/rename/RnNames.lhs
+++ b/compiler/rename/RnNames.lhs
@@ -13,7 +13,7 @@ module RnNames (
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

-import DynFlags                ( DynFlag(..), GhcMode(..), DynFlags(..) )
+import DynFlags

 import HsSyn           ( IE(..), ieName, ImportDecl(..), LImportDecl,
                          ForeignDecl(..), HsGroup(..), HsValBinds(..),
                          Sig(..), collectHsBindLocatedBinders, tyClDeclNames,
 import HsSyn           ( IE(..), ieName, ImportDecl(..), LImportDecl,
                          ForeignDecl(..), HsGroup(..), HsValBinds(..),
                          Sig(..), collectHsBindLocatedBinders, tyClDeclNames,

@@ -708,10 +708,10 @@ rnExports explicit_mod exports
        -- written "module Main where ..."
        -- Reason: don't want to complain about 'main' not in scope
        --         in interactive mode
        -- written "module Main where ..."
        -- Reason: don't want to complain about 'main' not in scope
        --         in interactive mode

-       ; ghc_mode <- getGhcMode
+        ; dflags <- getDOpts

        ; let real_exports 
        ; let real_exports 

-                | explicit_mod            = exports
-                | ghc_mode == Interactive = Nothing
+                | explicit_mod = exports
+                | ghcLink dflags == LinkInMemory = Nothing

                 | otherwise = Just ([noLoc (IEVar main_RDR_Unqual)])
                        -- ToDo: the 'noLoc' here is unhelpful if 'main' 
                        --       turns out to be out of scope
                 | otherwise = Just ([noLoc (IEVar main_RDR_Unqual)])
                        -- ToDo: the 'noLoc' here is unhelpful if 'main' 
                        --       turns out to be out of scope

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 4e0f283..e26c50b 100644 (file)
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -728,19 +728,18 @@ tcTopSrcDecls boot_details
 checkMain :: TcM TcGblEnv
 -- If we are in module Main, check that 'main' is defined.
 checkMain 
 checkMain :: TcM TcGblEnv
 -- If we are in module Main, check that 'main' is defined.
 checkMain 

-  = do { ghc_mode <- getGhcMode ;
-        tcg_env   <- getGblEnv ;
+  = do { tcg_env   <- getGblEnv ;

         dflags    <- getDOpts ;
         let { main_mod = mainModIs dflags ;
               main_fn  = case mainFunIs dflags of {
                                Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) ;
                                Nothing -> main_RDR_Unqual } } ;
        
         dflags    <- getDOpts ;
         let { main_mod = mainModIs dflags ;
               main_fn  = case mainFunIs dflags of {
                                Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) ;
                                Nothing -> main_RDR_Unqual } } ;
        

-        check_main ghc_mode tcg_env main_mod main_fn
+        check_main dflags tcg_env main_mod main_fn

     }
 
 
     }
 
 

-check_main ghc_mode tcg_env main_mod main_fn
+check_main dflags tcg_env main_mod main_fn

  | mod /= main_mod
  = traceTc (text "checkMain not" <+> ppr main_mod <+> ppr mod) >>
    return tcg_env
  | mod /= main_mod
  = traceTc (text "checkMain not" <+> ppr main_mod <+> ppr mod) >>
    return tcg_env

@@ -780,8 +779,8 @@ check_main ghc_mode tcg_env main_mod main_fn
   where
     mod = tcg_mod tcg_env
  
   where
     mod = tcg_mod tcg_env
  

-    complain_no_main | ghc_mode == Interactive = return ()
-                    | otherwise                = failWithTc noMainMsg
+    complain_no_main | ghcLink dflags == LinkInMemory = return ()
+                    | otherwise = failWithTc noMainMsg

        -- In interactive mode, don't worry about the absence of 'main'
        -- In other modes, fail altogether, so that we don't go on
        -- and complain a second time when processing the export list.
        -- In interactive mode, don't worry about the absence of 'main'
        -- In other modes, fail altogether, so that we don't go on
        -- and complain a second time when processing the export list.

diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml
index 29de82f..1de581d 100644 (file)
--- a/docs/users_guide/flags.xml
+++ b/docs/users_guide/flags.xml
@@ -1268,7 +1268,19 @@
            <row>
              <entry><option>-fno-code</option></entry>
              <entry>Omit code generation</entry>
            <row>
              <entry><option>-fno-code</option></entry>
              <entry>Omit code generation</entry>

-             <entry>mode</entry>
+             <entry>dynamic</entry>
+             <entry>-</entry>
+           </row>
+           <row>
+             <entry><option>-fbyte-code</option></entry>
+             <entry>Generate byte-code</entry>
+             <entry>dynamic</entry>
+             <entry>-</entry>
+           </row>
+           <row>
+             <entry><option>-fobject-code</option></entry>
+             <entry>Generate object code</entry>
+             <entry>dynamic</entry>

              <entry>-</entry>
            </row>
          </tbody>
              <entry>-</entry>
            </row>
          </tbody>

diff --git a/docs/users_guide/ghci.xml b/docs/users_guide/ghci.xml
index 06eb348..03f4a3e 100644 (file)
--- a/docs/users_guide/ghci.xml
+++ b/docs/users_guide/ghci.xml
@@ -1952,6 +1952,32 @@ Main.hs:15> x'
 
   </sect1>
 
 
   </sect1>
 

+  <sect1 id="ghci-obj">
+    <title>Compiling to object code inside GHCi</title>
+
+    <para>By default, GHCi compiles Haskell source code into byte-code
+    that is interpreted by the runtime system.  GHCi can also compile
+    Haskell code to object code: to turn on this feature, use the
+    <option>-fobject-code</option> flag either on the command line or
+    with <literal>:set</literal> (the option
+    <option>-fbyte-code</option> restores byte-code compilation
+    again).  Compiling to object code takes longer, but typically the
+    code will execute 10-20 times faster than byte-code.</para>
+
+    <para>Compiling to object code inside GHCi is particularly useful
+    if you are developing a compiled application, because the
+    <literal>:reload</literal> command typically runs much faster than
+    restarting GHC with <option>--make</option> from the command-line,
+    because all the interface files are already cached in
+    memory.</para>
+
+    <para>There are disadvantages to compiling to object-code: you
+    can't set breakpoints in object-code modules, for example.  Only
+    the exports of an object-code module will be visible in GHCi,
+    rather than all top-level bindings as in interpreted
+    modules.</para>
+  </sect1>
+

   <sect1 id="ghci-faq">
     <title>FAQ and Things To Watch Out For</title>
     
   <sect1 id="ghci-faq">
     <title>FAQ and Things To Watch Out For</title>
     

diff --git a/docs/users_guide/phases.xml b/docs/users_guide/phases.xml
index ba4d72e..3ac9ef2 100644 (file)
--- a/docs/users_guide/phases.xml
+++ b/docs/users_guide/phases.xml
@@ -597,6 +597,32 @@ $ cat foo.hspp</screen>
 
       <varlistentry>
         <term>
 
       <varlistentry>
         <term>

+          <option>-fobject-code</option>
+          <indexterm><primary><option>-fobject-code</option></primary></indexterm>
+        </term>
+        <listitem>
+          <para>Generate object code.  This is the default outside of
+          GHCi, and can be used with GHCi to cause object code to be
+          generated in preference to bytecode.</para>
+        </listitem>
+      </varlistentry>
+
+      <varlistentry>
+        <term>
+          <option>-fbyte-code</option>
+          <indexterm><primary><option>-fbyte-code</option></primary></indexterm>
+        </term>
+        <listitem>
+          <para>Generate byte-code instead of object-code.  This is
+          the default in GHCi.  Byte-code can currently only be used
+          in the interactive interpreter, not saved to disk.  This
+          option is only useful for reversing the effect of
+          <option>-fobject-code</option>.</para>
+        </listitem>
+      </varlistentry>
+
+      <varlistentry>
+        <term>

           <option>-fPIC</option>
           <indexterm><primary><option>-fPIC</option></primary></indexterm>
         </term>
           <option>-fPIC</option>
           <indexterm><primary><option>-fPIC</option></primary></indexterm>
         </term>