X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FilxGen%2FIlxGen.lhs;h=8d6c915cdde469b5a9a9eceb5bd9794e06095775;hb=f25b9225f77ca8aa097a9acb4b5be27daea94891;hp=9a904223ecd1f2bb875e8c166b2279194316fc4a;hpb=3a60e526b101bc913fb8abf9fd4f5f37a3e2f821;p=ghc-hetmet.git diff --git a/ghc/compiler/ilxGen/IlxGen.lhs b/ghc/compiler/ilxGen/IlxGen.lhs index 9a90422..8d6c915 100644 --- a/ghc/compiler/ilxGen/IlxGen.lhs +++ b/ghc/compiler/ilxGen/IlxGen.lhs @@ -1,5 +1,5 @@ % -\section{Generate COM+ extended assembler} +\section{Generate .NET extended IL} \begin{code} module IlxGen( ilxGen ) where @@ -8,8 +8,7 @@ module IlxGen( ilxGen ) where import Char ( ord, chr ) import StgSyn -import Id ( idType, idName, isDeadBinder, idArityInfo ) -import IdInfo ( arityLowerBound ) +import Id ( idType, idName, isDeadBinder, idArity ) import Var ( Var, Id, TyVar, isId, isTyVar, tyVarKind, tyVarName ) import VarEnv import VarSet ( isEmptyVarSet ) @@ -17,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(..) ) @@ -28,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 ) @@ -44,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 ) @@ -54,6 +52,8 @@ import TysPrim ( foreignObjPrimTyCon, weakPrimTyCon, byteArrayPrimTyCon, mutabl -- One day this will be configured by the command line. import CmdLineOpts ( opt_InPackage, opt_SimplDoEtaReduction ) +import Util ( lengthIs, equalLength ) + \end{code} @@ -156,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 @@ -167,7 +167,7 @@ importsName env n importsPrelude | inPrelude = addModuleImpInfo (mkModuleName "PrelGHC") - | otherwise = addPackageImpInfo preludePackage + | otherwise = addPackageImpInfo basePackage importsType :: IlxEnv -> Type -> ImportsInfo -> ImportsInfo @@ -186,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) @@ -209,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) @@ -772,7 +772,7 @@ ilxFunAppAfterPush env fun args tail_call case lookupIlxBindEnv env fun of Just (_, StgRhsClosure _ _ _ Updatable _ _) -> Nothing Just (place, StgRhsClosure _ _ fvs _ args _) -> Just (place,fun,args,fvs) - _ -> Nothing -- trace (show fun ++ " --> " ++ show (arityLowerBound (idArityInfo fun))) + _ -> Nothing -- trace (show fun ++ " --> " ++ show (idArity fun)) type KnownClosure = Maybe ( IlxEnv -- Of the binding site of the function , Id -- The function @@ -856,7 +856,7 @@ ilxFunAppArgs env num_sofar funty args tail_call known_clo = ([],[],env,args,funty) get_term_args n max args env funty | (case known_clo of - Just (_,_,needed,_) -> (length needed == n) + Just (_,_,needed,_) -> needed `lengthIs` n Nothing -> False) -- Stop if we have the optimal number for a direct call = ([],[],env,args,funty) @@ -898,7 +898,7 @@ ilxFunAppArgs env num_sofar funty args tail_call known_clo -- the "callfunc" case. basic_call_instr = case known_clo of - Just (known_env,fun,needed,fvs) | (length needed == length now_args) && + Just (known_env,fun,needed,fvs) | (equalLength needed now_args) && all (\x -> elemIlxTyEnv x env) free_ilx_tvs -> vcat [text "callclo class", nameReference env (idName fun) <+> singleQuotes (ilxEnvQualifyByModule env (ppr fun)), @@ -967,7 +967,7 @@ ilxRhs env rec (bndr, StgRhsClosure _ _ fvs upd args rhs) where pushFv id = if elem id rec then text "ldnull" else pushId env id (free_ilx_tvs, free_non_ilx_tvs,free_vs) = categorizeVars fvs - clotext = pprIlxBoxedTyConApp env (ilxEnvQualifyByModule env (ppr bndr)) (map mkTyVarTy free_ilx_tvs) + clotext = pprIlxNamedTyConApp env (ilxEnvQualifyByModule env (ppr bndr)) (map mkTyVarTy free_ilx_tvs) ilxFixupRec env rec (bndr, _) | isVoidIlxRepId bndr = ilxComment (text "no recursive fixup for void-rep-id") @@ -983,7 +983,7 @@ ilxFixupRec env rec (bndr, StgRhsClosure _ _ fvs upd args rhs) text "stclofld" <+> clotext <> text "," <+> pprId recid] else text "//no fixup needed for" <+> pprId recid (free_ilx_tvs, free_non_ilx_tvs,free_vs) = categorizeVars fvs - clotext = pprIlxBoxedTyConApp env (ilxEnvQualifyByModule env (ppr bndr)) (map mkTyVarTy free_ilx_tvs) + clotext = pprIlxNamedTyConApp env (ilxEnvQualifyByModule env (ppr bndr)) (map mkTyVarTy free_ilx_tvs) @@ -1045,7 +1045,7 @@ ilxTopBind mod env pairs = ilxTopRhs mod env (bndr, StgRhsClosure _ _ fvs upd args rhs) = vcat [vcat (map (pushId env) free_vs), (if null free_non_ilx_tvs then empty else (ilxComment (text "ignored some higher order type arguments in application - code will be non verifiable...."))), - text "newclo" <+> pprIlxBoxedTyConApp env (ilxEnvQualifyByModule env (ppr bndr)) (map mkTyVarTy free_ilx_tvs), + text "newclo" <+> pprIlxNamedTyConApp env (ilxEnvQualifyByModule env (ppr bndr)) (map mkTyVarTy free_ilx_tvs), text "stsfld" <+> pprFieldRef env (mod,bndTy,bndr) ] where @@ -1118,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 @@ -1168,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) @@ -1228,17 +1227,28 @@ ilxTypeR env (NoteTy _ ty) pprIlxFunTy dom ran = parens (hsep [text "func",parens dom,text "-->", ran]) -ilxTyConApp env tc args = - case lookupUFM tyPrimConTable (getUnique tc) of +ilxTyConApp env tcon args = + case lookupUFM tyPrimConTable (getUnique tcon) of Just f -> f args env Nothing -> - (if isUnboxedTupleTyCon tc then pprIlxUnBoxedTyConApp else pprIlxBoxedTyConApp) - env ((nameReference env (getName tc)) <> (ppr tc)) args + (if isUnboxedTupleTyCon tcon then pprIlxUnboxedTupleTyConApp else pprIlxBoxedTyConApp) + env tcon args -pprIlxUnBoxedTyConApp env tcdoc args = text "value class" <+> tcdoc <> pprTypeArgs ilxTypeL env args -pprIlxBoxedTyConApp env tcdoc args = text "class" <+> tcdoc <> pprTypeArgs ilxTypeR env args +pprIlxTyCon env tcon = nameReference env (getName tcon) <> ppr tcon +pprIlxUnboxedTupleTyConApp env tcon args + = text "/* unboxed */ value class" <+> pprIlxTyCon env tcon' <> pprTypeArgs ilxTypeL env non_void + where + non_void = filter (not . isVoidIlxRepType) args + tcon' = dataConTyCon (tupleCon Unboxed (length non_void)) +pprIlxBoxedTyConApp env tcon args + = pprIlxNamedTyConApp env (pprIlxTyCon env tcon) args +pprIlxNamedTyConApp env tcon_text args + = text "class" <+> tcon_text <> pprTypeArgs ilxTypeR env args -- Returns e.g: +-- Void-sized type arguments are _always_ eliminated, everywhere. +-- If the type constructor is an unboxed tuple type then it should already have +-- been adjusted to be the correct constructor. pprTypeArgs f env tys = pprTypeArgs_aux f env (filter (not . isVoidIlxRepType) tys) pprTypeArgs_aux f env [] = empty @@ -1446,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)) @@ -1465,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, @@ -1479,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 @@ -1608,8 +1618,14 @@ splitTyArgs1 (StgTypeArg ty : args) = (ty:tys, args') splitTyArgs1 args = ([], args) ilxConRef env data_con - = pprId data_con <> pprValArgTys ilxTypeL env' (map deepIlxRepType (filter (not . isVoidIlxRepType) arg_tys)) + | isUnboxedTupleCon data_con + = let data_con' = tupleCon Unboxed (length non_void_args)in + pprId data_con' <> arg_text + | otherwise + = pprId data_con <> arg_text where + arg_text = pprValArgTys ilxTypeL env' (map deepIlxRepType non_void_args) + non_void_args = filter (not . isVoidIlxRepType) arg_tys (tyvars, tau_ty) = splitForAllTys (dataConRepType data_con) (arg_tys, _) = splitFunTys tau_ty env' = formalIlxEnv env tyvars @@ -1675,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# */ " @@ -1710,10 +1726,10 @@ repBCO = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_BCOzh"] ilxTyPair l r = ilxTyParams [l,r] ilxTyTriple l m r = ilxTyParams [l,m,r] ilxTyQuad l m1 m2 r = ilxTyParams [l,m1,m2,r] -ilxUnboxedEmptyRep = ilxTypeSeq [ilxType "value class",prelGHCReference,ilxType "PrelGHC_Z0H"] -ilxUnboxedPairRep l r = ilxTypeSeq [ilxType "value class",prelGHCReference,ilxType "PrelGHC_Z1H",ilxTyPair l r] -ilxUnboxedTripleRep l m r = ilxTypeSeq [ilxType "value class",prelGHCReference,ilxType "PrelGHC_Z2H",ilxTyTriple l m r] -ilxUnboxedQuadRep l m1 m2 r = ilxTypeSeq [ilxType "value class",prelGHCReference,ilxType "PrelGHC_Z3H",ilxTyQuad l m1 m2 r] +ilxUnboxedEmptyRep = ilxTypeSeq [ilxType "value class",prelGHCReference,ilxType "PrelGHC_Z1H"] +ilxUnboxedPairRep l r = ilxTypeSeq [ilxType "value class",prelGHCReference,ilxType "PrelGHC_Z2H",ilxTyPair l r] +ilxUnboxedTripleRep l m r = ilxTypeSeq [ilxType "value class",prelGHCReference,ilxType "PrelGHC_Z3H",ilxTyTriple l m r] +ilxUnboxedQuadRep l m1 m2 r = ilxTypeSeq [ilxType "value class",prelGHCReference,ilxType "PrelGHC_Z4H",ilxTyQuad l m1 m2 r] ilxTyIO b = ilxTypeSeq [ilxType "(func ( /* unit skipped */ ) --> ", b, ilxType ")"] @@ -1834,7 +1850,6 @@ ilxPrimOpTable op IntRemOp -> simp_op (ilxOp "rem") -- Addr# ops: - AddrNullOp -> simp_op (ilxOp "pop ldnull") AddrAddOp -> simp_op (ilxOp "add") AddrSubOp -> simp_op (ilxOp "sub") AddrRemOp -> simp_op (ilxOp "rem") @@ -1853,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]) @@ -1941,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]) @@ -2227,7 +2241,12 @@ ilxPrimOpTable op YieldOp -> simp_op (ilxOpSeq [ilxOp "call class [mscorlib]System.Threading.Thread class [mscorlib]System.Threading.Thread::get_CurrentThread() call instance void class [mscorlib]System.Threading.Thread::Suspend()"]) MyThreadIdOp -> simp_op (ilxOpSeq [ilxOp "call default class [mscorlib]System.Threading.Thread class [mscorlib]System.Threading.Thread::get_CurrentThread() "]) - KillThreadOp -> ty1_op (\ty -> ilxOpSeq [ilxOp "box", ty, ilxOp "call instance void class [mscorlib]System.Threading.Thread::Abort(class [mscorlib]System.Object) "]) + -- This pushes a THUNK across as the exception value. + -- This is the correct Haskell semantics... TODO: we should probably + -- push across an HaskellThreadAbortException object that wraps this + -- thunk, but which is still actually an exception of + -- an appropriate type. + KillThreadOp -> ty1_op (\ty -> ilxOpSeq [ilxOp "call instance void class [mscorlib]System.Threading.Thread::Abort(class [mscorlib]System.Object) "]) {- ThreadId# -> a -> State# RealWorld -> State# RealWorld -} ForkOp -> warn_op "ForkOp" (simp_op (ilxOp "/* ForkOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw")) @@ -2245,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"))