%
-\section{Generate COM+ extended assembler}
+\section{Generate .NET extended IL}
\begin{code}
module IlxGen( ilxGen ) where
tyConTyVars, isDataTyCon, isAlgTyCon, tyConArity
)
import Type ( liftedTypeKind, openTypeKind, unliftedTypeKind,
- isUnLiftedType, isTyVarTy, mkTyVarTy, sourceTypeRep,
+ isUnLiftedType, isTyVarTy, mkTyVarTy, predTypeRep,
splitForAllTys, splitFunTys, applyTy, applyTys, eqKind, tyVarsOfTypes
)
import TypeRep ( Type(..) )
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
)
-- One day this will be configured by the command line.
import CmdLineOpts ( opt_InPackage, opt_SimplDoEtaReduction )
+import Util ( lengthIs, equalLength )
+
\end{code}
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
importsPrelude | inPrelude = addModuleImpInfo (mkModuleName "PrelGHC")
- | otherwise = addPackageImpInfo preludePackage
+ | otherwise = addPackageImpInfo basePackage
importsType :: IlxEnv -> Type -> ImportsInfo -> ImportsInfo
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)
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)
= ([],[],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)
-- 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)),
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")
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)
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
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
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)
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: <Int32, Bool>
+-- 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
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))
| 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,
-- 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
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
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# */ "
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 ")"]
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")
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])
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])
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"))
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"))
projects / ghc-hetmet.git / blobdiff