Add (a) CoreM monad, (b) new Annotations feature

[ghc-hetmet.git] / compiler / iface / MkIface.lhs

diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 1346a9a..285f171 100644 (file)
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -56,6 +56,7 @@ import LoadIface
 import Id
 import IdInfo
 import NewDemand
+import Annotations
 import CoreSyn
 import CoreFVs
 import Class
@@ -220,6 +221,7 @@ mkIface_ hsc_env maybe_old_fingerprint
         ModDetails{  md_insts     = insts, 
                      md_fam_insts = fam_insts,
                      md_rules     = rules,
+                     md_anns      = anns,
                       md_vect_info = vect_info,
                      md_types     = type_env,
                      md_exports   = exports }
@@ -265,6 +267,7 @@ mkIface_ hsc_env maybe_old_fingerprint
 
                        mi_fixities = fixities,
                        mi_warns  = warns,
+                       mi_anns     = mkIfaceAnnotations anns,
                        mi_globals  = Just rdr_env,
 
                        -- Left out deliberately: filled in by addVersionInfo
@@ -370,7 +373,7 @@ mkHashFun
 mkHashFun hsc_env eps
   = \name -> 
       let 
-        mod = nameModule name
+        mod = ASSERT2( isExternalName name, ppr name ) nameModule name
         occ = nameOccName name
         iface = lookupIfaceByModule (hsc_dflags hsc_env) hpt pit mod `orElse` 
                    pprPanic "lookupVers2" (ppr mod <+> ppr occ)
@@ -411,8 +414,9 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
               , let out = localOccs $ freeNamesDeclABI abi
                ]
 
+       name_module n = ASSERT( isExternalName n ) nameModule n
        localOccs = map (getUnique . getParent . getOccName) 
-                        . filter ((== this_mod) . nameModule)
+                        . filter ((== this_mod) . name_module)
                         . nameSetToList
           where getParent occ = lookupOccEnv parent_map occ `orElse` occ
 
@@ -442,7 +446,8 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
           | isWiredInName name  =  putNameLiterally bh name 
            -- wired-in names don't have fingerprints
           | otherwise
-          = let hash | nameModule name /= this_mod =  global_hash_fn name
+          = ASSERT( isExternalName name )
+           let hash | nameModule name /= this_mod =  global_hash_fn name
                      | otherwise = 
                         snd (lookupOccEnv local_env (getOccName name)
                            `orElse` pprPanic "urk! lookup local fingerprint" 
@@ -698,9 +703,9 @@ lookupOccEnvL env k = lookupOccEnv env k `orElse` []
 -- used when we want to fingerprint a structure without depending on the
 -- fingerprints of external Names that it refers to.
 putNameLiterally :: BinHandle -> Name -> IO ()
-putNameLiterally bh name = do
-  put_ bh $! nameModule name
-  put_ bh $! nameOccName name
+putNameLiterally bh name = ASSERT( isExternalName name ) 
+  do { put_ bh $! nameModule name
+     ; put_ bh $! nameOccName name }
 
 computeFingerprint :: Binary a
                    => DynFlags 
@@ -818,7 +823,10 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names
         | otherwise
         = case nameModule_maybe name of
              Nothing  -> pprTrace "mkUsageInfo: internal name?" (ppr name) mv_map
-             Just mod -> extendModuleEnv_C (++) mv_map mod [occ]
+             Just mod -> -- We use this fiddly lambda function rather than
+                         -- (++) as the argument to extendModuleEnv_C to
+                         -- avoid quadratic behaviour (trac #2680)
+                         extendModuleEnv_C (\xs _ -> occ:xs) mv_map mod [occ]
                   where occ = nameOccName name
     
     -- We want to create a Usage for a home module if 
@@ -900,6 +908,17 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names
 \end{code}
 
 \begin{code}
+mkIfaceAnnotations :: [Annotation] -> [IfaceAnnotation]
+mkIfaceAnnotations = map mkIfaceAnnotation
+
+mkIfaceAnnotation :: Annotation -> IfaceAnnotation
+mkIfaceAnnotation (Annotation { ann_target = target, ann_value = serialized }) = IfaceAnnotation { 
+        ifAnnotatedTarget = fmap nameOccName target,
+        ifAnnotatedValue = serialized
+    }
+\end{code}
+
+\begin{code}
 mkIfaceExports :: [AvailInfo]
                -> [(Module, [GenAvailInfo OccName])]
   -- Group by module and sort by occurrence
@@ -927,10 +946,12 @@ mkIfaceExports exports
        --     else the plusFM will simply discard one!  They
        --     should have been combined by now.
     add env (Avail n)
-      = add_one env (nameModule n) (Avail (nameOccName n))
+      = ASSERT( isExternalName n ) 
+        add_one env (nameModule n) (Avail (nameOccName n))
 
     add env (AvailTC tc ns)
-      = foldl add_for_mod env mods
+      = ASSERT( all isExternalName ns ) 
+       foldl add_for_mod env mods
       where
        tc_occ = nameOccName tc
        mods   = nub (map nameModule ns)
@@ -1368,7 +1389,7 @@ instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag,
     do_rough (Just n) = Just (toIfaceTyCon_name n)
 
     dfun_name = idName dfun_id
-    mod       = nameModule dfun_name
+    mod       = ASSERT( isExternalName dfun_name ) nameModule dfun_name
     is_local name = nameIsLocalOrFrom mod name
 
        -- Compute orphanhood.  See Note [Orphans] in IfaceSyn