From ea882e69c0ee039aac9b7ce4e62917b1d63b36d9 Mon Sep 17 00:00:00 2001 From: rrt Date: Wed, 31 Oct 2001 17:04:45 +0000 Subject: [PATCH] [project @ 2001-10-31 17:04:45 by rrt] Many changes, presumably by Don. --- ghc/compiler/ilxGen/IlxGen.lhs | 54 ++++++++++++++++++++++++++++------------ 1 file changed, 38 insertions(+), 16 deletions(-) diff --git a/ghc/compiler/ilxGen/IlxGen.lhs b/ghc/compiler/ilxGen/IlxGen.lhs index 9e7423d..6648889 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 @@ -966,7 +966,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") @@ -982,7 +982,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) @@ -1044,7 +1044,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 @@ -1227,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 @@ -1607,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 @@ -1709,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 ")"] @@ -2225,7 +2242,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")) -- 1.7.10.4