X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FilxGen%2FIlxGen.lhs;h=19e9f76ecf38a17857774440266774152faf5985;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=66488899270e3ec8d038c1a4dfc72447494dbc04;hpb=ea882e69c0ee039aac9b7ce4e62917b1d63b36d9;p=ghc-hetmet.git diff --git a/ghc/compiler/ilxGen/IlxGen.lhs b/ghc/compiler/ilxGen/IlxGen.lhs index 6648889..19e9f76 100644 --- a/ghc/compiler/ilxGen/IlxGen.lhs +++ b/ghc/compiler/ilxGen/IlxGen.lhs @@ -16,7 +16,7 @@ import TyCon ( TyCon, tyConPrimRep, isUnboxedTupleTyCon, tyConDataCons, tyConTyVars, isDataTyCon, isAlgTyCon, tyConArity ) import Type ( liftedTypeKind, openTypeKind, unliftedTypeKind, - isUnLiftedType, isTyVarTy, mkTyVarTy, sourceTypeRep, + isUnLiftedType, isTyVarTy, mkTyVarTy, predTypeRep, pprType, splitForAllTys, splitFunTys, applyTy, applyTys, eqKind, tyVarsOfTypes ) import TypeRep ( Type(..) ) @@ -27,11 +27,11 @@ import PrimOp ( PrimOp(..) ) import ForeignCall ( CCallConv(..), ForeignCall(..), CCallSpec(..), CCallTarget(..), DNCallSpec(..) ) import TysWiredIn ( mkTupleTy, tupleCon ) import PrimRep ( PrimRep(..) ) -import Name ( nameModule, nameOccName, isGlobalName, isLocalName, NamedThing(getName) ) +import Name ( nameModule, nameOccName, isExternalName, isInternalName, NamedThing(getName) ) import Subst ( substTyWith ) import Module ( Module, PackageName, ModuleName, moduleName, - modulePackage, preludePackage, + modulePackage, basePackage, isHomeModule, isVanillaModule, pprModuleName, mkHomeModule, mkModuleName ) @@ -43,7 +43,6 @@ import Outputable import Char ( ord ) import List ( partition, elem, insertBy,any ) import UniqSet -import PprType ( pprType ) -- Only called in debug messages import TysPrim ( foreignObjPrimTyCon, weakPrimTyCon, byteArrayPrimTyCon, mutableByteArrayPrimTyCon ) @@ -51,7 +50,9 @@ import TysPrim ( foreignObjPrimTyCon, weakPrimTyCon, byteArrayPrimTyCon, mutabl -- versions of compiled Haskell code. We add a ".O" to all assembly and module -- names when this is set (because that's clue that -O was set). -- One day this will be configured by the command line. -import CmdLineOpts ( opt_InPackage, opt_SimplDoEtaReduction ) +import DynFlags ( opt_InPackage, opt_SimplDoEtaReduction ) + +import Util ( lengthIs, equalLength ) \end{code} @@ -155,7 +156,7 @@ importsVars env vs = foldR (importsVar env) vs importsVar env v = importsName env (idName v). importsType env (idType v) importsName env n - | isLocalName n = importsNone + | isInternalName n = importsNone | ilxEnvModule env == nameModule n = importsNone | isHomeModule (nameModule n) = addModuleImpInfo (moduleName (nameModule n)) -- See HACK below @@ -166,7 +167,7 @@ importsName env n importsPrelude | inPrelude = addModuleImpInfo (mkModuleName "PrelGHC") - | otherwise = addPackageImpInfo preludePackage + | otherwise = addPackageImpInfo basePackage importsType :: IlxEnv -> Type -> ImportsInfo -> ImportsInfo @@ -185,7 +186,7 @@ importsTypeArgs2 env tys = foldR (importsType2 env) tys importsDataCon env dcon = importsTyCon env (dataConTyCon dcon) importsTyCon env tc | (not (isDataTyCon tc) || - isLocalName (getName tc) || + isInternalName (getName tc) || ilxEnvModule env == nameModule (getName tc)) = importsNone importsTyCon env tc | otherwise = importsName env (getName tc) . addTyConImpInfo tc . foldR (importsTyConDataCon env) (tyConDataCons tc) @@ -208,7 +209,7 @@ importsTyConDataConType2 _ _ = panic "IlxGen.lhs: importsTyConDataConType2 ty" importsTyConDataConTypeArgs2 env tys = foldR (importsTyConDataConType2 env) tys importsTyConDataConTypeTyCon env tc | (not (isDataTyCon tc) || - isLocalName (getName tc) || + isInternalName (getName tc) || ilxEnvModule env == nameModule (getName tc)) = importsNone importsTyConDataConTypeTyCon env tc | otherwise = importsName env (getName tc) @@ -1117,12 +1118,11 @@ pushLit env (MachWord w) = text "ldc.i4" <+> integer w <+> text "conv.u4" pushLit env (MachWord64 w) = text "ldc.i8" <+> integer w <+> text "conv.u8" pushLit env (MachFloat f) = text "ldc.r4" <+> rational f pushLit env (MachDouble f) = text "ldc.r8" <+> rational f -pushLit env (MachLitLit _ _) = trace "WARNING: Cannot compile MachLitLit to ILX in IlxGen.lhs" (text "// MachLitLit!!! Not valid in ILX!!") -pushLit env (MachAddr w) = text "ldc.i4" <+> integer w <+> text "conv.i" -pushLit env (MachLabel l) = trace "WARNING: Cannot compile MachLabel to ILX in IlxGen.lhs" (text "// MachLabel!!! Not valid in ILX!!") +pushLit env (MachNullAddr) = text "ldc.i4 0" +pushLit env (MachLabel l _) = trace "WARNING: Cannot compile MachLabel to ILX in IlxGen.lhs" (text "// MachLabel!!! Not valid in ILX!!") pprIlxTopVar env v - | isGlobalName n = (nameReference env n) <> pprId (nameModule n) <> text "::" <> singleQuotes (ppr (nameModule n) <> text "_" <> ppr (nameOccName n)) + | isExternalName n = (nameReference env n) <> pprId (nameModule n) <> text "::" <> singleQuotes (ppr (nameModule n) <> text "_" <> ppr (nameOccName n)) | otherwise = pprId (nameOccName n) where n = idName v @@ -1167,7 +1167,7 @@ deepIlxRepType ty@(TyConApp tc tys) deepIlxRepType (AppTy f x) = AppTy (deepIlxRepType f) (deepIlxRepType x) deepIlxRepType (ForAllTy b ty) = ForAllTy b (deepIlxRepType ty) deepIlxRepType (NoteTy _ ty) = deepIlxRepType ty -deepIlxRepType (SourceTy p) = deepIlxRepType (sourceTypeRep p) +deepIlxRepType (PredTy p) = deepIlxRepType (predTypeRep p) deepIlxRepType ty@(TyVarTy tv) = ty idIlxRepType id = deepIlxRepType (idType id) @@ -1456,14 +1456,14 @@ line = text "// ----------------------------------" hscOptionQual = text ".i_" nameReference env n - | isLocalName n = empty + | isInternalName n = empty | ilxEnvModule env == nameModule n = text "" | isHomeModule (nameModule n) = moduleNameReference (moduleName (nameModule n)) -- HACK: no Vanilla modules should be around, but they are!! This -- gets things working for the scenario "standard library linked as one -- assembly with multiple modules + a one module program running on top of this" -- Same applies to all other mentions of Vailla modules in this file - | isVanillaModule (nameModule n) && not inPrelude = preludePackageReference + | isVanillaModule (nameModule n) && not inPrelude = basePackageReference | isVanillaModule (nameModule n) && inPrelude = moduleNameReference (moduleName (nameModule n)) -- end hack | otherwise = packageReference (modulePackage (nameModule n)) @@ -1475,13 +1475,13 @@ moduleReference env m | ilxEnvModule env == m = text "" | isHomeModule m = moduleNameReference (moduleName m) -- See hack above - | isVanillaModule m && not inPrelude = preludePackageReference + | isVanillaModule m && not inPrelude = basePackageReference | isVanillaModule m && inPrelude = moduleNameReference (moduleName m) -- end hack | otherwise = packageReference (modulePackage m) -preludePackageReference = packageReference preludePackage -inPrelude = preludePackage == opt_InPackage +basePackageReference = packageReference basePackage +inPrelude = basePackage == opt_InPackage ------------------------------------------------ -- This code is copied from absCSyn/CString.lhs, @@ -1489,8 +1489,8 @@ inPrelude = preludePackage == opt_InPackage -- still a mess though. Also, still have to do the -- right thing for embedded nulls. -pprFSInILStyle :: FAST_STRING -> SDoc -pprFSInILStyle fs = doubleQuotes (text (stringToC (_UNPK_ fs))) +pprFSInILStyle :: FastString -> SDoc +pprFSInILStyle fs = doubleQuotes (text (stringToC (unpackFS fs))) stringToC :: String -> String -- Convert a string to the form required by C in a C literal string @@ -1691,13 +1691,13 @@ prelGHCReference :: IlxTyFrag prelGHCReference env = if ilxEnvModule env == mkHomeModule (mkModuleName "PrelGHC") then empty else if inPrelude then moduleNameReference (mkModuleName "PrelGHC") - else preludePackageReference + else basePackageReference prelBaseReference :: IlxTyFrag prelBaseReference env = if ilxEnvModule env == mkHomeModule (mkModuleName "PrelBase") then empty else if inPrelude then moduleNameReference (mkModuleName "PrelBase") - else preludePackageReference + else basePackageReference repThread = ilxType "class [mscorlib]System.Threading.Thread /* ThreadId# */ " repByteArray = ilxType "unsigned int8[] /* ByteArr# */ " @@ -1868,7 +1868,6 @@ ilxPrimOpTable op ISrlOp -> simp_op (ilxOp "shr.un") IntAddCOp -> simp_op (ilxCallSuppMeth (ilxUnboxedPairRep repInt repInt) "IntAddCOp" [] [repInt, repInt]) IntSubCOp -> simp_op (ilxCallSuppMeth (ilxUnboxedPairRep repInt repInt) "IntSubCOp" [] [repInt, repInt]) - IntMulCOp -> simp_op (ilxCallSuppMeth (ilxUnboxedPairRep repInt repInt) "IntMulCOp" [] [repInt, repInt]) IntGcdOp -> simp_op (ilxCallSuppMeth repInt "IntGcdOp" [] [repInt, repInt]) @@ -1915,7 +1914,7 @@ ilxPrimOpTable op FloatSinhOp -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Sinh(float64) conv.r4") FloatCoshOp -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Cosh(float64) conv.r4") FloatTanhOp -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Tanh(float64) conv.r4") - FloatPowerOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Pow(float64, float64) conv.r4") -- ** op, make use of implicit cast to r8... + FloatPowerOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Pow(float64, float64) conv.r4") -- ** op, make use of implicit cast to r8... DoubleExpOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Exp(float64)") DoubleLogOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Log(float64)") @@ -1956,9 +1955,9 @@ ilxPrimOpTable op Integer2WordOp -> simp_op (ilxCallSuppMeth repWord "Integer2WordOp" [] [repInt, repByteArray]) Int2IntegerOp -> simp_op (ilxCallSuppMeth repInteger "Int2IntegerOp" [] [repInt]) Word2IntegerOp -> simp_op (ilxCallSuppMeth repInteger "Word2IntegerOp" [] [repWord]) - IntegerToInt64Op -> simp_op (ilxCallSuppMeth repInt64 "IntegerToInt64Op" [] [repInt,repByteArray]) +-- IntegerToInt64Op -> simp_op (ilxCallSuppMeth repInt64 "IntegerToInt64Op" [] [repInt,repByteArray]) Int64ToIntegerOp -> simp_op (ilxCallSuppMeth repInteger "Int64ToIntegerOp" [] [repInt64]) - IntegerToWord64Op -> simp_op (ilxCallSuppMeth repWord64 "IntegerToWord64Op" [] [repInt,repByteArray]) +-- IntegerToWord64Op -> simp_op (ilxCallSuppMeth repWord64 "IntegerToWord64Op" [] [repInt,repByteArray]) Word64ToIntegerOp -> simp_op (ilxCallSuppMeth repInteger "Word64ToIntegerOp" [] [repWord64]) @@ -2265,7 +2264,7 @@ ilxPrimOpTable op ParGlobalOp -> warn_op "ParGlobalOp" (simp_op (ilxOp " /* ParGlobalOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw")) SeqOp -> warn_op "SeqOp" (simp_op (ilxOp " newobj void [mscorlib]System.Object::.ctor() throw ")) AddrToHValueOp -> warn_op "AddrToHValueOp" (simp_op (ilxOp "newobj void [mscorlib]System.Object::.ctor() throw")) - ReallyUnsafePtrEqualityOp -> simp_op (ilxOp "ceq") +-- ReallyUnsafePtrEqualityOp -> simp_op (ilxOp "ceq") MkApUpd0_Op -> warn_op "MkApUpd0_Op" (simp_op (ilxOp " newobj void [mscorlib]System.Object::.ctor() throw")) NewBCOOp -> warn_op "NewBCOOp" (simp_op (ilxOp " newobj void [mscorlib]System.Object::.ctor() throw"))