%
-\section{Generate COM+ extended assembler}
+\section{Generate .NET extended IL}
\begin{code}
module IlxGen( ilxGen ) where
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,
-- 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
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)
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 (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
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
-- 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
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 ")"]
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