Correctly handle wired in unit IDs in -instantiated-with

Summary:
To handle wired in packages, we must rewrite all occurrences
of unit ids like base-4.9.0.0 to base.  However, I forgot
to do this on unit ids that occurred in unit identifiers
passed via -instantiated-with.  This patch handles that case,
plus a test.

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>

Test Plan: validate

Reviewers: bgamari, austin

Subscribers: rwbarton, thomie

Differential Revision: https://phabricator.haskell.org/D3385

1 files changed, 34 insertions, 20 deletions

diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs
index 5db198be4b..10ef0d42ec 100644
--- a/compiler/main/Packages.hs
+++ b/compiler/main/Packages.hs
@@ -471,10 +471,11 @@ initPackages dflags0 = do
         Nothing -> readPackageConfigs dflags
         Just db -> return $ map (\(p, pkgs)
                                     -> (p, setBatchPackageFlags dflags pkgs)) db
-  (pkg_state, preload)
+  (pkg_state, preload, insts)
         <- mkPackageState dflags pkg_db []
   return (dflags{ pkgDatabase = Just pkg_db,
-                  pkgState = pkg_state },
+                  pkgState = pkg_state,
+                  thisUnitIdInsts_ = insts },
           preload)
 
 -- -----------------------------------------------------------------------------
@@ -1069,25 +1070,36 @@ findWiredInPackages dflags prec_map pkgs vis_map = do
                   = pkg
                 upd_deps pkg = pkg {
                       -- temporary harmless DefUnitId invariant violation
-                      depends = map (unDefUnitId . upd_wired_in . DefUnitId) (depends pkg),
+                      depends = map (unDefUnitId . upd_wired_in wiredInMap . DefUnitId) (depends pkg),
                       exposedModules
-                        = map (\(k,v) -> (k, fmap upd_wired_in_mod v))
+                        = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v))
                               (exposedModules pkg)
                     }
-                upd_wired_in_mod (Module uid m) = Module (upd_wired_in_uid uid) m
-                upd_wired_in_uid (DefiniteUnitId def_uid) =
-                    DefiniteUnitId (upd_wired_in def_uid)
-                upd_wired_in_uid (IndefiniteUnitId indef_uid) =
-                    IndefiniteUnitId $ newIndefUnitId
-                        (indefUnitIdComponentId indef_uid)
-                        (map (\(x,y) -> (x,upd_wired_in_mod y)) (indefUnitIdInsts indef_uid))
-                upd_wired_in key
-                    | Just key' <- Map.lookup key wiredInMap = key'
-                    | otherwise = key
 
 
   return (updateWiredInDependencies pkgs, wiredInMap)
 
+-- Helper functions for rewiring Module and UnitId.  These
+-- rewrite UnitIds of modules in wired-in packages to the form known to the
+-- compiler. For instance, base-4.9.0.0 will be rewritten to just base, to match
+-- what appears in PrelNames.
+
+upd_wired_in_mod :: WiredPackagesMap -> Module -> Module
+upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m
+
+upd_wired_in_uid :: WiredPackagesMap -> UnitId -> UnitId
+upd_wired_in_uid wiredInMap (DefiniteUnitId def_uid) =
+    DefiniteUnitId (upd_wired_in wiredInMap def_uid)
+upd_wired_in_uid wiredInMap (IndefiniteUnitId indef_uid) =
+    IndefiniteUnitId $ newIndefUnitId
+        (indefUnitIdComponentId indef_uid)
+        (map (\(x,y) -> (x,upd_wired_in_mod wiredInMap y)) (indefUnitIdInsts indef_uid))
+
+upd_wired_in :: WiredPackagesMap -> DefUnitId -> DefUnitId
+upd_wired_in wiredInMap key
+    | Just key' <- Map.lookup key wiredInMap = key'
+    | otherwise = key
+
 updateVisibilityMap :: WiredPackagesMap -> VisibilityMap -> VisibilityMap
 updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (Map.toList wiredInMap)
   where f vm (from, to) = case Map.lookup (DefiniteUnitId from) vis_map of
@@ -1344,12 +1356,10 @@ mkPackageState
     -> [(FilePath, [PackageConfig])]
     -> [PreloadUnitId]              -- preloaded packages
     -> IO (PackageState,
-           [PreloadUnitId])         -- new packages to preload
+           [PreloadUnitId],         -- new packages to preload
+           Maybe [(ModuleName, Module)])
 
 mkPackageState dflags dbs preload0 = do
-  -- Compute the unit id
-  let this_package = thisPackage dflags
-
 {-
    Plan.
 
@@ -1541,7 +1551,10 @@ mkPackageState dflags dbs preload0 = do
       -- but in any case remove the current package from the set of
       -- preloaded packages so that base/rts does not end up in the
       -- set up preloaded package when we are just building it
-      preload3 = nub $ filter (/= this_package)
+      -- (NB: since this is only relevant for base/rts it doesn't matter
+      -- that thisUnitIdInsts_ is not wired yet)
+      --
+      preload3 = nub $ filter (/= thisPackage dflags)
                      $ (basicLinkedPackages ++ preload2)
 
   -- Close the preload packages with their dependencies
@@ -1564,7 +1577,8 @@ mkPackageState dflags dbs preload0 = do
     unwireMap = Map.fromList [ (v,k) | (k,v) <- Map.toList wired_map ],
     requirementContext = req_ctx
     }
-  return (pstate, new_dep_preload)
+  let new_insts = fmap (map (fmap (upd_wired_in_mod wired_map))) (thisUnitIdInsts_ dflags)
+  return (pstate, new_dep_preload, new_insts)
 
 -- | Given a wired-in 'UnitId', "unwire" it into the 'UnitId'
 -- that it was recorded as in the package database.