X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FilxGen%2FIlxGen.lhs;h=19e9f76ecf38a17857774440266774152faf5985;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=d59612e3468d638846d51587dd8862d50bbd7bdb;hpb=ce6b5c20ce90aa7cba33164a53dd62395b0291de;p=ghc-hetmet.git diff --git a/ghc/compiler/ilxGen/IlxGen.lhs b/ghc/compiler/ilxGen/IlxGen.lhs index d59612e..19e9f76 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,30 +8,30 @@ 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 ) import TyCon ( TyCon, tyConPrimRep, isUnboxedTupleTyCon, tyConDataCons, tyConTyVars, isDataTyCon, isAlgTyCon, tyConArity ) import Type ( liftedTypeKind, openTypeKind, unliftedTypeKind, - isUnLiftedType, isTyVarTy, mkTyVarTy, sourceTypeRep, - splitForAllTys, splitFunTys, applyTy, applyTys, eqKind + isUnLiftedType, isTyVarTy, mkTyVarTy, predTypeRep, pprType, + splitForAllTys, splitFunTys, applyTy, applyTys, eqKind, tyVarsOfTypes ) import TypeRep ( Type(..) ) -import DataCon ( isUnboxedTupleCon, dataConTyCon, dataConRepType, dataConRepArgTys ) +import DataCon ( isUnboxedTupleCon, dataConTyCon, dataConRepType, dataConRepArgTys, DataCon(..) ) import Literal ( Literal(..) ) import PrelNames -- Lots of keys 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 Subst ( substTy, mkTyVarSubst ) +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} @@ -67,7 +68,8 @@ import CmdLineOpts ( opt_InPackage, opt_SimplDoEtaReduction ) ilxGen :: Module -> [TyCon] -> [(StgBinding,[Id])] -> SDoc -- The TyCons should include those arising from classes ilxGen mod tycons binds_w_srts - = vcat [ text ".assembly extern ilx 'mscorlib' {}", + = vcat [ text ".module '" <> (ppr (moduleName mod)) <> hscOptionQual <> text "o'", + text ".assembly extern 'mscorlib' {}", vcat (map (ilxImportPackage topenv) (uniqSetToList import_packages)), vcat (map (ilxImportModule topenv) (uniqSetToList import_modules)), vcat (map (ilxImportTyCon topenv) (uniqSetToList import_tycons)), @@ -93,7 +95,7 @@ ilxGen mod tycons binds_w_srts \begin{code} -importsBinds :: IlxEnv -> [StgBinding] -> ImportsInfo-> ImportsInfo +importsBinds :: IlxEnv -> [StgBinding] -> ImportsInfo -> ImportsInfo importsBinds env binds = foldR (importsBind env) binds importsNone :: ImportsInfo -> ImportsInfo @@ -154,8 +156,8 @@ importsVars env vs = foldR (importsVar env) vs importsVar env v = importsName env (idName v). importsType env (idType v) importsName env n - | isLocalName n = importsNone - | ilxEnvModule env == nameModule n = importsNone + | isInternalName n = importsNone + | ilxEnvModule env == nameModule n = importsNone | isHomeModule (nameModule n) = addModuleImpInfo (moduleName (nameModule n)) -- See HACK below | isVanillaModule (nameModule n) && not inPrelude = importsPrelude @@ -164,11 +166,15 @@ importsName env n | otherwise = addPackageImpInfo (modulePackage (nameModule n)) +importsPrelude | inPrelude = addModuleImpInfo (mkModuleName "PrelGHC") + | otherwise = addPackageImpInfo basePackage + + importsType :: IlxEnv -> Type -> ImportsInfo -> ImportsInfo importsType env ty = importsType2 env (deepIlxRepType ty) importsType2 :: IlxEnv -> Type -> ImportsInfo -> ImportsInfo -importsType2 env (AppTy f x) = importsType2 env f . importsType2 env x +importsType2 env (AppTy f x) = importsType2 env f . importsType2 env x importsType2 env (TyVarTy _) = importsNone importsType2 env (TyConApp tc args) =importsTyCon env tc . importsTypeArgs2 env args importsType2 env (FunTy arg res) = importsType env arg . importsType2 env res @@ -180,12 +186,33 @@ 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 +importsTyCon env tc | otherwise = importsName env (getName tc) . addTyConImpInfo tc . + foldR (importsTyConDataCon env) (tyConDataCons tc) + + +importsTyConDataCon :: IlxEnv -> DataCon -> ImportsInfo -> ImportsInfo +importsTyConDataCon env dcon = foldR (importsTyConDataConType env) (filter (not . isVoidIlxRepType) (dataConRepArgTys dcon)) + +importsTyConDataConType :: IlxEnv -> Type -> ImportsInfo -> ImportsInfo +importsTyConDataConType env ty = importsTyConDataConType2 env (deepIlxRepType ty) + +importsTyConDataConType2 :: IlxEnv -> Type -> ImportsInfo -> ImportsInfo +importsTyConDataConType2 env (AppTy f x) = importsTyConDataConType2 env f . importsTyConDataConType2 env x +importsTyConDataConType2 env (TyVarTy _) = importsNone +importsTyConDataConType2 env (TyConApp tc args) = importsTyConDataConTypeTyCon env tc . importsTyConDataConTypeArgs2 env args +importsTyConDataConType2 env (FunTy arg res) = importsTyConDataConType env arg . importsTyConDataConType2 env res +importsTyConDataConType2 env (ForAllTy tv body_ty) = importsTyConDataConType2 env body_ty +importsTyConDataConType2 env (NoteTy _ ty) = importsTyConDataConType2 env ty +importsTyConDataConType2 _ _ = panic "IlxGen.lhs: importsTyConDataConType2 ty" +importsTyConDataConTypeArgs2 env tys = foldR (importsTyConDataConType2 env) tys + +importsTyConDataConTypeTyCon env tc | (not (isDataTyCon tc) || + isInternalName (getName tc) || + ilxEnvModule env == nameModule (getName tc)) = importsNone +importsTyConDataConTypeTyCon env tc | otherwise = importsName env (getName tc) -importsPrelude | inPrelude = addModuleImpInfo (mkModuleName "PrelGHC") - | otherwise = addPackageImpInfo preludePackage type StaticCCallInfo = (CLabelString,CCallConv,[Type],Type) type ImportsInfo = (UniqSet PackageName, UniqSet ModuleName, UniqSet TyCon, UniqFM StaticCCallInfo) @@ -203,10 +230,10 @@ ilxImportTyCon env tycon | isDataTyCon tycon = ilxTyConDef True env tycon ilxImportTyCon _ _ | otherwise = empty ilxImportPackage :: IlxEnv -> PackageName -> SDoc -ilxImportPackage _ p = text ".assembly extern ilx" <+> singleQuotes (ppr p <> hscOptionQual) <+> text "{ }" +ilxImportPackage _ p = text ".assembly extern" <+> singleQuotes (ppr p <> hscOptionQual) <+> text "{ }" ilxImportModule :: IlxEnv -> ModuleName -> SDoc -ilxImportModule _ m = text ".module extern ilx" <+> singleQuotes (ppr m <> hscOptionQual <> text ".dll") +ilxImportModule _ m = text ".module extern" <+> singleQuotes (ppr m <> hscOptionQual <> text "o") -- Emit a P/Invoke declaration for the imported C function -- TODO: emit the right DLL name @@ -586,7 +613,7 @@ ilxWipe env ids ilxWipeOne env id = case lookupIlxVarEnv env id of - Just Local -> text "ldloca " <+> pprId id <+> text "initobj" <+> (ilxTypeL env (idIlxRepType id)) + Just Local -> text "ldloca " <+> pprId id <+> text "initobj.any" <+> (ilxTypeL env (idIlxRepType id)) Just Arg -> text "deadarg " <+> pprId id <+> text "," <+> (ilxTypeL env (idIlxRepType id)) Just (CloVar _) -> ilxComment (text "not yet wiping closure variable" <+> pprId id ) _ -> ilxComment (text "cannot wipe non-local/non-argument" <+> pprId id ) @@ -745,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) - _ -> trace (show fun ++ " --> " ++ show (arityLowerBound (idArityInfo fun))) Nothing + _ -> Nothing -- trace (show fun ++ " --> " ++ show (idArity fun)) type KnownClosure = Maybe ( IlxEnv -- Of the binding site of the function , Id -- The function @@ -812,7 +839,7 @@ ilxFunAppArgs env num_sofar funty args tail_call known_clo get_type_args max ((arg@(StgTypeArg v)):rest) env (ForAllTy tv rem_funty) = if isIlxTyVar tv then let env2 = extendIlxEnvWithFormalTyVars env [tv] in - let rest_ty = deepIlxRepType (substTy (mkTyVarSubst [tv] [v]) rem_funty) in + let rest_ty = deepIlxRepType (substTyWith [tv] [v] rem_funty) in let (now,now_tys,env3,later,later_ty) = get_type_args (max - 1) rest env rest_ty in let arg_ty = mkTyVarTy tv in (arg:now,(arg,arg_ty):now_tys,env2, later, later_ty) @@ -829,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) @@ -871,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)), @@ -940,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") @@ -956,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) @@ -1018,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 @@ -1091,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 @@ -1141,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) @@ -1162,7 +1188,7 @@ ilxTypeL env ty = text "thunk" <> angleBrackets (ilxTypeR env ty) ilxTypeR :: IlxEnv -> Type -> SDoc ilxTypeR env ty | isVoidIlxRepType ty = text "/* unit skipped */" ilxTypeR env ty@(AppTy f _) | isTyVarTy f = ilxComment (text "type app:" <+> pprType ty) <+> (text "class [mscorlib]System.Object") -ilxTypeR env ty@(AppTy f x) = trace "ilxTypeR: should I be beta reducing types?!" (ilxComment (text "ilxTypeR: should I be beta reducing types...") <+> ilxTypeR env (applyTy f x)) +ilxTypeR env ty@(AppTy f x) = trace "ilxTypeR: should I be beta reducing types?!" (ilxComment (text "ilxTypeR: should I be beta reducing types?!") <+> ilxTypeR env (applyTy f x)) ilxTypeR env (TyVarTy tv) = ilxTyVar env tv -- The following is a special rule for types constructed out of @@ -1201,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 @@ -1416,35 +1453,35 @@ singleQuotes pp = char '\'' <> pp <> char '\'' line = text "// ----------------------------------" -hscOptionQual = if opt_SimplDoEtaReduction then text ".ilx-O" else text ".ilx-Onot" +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)) packageReference p = brackets (singleQuotes (ppr p <> hscOptionQual)) -moduleNameReference m = brackets ((text ".module") <+> (singleQuotes (pprModuleName m <> hscOptionQual <> text ".dll"))) +moduleNameReference m = brackets ((text ".module") <+> (singleQuotes (pprModuleName m <> hscOptionQual <> text "o"))) 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, @@ -1452,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 @@ -1581,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 @@ -1642,19 +1685,19 @@ ilxTypeL2 ty env = ilxTypeL env ty ilxTypeR2 :: Type -> IlxTyFrag ilxTypeR2 ty env = ilxTypeR env ty -ilxMethA = ilxType "!!0" -ilxMethB = ilxType "!!1" +ilxMethTyVarA = ilxType "!!0" +ilxMethTyVarB = ilxType "!!1" 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# */ " @@ -1683,9 +1726,12 @@ 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] -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 ")"] ilxTyParams :: [IlxTyFrag] -> IlxTyFrag ilxTyParams [] env = empty @@ -1760,12 +1806,12 @@ ilxPrimOpTable op IntLtOp -> simp_op ilxClt IntLeOp -> simp_op ilxCle - IntToInt8Op -> simp_op (ilxOp"conv.i1") - IntToInt16Op -> simp_op (ilxOp "conv.i2") - IntToInt32Op -> simp_op (ilxOp "conv.i4") - WordToWord8Op -> simp_op (ilxOp "conv.u1") - WordToWord16Op -> simp_op (ilxOp "conv.u2") - WordToWord32Op -> simp_op (ilxOp "conv.u4") + Narrow8IntOp -> simp_op (ilxOp"conv.i1") + Narrow16IntOp -> simp_op (ilxOp "conv.i2") + Narrow32IntOp -> simp_op (ilxOp "conv.i4") + Narrow8WordOp -> simp_op (ilxOp "conv.u1") + Narrow16WordOp -> simp_op (ilxOp "conv.u2") + Narrow32WordOp -> simp_op (ilxOp "conv.u4") WordGtOp -> simp_op ilxCgtUn WordGeOp -> simp_op ilxCgeUn @@ -1803,6 +1849,13 @@ ilxPrimOpTable op IntNegOp -> simp_op (ilxOp "neg") IntRemOp -> simp_op (ilxOp "rem") + -- Addr# ops: + AddrAddOp -> simp_op (ilxOp "add") + AddrSubOp -> simp_op (ilxOp "sub") + AddrRemOp -> simp_op (ilxOp "rem") + Int2AddrOp -> warn_op "int2Addr" (simp_op (ilxOp "/* PrimOp int2Addr */ ")) + Addr2IntOp -> warn_op "addr2Int" (simp_op (ilxOp "/* PrimOp addr2Int */ ")) + -- Word#-related ops: WordAddOp -> simp_op (ilxOp "add") WordSubOp -> simp_op (ilxOp "sub") @@ -1810,14 +1863,11 @@ ilxPrimOpTable op WordQuotOp -> simp_op (ilxOp "div") WordRemOp -> simp_op (ilxOp "rem") - Addr2IntOp -> simp_op (ilxOp "conv.i4") -- Addresses are very dodgy for ILX. They are used for both C-strings and - Int2AddrOp -> simp_op (ilxOp "conv.i") -- the FFI. This needs more work. ISllOp -> simp_op (ilxOp "shl") ISraOp -> simp_op (ilxOp "shr") 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]) @@ -1864,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)") @@ -1905,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]) @@ -1972,8 +2022,8 @@ ilxPrimOpTable op IndexOffAddrOp_WideChar -> simp_op (ilxOp "sizeof int32 mul add ldind.u4") IndexOffAddrOp_Int -> simp_op (ilxOp "sizeof int32 mul add ldind.i4") IndexOffAddrOp_Word -> simp_op (ilxOp "sizeof int32 mul add ldind.u4") - IndexOffAddrOp_Addr -> simp_op (ilxOp "sizeof unsigned int mul add ldind.i") - IndexOffAddrOp_StablePtr -> simp_op (ilxOp "sizeof unsigned int mul add ldind.ref") + IndexOffAddrOp_Addr -> simp_op (ilxOp "sizeof native unsigned int mul add ldind.i") + IndexOffAddrOp_StablePtr -> simp_op (ilxOp "sizeof native unsigned int mul add ldind.ref") IndexOffAddrOp_Float -> simp_op (ilxOp "sizeof float32 mul add ldind.r4") IndexOffAddrOp_Double -> simp_op (ilxOp "sizeof float64 mul add ldind.r8") IndexOffAddrOp_Int8 -> simp_op (ilxOp "sizeof int8 mul add ldind.i1") @@ -1987,12 +2037,13 @@ ilxPrimOpTable op -- ForeignObj: load the address inside the object first -- TODO: is this remotely right? + EqForeignObj -> warn_op "eqForeignObj" (simp_op (ilxOp "pop /* PrimOp eqForeignObj */ ")) IndexOffForeignObjOp_Char -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof unsigned int8 mul add ldind.u1"]) IndexOffForeignObjOp_WideChar -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof int32 mul add ldind.u4"]) IndexOffForeignObjOp_Int -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof int32 mul add ldind.i4"]) IndexOffForeignObjOp_Word -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof unsigned int32 mul add ldind.u4"]) - IndexOffForeignObjOp_Addr -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof unsigned int mul add ldind.i "]) - IndexOffForeignObjOp_StablePtr -> ty1_arg2_op (\ty fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof unsigned int mul add ldind.ref "]) + IndexOffForeignObjOp_Addr -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof native unsigned int mul add ldind.i "]) + IndexOffForeignObjOp_StablePtr -> ty1_arg2_op (\ty fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof native unsigned int mul add ldind.ref "]) IndexOffForeignObjOp_Float -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof float32 mul add ldind.r4"]) IndexOffForeignObjOp_Double -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof float64 mul add ldind.r8"]) IndexOffForeignObjOp_Int8 -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof int8 mul add ldind.i1"]) @@ -2008,10 +2059,10 @@ ilxPrimOpTable op ReadOffAddrOp_WideChar -> simp_op (ilxOp "sizeof int32 mul add ldind.u4") ReadOffAddrOp_Int -> simp_op (ilxOp "sizeof int32 mul add ldind.i4") ReadOffAddrOp_Word -> simp_op (ilxOp "sizeof unsigned int32 mul add ldind.u4") - ReadOffAddrOp_Addr -> simp_op (ilxOp "sizeof unsigned int mul add ldind.i") + ReadOffAddrOp_Addr -> simp_op (ilxOp "sizeof native unsigned int mul add ldind.i") ReadOffAddrOp_Float -> simp_op (ilxOp "sizeof float32 mul add ldind.r4") ReadOffAddrOp_Double -> simp_op (ilxOp "sizeof float64 mul add ldind.r8") - ReadOffAddrOp_StablePtr -> simp_op (ilxOp "sizeof unsigned int mul add ldind.ref") + ReadOffAddrOp_StablePtr -> simp_op (ilxOp "sizeof native unsigned int mul add ldind.ref") ReadOffAddrOp_Int8 -> simp_op (ilxOp "sizeof int8 mul add ldind.i1") ReadOffAddrOp_Int16 -> simp_op (ilxOp "sizeof int16 mul add ldind.i2") ReadOffAddrOp_Int32 -> simp_op (ilxOp "sizeof int32 mul add ldind.i4") @@ -2026,10 +2077,10 @@ ilxPrimOpTable op WriteOffAddrOp_WideChar -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr, n, ilxOp "sizeof int32 mul add", v, ilxOp "stind.u4"]) WriteOffAddrOp_Int -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr, n, ilxOp "sizeof int32 mul add", v, ilxOp "stind.i4"]) WriteOffAddrOp_Word -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr, n, ilxOp "sizeof int32 mul add", v, ilxOp "stind.u4"]) - WriteOffAddrOp_Addr -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr, n, ilxOp "sizeof unsigned int mul add", v, ilxOp "stind.i"]) - WriteOffAddrOp_ForeignObj -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr, n, ilxOp "sizeof unsigned int mul add", v, ilxOp "stind.ref"]) + WriteOffAddrOp_Addr -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr, n, ilxOp "sizeof native unsigned int mul add", v, ilxOp "stind.i"]) + WriteOffAddrOp_ForeignObj -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr, n, ilxOp "sizeof native unsigned int mul add", v, ilxOp "stind.ref"]) WriteOffAddrOp_Float -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr, n, ilxOp "sizeof float32 mul add", v,ilxOp "stind.r4"]) - WriteOffAddrOp_StablePtr -> ty2_arg4_op (\ty1 sty addr n v s -> ilxOpSeq [addr, n, ilxOp "sizeof unsigned int mul add", v, ilxOp "stind.ref"]) + WriteOffAddrOp_StablePtr -> ty2_arg4_op (\ty1 sty addr n v s -> ilxOpSeq [addr, n, ilxOp "sizeof native unsigned int mul add", v, ilxOp "stind.ref"]) WriteOffAddrOp_Double -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof float64 mul add",v,ilxOp "stind.r8"]) WriteOffAddrOp_Int8 -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof int8 mul add",v,ilxOp "stind.i1"]) WriteOffAddrOp_Int16 -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof int16 mul add",v,ilxOp "stind.i2"]) @@ -2042,6 +2093,7 @@ ilxPrimOpTable op {- Addr# -> Int# -> Char# -> State# s -> State# s -} {- should be monadic??? -} + NewPinnedByteArrayOp_Char -> warn_op "newPinnedByteArray" (simp_op (ilxOp "newarr [mscorlib]System.Byte ")) NewByteArrayOp_Char -> simp_op (ilxOp "newarr [mscorlib]System.Byte") -- NewByteArrayOp_Int -> simp_op (ilxOp "newarr [mscorlib]System.Int32") -- NewByteArrayOp_Word -> simp_op (ilxOp "newarr [mscorlib]System.UInt32") @@ -2052,6 +2104,7 @@ ilxPrimOpTable op -- NewByteArrayOp_Int64 -> simp_op (ilxOp "newarr [mscorlib]System.Int64") TODO: there is no unique for this one -} -- NewByteArrayOp_Word64 -> simp_op (ilxOp "newarr [mscorlib]System.UInt64") -} {- Int# -> State# s -> (# State# s, MutByteArr# s #) -} + ByteArrayContents_Char -> warn_op "byteArrayContents" (simp_op ilxAddrOfByteArrOp) UnsafeFreezeByteArrayOp -> ty1_op (\ty1 -> ilxOp "nop ") {- MutByteArr# s -> State# s -> (# State# s, ByteArr# #) -} @@ -2072,7 +2125,7 @@ ilxPrimOpTable op WriteMutVarOp -> ty2_op (\ty1 ty2 -> ilxOpSeq [ilxOp "stfld !0" , repMutVar ty1 ty2 , ilxOp "::contents"]) {- MutVar# s a -> a -> State# s -> State# s -} - NewArrayOp -> ty2_op (\ty1 ty2 -> ilxCallSuppMeth (ilxType "!!0[]") "newArray" [ty1] [repInt,ilxMethA]) + NewArrayOp -> ty2_op (\ty1 ty2 -> ilxCallSuppMeth (ilxType "!!0[]") "newArray" [ty1] [repInt,ilxMethTyVarA]) {- Int# -> a -> State# s -> (# State# s, MutArr# s a #) -} IndexArrayOp -> ty1_op (\ty1 -> ilxOp "ldelem.ref") {- Array# a -> Int# -> (# a #) -} @@ -2091,7 +2144,8 @@ ilxPrimOpTable op RaiseOp -> ty2_op (\ty1 ty2 -> ilxOp "throw") CatchOp -> ty2_op (\ty1 ty2 -> - ilxCallSuppMeth ilxMethA "'catch'" [ty1,ty2] [ilxOp "thunk<(func ( /* unit skipped */ ) --> !!0)>", ilxOp "thunk<(func (!!1) --> (func ( /* unit skipped */ ) --> !!0))>"]) + ilxCallSuppMeth ilxMethTyVarA "'catch'" [ty1,ty2] [ilxLift (ilxTyIO (ilxType "!!0")), + ilxOp "thunk<(func (!!1) --> (func ( /* unit skipped */ ) --> !!0))>"]) {- (State# RealWorld -> (# State# RealWorld, a #) ) -> (b -> State# RealWorld -> (# State# RealWorld, a #) ) -> State# RealWorld @@ -2099,14 +2153,14 @@ ilxPrimOpTable op -} BlockAsyncExceptionsOp -> ty1_op (\ty1 -> - ilxCallSuppMeth ilxMethA "blockAsyncExceptions" [ty1] [ilxOp "thunk<(func ( /* unit skipped */ ) --> !!0)>"]) + ilxCallSuppMeth ilxMethTyVarA "blockAsyncExceptions" [ty1] [ilxLift (ilxTyIO (ilxType "!!0"))]) {- (State# RealWorld -> (# State# RealWorld, a #)) -> (State# RealWorld -> (# State# RealWorld, a #)) -} UnblockAsyncExceptionsOp -> ty1_op (\ty1 -> - ilxCallSuppMeth ilxMethA "unblockAsyncExceptions" [ty1] [ilxOp "thunk<(func ( /* unit skipped */ ) --> !!0)>"]) + ilxCallSuppMeth ilxMethTyVarA "unblockAsyncExceptions" [ty1] [ilxLift (ilxTyIO (ilxType "!!0"))]) {- State# RealWorld -> (# State# RealWorld, a #)) @@ -2118,42 +2172,42 @@ ilxPrimOpTable op {- State# s -> (# State# s, MVar# s a #) -} TakeMVarOp -> ty2_op (\sty ty -> - ilxCallSuppMeth ilxMethA "takeMVar" [ty] [repMVar ilxMethA]) + ilxCallSuppMeth ilxMethTyVarA "takeMVar" [ty] [repMVar ilxMethTyVarA]) {- MVar# s a -> State# s -> (# State# s, a #) -} -- These aren't yet right TryTakeMVarOp -> ty2_op (\sty ty -> - ilxCallSuppMeth (ilxUnboxedPairRep repInt ilxMethA) "tryTakeMVar" [ty] [repMVar ilxMethA]) + ilxCallSuppMeth (ilxUnboxedPairRep repInt ilxMethTyVarA) "tryTakeMVar" [ty] [repMVar ilxMethTyVarA]) {- MVar# s a -> State# s -> (# State# s, a #) -} TryPutMVarOp -> ty2_op (\sty ty -> - ilxCallSuppMeth repInt "tryPutMVar" [ty] [repMVar ilxMethA,ilxMethA]) + ilxCallSuppMeth repInt "tryPutMVar" [ty] [repMVar ilxMethTyVarA,ilxMethTyVarA]) {- MVar# s a -> State# s -> (# State# s, a #) -} PutMVarOp -> ty2_op (\sty ty -> - ilxCallSuppMeth (ilxOp "void") "putMVar" [ty] [repMVar ilxMethA, ilxMethA]) + ilxCallSuppMeth (ilxOp "void") "putMVar" [ty] [repMVar ilxMethTyVarA, ilxMethTyVarA]) {- MVar# s a -> a -> State# s -> State# s -} SameMVarOp -> ty2_op (\sty ty -> ilxCeq) {- MVar# s a -> MVar# s a -> Bool -} -- TakeMaybeMVarOp -> ty2_op (\sty ty -> --- (ilxCallSuppMeth (ilxUnboxedPairRep repInt ilxMethA) "tryTakeMVar" [ty] [repMVar ilxMethA])) +-- (ilxCallSuppMeth (ilxUnboxedPairRep repInt ilxMethTyVarA) "tryTakeMVar" [ty] [repMVar ilxMethTyVarA])) -- {- MVar# s a -> State# s -> (# State# s, Int#, a #) -} IsEmptyMVarOp -> ty2_op (\sty ty -> - ilxCallSuppMeth repInt "isEmptyMVar" [ty] [repMVar ilxMethA]) + ilxCallSuppMeth repInt "isEmptyMVar" [ty] [repMVar ilxMethTyVarA]) {- MVar# s a -> State# s -> (# State# s, Int# #) -} TouchOp -> warn_op "touch" (ty1_op (\ty1 -> ilxOp "pop /* PrimOp touch */ ")) {- a -> Int# -} DataToTagOp -> ty1_op (\ty1 -> - ilxCallSuppMeth repInt "dataToTag" [ty1] [ilxMethA]) + ilxCallSuppMeth repInt "dataToTag" [ty1] [ilxMethTyVarA]) {- a -> Int# -} TagToEnumOp -> ty1_op (\ty1 -> - ilxCallSuppMeth ilxMethA "tagToEnum" [ty1] [repInt]) + ilxCallSuppMeth ilxMethTyVarA "tagToEnum" [ty1] [repInt]) {- Int# -> a -} MakeStablePtrOp -> ty1_op (\ty1 -> ilxOpSeq [ilxOp "box", ty1, ilxOp "newobj void", repStablePtr {- ty1 -}, ilxOp "::.ctor(class [mscorlib]System.Object)"]) @@ -2172,11 +2226,12 @@ ilxPrimOpTable op EqStablePtrOp -> ty1_op (\ty1 -> ilxOp "ceq") {- StablePtr# a -> StablePtr# a -> Int# -} - MkWeakOp -> ty3_op (\ty1 ty2 ty3 -> ilxCall (ilxMethodRef (repWeak ilxMethB) classWeak "bake" [ilxLift ty1,ilxLift ty2,ty3] [ilxMethA, ilxMethB, ilxLift (ilxOp "!!2")])) + -- The 3rd argument to MkWeakOp is always a IO Monad action, i.e. passed as () --> () + MkWeakOp -> ty3_op (\ty1 ty2 ty3 -> ilxCall (ilxMethodRef (repWeak ilxMethTyVarB) classWeak "bake" [ilxLift ty1,ilxLift ty2] [ilxMethTyVarA, ilxMethTyVarB, ilxLift (ilxTyIO ilxUnboxedEmptyRep)])) {- o -> b -> c -> State# RealWorld -> (# State# RealWorld, Weak# b #) -} - DeRefWeakOp -> ty1_op (\ty1 -> ilxCall (ilxMethodRef (ilxUnboxedPairRep repInt ilxMethA) classWeak "deref" [ty1] [repWeak ilxMethA])) - FinalizeWeakOp -> ty1_op (\ty1 -> ilxCall (ilxMethodRef (ilxUnboxedPairRep repInt (ilxOp "thunk<(func ( /* unit skipped */ ) --> class '()')>")) classWeak "finalizer" [ty1] [repWeak ilxMethA])) + DeRefWeakOp -> ty1_op (\ty1 -> ilxCall (ilxMethodRef (ilxUnboxedPairRep repInt ilxMethTyVarA) classWeak "deref" [ty1] [repWeak ilxMethTyVarA])) + FinalizeWeakOp -> ty1_op (\ty1 -> ilxCall (ilxMethodRef (ilxUnboxedPairRep repInt (ilxTyIO ilxUnboxedEmptyRep)) classWeak "finalizer" [ty1] [repWeak ilxMethTyVarA])) {- Weak# a -> State# RealWorld -> (# State# RealWorld, Int#, State# RealWorld -> (# State# RealWorld, Unit #)) #) -} @@ -2186,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")) @@ -2204,11 +2264,12 @@ 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")) -- ("newBCO#") [alphaTyVar, deltaTyVar] [byteArrayPrimTy, byteArrayPrimTy, mkArrayPrimTy alphaTy, byteArrayPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed 2 [mkStatePrimTy deltaTy, bcoPrimTy])) + _ -> pprPanic "Unimplemented primop" (ppr op) ty1_op :: (IlxTyFrag -> IlxOpFrag) -> [StgArg] -> IlxOpFrag @@ -2279,14 +2340,16 @@ warn_op warning f args = trace ("WARNING! IlxGen cannot translate primop " ++ w -- We also do some type-directed translation for pinning Haskell-managed blobs -- of data as we throw them across the boundary. ilxFCall env (CCall (CCallSpec (StaticTarget c) cconv gc)) args ret_ty - = ilxComment (text "C call <+> pprCLabelString c") <+> + = ilxComment ((text "C call") <+> pprCLabelString c) <+> vcat [vcat (ilxMapPlaceArgs 0 pushCArg env args), - text "call" <+> retdoc <+> pprCLabelString c <+> pprTypeArgs ilxTypeR env ty_args + text "call" <+> retdoc <+> pprCLabelString c <+> tyarg_doc <+> pprCValArgTys ilxTypeL env (map deepIlxRepType (filter (not. isVoidIlxRepType) (map stgArgType tm_args))) ] where - retdoc | isVoidIlxRepType ret_ty = text "void" + retdoc | isVoidIlxRepType ret_ty = text "void" | otherwise = ilxTypeR env (deepIlxRepType ret_ty) - (ty_args,tm_args) = splitTyArgs1 args + (ty_args,tm_args) = splitTyArgs1 args + tyarg_doc | not (isEmptyVarSet (tyVarsOfTypes ty_args)) = text "/* type variable found */" + | otherwise = pprTypeArgs ilxTypeR env ty_args ilxFCall env (DNCall (DNCallSpec call_instr)) args ret_ty = ilxComment (text "IL call") <+>