Let 'loadModule' generate proper code depending on the 'hscTarget'.

[ghc-hetmet.git] / compiler / main / DriverPipeline.hs

diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index c65941c..5253a2a 100644 (file)
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -19,7 +19,7 @@ module DriverPipeline (
 
        -- Interfaces for the compilation manager (interpreted/batch-mode)
    preprocess, 
-   compile,
+   compile, compile',
    link, 
 
   ) where
@@ -103,7 +103,26 @@ compile :: GhcMonad m =>
         -> Maybe Linkable  -- ^ old linkable, if we have one
         -> m HomeModInfo   -- ^ the complete HomeModInfo, if successful
 
-compile hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable
+compile = compile' (hscCompileNothing, hscCompileInteractive, hscCompileBatch)
+
+type Compiler m a = HscEnv -> ModSummary -> Bool
+                  -> Maybe ModIface -> Maybe (Int, Int)
+                  -> m a
+
+compile' :: GhcMonad m =>
+           (Compiler m (HscStatus, ModIface, ModDetails),
+            Compiler m (InteractiveStatus, ModIface, ModDetails),
+            Compiler m (HscStatus, ModIface, ModDetails))
+        -> HscEnv
+        -> ModSummary      -- ^ summary for module being compiled
+        -> Int             -- ^ module N ...
+        -> Int             -- ^ ... of M
+        -> Maybe ModIface  -- ^ old interface, if we have one
+        -> Maybe Linkable  -- ^ old linkable, if we have one
+        -> m HomeModInfo   -- ^ the complete HomeModInfo, if successful
+
+compile' (nothingCompiler, interactiveCompiler, batchCompiler)
+        hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable
  = do
    let dflags0     = ms_hspp_opts summary
        this_mod    = ms_mod summary
@@ -153,7 +172,7 @@ compile hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable
            = ASSERT (isJust maybe_old_linkable)
              return maybe_old_linkable
 
-       handleBatch (HscRecomp hasStub)
+       handleBatch (HscRecomp hasStub _)
            | isHsBoot src_flavour
                = do when (isObjectTarget hsc_lang) $ -- interpreted reaches here too
                        liftIO $ SysTools.touch dflags' "Touching object file"
@@ -179,10 +198,13 @@ compile hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable
                                   (hs_unlinked ++ stub_unlinked)
                     return (Just linkable)
 
-       handleInterpreted InteractiveNoRecomp
+       handleInterpreted HscNoRecomp
            = ASSERT (isJust maybe_old_linkable)
              return maybe_old_linkable
-       handleInterpreted (InteractiveRecomp hasStub comp_bc modBreaks)
+       handleInterpreted (HscRecomp _hasStub Nothing)
+           = ASSERT (isHsBoot src_flavour)
+             return maybe_old_linkable
+       handleInterpreted (HscRecomp hasStub (Just (comp_bc, modBreaks)))
            = do stub_unlinked <- getStubLinkable hasStub
                 let hs_unlinked = [BCOs comp_bc modBreaks]
                     unlinked_time = ms_hs_date summary
@@ -208,15 +230,13 @@ compile hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable
                                      hm_linkable = linkable })
    -- run the compiler
    case hsc_lang of
-      HscInterpreted
-        | isHsBoot src_flavour -> 
-                runCompiler hscCompileNothing handleBatch
-        | otherwise -> 
-                runCompiler hscCompileInteractive handleInterpreted
+      HscInterpreted ->
+                runCompiler interactiveCompiler handleInterpreted
       HscNothing -> 
-                runCompiler hscCompileNothing handleBatch
+                runCompiler nothingCompiler handleBatch
       _other -> 
-                runCompiler hscCompileBatch handleBatch
+                runCompiler batchCompiler handleBatch
+
 
 -----------------------------------------------------------------------------
 -- stub .h and .c files (for foreign export support)
@@ -666,8 +686,8 @@ runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
        src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn
        (dflags, unhandled_flags, warns)
            <- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts
-       liftIO $ handleFlagWarnings dflags warns  -- XXX: may exit the program
-       liftIO $ checkProcessArgsResult unhandled_flags -- XXX: may throw program error
+       handleFlagWarnings dflags warns
+       checkProcessArgsResult unhandled_flags
 
        if not (dopt Opt_Cpp dflags) then
            -- no need to preprocess CPP, just pass input file along
@@ -726,8 +746,8 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma
                     m <- liftIO $ getCoreModuleName input_fn
                     return (Nothing, mkModuleName m, [], [])
 
-                _           -> liftIO $ do
-                    buf <- hGetStringBuffer input_fn
+                _           -> do
+                    buf <- liftIO $ hGetStringBuffer input_fn
                     (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff)
                     return (Just buf, mod_name, imps, src_imps)
 
@@ -830,7 +850,7 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma
                     -- than the source file (else we wouldn't be in HscNoRecomp)
                     -- but we touch it anyway, to keep 'make' happy (we think).
                     return (StopLn, dflags', Just location4, o_file)
-          (HscRecomp hasStub)
+          (HscRecomp hasStub _)
               -> do when hasStub $
                          do stub_o <- compileStub hsc_env' mod location4
                             liftIO $ consIORef v_Ld_inputs stub_o