X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fiface%2FBinIface.hs;h=9fb0d4be660824bfd326aabfd5d5395c78082b55;hb=36436bc62a98f53e126ec02fe946337c4c766c3f;hp=0d9f61934c92a19a98955e6092366ceed648c392;hpb=ef5b4b146aa172d8ac10f39b5eb3d7a0f948d8f1;p=ghc-hetmet.git diff --git a/ghc/compiler/iface/BinIface.hs b/ghc/compiler/iface/BinIface.hs index 0d9f619..9fb0d4b 100644 --- a/ghc/compiler/iface/BinIface.hs +++ b/ghc/compiler/iface/BinIface.hs @@ -14,10 +14,11 @@ import BasicTypes import NewDemand import IfaceSyn import VarEnv +import InstEnv ( OverlapFlag(..) ) +import Packages ( PackageIdH(..) ) import Class ( DefMeth(..) ) import CostCentre -import DriverState ( v_Build_tag ) -import CmdLineOpts ( opt_HiVersion ) +import StaticFlags ( opt_HiVersion, v_Build_tag ) import Kind ( Kind(..) ) import Panic import Binary @@ -93,6 +94,7 @@ readBinIface hi_path = getBinFileWithDict hi_path instance Binary ModIface where put_ bh (ModIface { mi_module = mod, + mi_boot = is_boot, mi_mod_vers = mod_vers, mi_package = _, -- we ignore the package on output mi_orphan = orphan, @@ -110,6 +112,7 @@ instance Binary ModIface where build_tag <- readIORef v_Build_tag put bh build_tag put_ bh mod + put_ bh is_boot put_ bh mod_vers put_ bh orphan lazyPut bh deps @@ -144,7 +147,7 @@ instance Binary ModIface where ++ build_tag ++ ", found " ++ check_way)) mod_name <- get bh - + is_boot <- get bh mod_vers <- get bh orphan <- get bh deps <- lazyGet bh @@ -158,10 +161,10 @@ instance Binary ModIface where rules <- {-# SCC "bin_rules" #-} lazyGet bh rule_vers <- get bh return (ModIface { - mi_package = ThisPackage, -- to be filled in properly later + mi_package = HomePackage, -- to be filled in properly later mi_module = mod_name, + mi_boot = is_boot, mi_mod_vers = mod_vers, - mi_boot = False, -- Binary interfaces are never .hi-boot files! mi_orphan = orphan, mi_deps = deps, mi_usages = usages, @@ -170,6 +173,7 @@ instance Binary ModIface where mi_fixities = fixities, mi_deprecs = deprecs, mi_decls = decls, + mi_globals = Nothing, mi_insts = insts, mi_rules = rules, mi_rule_vers = rule_vers, @@ -632,17 +636,25 @@ instance Binary IfaceType where instance Binary IfaceTyCon where -- Int,Char,Bool can't show up here because they can't not be saturated - put_ bh IfaceListTc = putByte bh 1 - put_ bh IfacePArrTc = putByte bh 2 - put_ bh (IfaceTupTc bx ar) = do { putByte bh 3; put_ bh bx; put_ bh ar } - put_ bh tc = pprPanic "BinIface.put:" (ppr tc) -- Dealt with by the IfaceType instance + + put_ bh IfaceIntTc = putByte bh 1 + put_ bh IfaceBoolTc = putByte bh 2 + put_ bh IfaceCharTc = putByte bh 3 + put_ bh IfaceListTc = putByte bh 4 + put_ bh IfacePArrTc = putByte bh 5 + put_ bh (IfaceTupTc bx ar) = do { putByte bh 6; put_ bh bx; put_ bh ar } + put_ bh (IfaceTc ext) = do { putByte bh 7; put_ bh ext } get bh = do h <- getByte bh case h of - 1 -> return IfaceListTc - 2 -> return IfacePArrTc - _ -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) } + 1 -> return IfaceIntTc + 2 -> return IfaceBoolTc + 3 -> return IfaceCharTc + 4 -> return IfaceListTc + 5 -> return IfacePArrTc + 6 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) } + _ -> do { ext <- get bh; return (IfaceTc ext) } instance Binary IfacePredType where put_ bh (IfaceClassP aa ab) = do @@ -793,13 +805,13 @@ instance Binary IfaceIdInfo where put_ bh NoInfo = putByte bh 0 put_ bh (HasInfo i) = do putByte bh 1 - lazyPut bh i + lazyPut bh i -- NB lazyPut get bh = do h <- getByte bh case h of 0 -> return NoInfo - _ -> do info <- lazyGet bh + _ -> do info <- lazyGet bh -- NB lazyGet return (HasInfo info) instance Binary IfaceInfoItem where @@ -873,7 +885,7 @@ instance Binary IfaceDecl where put_ bh idinfo put_ bh (IfaceForeign ae af) = error "Binary.put_(IfaceDecl): IfaceForeign" - put_ bh (IfaceData a1 a2 a3 a4 a5 a6) = do + put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do putByte bh 2 put_ bh a1 put_ bh a2 @@ -881,6 +893,7 @@ instance Binary IfaceDecl where put_ bh a4 put_ bh a5 put_ bh a6 + put_ bh a7 put_ bh (IfaceSyn aq ar as at) = do putByte bh 3 @@ -912,7 +925,8 @@ instance Binary IfaceDecl where a4 <- get bh a5 <- get bh a6 <- get bh - return (IfaceData a1 a2 a3 a4 a5 a6) + a7 <- get bh + return (IfaceData a1 a2 a3 a4 a5 a6 a7) 3 -> do aq <- get bh ar <- get bh @@ -930,27 +944,41 @@ instance Binary IfaceDecl where return (IfaceClass a1 a2 a3 a4 a5 a6 a7) instance Binary IfaceInst where - put_ bh (IfaceInst ty dfun) = do - put_ bh ty + put_ bh (IfaceInst cls tys dfun flag orph) = do + put_ bh cls + put_ bh tys put_ bh dfun - get bh = do ty <- get bh + put_ bh flag + put_ bh orph + get bh = do cls <- get bh + tys <- get bh dfun <- get bh - return (IfaceInst ty dfun) + flag <- get bh + orph <- get bh + return (IfaceInst cls tys dfun flag orph) + +instance Binary OverlapFlag where + put_ bh NoOverlap = putByte bh 0 + put_ bh OverlapOk = putByte bh 1 + put_ bh Incoherent = putByte bh 2 + get bh = do h <- getByte bh + case h of + 0 -> return NoOverlap + 1 -> return OverlapOk + 2 -> return Incoherent instance Binary IfaceConDecls where put_ bh IfAbstractTyCon = putByte bh 0 - put_ bh (IfDataTyCon st cs) = do { putByte bh 1 - ; put_ bh st - ; put_ bh cs } + put_ bh (IfDataTyCon cs) = do { putByte bh 1 + ; put_ bh cs } put_ bh (IfNewTyCon c) = do { putByte bh 2 ; put_ bh c } get bh = do h <- getByte bh case h of 0 -> return IfAbstractTyCon - 1 -> do st <- get bh - cs <- get bh - return (IfDataTyCon st cs) + 1 -> do cs <- get bh + return (IfDataTyCon cs) _ -> do aa <- get bh return (IfNewTyCon aa) @@ -999,14 +1027,14 @@ instance Binary IfaceClassOp where return (IfaceClassOp n def ty) instance Binary IfaceRule where - -- IfaceBuiltinRule should not happen here - put_ bh (IfaceRule a1 a2 a3 a4 a5 a6) = do + put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do put_ bh a1 put_ bh a2 put_ bh a3 put_ bh a4 put_ bh a5 put_ bh a6 + put_ bh a7 get bh = do a1 <- get bh a2 <- get bh @@ -1014,6 +1042,7 @@ instance Binary IfaceRule where a4 <- get bh a5 <- get bh a6 <- get bh - return (IfaceRule a1 a2 a3 a4 a5 a6) + a7 <- get bh + return (IfaceRule a1 a2 a3 a4 a5 a6 a7)