X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FilxGen%2FIlxGen.lhs;h=19e9f76ecf38a17857774440266774152faf5985;hb=43c2b68138397eb08aa386e2818b6cc17e94fd1e;hp=babd35c9303a271be6bac2ced166a050855bc0e3;hpb=6ae5ca0c2ab4281e03978a4a74cb9441793a1e9c;p=ghc-hetmet.git diff --git a/ghc/compiler/ilxGen/IlxGen.lhs b/ghc/compiler/ilxGen/IlxGen.lhs index babd35c..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,47 +8,51 @@ 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, - newTyConRep, tyConTyVars, isDataTyCon, isAlgTyCon, tyConArity + tyConTyVars, isDataTyCon, isAlgTyCon, tyConArity ) -import Class ( Class ) import Type ( liftedTypeKind, openTypeKind, unliftedTypeKind, - isUnLiftedType, isTyVarTy, mkTyVarTy, predRepTy, - splitForAllTys, splitFunTys, applyTy, applyTys + 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(..), CCallTarget(..),CCall(..) ) +import PrimOp ( PrimOp(..) ) +import ForeignCall ( CCallConv(..), ForeignCall(..), CCallSpec(..), CCallTarget(..), DNCallSpec(..) ) import TysWiredIn ( mkTupleTy, tupleCon ) import PrimRep ( PrimRep(..) ) -import Name ( nameModule, nameOccName, isGlobalName, isLocalName, isDllName, 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, - isHomeModule, pprModuleName, mkHomeModule, mkModuleName +import Module ( Module, PackageName, ModuleName, moduleName, + modulePackage, basePackage, + isHomeModule, isVanillaModule, + pprModuleName, mkHomeModule, mkModuleName ) import UniqFM import BasicTypes ( Boxity(..) ) -import CStrings ( pprCLabelString ) +import CStrings ( CLabelString, pprCLabelString ) import Outputable import Char ( ord ) import List ( partition, elem, insertBy,any ) import UniqSet -import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon ) +import TysPrim ( foreignObjPrimTyCon, weakPrimTyCon, byteArrayPrimTyCon, mutableByteArrayPrimTyCon ) -- opt_SimplDoEtaReduction is used to help with assembly naming conventions for different -- 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_Static, opt_InPackage, opt_SimplDoEtaReduction ) +import DynFlags ( opt_InPackage, opt_SimplDoEtaReduction ) + +import Util ( lengthIs, equalLength ) \end{code} @@ -64,19 +68,22 @@ import CmdLineOpts ( opt_Static, 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 [vcat (map (ilxImportPackage topenv) (uniqSetToList import_packages)), + = 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)), + vcat (map (ilxImportCCall topenv) (map snd (ufmToList import_ccalls))), vcat (map (ilxTyCon topenv) data_tycons), vcat (map (ilxBindClosures topenv) binds), ilxTopBind mod topenv toppairs ] where binds = map fst binds_w_srts - (import_packages,import_modules,import_tycons) = importsBinds binds `unionImpInfo` importsPrelude toppairs = ilxPairs binds topenv = extendIlxEnvWithTops (emptyIlxEnv False mod) mod toppairs -- Generate info from class decls as well + (import_packages,import_modules,import_tycons,import_ccalls) = importsBinds topenv binds (importsPrelude emptyImpInfo) data_tycons = filter isDataTyCon tycons \end{code} @@ -88,112 +95,158 @@ ilxGen mod tycons binds_w_srts \begin{code} -importsBinds :: [StgBinding] -> ImportsInfo -importsBinds binds = unionImpInfos (map importsBind binds) +importsBinds :: IlxEnv -> [StgBinding] -> ImportsInfo -> ImportsInfo +importsBinds env binds = foldR (importsBind env) binds + +importsNone :: ImportsInfo -> ImportsInfo +importsNone sofar = sofar + +importsBind :: IlxEnv -> StgBinding -> ImportsInfo -> ImportsInfo +importsBind env (StgNonRec _ b rhs) = importsRhs env rhs.importsVar env b +importsBind env (StgRec _ pairs) = foldR (\(b,rhs) -> importsRhs env rhs . importsVar env b) pairs -importsBind :: StgBinding -> ImportsInfo -importsBind (StgNonRec _ b rhs) = importsRhs rhs `unionImpInfo` importsVar b -importsBind (StgRec _ pairs) = unionImpInfos (map (\(b,rhs) -> importsRhs rhs `unionImpInfo` importsVar b) pairs) +importsRhs :: IlxEnv -> StgRhs -> ImportsInfo -> ImportsInfo +importsRhs env (StgRhsCon _ con args) = importsDataCon env con . importsStgArgs env args +importsRhs env (StgRhsClosure _ _ _ _ args body) = importsExpr env body. importsVars env args + +importsExpr :: IlxEnv -> StgExpr -> ImportsInfo -> ImportsInfo +importsExpr env (StgLit _) = importsNone +importsExpr env (StgApp f args) = importsVar env f.importsStgArgs env args +importsExpr env (StgConApp con args) = importsDataCon env con.importsStgArgs env args +importsExpr env (StgOpApp (StgFCallOp (CCall (CCallSpec (StaticTarget c) cc _)) _) args rty) + = addCCallInfo (c,cc, map stgArgType tm_args, rty) . importsStgArgs env args + where + (ty_args,tm_args) = splitTyArgs1 args -importsRhs (StgRhsCon _ con args) = importsDataCon con `unionImpInfo` importsStgArgs args -importsRhs (StgRhsClosure _ _ _ upd args body) = importsExpr body `unionImpInfo` importsVars args +importsExpr env (StgOpApp _ args res_ty) = importsType env res_ty. importsStgArgs env args -importsExpr :: StgExpr -> ImportsInfo -importsExpr (StgLit l) = emptyImpInfo -importsExpr (StgApp f args) = importsVar f `unionImpInfo` importsStgArgs args -importsExpr (StgConApp con args) = importsDataCon con `unionImpInfo` importsStgArgs args -importsExpr (StgPrimApp op args res_ty) = importsType res_ty `unionImpInfo` importsStgArgs args -importsExpr (StgSCC cc expr) = importsExpr expr -importsExpr (StgCase scrut _ _ bndr srt alts) - = importsExpr scrut `unionImpInfo` imports_alts alts `unionImpInfo` importsVar bndr + +importsExpr env (StgSCC _ expr) = importsExpr env expr +importsExpr env (StgCase scrut _ _ bndr _ alts) + = importsExpr env scrut. imports_alts alts. importsVar env bndr where - imports_alts (StgAlgAlts _ alts deflt) -- The Maybe TyCon part is dealt with + imports_alts (StgAlgAlts _ alg_alts deflt) -- The Maybe TyCon part is dealt with -- by the case-binder's type - = unionImpInfos (map imports_alg_alt alts) `unionImpInfo` imports_deflt deflt + = foldR imports_alg_alt alg_alts . imports_deflt deflt where imports_alg_alt (con, bndrs, _, rhs) - = importsExpr rhs `unionImpInfo` importsDataCon con `unionImpInfo` importsVars bndrs + = importsExpr env rhs . importsDataCon env con. importsVars env bndrs - imports_alts (StgPrimAlts _ alts deflt) - = unionImpInfos (map imports_prim_alt alts) `unionImpInfo` imports_deflt deflt + imports_alts (StgPrimAlts _ alg_alts deflt) + = foldR imports_prim_alt alg_alts . imports_deflt deflt where - imports_prim_alt (lit, rhs) = importsExpr rhs - imports_deflt StgNoDefault = emptyImpInfo - imports_deflt (StgBindDefault rhs) = importsExpr rhs + imports_prim_alt (_, rhs) = importsExpr env rhs + imports_deflt StgNoDefault = importsNone + imports_deflt (StgBindDefault rhs) = importsExpr env rhs -importsExpr (StgLetNoEscape _ _ bind body) = importsExpr (StgLet bind body) -importsExpr (StgLet bind body) - = importsBind bind `unionImpInfo` importsExpr body -importsApp v args = importsVar v `unionImpInfo` importsStgArgs args -importsStgArgs args = unionImpInfos (map importsStgArg args) +importsExpr env (StgLetNoEscape _ _ bind body) = importsExpr env (StgLet bind body) +importsExpr env (StgLet bind body) + = importsBind env bind . importsExpr env body -importsStgArg :: StgArg -> ImportsInfo -importsStgArg (StgTypeArg ty) = importsType ty -importsStgArg (StgVarArg v) = importsVar v -importsStgArg _ = emptyImpInfo +importsApp env v args = importsVar env v. importsStgArgs env args +importsStgArgs env args = foldR (importsStgArg env) args -importsVars vs = unionImpInfos (map importsVar vs) -importsVar v = importsName (idName v) `unionImpInfo` importsType (idType v) +importsStgArg :: IlxEnv -> StgArg -> ImportsInfo -> ImportsInfo +importsStgArg env (StgTypeArg ty) = importsType env ty +importsStgArg env (StgVarArg v) = importsVar env v +importsStgArg env _ = importsNone -importsName n - | isLocalName n = emptyImpInfo - | thisModule == nameModule n = emptyImpInfo - | isDllName n = singlePackageImpInfo (modulePackage (nameModule n)) - | otherwise = singleModuleImpInfo (moduleName (nameModule n)) +importsVars env vs = foldR (importsVar env) vs +importsVar env v = importsName env (idName v). importsType env (idType v) -importsModule m - | thisModule == m = emptyImpInfo - | isHomeModule m = singleModuleImpInfo (moduleName m) - | otherwise = singlePackageImpInfo (modulePackage m) +importsName env n + | isInternalName n = importsNone + | ilxEnvModule env == nameModule n = importsNone + | isHomeModule (nameModule n) = addModuleImpInfo (moduleName (nameModule n)) +-- See HACK below + | isVanillaModule (nameModule n) && not inPrelude = importsPrelude + | isVanillaModule (nameModule n) && inPrelude = addModuleImpInfo (moduleName (nameModule n)) +-- End HACK + | otherwise = addPackageImpInfo (modulePackage (nameModule n)) -importsType :: Type -> ImportsInfo -importsType ty = importsType2 (deepIlxRepType ty) -importsType2 :: Type -> ImportsInfo -importsType2 (AppTy f x) = importsType2 f `unionImpInfo` importsType2 x -importsType2 (TyVarTy _) = emptyImpInfo -importsType2 (TyConApp tc args) =importsTyCon tc `unionImpInfo` importsTypeArgs2 args -importsType2 (FunTy arg res) = importsType arg `unionImpInfo` importsType2 res -importsType2 (ForAllTy tv body_ty) = importsType2 body_ty -importsType2 (NoteTy _ ty) = importsType2 ty -importsTypeArgs2 tys =unionImpInfos (map importsType2 tys) +importsPrelude | inPrelude = addModuleImpInfo (mkModuleName "PrelGHC") + | otherwise = addPackageImpInfo basePackage -importsDataCon dcon = importsTyCon (dataConTyCon dcon) -importsMaybeTyCon Nothing = emptyImpInfo -importsMaybeTyCon (Just tc) = importsName (getName tc) +importsType :: IlxEnv -> Type -> ImportsInfo -> ImportsInfo +importsType env ty = importsType2 env (deepIlxRepType ty) -importsTyCon tc | (not (isDataTyCon tc) || - isLocalName (getName tc) || - thisModule == nameModule (getName tc)) = emptyImpInfo -importsTyCon tc | otherwise = importsName (getName tc) `unionImpInfo` (emptyUniqSet, emptyUniqSet,unitUniqSet tc) +importsType2 :: IlxEnv -> Type -> ImportsInfo -> ImportsInfo +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 +importsType2 env (ForAllTy tv body_ty) = importsType2 env body_ty +importsType2 env (NoteTy _ ty) = importsType2 env ty +importsType2 _ _ = panic "IlxGen.lhs: importsType2 ty" +importsTypeArgs2 env tys = foldR (importsType2 env) tys -importsPrelude | preludePackage == opt_InPackage = singleModuleImpInfo (mkModuleName "PrelGHC") - | otherwise = singlePackageImpInfo preludePackage +importsDataCon env dcon = importsTyCon env (dataConTyCon dcon) -type ImportsInfo = (UniqSet PackageName, UniqSet ModuleName, UniqSet TyCon) -- (Packages, Modules, Datatypes) +importsTyCon env tc | (not (isDataTyCon 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) -emptyImpInfo :: ImportsInfo -emptyImpInfo = (emptyUniqSet, emptyUniqSet, emptyUniqSet) -singlePackageImpInfo p = (unitUniqSet p, emptyUniqSet, emptyUniqSet) -singleModuleImpInfo m = (emptyUniqSet, unitUniqSet m, emptyUniqSet) -unionImpInfo :: ImportsInfo -> ImportsInfo -> ImportsInfo -unionImpInfo (w1,x1,y1) (w2,x2,y2) = (unionUniqSets w1 w2, unionUniqSets x1 x2, unionUniqSets y1 y2) +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) -unionImpInfos :: [ImportsInfo] -> ImportsInfo -unionImpInfos fvs = foldr unionImpInfo emptyImpInfo fvs + +type StaticCCallInfo = (CLabelString,CCallConv,[Type],Type) +type ImportsInfo = (UniqSet PackageName, UniqSet ModuleName, UniqSet TyCon, UniqFM StaticCCallInfo) + -- (Packages, Modules, Datatypes, Imported CCalls) + +emptyImpInfo :: ImportsInfo +emptyImpInfo = (emptyUniqSet, emptyUniqSet, emptyUniqSet, emptyUFM) +addPackageImpInfo p (w,x,y,z) = (addOneToUniqSet w p, x, y,z) +addModuleImpInfo m (w,x,y,z) = (w, addOneToUniqSet x m, y,z) +addTyConImpInfo tc (w,x,y,z) = (w, x, addOneToUniqSet y tc,z) +addCCallInfo info@(nm,a,b,c) (w,x,y,z) = (w, x, y,addToUFM z nm info) ilxImportTyCon :: IlxEnv -> TyCon -> SDoc -ilxImportTyCon env tycon | isDataTyCon tycon = pprIlxTyConDef True env tycon -ilxImportTyCon env tycon | otherwise = empty +ilxImportTyCon env tycon | isDataTyCon tycon = ilxTyConDef True env tycon +ilxImportTyCon _ _ | otherwise = empty ilxImportPackage :: IlxEnv -> PackageName -> SDoc -ilxImportPackage env 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 env m = text ".module extern ilx" <+> singleQuotes (ppr m <> hscOptionQual) +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 +ilxImportCCall :: IlxEnv -> StaticCCallInfo -> SDoc +ilxImportCCall env (c,cc,args,ret) = + text ".method static assembly pinvokeimpl" <+> + parens (doubleQuotes (text "HSstd_cbits.dll") <+> text "cdecl") <+> retdoc <+> singleQuotes (pprCLabelString c) <+> + pprCValArgTys ilxTypeL env (map deepIlxRepType (filter (not. isVoidIlxRepType) args)) <+> + text "unmanaged preservesig { }" + where + retdoc = + if isVoidIlxRepType ret then text "void" + else ilxTypeR env (deepIlxRepType ret) \end{code} @@ -208,16 +261,17 @@ ilxImportModule env m = text ".module extern ilx" <+> singleQuotes (ppr m <> hs ilxTyCon :: IlxEnv -> TyCon -> SDoc -ilxTyCon env tycon = pprIlxTyConDef False env tycon +ilxTyCon env tycon = ilxTyConDef False env tycon -- filter to get only dataTyCons? -pprIlxTyConDef importing env tycon = +ilxTyConDef importing env tycon = vcat [empty $$ line, - text ".classunion" <+> (if importing then text "extern" else empty) <+> text "thunk" - <+> ((nameReference env (getName tycon)) <> (ppr tycon)) <+> tyvars_text <+> alts_text] + text ".classunion" <+> (if importing then text "import" else empty) <+> tycon_ref <+> tyvars_text <+> super_text <+> alts_text] where + tycon_ref = nameReference env (getName tycon) <> (ppr tycon) + super_text = if importing then empty else text "extends thunk" <> angleBrackets (text "class" <+> tycon_ref) tyvars = tyConTyVars tycon - (ilx_tvs, non_ilx_tvs) = categorizeTyVars tyvars + (ilx_tvs, _) = categorizeTyVars tyvars alts_env = extendIlxEnvWithFormalTyVars env ilx_tvs tyvars_text = pprTyVarBinders alts_env ilx_tvs alts = vcat (map (pprIlxDataCon alts_env) (tyConDataCons tycon)) @@ -225,7 +279,7 @@ pprIlxTyConDef importing env tycon = pprIlxDataCon env dcon = text ".alternative" <+> pprId dcon <+> - parens (pprSepWithCommas (pprIlxTypeL env) (map deepIlxRepType (filter (not. isVoidIlxRepType) (dataConRepArgTys dcon)))) + parens (pprSepWithCommas (ilxTypeL env) (map deepIlxRepType (filter (not. isVoidIlxRepType) (dataConRepArgTys dcon)))) \end{code} @@ -244,14 +298,14 @@ ilxBindClosures env (StgRec _ pairs) new_env = extendIlxEnvWithBinds env pairs --------------- -ilxRhsClosures env (bndr, StgRhsCon _ _ _) +ilxRhsClosures _ (_, StgRhsCon _ _ _) = empty ilxRhsClosures env (bndr, StgRhsClosure _ _ fvs upd args rhs) = vcat [ilxExprClosures next_env rhs, empty $$ line, - kind_text <+> squotes cloname <+> free_vs_text, + kind_text <+> singleQuotes cloname <+> free_vs_text, nest 2 (braces ( nest 2 (vcat [empty, vcat [text ".apply" <+> closure_sig_text, @@ -264,7 +318,7 @@ ilxRhsClosures env (bndr, StgRhsClosure _ _ fvs upd args rhs) where kind_of_thing = case upd of Updatable -> ASSERT( null args ) ".thunk" - other -> ".closure" + otherwise -> ".closure" kind_text = text kind_of_thing cloname = ilxEnvQualifyByModule env (ppr bndr) @@ -273,9 +327,10 @@ ilxRhsClosures env (bndr, StgRhsClosure _ _ fvs upd args rhs) closure_sig_text = - vcat [(case args of - [] -> empty - other -> args_text), + vcat [ text "()", + (case args of + [] -> empty + otherwise -> args_text), text "-->" <+> rty_text] (args_text,env_with_args) = pprArgBinders env_with_fvs args @@ -283,8 +338,10 @@ ilxRhsClosures env (bndr, StgRhsClosure _ _ fvs upd args rhs) -- Find the type returned, from the no. of args and the type of "bndr" rty_text = case retType env_with_fvs (idIlxRepType bndr) args of - Just (env,ty) -> pprIlxTypeR env ty - Nothing -> trace "WARNING! IlxGen.trace could not find return type - see generated ILX for context where this occurs." (text "// Could not find return type:" <+> pprIlxTypeR env_with_fvs (idIlxRepType bndr)<+> text ", non representation: " <+> pprIlxTypeR env_with_fvs (idType bndr)) + Just (env,ty) -> + if isVoidIlxRepType ty then (text "void") + else ilxTypeR env ty + Nothing -> trace "WARNING! IlxGen.trace could not find return type - see generated ILX for context where this occurs." (text "// Could not find return type:" <+> ilxTypeR env_with_fvs (idIlxRepType bndr)<+> text ", non representation: " <+> ilxTypeR env_with_fvs (idType bndr)) -- strip off leading ForAll and Fun type constructions -- up to the given number of arguments, extending the environment as @@ -316,23 +373,23 @@ pprIlxLocals env vs nonVoidLocal (LocalId v,_) = not (isVoidIlxRepId v) nonVoidLocal _ = True -pprIlxLocal env (LocalId v,_) = pprIlxTypeL env (idIlxRepType v) <+> pprId v -pprIlxLocal env (LocalSDoc (ty,doc,pin),_) = pprIlxTypeL env (deepIlxRepType ty) <+> (if pin then text "pinned" else empty) <+> doc +pprIlxLocal env (LocalId v,_) = ilxTypeL env (idIlxRepType v) <+> pprId v +pprIlxLocal env (LocalSDoc (ty,doc,pin),_) = ilxTypeL env (deepIlxRepType ty) <+> (if pin then text "pinned" else empty) <+> doc pprFreeBinders env fvs = (ilx_tvs_text <+> vs_text, env2) where - (free_ilx_tvs, free_non_ilx_tvs,free_vs) = categorizeVars fvs + (free_ilx_tvs, _,free_vs) = categorizeVars fvs real_free_vs = filter (not . isVoidIlxRepId) free_vs -- ignore the higher order type parameters for the moment env1 = extendIlxEnvWithFreeTyVars env free_ilx_tvs ilx_tvs_text = pprTyVarBinders env1 free_ilx_tvs vs_text = parens (pprSepWithCommas ppr_id real_free_vs) - ppr_id v = pprIlxTypeL env1 (idIlxRepType v) <+> pprId v + ppr_id v = ilxTypeL env1 (idIlxRepType v) <+> pprId v env2 = extendIlxEnvWithFreeVars env1 real_free_vs -pprIdBinder env v = parens (pprIlxTypeL env (idIlxRepType v) <+> pprId v) +pprIdBinder env v = parens (ilxTypeL env (idIlxRepType v) <+> pprId v) -- Declarations for the arguments of the main apply method pprArgBinders env [] = (empty,env) @@ -365,13 +422,13 @@ ilxExprLocals env (StgCase scrut _ _ bndr _ alts) = ilxExprLocals (ilxPlaceStgCaseScrut env) scrut ++ (if isDeadBinder bndr then [] else [(LocalId bndr,Nothing)]) ++ ilxAltsLocals env alts -ilxExprLocals env (StgPrimApp (CCallOp (CCall (StaticTarget c) casm gc cconv)) args ret_ty) +ilxExprLocals env (StgOpApp (StgFCallOp fcall _) args _) = concat (ilxMapPlaceArgs 0 ilxCCallArgLocals env args) ilxExprLocals _ _ = [] -- Generate locals to use for pinning arguments as we cross the boundary -- to C. -ilxCCallArgLocals env arg@(StgVarArg v) | pinCCallArg v = +ilxCCallArgLocals env (StgVarArg v) | pinCCallArg v = [(LocalSDoc (idType v, ilxEnvQualifyByExact env (ppr v) <> text "pin", True), Nothing)] ilxCCallArgLocals _ _ | otherwise = [] @@ -381,10 +438,10 @@ ilxBindLocals env (StgRec _ pairs) = map (\(x,y) -> (LocalId x,Just (env, y)) ilxAltsLocals env (StgAlgAlts _ alts deflt) = ilxDefltLocals env deflt ++ concat (ilxMapPlaceAlts ilxAlgAltLocals env alts) ilxAltsLocals env (StgPrimAlts _ alts deflt) = ilxDefltLocals env deflt ++ concat (ilxMapPlaceAlts ilxPrimAltLocals env alts) -ilxAlgAltLocals env (con, bndrs, _, rhs) = map (\x -> (LocalId x,Nothing)) (filter (\v -> isId v && not (isDeadBinder v)) bndrs) ++ ilxExprLocals env rhs -ilxPrimAltLocals env (lit, rhs) = ilxExprLocals env rhs +ilxAlgAltLocals env (_, bndrs, _, rhs) = map (\x -> (LocalId x,Nothing)) (filter (\v -> isId v && not (isDeadBinder v)) bndrs) ++ ilxExprLocals env rhs +ilxPrimAltLocals env (_, rhs) = ilxExprLocals env rhs -ilxDefltLocals env StgNoDefault = [] +ilxDefltLocals _ StgNoDefault = [] ilxDefltLocals env (StgBindDefault rhs) = ilxExprLocals (ilxPlaceStgBindDefault env) rhs -------------- @@ -393,7 +450,7 @@ ilxExprClosures env (StgApp _ args) = vcat (ilxMapPlaceArgs 0 (ilxArgClosures) env args) -- get strings ilxExprClosures env (StgConApp _ args) = vcat (ilxMapPlaceArgs 0 (ilxArgClosures) env args) -- get strings -ilxExprClosures env (StgPrimApp _ args _) +ilxExprClosures env (StgOpApp _ args _) = vcat (ilxMapPlaceArgs 0 (ilxArgClosures) env args) -- get strings ilxExprClosures env (StgLet bind body) = ilxBindClosures env bind $$ ilxExprClosures (extendIlxEnvWithBinds env (ilxPairs1 bind)) body @@ -403,7 +460,7 @@ ilxExprClosures env (StgCase scrut _ _ _ _ alts) = ilxExprClosures (ilxPlaceStgCaseScrut env) scrut $$ ilxAltsClosures env alts ilxExprClosures env (StgLit lit) = ilxGenLit env lit -ilxExprClosures env other +ilxExprClosures _ _ = empty ilxAltsClosures env (StgAlgAlts _ alts deflt) @@ -419,7 +476,7 @@ ilxAltsClosures env (StgPrimAlts _ alts deflt) ilxDefltClosures env deflt ilxDefltClosures env (StgBindDefault rhs) = ilxExprClosures (ilxPlaceStgBindDefault env) rhs -ilxDefltClosures env StgNoDefault = empty +ilxDefltClosures _ StgNoDefault = empty ilxArgClosures env (StgLitArg lit) = ilxGenLit env lit ilxArgClosures _ _ = empty @@ -427,7 +484,7 @@ ilxArgClosures _ _ = empty ilxGenLit env (MachStr fs) - = vcat [text ".field static assembly char " <+> squotes nm <+> text "at" <+> nm <> text "L", + = vcat [text ".field static assembly char " <+> singleQuotes nm <+> text "at" <+> nm <> text "L", text ".data" <+> nm <> text "L" <+> text "= char *(" <> pprFSInILStyle fs <> text ")" ] where @@ -463,28 +520,31 @@ ilxExpr :: IlxEEnv -> StgExpr -> Sequel -- What to do at the end -> SDoc -ilxExpr eenv@(IlxEEnv env _) (StgApp fun args) sequel +ilxExpr (IlxEEnv env _) (StgApp fun args) sequel = ilxFunApp env fun args (isReturn sequel) $$ ilxSequel sequel -- ilxExpr eenv (StgLit lit) sequel -ilxExpr eenv@(IlxEEnv env _) (StgLit lit) sequel +ilxExpr (IlxEEnv env _) (StgLit lit) sequel = pushLit env lit $$ ilxSequel sequel -- ilxExpr eenv (StgConApp data_con args) sequel -ilxExpr eenv@(IlxEEnv env _) (StgConApp data_con args) sequel +ilxExpr (IlxEEnv env _) (StgConApp data_con args) sequel = text " /* ilxExpr:StgConApp */ " <+> ilxConApp env data_con args $$ ilxSequel sequel -- ilxExpr eenv (StgPrimApp primop args _) sequel -ilxExpr eenv@(IlxEEnv env _) (StgPrimApp primop args ret_ty) sequel - = ilxPrimApp env primop args ret_ty $$ ilxSequel sequel +ilxExpr (IlxEEnv env _) (StgOpApp (StgFCallOp fcall _) args ret_ty) sequel + = ilxFCall env fcall args ret_ty $$ ilxSequel sequel + +ilxExpr (IlxEEnv env _) (StgOpApp (StgPrimOp primop) args ret_ty) sequel + = ilxPrimOpTable primop args env $$ ilxSequel sequel --BEGIN TEMPORARY -- The following are versions of a peephole optimizations for "let t = \[] t2[fvs] in t" -- I think would be subsumed by a general treatmenet of let-no-rec bindings?? -ilxExpr eenv@(IlxEEnv env _) (StgLet (StgNonRec _ bndr (StgRhsClosure _ _ fvs upd [] rhs)) (StgApp fun [])) sequel +ilxExpr eenv@(IlxEEnv env _) (StgLet (StgNonRec _ bndr (StgRhsClosure _ _ _ _ [] rhs)) (StgApp fun [])) sequel | (bndr == fun && null (ilxExprLocals env rhs)) -- TO DO??? = ilxExpr eenv rhs sequel -ilxExpr eenv@(IlxEEnv env _) (StgLetNoEscape _ _ (StgNonRec _ bndr (StgRhsClosure _ _ fvs upd [] rhs)) (StgApp fun [])) sequel +ilxExpr eenv@(IlxEEnv env _) (StgLetNoEscape _ _ (StgNonRec _ bndr (StgRhsClosure _ _ _ _ [] rhs)) (StgApp fun [])) sequel | (bndr == fun && null (ilxExprLocals env rhs)) -- TO DO??? = ilxExpr eenv rhs sequel --END TEMPORARY @@ -497,35 +557,39 @@ ilxExpr eenv (StgLetNoEscape _ _ bind body) sequel -- TO DO??? = ilxBind eenv bind $$ ilxExpr eenv body sequel -- StgCase: Special case 1 to avoid spurious branch. -ilxExpr eenv@(IlxEEnv env live) (StgCase (StgApp fun args) live_in_case live_in_alts bndr _ alts) sequel +ilxExpr eenv@(IlxEEnv env live) (StgCase (StgApp fun args) live_in_case _live_in_alts bndr _ alts) sequel = vcat [ilxWipe env (uniqSetToList (live `minusUniqSet` live_in_case)), ilxFunApp (ilxPlaceStgCaseScrut env) fun args False, - --ilxWipe env (uniqSetToList (live_in_case `minusUniqSet` live_in_alts)), - --ilxAlts (IlxEEnv env live_in_alts) bndr alts sequel + --ilxWipe env (uniqSetToList (live_in_case `minusUniqSet` _live_in_alts)), + --ilxAlts (IlxEEnv env _live_in_alts) bndr alts sequel ilxAlts (IlxEEnv env live_in_case) bndr alts sequel ] -- StgCase: Special case 2 to avoid spurious branch. -ilxExpr eenv@(IlxEEnv env live) (StgCase (StgPrimApp primop args ret_ty) live_in_case live_in_alts bndr _ alts) sequel +ilxExpr eenv@(IlxEEnv env live) (StgCase (StgOpApp (StgPrimOp primop) args ret_ty) live_in_case _live_in_alts bndr _ alts) sequel = vcat [ilxWipe env (uniqSetToList (live `minusUniqSet` live_in_case)), - ilxPrimApp (ilxPlaceStgCaseScrut env) primop args ret_ty, - --ilxWipe env (uniqSetToList (live_in_case `minusUniqSet` live_in_alts)), - --ilxAlts (IlxEEnv env live_in_alts) bndr alts sequel + ilxPrimOpTable primop args (ilxPlaceStgCaseScrut env), + --ilxWipe env (uniqSetToList (live_in_case `minusUniqSet` _live_in_alts)), + --ilxAlts (IlxEEnv env _live_in_alts) bndr alts sequel ilxAlts (IlxEEnv env live_in_case) bndr alts sequel ] -- StgCase: Normal case. -ilxExpr eenv@(IlxEEnv env live) (StgCase scrut live_in_case live_in_alts bndr _ alts) sequel +ilxExpr eenv@(IlxEEnv env live) (StgCase scrut live_in_case _live_in_alts bndr _ alts) sequel = vcat [ilxWipe env (uniqSetToList (live `minusUniqSet` live_in_case)), ilxExpr (IlxEEnv (ilxPlaceStgCaseScrut env) live_in_case) scrut (Jump join_lbl), ilxLabel join_lbl, - --ilxWipe env (uniqSetToList (live_in_case `minusUniqSet` live_in_alts)), - --ilxAlts (IlxEEnv env live_in_alts) bndr alts sequel + --ilxWipe env (uniqSetToList (live_in_case `minusUniqSet` _live_in_alts)), + --ilxAlts (IlxEEnv env _live_in_alts) bndr alts sequel ilxAlts (IlxEEnv env live_in_case) bndr alts sequel ] where join_lbl = mkJoinLabel bndr +ilxExpr _ _ _ + = panic "ilxExpr: Patterns not matched:(IlxEEnv _ _) (StgSCC _ _) _ (IlxEEnv _ _) (StgLam _ _ _) _" + + -- Wipe out locals and arguments that are no longer in use, to -- prevent space leaks. If the VM is implemented 100% correctly then -- this should probably not be needed, as the live variable analysis @@ -549,8 +613,8 @@ ilxWipe env ids ilxWipeOne env id = case lookupIlxVarEnv env id of - Just Local -> text "ldloca " <+> pprId id <+> text "initobj" <+> (pprIlxTypeL env (idIlxRepType id)) - Just Arg -> text "deadarg " <+> pprId id <+> text "," <+> (pprIlxTypeL 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 ) where @@ -559,7 +623,7 @@ ilxWipeOne env id ---------------------- ilxAlts :: IlxEEnv -> Id -> StgCaseAlts -> Sequel -> SDoc -ilxAlts eenv@(IlxEEnv env live) bndr alts sequel +ilxAlts (IlxEEnv env live) bndr alts sequel -- At the join label, the result is on top -- of the stack = vcat [store_in_bndr, @@ -607,13 +671,13 @@ ilxAlts eenv@(IlxEEnv env live) bndr alts sequel do_alg_alts [(i, alt@(data_con,bndrs,used_flags, rhs))] StgNoDefault - = vcat [text "castdata" <+> sep [pprIlxTypeR env scrut_rep_ty <> comma, + = vcat [text "castdata" <+> sep [ilxTypeR env scrut_rep_ty <> comma, ilxConRef env data_con], do_alg_alt (IlxEEnv (ilxPlaceAlt env i) live) alt ] do_alg_alts alts deflt - = vcat [text "datacase" <+> sep [pprIlxTypeR env scrut_rep_ty,text ",", + = vcat [text "datacase" <+> sep [ilxTypeR env scrut_rep_ty,text ",", pprSepWithCommas pp_case labels_w_alts], do_deflt deflt, vcat (map do_labelled_alg_alt labels_w_alts) @@ -669,9 +733,9 @@ ilxAlts eenv@(IlxEEnv env live) bndr alts sequel ld_data alt_env data_con reduced_fld_no bndr | isUnboxedTupleCon data_con = text "ldfld" <+> sep [text "!" <> integer reduced_fld_no, - pprIlxTypeR alt_env scrut_rep_ty <> text "::fld" <> integer reduced_fld_no] + ilxTypeR alt_env scrut_rep_ty <> text "::fld" <> integer reduced_fld_no] | otherwise - = text "lddata" <+> sep [pprIlxTypeR alt_env scrut_rep_ty <> comma, + = text "lddata" <+> sep [ilxTypeR alt_env scrut_rep_ty <> comma, ilxConRef env data_con <> comma, integer reduced_fld_no] @@ -693,30 +757,62 @@ ilxFunApp env fun args tail_call -- ldloc x arg of type Int -- .tail callfunc (!0) --> !0 -- - vcat [pushId env fun,ilxFunAppArgs env 0 (idIlxRepType fun) args tail_call known_clo] + vcat [pushId env fun,ilxFunAppAfterPush env fun args tail_call] + +ilxFunAppAfterPush env fun args tail_call + = -- For example: + -- ldloc f function of type forall a. a->a + -- ldloc x arg of type Int + -- .tail callfunc (!0) --> !0 + -- + vcat [ilxFunAppArgs env 0 (idIlxRepType fun) args tail_call known_clo] where + known_clo :: KnownClosure known_clo = case lookupIlxBindEnv env fun of - Just (place, StgRhsClosure _ _ _ Updatable _ _) -> Nothing + 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 + , [Var] -- Binders + , [Var]) -- Free vars of the closure --- Push as many arguments as ILX allows us to in one go. +-- Push as many arguments as ILX allows us to in one go, and call the function -- Recurse until we're done. +-- The function is already on the stack +ilxFunAppArgs :: IlxEnv + -> Int -- Number of args already pushed (zero is a special case; + -- otherwise used only for place generation) + -> Type -- Type of the function + -> [StgArg] -- The arguments + -> Bool -- True <=> tail call please + -> KnownClosure -- Information about the function we're calling + -> SDoc + ilxFunAppArgs env num_sofar funty args tail_call known_clo = vcat [vcat (ilxMapPlaceArgs num_sofar pushArgWithVoids env now_args), - call_instr <+> now_args_text + call_instr <+> (if num_sofar == 0 then text "() /* first step in every Haskell app. is to a thunk */ " else empty) + <+> now_args_text <+> text "-->" - <+> (pprIlxTypeR env_after_now_tyvs later_ty), + <+> later_ty_text, later ] where - now_args_text = hsep (map (pprIlxArgInfo env_after_now_tyvs) now_arg_tys) + now_args_text = + case now_arg_tys of + [] -> empty + _ -> hsep (map (pprIlxArgInfo env_after_now_tyvs) now_arg_tys) + + later_ty_text + | isVoidIlxRepType later_ty = text "void" + | otherwise = ilxTypeR env_after_now_tyvs later_ty (now_args,now_arg_tys,env_after_now_tyvs,later_args,later_ty) = case args of (StgTypeArg v:rest) -> get_type_args ilxBestTypeArity args env funty - _ -> get_term_args ilxBestTermArity args env funty + _ -> get_term_args 0 ilxBestTermArity args env funty -- Only apply up to maxArity real (non-type) arguments -- at a time. ILX should, in principle, allow us to apply @@ -743,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) @@ -752,21 +848,27 @@ ilxFunAppArgs env num_sofar funty args tail_call known_clo get_type_args _ (StgTypeArg _:_) _ _ = trace "IlxGen Internal Error: get_type_args could not get ForAllTy for corresponding arg" ([],[],env,[],funty) get_type_args _ args env funty = ([],[],env,args,funty) - -- We could probably skip some void-rep arguments. Instead we - -- emit "ldvoid" for these and let ILXASM optimize them away. - -- get_term_args max (h@(StgVarArg v):t) env (FunTy dom ran) | isVoidIlxRepId v - -- = get_term_args max t env ran - get_term_args max args env (NoteTy _ ty) = - -- Skip NoteTy types - trace "IlxGen Internal Error: non representation type passed to get_term_args" (get_term_args max args env ty) - get_term_args 0 args env funty = ([],[],env,args,funty) - -- Stop if no more - get_term_args _ (args@(StgTypeArg _:_)) env funty = ([],[],env,args,funty) - get_term_args max (h:t) env (FunTy dom ran) = - let (now,now_tys,env2,later,later_ty) = get_term_args (max - 1) t env ran in - (h:now, (h,dom):now_tys,env2,later,later_ty) - get_term_args max (h:t) env funty = trace "IlxGen Internal Error: get_term_args could not get FunTy or ForAllTy for corresponding arg" ([],[],env,[],funty) - get_term_args max args env funty = ([],[],env,args,funty) + get_term_args n max args env (NoteTy _ ty) + -- Skip NoteTy types + = trace "IlxGen Internal Error: non representation type passed to get_term_args" (get_term_args n max args env ty) + get_term_args n 0 args env funty + -- Stop if we've hit the maximum number of ILX arguments to apply n one hit. + = ([],[],env,args,funty) + get_term_args n max args env funty + | (case known_clo of + Just (_,_,needed,_) -> needed `lengthIs` n + Nothing -> False) + -- Stop if we have the optimal number for a direct call + = ([],[],env,args,funty) + get_term_args _ _ (args@(StgTypeArg _:_)) env funty + -- Stop if we hit a type arg. + = ([],[],env,args,funty) + get_term_args n max (h:t) env (FunTy dom ran) + -- Take an argument. + = let (now,now_tys,env2,later,later_ty) = get_term_args (n+1) (max - 1) t env ran in + (h:now, (h,dom):now_tys,env2,later,later_ty) + get_term_args _ max (h:t) env funty = trace "IlxGen Internal Error: get_term_args could not get FunTy or ForAllTy for corresponding arg" ([],[],env,[],funty) + get_term_args _ max args env funty = ([],[],env,args,funty) -- Are there any remaining arguments? done = case later_args of @@ -796,11 +898,11 @@ 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 args) && - all (\x -> elemIlxTyVarEnv x env) free_ilx_tvs -> + 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) <+> squotes (ilxEnvQualifyByModule env (ppr fun)), - pprTypeArgs pprIlxTypeR env (map mkTyVarTy free_ilx_tvs)] + nameReference env (idName fun) <+> singleQuotes (ilxEnvQualifyByModule env (ppr fun)), + pprTypeArgs ilxTypeR env (map mkTyVarTy free_ilx_tvs)] <> text "," where (free_ilx_tvs, free_non_ilx_tvs,free_vs) = categorizeVars fvs @@ -820,9 +922,9 @@ ilxFunAppArgs env num_sofar funty args tail_call known_clo -- non-type args the actuals are on the stack, and we just give the -- formal type. pprIlxArgInfo env (StgTypeArg arg,ty) = - angleBrackets (pprIlxTypeR env (deepIlxRepType arg) <+> ilxComment (text "actual for tyvar")) <+> text "" + angleBrackets (ilxTypeR env (deepIlxRepType arg) <+> ilxComment (text "actual for tyvar")) <+> text "" pprIlxArgInfo env (_,ty) = - parens (pprIlxTypeL env ty) + parens (ilxTypeL env ty) ---------------------------- @@ -865,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") @@ -881,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) @@ -943,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 @@ -958,14 +1060,14 @@ ilxTopRhs mod env (bndr, StgRhsCon _ data_con args) bndTy = idIlxRepType bndr pprFieldRef env (mod,ty,id) - = pprIlxTypeL env ty <+> moduleReference env mod <+> pprId mod <> text "::" <> pprId id + = ilxTypeL env ty <+> moduleReference env mod <+> pprId mod <> text "::" <> pprId id ilxTopRhsStorage mod env (bndr, StgRhsClosure _ _ _ _ _ _) - = text ".field public static " <+> pprIlxTypeL env bndTy <+> pprId bndr + = text ".field public static " <+> ilxTypeL env bndTy <+> pprId bndr where bndTy = idIlxRepType bndr ilxTopRhsStorage mod env (bndr, StgRhsCon _ _ _) - = text ".field public static " <+> pprIlxTypeL env bndTy <+> pprId bndr + = text ".field public static " <+> ilxTypeL env bndTy <+> pprId bndr where bndTy = idIlxRepType bndr @@ -990,7 +1092,7 @@ pushId = pushId_aux False pushId_aux :: Bool -> IlxEnv -> Id -> SDoc pushId_aux voids _ id | isVoidIlxRepId id = - if voids then text "ldvoid" else ilxComment (text "pushId: void rep skipped") + /* if voids then text "ldunit" else */ ilxComment (text "pushId: void rep skipped") pushId_aux _ env var = case lookupIlxVarEnv env var of Just Arg -> text "ldarg" <+> pprId var @@ -998,12 +1100,12 @@ pushId_aux _ env var Just Local -> text "ldloc" <+> pprId var Just (Top m) -> vcat [ilxComment (text "pushId (Top) " <+> pprId m), - text "ldsfld" <+> pprIlxTypeL env (idIlxRepType var) + text "ldsfld" <+> ilxTypeL env (idIlxRepType var) <+> moduleReference env m <+> pprId (moduleName m) <> text "::" <> pprId var] Nothing -> vcat [ilxComment (text "pushId (import) " <+> pprIlxTopVar env var), - text "ldsfld" <+> pprIlxTypeL env (idIlxRepType var) + text "ldsfld" <+> ilxTypeL env (idIlxRepType var) <+> pprIlxTopVar env var] -------------------------------------- @@ -1016,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 conv.i " <+> integer w - +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 "::" <> squotes (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 @@ -1041,11 +1142,7 @@ pprIlxTopVar env v isVoidIlxRepType (NoteTy _ ty) = isVoidIlxRepType ty isVoidIlxRepType (TyConApp tc _) | (tyConPrimRep tc == VoidRep) = True isVoidIlxRepType (TyConApp tc tys) - = case newTyConRep tc of - Just rep_ty -> isVoidIlxRepType (applyTys rep_ty tys) - Nothing -> - isUnboxedTupleTyCon tc && - null (filter (not. isVoidIlxRepType) tys) + = isUnboxedTupleTyCon tc && null (filter (not. isVoidIlxRepType) tys) isVoidIlxRepType _ = False isVoidIlxRepId id = isVoidIlxRepType (idType id) @@ -1054,33 +1151,12 @@ isVoidIlxRepId id = isVoidIlxRepType (idType id) -- Get rid of all NoteTy and NewTy artifacts deepIlxRepType :: Type -> Type - --- Eliminate state variables on left of arrow types... --- We have to be careful not to erase too much information here - --- the type may not accurately describe --- the "functionness" of the result. For example, --- State# -> Int# --- reduces to --- Int# --- which looks like an unboxed type. It isn't - it's --- just a function taking no arguments. As such, we --- have to rely on the context in which a function type is being --- used to know what to do. --- --- deepIlxRepType (FunTy l r) | isVoidIlxRepType l --- = deepIlxRepType r - deepIlxRepType (FunTy l r) = FunTy (deepIlxRepType l) (deepIlxRepType r) -deepIlxRepType (TyConApp tc tys) - = case newTyConRep tc of - Just rep_ty -> ASSERT( length tys == tyConArity tc ) - -- The assert should hold because deepIlxRepType should - -- only be applied to *types* (of kind *) - deepIlxRepType (applyTys rep_ty tys) - Nothing -> - -- collapse UnboxedTupleTyCon down when it contains VoidRep types. +deepIlxRepType ty@(TyConApp tc tys) + = -- collapse UnboxedTupleTyCon down when it contains VoidRep types. + -- e.g. (# State#, Int#, Int# #) ===> (# Int#, Int# #) if isUnboxedTupleTyCon tc then let tys' = map deepIlxRepType (filter (not. isVoidIlxRepType) tys) in case tys' of @@ -1088,51 +1164,32 @@ deepIlxRepType (TyConApp tc tys) _ -> mkTupleTy Unboxed (length tys') tys' else TyConApp tc (map deepIlxRepType tys) -deepIlxRepType (AppTy f x) = AppTy (deepIlxRepType f) (deepIlxRepType x) +deepIlxRepType (AppTy f x) = AppTy (deepIlxRepType f) (deepIlxRepType x) deepIlxRepType (ForAllTy b ty) = ForAllTy b (deepIlxRepType ty) deepIlxRepType (NoteTy _ ty) = deepIlxRepType ty -deepIlxRepType (PredTy p) = deepIlxRepType (predRepTy p) +deepIlxRepType (PredTy p) = deepIlxRepType (predTypeRep p) deepIlxRepType ty@(TyVarTy tv) = ty idIlxRepType id = deepIlxRepType (idType id) -------------------------- --- Function types and type functions are implicitly thunkable. -- Some primitive type constructors are not thunkable. -- Everything else needs to be marked thunkable. -pprIlxTypeL :: IlxEnv -> Type -> SDoc - -pprIlxTypeL env ty | isVoidIlxRepType ty - = trace "pprIlxTypeL: VoidRep" pprIlxTypeR env ty - -pprIlxTypeL env ty@(FunTy arg res) - = pprIlxTypeR env ty - -pprIlxTypeL env ty@(ForAllTy arg res) - = pprIlxTypeR env ty - -pprIlxTypeL env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && null (tyConTyVars tc) - = ilxComment (text "what the fuck?") <+> (pprIlxTypeR env ty) -pprIlxTypeL env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && not (isIlxTyVar (hd (tyConTyVars tc))) - = pprIlxTypeR env ty +ilxTypeL :: IlxEnv -> Type -> SDoc -pprIlxTypeL env ty | isUnLiftedType ty -- must come after cases above because isUnLiftedType strips Forall's - = pprIlxTypeR env ty +ilxTypeL env ty | isUnLiftedType ty || isVoidIlxRepType ty = ilxTypeR env ty +ilxTypeL env ty = text "thunk" <> angleBrackets (ilxTypeR env ty) -pprIlxTypeL env ty - = text "thunk" <> angleBrackets (pprIlxTypeR env ty) -------------------------- -- Print non-thunkable version of type. -- -pprIlxTypeR :: IlxEnv -> Type -> SDoc -pprIlxTypeR env ty | isVoidIlxRepType ty = text "void" -pprIlxTypeR env ty = pprIlxTypeR2 env ty - -pprIlxTypeR2 env ty@(AppTy f _) | isTyVarTy f = ilxComment (text "type app:" <+> pprId ty) <+> (text "class [mscorlib]System.Object") -pprIlxTypeR2 env ty@(AppTy f x) = trace "pprIlxTypeR: should I be beta reducing types?!" (ilxComment (text "pprIlxTypeR: should I be beta reducing types...") <+> pprIlxTypeR env (applyTy f x)) -pprIlxTypeR2 env (TyVarTy tv) = pprIlxTyVar env tv +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 (TyVarTy tv) = ilxTyVar env tv -- The following is a special rule for types constructed out of -- higher kinds, e.g. Monad f or Functor f. @@ -1140,50 +1197,58 @@ pprIlxTypeR2 env (TyVarTy tv) = pprIlxTyVar env tv -- The code below is not as general as it should be, but as I -- have no idea if this approach will even work, I'm going to -- just try it out on some simple cases arising from the prelude. -pprIlxTypeR2 env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && null (tyConTyVars tc) - = ilxComment (text "what the fuck? 2") <+> (pprIlxTypeR env (TyConApp tc t)) -pprIlxTypeR2 env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && not (isIlxTyVar (hd (tyConTyVars tc))) - = pprIlxTypeR env (TyConApp tc t) -pprIlxTypeR2 env (TyConApp tc args) = pprIlxTyConApp env tc args +ilxTypeR env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && null (tyConTyVars tc) + = ilxComment (text "what on earth? 2") <+> (ilxTypeR env (TyConApp tc t)) +ilxTypeR env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && not (isIlxTyVar (hd (tyConTyVars tc))) + = ilxTypeR env (TyConApp tc t) +ilxTypeR env (TyConApp tc args) = ilxTyConApp env tc args -- nb. the only legitimate place for VoidIlxRepTypes to occur in normalized IlxRepTypes -- is on the left of an arrow -- We could probably eliminate all but a final occurrence of these. - --pprIlxTypeR2 env (FunTy arg res@(FunTy _ _)) | isVoidIlxRepType arg - -- = pprIlxTypeR env res -pprIlxTypeR2 env (FunTy arg res) | isVoidIlxRepType arg - = parens (text "func () -->" <+> pprIlxTypeR env res) -pprIlxTypeR2 env (FunTy arg res) - = pprIlxFunTy (pprIlxTypeL env arg) (pprIlxTypeR env res) - -pprIlxTypeR2 env ty@(ForAllTy tv body_ty) | isIlxTyVar tv - = parens (text "forall" <+> pprTyVarBinders env' [tv] <+> nest 2 (pprIlxTypeR env' body_ty)) +ilxTypeR env (FunTy arg res)| isVoidIlxRepType res + = pprIlxFunTy (ilxTypeL env arg) (text "void") +ilxTypeR env (FunTy arg res) + = pprIlxFunTy (ilxTypeL env arg) (ilxTypeR env res) + +ilxTypeR env ty@(ForAllTy tv body_ty) | isIlxTyVar tv + = parens (text "forall" <+> pprTyVarBinders env' [tv] <+> nest 2 (ilxTypeR env' body_ty)) where env' = extendIlxEnvWithFormalTyVars env [tv] -pprIlxTypeR2 env ty@(ForAllTy tv body_ty) | otherwise +ilxTypeR env ty@(ForAllTy tv body_ty) | otherwise = ilxComment (text "higher order type var " <+> pprId tv) <+> - pprIlxFunTy (text "class [mscorlib]System.Object") (pprIlxTypeR env body_ty) - -pprIlxTypeR2 env (NoteTy _ ty) - = trace "WARNING! non-representation type given to pprIlxTypeR: see generated ILX for context where this occurs" - (vcat [text "/* WARNING! non-representation type given to pprIlxTypeR! */", - pprIlxTypeR env ty ]) + pprIlxFunTy (text "class [mscorlib]System.Object") (ilxTypeR env body_ty) +ilxTypeR env (NoteTy _ ty) + = trace "WARNING! non-representation type given to ilxTypeR: see generated ILX for context where this occurs" + (vcat [text "/* WARNING! non-representation type given to ilxTypeR! */", + ilxTypeR env ty ]) pprIlxFunTy dom ran = parens (hsep [text "func",parens dom,text "-->", ran]) -pprIlxTyConApp env tc args = - case lookupUFM tyPrimConTable (getUnique tc) of - Just f -> f env args +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 pprIlxTypeL env args -pprIlxBoxedTyConApp env tcdoc args = text "class" <+> tcdoc <> pprTypeArgs pprIlxTypeR 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 @@ -1202,22 +1267,22 @@ pprTyVarBinder env tv = angleBrackets (pprTyVarBinder_aux env tv) else ilxComment (text "higher order tyvar" <+> pprId tv <+> - text ":" <+> pprIlxTypeR env (tyVarKind tv)) <+> + text ":" <+> ilxTypeR env (tyVarKind tv)) <+> ilxComment (text "omitted") -- parens (text "class [mscorlib]System.Object" <+> pprId tv) pprTyVarBinder_aux env tv = ilxComment (text "tyvar" <+> pprId tv <+> text ":" <+> - pprIlxTypeR env (tyVarKind tv)) <+> + ilxTypeR env (tyVarKind tv)) <+> (text "class [mscorlib]System.Object") -- Only a subset of Haskell types can be generalized using the type quantification -- of ILX isIlxForAllKind h = - ( h == liftedTypeKind) || - ( h == unliftedTypeKind) || - ( h == openTypeKind) + ( h `eqKind` liftedTypeKind) || + ( h `eqKind` unliftedTypeKind) || + ( h `eqKind` openTypeKind) isIlxTyVar v = isTyVar v && isIlxForAllKind (tyVarKind v) @@ -1230,8 +1295,7 @@ categorizeTyVars tyvs = partition isIlxTyVar tyvs pprValArgTys ppr_ty env tys = parens (pprSepWithCommas (ppr_ty env) tys) -pprId id = squotes (ppr id) -squotes s = text "'" <> s <> text "'" +pprId id = singleQuotes (ppr id) \end{code} @@ -1255,21 +1319,6 @@ extendIlxTyEnvWithTyArgs env tyvars = env ++ mkIlxTyEnv tyvars -- bound by "<... formalIlxTyEnv tyvars = mkIlxTyEnv tyvars mkIlxTyEnv tyvars = [ v | v <- tyvars, isIlxTyVar v ] -pprIlxTyVarInIlxTyEnv :: IlxTyEnv -> TyVar -> SDoc -pprIlxTyVarInIlxTyEnv tv_env tv - = go 0 tv_env - where - go n [] - = pprTrace "pprIlxTyVar" (pprId tv <+> text "tv_env = { " - <+> pprSepWithCommas (\x -> pprId x <+> text ":" - <+> pprIlxTypeR (IlxEnv (thisModule, tv_env, emptyVarEnv, emptyVarEnv, (empty,empty),False)) (tyVarKind x)) tv_env <+> text "}") - (char '!' <> pprId tv) - go n (x:xs) - = {- pprTrace "go" (ppr (tyVarName tv) <+> ppr (tyVarName x)) -} - (if tyVarName x== tyVarName tv then char '!' <> int n <+> ilxComment (char '!' <> pprId tv) - else go (n+1) xs) - - data HowBound = Top Module -- Bound in a modules | Arg -- Arguments to the enclosing closure | CloVar Int -- A free variable of the enclosing closure @@ -1281,9 +1330,20 @@ data HowBound = Top Module -- Bound in a modules -- e.g. Foo_bar_baz when inside closure baz inside closure bar inside module Foo. data IlxEnv = IlxEnv (Module, IlxTyEnv, IdEnv HowBound,IdEnv (IlxEnv, StgRhs), Place,Bool) type Place = (SDoc,SDoc) -thisModule = mkHomeModule (mkModuleName "") -pprIlxTyVar (IlxEnv (_, tv_env, _, _,_,_)) tv = pprIlxTyVarInIlxTyEnv tv_env tv +ilxTyVar env tv + = go 0 (ilxEnvTyEnv env) + where + go n [] + = pprTrace "ilxTyVar" (pprId tv <+> text "tv_env = { " + <+> pprSepWithCommas + (\x -> pprId x <+> text ":" <+> ilxTypeR env (tyVarKind x)) + (ilxEnvTyEnv env) <+> text "}") + (char '!' <> pprId tv) + go n (x:xs) + = {- pprTrace "go" (ppr (tyVarName tv) <+> ppr (tyVarName x)) -} + (if tyVarName x== tyVarName tv then char '!' <> int n <+> ilxComment (char '!' <> pprId tv) + else go (n+1) xs) emptyIlxEnv :: Bool -> Module -> IlxEnv emptyIlxEnv trace mod = IlxEnv (mod, emptyIlxTyEnv, emptyVarEnv, emptyVarEnv, (ppr mod,empty),trace) @@ -1291,6 +1351,7 @@ emptyIlxEnv trace mod = IlxEnv (mod, emptyIlxTyEnv, emptyVarEnv, emptyVarEnv, (p nextPlace place sdoc = place <> sdoc usePlace place sdoc = place <> sdoc +ilxEnvModule (IlxEnv (m, _, _, _, _,_)) = m ilxEnvSetPlace (IlxEnv (m, tv_env, id_env, bind_env, (mod,exact),tr)) sdoc = IlxEnv (m, tv_env, id_env, bind_env, (mod, sdoc),tr) ilxEnvNextPlace (IlxEnv (m, tv_env, id_env, bind_env, (mod,exact),tr)) sdoc @@ -1352,10 +1413,12 @@ extendIlxEnvWithTops env@(IlxEnv (m, tv_env, id_env, bind_env, place,tr)) mod bi formalIlxEnv (IlxEnv (m, tv_env, id_env, bind_env, place, tr)) tyvars = IlxEnv (m, formalIlxTyEnv tyvars, id_env, bind_env, place, tr) -elemIlxTyVarEnv var env@(IlxEnv (_, tv_env, _,_,_,_)) = elem var tv_env -elemIlxVarEnv var env@(IlxEnv (_, _, id_env,_,_,_)) = elemVarEnv var id_env -lookupIlxVarEnv env@(IlxEnv (_, _, id_env,_,_,_)) var = lookupVarEnv id_env var -lookupIlxBindEnv env@(IlxEnv (_, _, _, bind_env,_,_)) var = lookupVarEnv bind_env var +ilxEnvTyEnv :: IlxEnv -> IlxTyEnv +ilxEnvTyEnv (IlxEnv (_, tv_env, _,_,_,_)) = tv_env +elemIlxTyEnv var env = elem var (ilxEnvTyEnv env ) +elemIlxVarEnv var (IlxEnv (_, _, id_env,_,_,_)) = elemVarEnv var id_env +lookupIlxVarEnv (IlxEnv (_, _, id_env,_,_,_)) var = lookupVarEnv id_env var +lookupIlxBindEnv (IlxEnv (_, _, _, bind_env,_,_)) var = lookupVarEnv bind_env var \end{code} @@ -1390,26 +1453,35 @@ singleQuotes pp = char '\'' <> pp <> char '\'' line = text "// ----------------------------------" -hscOptionQual = if opt_SimplDoEtaReduction then text ".O" else text ".Onot" - -nameReference (IlxEnv (thisMod, _, _, _, _, _)) n - | isLocalName n = text "/* local */" - | thisMod == nameModule n = text "" - | isDllName n = brackets ((text "ilx") <+> singleQuotes (ppr (modulePackage (nameModule n)) <> hscOptionQual)) - | otherwise = brackets ((text ".module") <+> (text "ilx") <+> singleQuotes (pprModuleName (moduleName (nameModule n)) <> hscOptionQual)) - -moduleReference (IlxEnv (thisMod, _, _, _, _, _)) m - | thisMod == m = text "" - | isHomeModule m = brackets ((text ".module") <+> (text "ilx") <+> singleQuotes (pprModuleName (moduleName m) <> hscOptionQual)) - | otherwise = brackets ((text "ilx") <+> singleQuotes (ppr (modulePackage m) <> hscOptionQual)) - -prelGHCReference = - if preludePackage == opt_InPackage then brackets (text ".module ilx PrelGHC" <> hscOptionQual) - else brackets (text "ilx" <+> text (_UNPK_ preludePackage) <> hscOptionQual) - -prelBaseReference = - if preludePackage == opt_InPackage then brackets (text ".module ilx PrelBase" <> hscOptionQual) - else brackets (text "ilx" <+> text (_UNPK_ preludePackage) <> hscOptionQual) +hscOptionQual = text ".i_" + +nameReference env n + | 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 = 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 "o"))) + +moduleReference env m + | ilxEnvModule env == m = text "" + | isHomeModule m = moduleNameReference (moduleName m) + -- See hack above + | isVanillaModule m && not inPrelude = basePackageReference + | isVanillaModule m && inPrelude = moduleNameReference (moduleName m) + -- end hack + | otherwise = packageReference (modulePackage m) + +basePackageReference = packageReference basePackage +inPrelude = basePackage == opt_InPackage ------------------------------------------------ -- This code is copied from absCSyn/CString.lhs, @@ -1417,8 +1489,8 @@ prelBaseReference = -- 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 @@ -1500,9 +1572,9 @@ ilxConApp env data_con args vcat [vcat (ilxMapPlaceArgs 0 pushArg env tm_args'), sep [text "newobj void ", - pprIlxTyConApp env tycon' rep_ty_args', + ilxTyConApp env tycon' rep_ty_args', text "::.ctor", - pprValArgTys pprIlxTypeR formal_env' (map deepIlxRepType formal_arg_tys') + pprValArgTys ilxTypeR formal_env' (map deepIlxRepType formal_arg_tys') ] ] | otherwise @@ -1518,7 +1590,7 @@ ilxConApp env data_con args vcat [vcat (ilxMapPlaceArgs 0 pushArg env tm_args), sep [ text "newdata", - nest 2 (pprIlxTyConApp env tycon rep_ty_args <> comma), + nest 2 (ilxTyConApp env tycon rep_ty_args <> comma), nest 2 (ilxConRef env data_con) ] ] @@ -1527,163 +1599,194 @@ ilxConApp env data_con args rep_ty_args = map deepIlxRepType ty_args (ty_args,tm_args) = if isAlgTyCon tycon then splitTyArgs (tyConTyVars tycon) args else splitTyArgs1 args --- split some type arguments off, throwing away the higher kinded ones for the moment --- base the higher-kinded checks off a corresponding list of formals +-- Split some type arguments off, throwing away the higher kinded ones for the moment. +-- Base the higher-kinded checks off a corresponding list of formals. +splitTyArgs :: [Var] -- Formals + -> [StgArg] -- Actuals + -> ([Type], [StgArg]) splitTyArgs (htv:ttv) (StgTypeArg h:t) | isIlxTyVar htv = ((h:l), r) | otherwise = trace "splitTyArgs: threw away higher kinded type arg" (l, r) where (l,r) = splitTyArgs ttv t splitTyArgs _ l = ([],l) --- split some type arguments off, where none should be higher kinded -splitTyArgs1 (StgTypeArg h:t) - = ((h:l), r) - where (l,r) = splitTyArgs1 t -splitTyArgs1 l = ([],l) - +-- Split some type arguments off, where none should be higher kinded +splitTyArgs1 :: [StgArg] -> ([Type], [StgArg]) +splitTyArgs1 (StgTypeArg ty : args) = (ty:tys, args') + where + (tys, args') = splitTyArgs1 args +splitTyArgs1 args = ([], args) ilxConRef env data_con - = pprId data_con <> pprValArgTys pprIlxTypeL 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 -tyPrimConTable :: UniqFM (IlxEnv -> [Type] -> SDoc) -tyPrimConTable = listToUFM [(addrPrimTyConKey, (\_ _ -> repAddr)), --- (fileStreamPrimTyConKey, (\_ _ -> repFileStream)), - (foreignObjPrimTyConKey, (\_ _ -> text "/* ForeignObj */ void *")), --- (stablePtrPrimTyConKey, (\_ _ -> text "/* StablePtr */ void *")), - (charPrimTyConKey, (\_ _ -> repChar)), - (wordPrimTyConKey, (\_ _ -> repWord)), - (byteArrayPrimTyConKey, (\_ _ -> repByteArray)), - (intPrimTyConKey, (\_ _ -> repInt)), - (int64PrimTyConKey, (\_ _ -> repInt64)), - (word64PrimTyConKey, (\_ _ -> repWord64)), - (floatPrimTyConKey, (\_ _ -> text "float32")), - (arrayPrimTyConKey, (\env [ty] -> pprIlxTypeL env ty <> text "[]")), - (mutableArrayPrimTyConKey, (\env [_, ty] -> pprIlxTypeL env ty <> text "[]")), - (mVarPrimTyConKey, (\env [_, ty] -> repMVar (pprIlxTypeL env ty))), - (mutVarPrimTyConKey, (\env [ty1, ty2] -> repMutVar (pprIlxTypeL env ty1) (pprIlxTypeL env ty2))), - (mutableByteArrayPrimTyConKey, (\_ _ -> repByteArray)), - (threadIdPrimTyConKey, (\_ _ -> text "class [mscorlib]System.Threading.Thread /* ThreadId# */ ")), - (doublePrimTyConKey, (\_ _ -> text "float64")) - ] \end{code} + %************************************************************************ %* * -\subsection{C Calls} -%* * +\subsection{PrimOps and Prim Representations} * %************************************************************************ \begin{code} --- We eliminate voids in and around an IL C Call. We don't yet emit PInvoke stubs. --- We also do some type-directed translation for pinning Haskell-managed blobs --- of data as we throw them across the boundary. -ilxCCall env (CCall (StaticTarget c) casm gc cconv) args ret_ty = - ilxComment (text "C call <+> pprCLabelString c") <+> - vcat [vcat (ilxMapPlaceArgs 0 pushCArg env args), - text "call" <+> retdoc <+> text "class " <+> prelGHCReference <+> text "PrelGHC::" <+> pprCLabelString c <+> pprTypeArgs pprIlxTypeR env ty_args - <+> pprCValArgTys pprIlxTypeL env (map deepIlxRepType (filter (not. isVoidIlxRepType) (map stgArgType tm_args))) ] - where - retdoc = - if isVoidIlxRepType ret_ty then text "void" - else pprIlxTypeR env (deepIlxRepType ret_ty) - (ty_args,tm_args) = splitTyArgs1 args - - -hasTyCon (TyConApp tc _) tc2 = tc == tc2 -hasTyCon _ _ = False - -isByteArrayCArgTy ty = hasTyCon ty byteArrayPrimTyCon || hasTyCon ty mutableByteArrayPrimTyCon -isByteArrayCArg v = isByteArrayCArgTy (deepIlxRepType (idType v)) -pinCCallArg v = isByteArrayCArg v - -ilxAddrOfPinnedByteArr = text "ldc.i4 0 ldelema unsigned int8" - -pushCArg env arg@(StgVarArg v) | isByteArrayCArg v = pushArg env arg <+> text "dup stloc" <+> squotes (ilxEnvQualifyByExact env (ppr v) <> text "pin") <+> ilxAddrOfPinnedByteArr -pushCArg env arg | otherwise = pushArg env arg - -pprCValArgTys f env tys = parens (pprSepWithCommas (pprCValArgTy f env) tys) -pprCValArgTy f env ty | isByteArrayCArgTy ty = text "void *" <+> ilxComment (text "interior pointer into ByteArr#") -pprCValArgTy f env ty | otherwise = f env ty +ilxPrimApp env op args ret_ty = ilxPrimOpTable op args env + + +type IlxTyFrag = IlxEnv -> SDoc +ilxType s env = text s + +ilxLift ty env = text "thunk" <> angleBrackets (ty env) + +ilxTypeSeq :: [IlxTyFrag] -> IlxTyFrag +ilxTypeSeq ops env = hsep (map (\x -> x env) ops) + +tyPrimConTable :: UniqFM ([Type] -> IlxTyFrag) +tyPrimConTable = + listToUFM [(addrPrimTyConKey, (\_ -> repAddr)), +-- (fileStreamPrimTyConKey, (\_ -> repFileStream)), + (foreignObjPrimTyConKey, (\_ -> repForeign)), + (stablePtrPrimTyConKey, (\[ty] -> repStablePtr {- (ilxTypeL2 ty) -})), + (stableNamePrimTyConKey, (\[ty] -> repStableName {- (ilxTypeL2 ty) -} )), + (charPrimTyConKey, (\_ -> repChar)), + (wordPrimTyConKey, (\_ -> repWord)), + (byteArrayPrimTyConKey, (\_ -> repByteArray)), + (intPrimTyConKey, (\_ -> repInt)), + (int64PrimTyConKey, (\_ -> repInt64)), + (word64PrimTyConKey, (\_ -> repWord64)), + (floatPrimTyConKey, (\_ -> repFloat)), + (doublePrimTyConKey, (\_ -> repDouble)), + -- These can all also accept unlifted parameter types so we explicitly lift. + (arrayPrimTyConKey, (\[ty] -> repArray (ilxTypeL2 ty))), + (mutableArrayPrimTyConKey, (\[_, ty] -> repMutArray (ilxTypeL2 ty))), + (weakPrimTyConKey, (\[ty] -> repWeak (ilxTypeL2 ty))), + (mVarPrimTyConKey, (\[_, ty] -> repMVar (ilxTypeL2 ty))), + (mutVarPrimTyConKey, (\[ty1, ty2] -> repMutVar (ilxTypeL2 ty1) (ilxTypeL2 ty2))), + (mutableByteArrayPrimTyConKey, (\_ -> repByteArray)), + (threadIdPrimTyConKey, (\_ -> repThread)), + (bcoPrimTyConKey, (\_ -> repBCO)) + ] +ilxTypeL2 :: Type -> IlxTyFrag +ilxTypeL2 ty env = ilxTypeL env ty +ilxTypeR2 :: Type -> IlxTyFrag +ilxTypeR2 ty env = ilxTypeR env ty + +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 basePackageReference + +prelBaseReference :: IlxTyFrag +prelBaseReference env = + if ilxEnvModule env == mkHomeModule (mkModuleName "PrelBase") then empty + else if inPrelude then moduleNameReference (mkModuleName "PrelBase") + else basePackageReference + +repThread = ilxType "class [mscorlib]System.Threading.Thread /* ThreadId# */ " +repByteArray = ilxType "unsigned int8[] /* ByteArr# */ " +--repFileStream = text "void * /* FileStream# */ " -- text "class [mscorlib]System.IO.FileStream" +repInt = ilxType "int32" +repWord = ilxType "unsigned int32" +repAddr =ilxType "/* Addr */ void *" +repInt64 = ilxType "int64" +repWord64 = ilxType "unsigned int64" +repFloat = ilxType "float32" +repDouble = ilxType "float64" +repChar = ilxType "/* Char */ unsigned int8" +repForeign = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_Foreignzh"] +repInteger = ilxUnboxedPairRep repInt repByteArray +repIntegerPair = ilxUnboxedQuadRep repInt repByteArray repInt repByteArray +repArray ty = ilxTypeSeq [ty,ilxType "[]"] +repMutArray ty = ilxTypeSeq [ty,ilxType "[]"] +repMVar ty = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_MVarzh",ilxTyParams [ty]] +repMutVar _ ty2 = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_MutVarzh",ilxTyParams [ty2]] +repWeak ty1 = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_Weakzh",ilxTyParams [ty1]] +repStablePtr {- ty1 -} = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_StablePtrzh" {- ,ilxTyParams [ty1] -} ] +repStableName {- ty1 -} = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_StableNamezh" {- ,ilxTyParams [ty1] -} ] +classWeak = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_Weakzh"] +repBCO = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_BCOzh"] -\end{code} +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_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] -%************************************************************************ -%* * -\subsection{PrimOps} -%* * -%************************************************************************ +ilxTyIO b = ilxTypeSeq [ilxType "(func ( /* unit skipped */ ) --> ", b, ilxType ")"] -\begin{code} +ilxTyParams :: [IlxTyFrag] -> IlxTyFrag +ilxTyParams [] env = empty +ilxTyParams l env = angleBrackets (ilxTyParamsAux l env) + where + ilxTyParamsAux [] env = empty + ilxTyParamsAux [h] env = h env + ilxTyParamsAux (h:t) env = h env <> text "," <+> ilxTyParamsAux t env + ilxTyParams [] env = empty -ilxPrimApp env (CCallOp ccall) args ret_ty = ilxCCall env ccall args ret_ty -ilxPrimApp env op args ret_ty = ilxPrimOpTable op env args - -ilxMkBool = text "call class" <+> prelBaseReference <+> - text "PrelBase_Bool" <+> - prelGHCReference <+> text "GHC.support::mkBool(bool)" -ilxCgt = text "cgt " <+> ilxMkBool -ilxCge = text "clt ldc.i4 0 ceq " <+> ilxMkBool -ilxClt = text "clt " <+> ilxMkBool -ilxCle = text "cgt ldc.i4 0 ceq " <+> ilxMkBool -ilxCeq = text "ceq " <+> ilxMkBool -ilxCne = text "ceq ldc.i4 0 ceq " <+> ilxMkBool -ilxCgtUn = text "cgt.un " <+> ilxMkBool -ilxCgeUn = text "clt.un ldc.i4 0 ceq " <+> ilxMkBool -ilxCltUn = text "clt.un " <+> ilxMkBool -ilxCleUn = text "cgt.un ldc.i4 0 ceq " <+> ilxMkBool -ldDummyInteger = text " ldc.i4 0 ldnull newobj void" <+> ilxUnboxedPairRep repInt repByteArray <+> text "::.ctor(!0,!1)" -ldDummyInteger2 = text " ldc.i4 0 ldnull ldc.i4 0 ldnull newobj void" <+> ilxUnboxedQuadRep repInt repByteArray repInt repByteArray <+> text "::.ctor(!0,!1,!2,!3)" - -repByteArray = text "unsigned int8[] /* ByteArr# */ " -repFileStream = text "void * /* FileStream# */ " -- text "class [mscorlib]System.IO.FileStream" -repInt = text "int32" -repWord = text "unsigned int32" -repAddr = text "/* Addr */ void *" -repInt64 = text "int64" -repWord64 = text "unsigned int64" -repChar = text "/* Char */ unsigned int8" -repInteger = ilxUnboxedPairRep repInt repByteArray -repIntegerPair = ilxUnboxedQuadRep repInt repByteArray repInt repByteArray -repMVar ty = text "class " <+> prelGHCReference <+> text "PrelGHC_MVarzh" <+> ilxTyParams [ty] -repMutVar _ ty2 = text "class " <+> prelGHCReference <+> text "PrelGHC_MutVarzh" <+> ilxTyParams [ty2] -repWeak ty1 = text "class " <+> prelGHCReference <+> text "PrelGHC_Weakzh" <+> ilxTyParams [ty1] -ilxParamsAux [] = empty -ilxParamsAux [h] = h -ilxParamsAux (h:t) = h <> text "," <+> ilxParamsAux t -ilxParams [] = empty -ilxParams l = parens (ilxParamsAux l) +type IlxOpFrag = IlxEnv -> SDoc +ilxOp :: String -> IlxOpFrag +ilxOp s env = text s +ilxOpSeq :: [IlxOpFrag] -> IlxOpFrag +ilxOpSeq ops env = hsep (map (\x -> x env) ops) -ilxTyParamsAux [] = empty -ilxTyParamsAux [h] = h -ilxTyParamsAux (h:t) = h <> text "," <+> ilxTyParamsAux t -ilxTyParams [] = empty -ilxTyParams l = angleBrackets (ilxTyParamsAux l) +ilxParams :: [IlxOpFrag] -> IlxOpFrag +ilxParams l env = parens (ilxParamsAux l env) + where + ilxParamsAux [] env = empty + ilxParamsAux [h] env = h env + ilxParamsAux (h:t) env = h env <> text "," <+> ilxParamsAux t env -ilxMethA = text "!!0" -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 = text "value class" <+> prelGHCReference <+> text "PrelGHC_ZLzhzx2czhZR" <+> ilxTyPair l r -ilxUnboxedTripleRep l m r = text "value class" <+> prelGHCReference <+> text "PrelGHC_ZLzhzx2czx2czhZR" <+> ilxTyTriple l m r -ilxUnboxedQuadRep l m1 m2 r = text "value class" <+> prelGHCReference <+> text "PrelGHC_ZLzhzx2czx2czx2czhZR" <+> ilxTyQuad l m1 m2 r +ilxMethodRef rty cls nm tyargs args = + ilxOpSeq [rty,cls,ilxOp "::",ilxOp nm, + ilxTyParams tyargs,ilxParams args] -ilxMethodRef rty cls nm tyargs args = rty <+> cls <+> text "::" <> squotes (text nm) <> ilxTyParams tyargs <> ilxParams args +ilxCall m = ilxOpSeq [ilxOp "call", m] -ilxSupportClass = prelGHCReference <+> text "GHC.support" +ilxSupportClass = ilxOpSeq [prelGHCReference, ilxOp "'GHC.support'"] ilxSuppMeth rty nm tyargs args = ilxMethodRef rty ilxSupportClass nm tyargs args -ilxPrimOpTable :: PrimOp -> IlxEnv -> [StgArg] -> SDoc +ilxCallSuppMeth rty nm tyargs args = ilxCall (ilxSuppMeth rty nm tyargs args) + +ilxMkBool :: IlxOpFrag +ilxMkBool = ilxOpSeq [ilxOp "call class",prelBaseReference, + ilxOp "PrelBase_Bool", + prelGHCReference,ilxOp "GHC.support::mkBool(bool)"] +ilxCgt = ilxOpSeq [ilxOp "cgt",ilxMkBool] +ilxCge = ilxOpSeq [ilxOp "clt ldc.i4 0 ceq ",ilxMkBool] +ilxClt = ilxOpSeq [ilxOp "clt ",ilxMkBool] +ilxCle = ilxOpSeq [ilxOp "cgt ldc.i4 0 ceq ",ilxMkBool] +ilxCeq = ilxOpSeq [ilxOp "ceq ",ilxMkBool] +ilxCne = ilxOpSeq [ilxOp "ceq ldc.i4 0 ceq " ,ilxMkBool] +ilxCgtUn = ilxOpSeq [ilxOp "cgt.un ",ilxMkBool] +ilxCgeUn = ilxOpSeq [ilxOp "clt.un ldc.i4 0 ceq ",ilxMkBool] +ilxCltUn = ilxOpSeq [ilxOp "clt.un ",ilxMkBool] +ilxCleUn = ilxOpSeq [ilxOp "cgt.un ldc.i4 0 ceq ",ilxMkBool] + +ilxAddrOfForeignOp = ilxOpSeq [ilxOp "ldfld void *" , repForeign, ilxOp "::contents"] +ilxAddrOfByteArrOp = ilxOp "ldc.i4 0 ldelema unsigned int8" + +ilxPrimOpTable :: PrimOp -> [StgArg] -> IlxOpFrag ilxPrimOpTable op = case op of CharGtOp -> simp_op ilxCgt @@ -1693,8 +1796,8 @@ ilxPrimOpTable op CharLtOp -> simp_op ilxClt CharLeOp -> simp_op ilxCle - OrdOp -> simp_op (text "conv.i4") -- chars represented by UInt32 (u4) - ChrOp -> simp_op (text "conv.u4") + OrdOp -> simp_op (ilxOp "conv.i4") -- chars represented by UInt32 (u4) + ChrOp -> simp_op (ilxOp "conv.u4") IntGtOp -> simp_op ilxCgt IntGeOp -> simp_op ilxCge @@ -1703,7 +1806,14 @@ ilxPrimOpTable op IntLtOp -> simp_op ilxClt IntLeOp -> simp_op ilxCle - WordGtOp -> simp_op ilxCgtUn -- words represented by UInt32 (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 WordEqOp -> simp_op ilxCeq WordNeOp -> simp_op ilxCne @@ -1732,237 +1842,310 @@ ilxPrimOpTable op DoubleLeOp -> simp_op ilxCle -- Int#-related ops: - IntAddOp -> simp_op (text "add") - IntSubOp -> simp_op (text "sub") - IntMulOp -> simp_op (text "mul") - IntQuotOp -> simp_op (text "div") - IntNegOp -> simp_op (text "neg") - IntRemOp -> simp_op (text "rem") - - Addr2IntOp -> simp_op (text "conv.i4") -- Addresses are very dodgy for ILX. They are used for both C-strings and - Int2AddrOp -> simp_op (text "conv.i") -- the FFI. This needs more work. - ISllOp -> simp_op (text "shl") - ISraOp -> simp_op (text "shr") - ISrlOp -> simp_op (text "shr.un") - IntAddCOp -> simp_op (text "call" <+> ilxSuppMeth (ilxUnboxedPairRep repInt repInt) "IntAddCOp" [] [repInt, repInt]) - IntSubCOp -> simp_op (text "call" <+> ilxSuppMeth (ilxUnboxedPairRep repInt repInt) "IntSubCOp" [] [repInt, repInt]) - IntMulCOp -> simp_op (text "call" <+> ilxSuppMeth (ilxUnboxedPairRep repInt repInt) "IntMulCOp" [] [repInt, repInt]) - IntGcdOp -> simp_op (text "call" <+> ilxSuppMeth repInt "IntMulCOp" [] [repInt, repInt]) + IntAddOp -> simp_op (ilxOp "add") + IntSubOp -> simp_op (ilxOp "sub") + IntMulOp -> simp_op (ilxOp "mul") + IntQuotOp -> simp_op (ilxOp "div") + 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") + WordMulOp -> simp_op (ilxOp "mul") + WordQuotOp -> simp_op (ilxOp "div") + WordRemOp -> simp_op (ilxOp "rem") + + 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]) + IntGcdOp -> simp_op (ilxCallSuppMeth repInt "IntGcdOp" [] [repInt, repInt]) -- Word#-related ops: - AndOp -> simp_op (text "and") - OrOp -> simp_op (text "or") - NotOp -> simp_op (text "not") - XorOp -> simp_op (text "xor") - SllOp -> simp_op (text "shl") - SrlOp -> simp_op (text "shr") - Word2IntOp -> simp_op (text "conv.i4") - Int2WordOp -> simp_op (text "conv.u4") + AndOp -> simp_op (ilxOp "and") + OrOp -> simp_op (ilxOp "or") + NotOp -> simp_op (ilxOp "not") + XorOp -> simp_op (ilxOp "xor") + SllOp -> simp_op (ilxOp "shl") + SrlOp -> simp_op (ilxOp "shr") + Word2IntOp -> simp_op (ilxOp "conv.i4") + Int2WordOp -> simp_op (ilxOp "conv.u4") -- Float#-related ops: - FloatAddOp -> simp_op (text "add") - FloatSubOp -> simp_op (text "sub") - FloatMulOp -> simp_op (text "mul") - FloatDivOp -> simp_op (text "div") - FloatNegOp -> simp_op (text "neg") - Float2IntOp -> simp_op (text "conv.i4") - Int2FloatOp -> simp_op (text "conv.r4") - - DoubleAddOp -> simp_op (text "add") - DoubleSubOp -> simp_op (text "sub") - DoubleMulOp -> simp_op (text "mul") - DoubleDivOp -> simp_op (text "div") - DoubleNegOp -> simp_op (text "neg") - Double2IntOp -> simp_op (text "conv.i4") - Int2DoubleOp -> simp_op (text "conv.r4") - Double2FloatOp -> simp_op (text "conv.r4") - Float2DoubleOp -> simp_op (text "conv.r8") - DoubleDecodeOp -> simp_op (text "call" <+> ilxSuppMeth (ilxUnboxedTripleRep repInt repInt repByteArray) "decodeDouble" [] [text "float64"]) - FloatDecodeOp -> simp_op (text "call" <+> ilxSuppMeth (ilxUnboxedTripleRep repInt repInt repByteArray) "decodeFloat" [] [text "float32"]) - - FloatExpOp -> simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Exp(float64) conv.r4") - FloatLogOp -> simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Log(float64) conv.r4") - FloatSqrtOp -> simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Sqrt(float64) conv.r4") - FloatSinOp -> simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Sin(float64) conv.r4") - FloatCosOp -> simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Cos(float64) conv.r4") - FloatTanOp -> simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Tan(float64) conv.r4") - FloatAsinOp -> simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Asin(float64) conv.r4") - FloatAcosOp -> simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Acos(float64) conv.r4") - FloatAtanOp -> simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Atan(float64) conv.r4") - FloatSinhOp -> simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Sinh(float64) conv.r4") - FloatCoshOp -> simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Cosh(float64) conv.r4") - FloatTanhOp -> simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Tanh(float64) conv.r4") - FloatPowerOp -> simp_op (text "call float64 [mscorlib]System.Math::Pow(float64, float64) conv.r4") -- ** op, make use of implicit cast to r8... - - DoubleExpOp -> simp_op (text "call float64 [mscorlib]System.Math::Exp(float64)") - DoubleLogOp -> simp_op (text "call float64 [mscorlib]System.Math::Log(float64)") - DoubleSqrtOp -> simp_op (text "call float64 [mscorlib]System.Math::Sqrt(float64)") + FloatAddOp -> simp_op (ilxOp "add") + FloatSubOp -> simp_op (ilxOp "sub") + FloatMulOp -> simp_op (ilxOp "mul") + FloatDivOp -> simp_op (ilxOp "div") + FloatNegOp -> simp_op (ilxOp "neg") + Float2IntOp -> simp_op (ilxOp "conv.i4") + Int2FloatOp -> simp_op (ilxOp "conv.r4") + + DoubleAddOp -> simp_op (ilxOp "add") + DoubleSubOp -> simp_op (ilxOp "sub") + DoubleMulOp -> simp_op (ilxOp "mul") + DoubleDivOp -> simp_op (ilxOp "div") + DoubleNegOp -> simp_op (ilxOp "neg") + Double2IntOp -> simp_op (ilxOp "conv.i4") + Int2DoubleOp -> simp_op (ilxOp "conv.r4") + Double2FloatOp -> simp_op (ilxOp "conv.r4") + Float2DoubleOp -> simp_op (ilxOp "conv.r8") + DoubleDecodeOp -> simp_op (ilxCallSuppMeth (ilxUnboxedTripleRep repInt repInt repByteArray) "decodeDouble" [] [ilxType "float64"]) + FloatDecodeOp -> simp_op (ilxCallSuppMeth (ilxUnboxedTripleRep repInt repInt repByteArray) "decodeFloat" [] [ilxType "float32"]) + + FloatExpOp -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Exp(float64) conv.r4") + FloatLogOp -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Log(float64) conv.r4") + FloatSqrtOp -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Sqrt(float64) conv.r4") + FloatSinOp -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Sin(float64) conv.r4") + FloatCosOp -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Cos(float64) conv.r4") + FloatTanOp -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Tan(float64) conv.r4") + FloatAsinOp -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Asin(float64) conv.r4") + FloatAcosOp -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Acos(float64) conv.r4") + FloatAtanOp -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Atan(float64) conv.r4") + 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... + + DoubleExpOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Exp(float64)") + DoubleLogOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Log(float64)") + DoubleSqrtOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Sqrt(float64)") - DoubleSinOp -> simp_op (text "call float64 [mscorlib]System.Math::Sin(float64)") - DoubleCosOp -> simp_op (text "call float64 [mscorlib]System.Math::Cos(float64)") - DoubleTanOp -> simp_op (text "call float64 [mscorlib]System.Math::Tan(float64)") + DoubleSinOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Sin(float64)") + DoubleCosOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Cos(float64)") + DoubleTanOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Tan(float64)") - DoubleAsinOp -> simp_op (text "call float64 [mscorlib]System.Math::Asin(float64)") - DoubleAcosOp -> simp_op (text "call float64 [mscorlib]System.Math::Acos(float64)") - DoubleAtanOp -> simp_op (text "call float64 [mscorlib]System.Math::Atan(float64)") + DoubleAsinOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Asin(float64)") + DoubleAcosOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Acos(float64)") + DoubleAtanOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Atan(float64)") - DoubleSinhOp -> simp_op (text "call float64 [mscorlib]System.Math::Sinh(float64)") - DoubleCoshOp -> simp_op (text "call float64 [mscorlib]System.Math::Cosh(float64)") - DoubleTanhOp -> simp_op (text "call float64 [mscorlib]System.Math::Tanh(float64)") + DoubleSinhOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Sinh(float64)") + DoubleCoshOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Cosh(float64)") + DoubleTanhOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Tanh(float64)") - DoublePowerOp -> simp_op (text "call float64 [mscorlib]System.Math::Pow(float64, float64)") + DoublePowerOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Pow(float64, float64)") -- Integer (and related...) ops: bail out to support routines --- IntegerNegOp -> simp_op (text "call" <+> ilxSuppMeth repInteger "IntegerNegOp" [] [repInt, repByteArray]) --- Addr2IntegerOp -> simp_op (text "call" <+> ilxSuppMeth repInteger "Addr2IntegerOp" [] [repAddr]) - IntegerAddOp -> simp_op (text "call" <+> ilxSuppMeth repInteger "IntegerAddOp" [] [repInt, repByteArray, repInt, repByteArray]) - IntegerSubOp -> simp_op (text "call" <+> ilxSuppMeth repInteger "IntegerSubOp" [] [repInt, repByteArray, repInt, repByteArray]) - IntegerMulOp -> simp_op (text "call" <+> ilxSuppMeth repInteger "IntegerMulOp" [] [repInt, repByteArray, repInt, repByteArray]) - IntegerGcdOp -> simp_op (text "call" <+> ilxSuppMeth repInteger "IntegerGcdOp" [] [repInt, repByteArray, repInt, repByteArray]) - IntegerQuotRemOp -> simp_op (text "call" <+> ilxSuppMeth repIntegerPair "IntegerQuotRemOp" [] [repInt, repByteArray, repInt, repByteArray]) - IntegerDivModOp -> simp_op (text "call" <+> ilxSuppMeth repIntegerPair "IntegerDivModOp" [] [repInt, repByteArray, repInt, repByteArray]) - IntegerIntGcdOp -> simp_op (text "call" <+> ilxSuppMeth repInt "IntegerIntGcdOp" [] [repInt, repByteArray, repInt]) - IntegerDivExactOp -> simp_op (text "call" <+> ilxSuppMeth repInteger "IntegerDivExactOp" [] [repInt, repByteArray, repInt, repByteArray]) - IntegerQuotOp -> simp_op (text "call" <+> ilxSuppMeth repInteger "IntegerQuotOp" [] [repInt, repByteArray, repInt, repByteArray]) - IntegerRemOp -> simp_op (text "call" <+> ilxSuppMeth repInteger "IntegerRemOp" [] [repInt, repByteArray, repInt, repByteArray]) - IntegerCmpOp -> simp_op (text "call" <+> ilxSuppMeth repInt "IntegerCmpOp" [] [repInt, repByteArray, repInt, repByteArray]) - IntegerCmpIntOp -> simp_op (text "call" <+> ilxSuppMeth repInt "IntegerCmpIntOp" [] [repInt, repByteArray, repInt]) - Integer2IntOp -> simp_op (text "call" <+> ilxSuppMeth repInt "Integer2IntOp" [] [repInt, repByteArray]) - Integer2WordOp -> simp_op (text "call" <+> ilxSuppMeth repWord "Integer2WordOp" [] [repInt, repByteArray]) - Int2IntegerOp -> simp_op (text "call" <+> ilxSuppMeth repInteger "Int2IntegerOp" [] [repInt]) - Word2IntegerOp -> simp_op (text "call" <+> ilxSuppMeth repInteger "Word2IntegerOp" [] [repWord]) - IntegerToInt64Op -> simp_op (text "call" <+> ilxSuppMeth repAddr "IntegerToInt64Op" [] [repInt,repByteArray]) - Int64ToIntegerOp -> simp_op (text "call" <+> ilxSuppMeth repInteger "Int64ToIntegerOp" [] [repInt64]) - IntegerToWord64Op -> simp_op (text "call" <+> ilxSuppMeth repWord64 "IntegerToWord64Op" [] [repInt,repByteArray]) - Word64ToIntegerOp -> simp_op (text "call" <+> ilxSuppMeth repInteger "Word64ToIntegerOp" [] [repWord64]) - - IndexOffForeignObjOp_Char -> simp_op (text "add ldind.u1") - IndexOffForeignObjOp_Int -> simp_op (text "ldc.i4 4 mul add ldind.i4") - IndexOffForeignObjOp_Word -> simp_op (text "ldc.i4 4 mul add ldind.u4") - IndexOffForeignObjOp_Addr -> warn_op "IndexOffForeignObjOp Addr: assuing 32 bit architecture" (simp_op (text "ldc.i4 4 mul add ldind.i ")) - IndexOffForeignObjOp_Float -> simp_op (text "ldc.i4 4 mul add ldind.r4") - IndexOffForeignObjOp_Double -> simp_op (text "ldc.i4 8 mul add ldind.r8") - IndexOffForeignObjOp_Int64 -> simp_op (text "ldc.i4 8 mul add ldind.i8") - IndexOffForeignObjOp_Word64 -> simp_op (text "ldc.i4 8 mul add ldind.u8") - - IndexOffAddrOp_Char -> simp_op (text "add ldind.u1") - IndexOffAddrOp_Int -> simp_op (text "ldc.i4 4 mul add ldind.i4") - IndexOffAddrOp_Word -> simp_op (text "ldc.i4 4 mul add ldind.u4") - IndexOffAddrOp_Addr -> warn_op "IndexOffAddrOp Addr: assuing 32 bit architecture" (simp_op (text "ldc.i4 4 mul add ldind.i")) - IndexOffAddrOp_Float -> simp_op (text "ldc.i4 4 mul add ldind.r4") - IndexOffAddrOp_Double -> simp_op (text "ldc.i4 8 mul add ldind.r8") - IndexOffAddrOp_Int64 -> simp_op (text "ldc.i4 8 mul add ldind.i8") - IndexOffAddrOp_Word64 -> simp_op (text "ldc.i4 8 mul add ldind.u8") - - - WriteOffAddrOp_Char -> ty1_arg4_op (\sty addr n v s -> addr <+> n <+> text "add" <+> v <+> text "stind.u1") - WriteOffAddrOp_Int -> ty1_arg4_op (\sty addr n v s -> addr <+> n <+> text "ldc.i4 4 mul add" <+> v <+> text "stind.i4") - WriteOffAddrOp_Word -> ty1_arg4_op (\sty addr n v s -> addr <+> n <+> text "ldc.i4 4 mul add" <+> v <+> text "stind.u4") - WriteOffAddrOp_Addr -> ty1_arg4_op (\sty addr n v s -> addr <+> n <+> text "ldc.i4 4 mul add" <+> v <+> text "stind.i") - WriteOffAddrOp_Float -> ty1_arg4_op (\sty addr n v s -> addr <+> n <+> text "ldc.i4 4 mul add" <+> v <+> text "stind.r4") - WriteOffAddrOp_Double -> ty1_arg4_op (\sty addr n v s -> addr <+> n <+> text "ldc.i4 8 mul add" <+> v <+> text "stind.r8") - WriteOffAddrOp_Int64 -> ty1_arg4_op (\sty addr n v s -> addr <+> n <+> text "ldc.i4 8 mul add" <+> v <+> text "stind.i8") - WriteOffAddrOp_Word64 -> ty1_arg4_op (\sty addr n v s -> addr <+> n <+> text "ldc.i4 8 mul add" <+> v <+> text "stind.u8") - {- Addr# -> Int# -> Char# -> State# s -> State# s -} - - ReadOffAddrOp_Char -> simp_op (text "add ldind.u1") - ReadOffAddrOp_Int -> simp_op (text "ldc.i4 4 mul add ldind.i4") - ReadOffAddrOp_Word -> simp_op (text "ldc.i4 4 mul add ldind.u4") - ReadOffAddrOp_Addr -> simp_op (text "ldc.i4 4 mul add ldind.i") - ReadOffAddrOp_Float -> simp_op (text "ldc.i4 4 mul add ldind.r4") - ReadOffAddrOp_Double -> simp_op (text "ldc.i4 8 mul add ldind.r8") - ReadOffAddrOp_Int64 -> simp_op (text "ldc.i4 8 mul add ldind.i8") - ReadOffAddrOp_Word64 -> simp_op (text "ldc.i4 8 mul add ldind.u8") - {- Addr# -> Int# -> Char# -> State# s -> State# s -} - - IndexByteArrayOp_Char -> simp_op (text "ldelem.u1") - IndexByteArrayOp_Int -> simp_op (text "ldelem.i4") - IndexByteArrayOp_Word -> simp_op (text "ldelem.u4") - IndexByteArrayOp_Addr -> simp_op (text "ldelem.u") - IndexByteArrayOp_Float -> simp_op (text "ldelem.r4") - IndexByteArrayOp_Double -> simp_op (text "ldelem.r8") - IndexByteArrayOp_StablePtr -> simp_op (text "ldelem.i4") - IndexByteArrayOp_Int64 -> simp_op (text "ldelem.i8") - IndexByteArrayOp_Word64 -> simp_op (text "ldelem.u8") + IntegerAndOp -> simp_op (ilxCallSuppMeth repInteger "IntegerAndOp" [] [repInt, repByteArray, repInt, repByteArray]) + IntegerOrOp -> simp_op (ilxCallSuppMeth repInteger "IntegerOrOp" [] [repInt, repByteArray, repInt, repByteArray]) + IntegerXorOp -> simp_op (ilxCallSuppMeth repInteger "IntegerXorOp" [] [repInt, repByteArray, repInt, repByteArray]) + IntegerComplementOp -> simp_op (ilxCallSuppMeth repInteger "IntegerComplementOp" [] [repInt, repByteArray]) + IntegerAddOp -> simp_op (ilxCallSuppMeth repInteger "IntegerAddOp" [] [repInt, repByteArray, repInt, repByteArray]) + IntegerSubOp -> simp_op (ilxCallSuppMeth repInteger "IntegerSubOp" [] [repInt, repByteArray, repInt, repByteArray]) + IntegerMulOp -> simp_op (ilxCallSuppMeth repInteger "IntegerMulOp" [] [repInt, repByteArray, repInt, repByteArray]) + IntegerGcdOp -> simp_op (ilxCallSuppMeth repInteger "IntegerGcdOp" [] [repInt, repByteArray, repInt, repByteArray]) + IntegerQuotRemOp -> simp_op (ilxCallSuppMeth repIntegerPair "IntegerQuotRemOp" [] [repInt, repByteArray, repInt, repByteArray]) + IntegerDivModOp -> simp_op (ilxCallSuppMeth repIntegerPair "IntegerDivModOp" [] [repInt, repByteArray, repInt, repByteArray]) + IntegerIntGcdOp -> simp_op (ilxCallSuppMeth repInt "IntegerIntGcdOp" [] [repInt, repByteArray, repInt]) + IntegerDivExactOp -> simp_op (ilxCallSuppMeth repInteger "IntegerDivExactOp" [] [repInt, repByteArray, repInt, repByteArray]) + IntegerQuotOp -> simp_op (ilxCallSuppMeth repInteger "IntegerQuotOp" [] [repInt, repByteArray, repInt, repByteArray]) + IntegerRemOp -> simp_op (ilxCallSuppMeth repInteger "IntegerRemOp" [] [repInt, repByteArray, repInt, repByteArray]) + IntegerCmpOp -> simp_op (ilxCallSuppMeth repInt "IntegerCmpOp" [] [repInt, repByteArray, repInt, repByteArray]) + IntegerCmpIntOp -> simp_op (ilxCallSuppMeth repInt "IntegerCmpIntOp" [] [repInt, repByteArray, repInt]) + Integer2IntOp -> simp_op (ilxCallSuppMeth repInt "Integer2IntOp" [] [repInt, repByteArray]) + 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]) + Int64ToIntegerOp -> simp_op (ilxCallSuppMeth repInteger "Int64ToIntegerOp" [] [repInt64]) +-- IntegerToWord64Op -> simp_op (ilxCallSuppMeth repWord64 "IntegerToWord64Op" [] [repInt,repByteArray]) + Word64ToIntegerOp -> simp_op (ilxCallSuppMeth repInteger "Word64ToIntegerOp" [] [repWord64]) + + + + IndexByteArrayOp_Char -> simp_op (ilxOp "ldelem.u1") + IndexByteArrayOp_WideChar -> simp_op (ilxOp "ldelem.u4") + IndexByteArrayOp_Int -> simp_op (ilxOp "ldelem.i4") + IndexByteArrayOp_Word -> simp_op (ilxOp "ldelem.u4") + IndexByteArrayOp_Addr -> simp_op (ilxOp "ldelem.u") + IndexByteArrayOp_Float -> simp_op (ilxOp "ldelem.r4") + IndexByteArrayOp_Double -> simp_op (ilxOp "ldelem.r8") + IndexByteArrayOp_StablePtr -> simp_op (ilxOp "ldelem.ref") + IndexByteArrayOp_Int8 -> simp_op (ilxOp "ldelem.i1") + IndexByteArrayOp_Int16 -> simp_op (ilxOp "ldelem.i2") + IndexByteArrayOp_Int32 -> simp_op (ilxOp "ldelem.i4") + IndexByteArrayOp_Int64 -> simp_op (ilxOp "ldelem.i8") + IndexByteArrayOp_Word8 -> simp_op (ilxOp "ldelem.u1") + IndexByteArrayOp_Word16 -> simp_op (ilxOp "ldelem.u2") + IndexByteArrayOp_Word32 -> simp_op (ilxOp "ldelem.u4") + IndexByteArrayOp_Word64 -> simp_op (ilxOp "ldelem.u8") + {- should be monadic??? -} + ReadByteArrayOp_Char -> simp_op (ilxOp "ldelem.u1") + ReadByteArrayOp_WideChar -> simp_op (ilxOp "ldelem.u4") + ReadByteArrayOp_Int -> simp_op (ilxOp "ldelem.i4") + ReadByteArrayOp_Word -> simp_op (ilxOp "ldelem.u4") + ReadByteArrayOp_Addr -> simp_op (ilxOp "ldelem.u") + ReadByteArrayOp_Float -> simp_op (ilxOp "ldelem.r4") + ReadByteArrayOp_Double -> simp_op (ilxOp "ldelem.r8") + ReadByteArrayOp_StablePtr -> simp_op (ilxOp "ldelem.ref") + ReadByteArrayOp_Int8 -> simp_op (ilxOp "ldelem.i1") + ReadByteArrayOp_Int16 -> simp_op (ilxOp "ldelem.i2") + ReadByteArrayOp_Int32 -> simp_op (ilxOp "ldelem.i4") + ReadByteArrayOp_Int64 -> simp_op (ilxOp "ldelem.i8") + ReadByteArrayOp_Word8 -> simp_op (ilxOp "ldelem.u1") + ReadByteArrayOp_Word16 -> simp_op (ilxOp "ldelem.u2") + ReadByteArrayOp_Word32 -> simp_op (ilxOp "ldelem.u4") + ReadByteArrayOp_Word64 -> simp_op (ilxOp "ldelem.u8") + {- MutByteArr# s -> Int# -> State# s -> (# State# s, Char# #) -} {- ByteArr# -> Int# -> Char# -} - WriteByteArrayOp_Char -> simp_op (text "stelem.u1") - WriteByteArrayOp_Int -> simp_op (text "stelem.i4") - WriteByteArrayOp_Word -> simp_op (text "stelem.u4") - WriteByteArrayOp_Addr -> simp_op (text "stelem.u") - WriteByteArrayOp_Float -> simp_op (text "stelem.r4") - WriteByteArrayOp_Double -> simp_op (text "stelem.r8") - WriteByteArrayOp_StablePtr -> simp_op (text "stelem.i4") - WriteByteArrayOp_Int64 -> simp_op (text "stelem.i8") - WriteByteArrayOp_Word64 -> simp_op (text "stelem.u8") + WriteByteArrayOp_Char -> simp_op (ilxOp "stelem.u1") + WriteByteArrayOp_WideChar -> simp_op (ilxOp "stelem.u4") + WriteByteArrayOp_Int -> simp_op (ilxOp "stelem.i4") + WriteByteArrayOp_Word -> simp_op (ilxOp "stelem.u4") + WriteByteArrayOp_Addr -> simp_op (ilxOp "stelem.u") + WriteByteArrayOp_Float -> simp_op (ilxOp "stelem.r4") + WriteByteArrayOp_Double -> simp_op (ilxOp "stelem.r8") + WriteByteArrayOp_StablePtr -> simp_op (ilxOp "stelem.ref") + WriteByteArrayOp_Int8 -> simp_op (ilxOp "stelem.i1") + WriteByteArrayOp_Int16 -> simp_op (ilxOp "stelem.i2") + WriteByteArrayOp_Int32 -> simp_op (ilxOp "stelem.i4") + WriteByteArrayOp_Int64 -> simp_op (ilxOp "stelem.i8") + WriteByteArrayOp_Word8 -> simp_op (ilxOp "stelem.u1") + WriteByteArrayOp_Word16 -> simp_op (ilxOp "stelem.u2") + WriteByteArrayOp_Word32 -> simp_op (ilxOp "stelem.u4") + WriteByteArrayOp_Word64 -> simp_op (ilxOp "stelem.i8 /* nb. no stelem.u8 */") {- MutByteArr# s -> Int# -> Char# -> State# s -> State# s -} - {- should be monadic??? -} - ReadByteArrayOp_Char -> simp_op (text "ldelem.u1") - ReadByteArrayOp_Int -> simp_op (text "ldelem.i4") - ReadByteArrayOp_Word -> simp_op (text "ldelem.u4") - ReadByteArrayOp_Addr -> simp_op (text "ldelem.u") - ReadByteArrayOp_Float -> simp_op (text "ldelem.r4") - ReadByteArrayOp_Double -> simp_op (text "ldelem.r8") - ReadByteArrayOp_StablePtr -> simp_op (text "ldelem.i4") - ReadByteArrayOp_Int64 -> simp_op (text "ldelem.i8") - ReadByteArrayOp_Word64 -> simp_op (text "ldelem.u8") - {- MutByteArr# s -> Int# -> State# s -> (# State# s, Char# #) -} + IndexOffAddrOp_Char -> simp_op (ilxOp "sizeof unsigned int8 mul add ldind.u1") + 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 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") + IndexOffAddrOp_Int16 -> simp_op (ilxOp "sizeof int16 mul add ldind.i2") + IndexOffAddrOp_Int32 -> simp_op (ilxOp "sizeof int32 mul add ldind.i4") + IndexOffAddrOp_Int64 -> simp_op (ilxOp "sizeof int64 mul add ldind.i8") + IndexOffAddrOp_Word8 -> simp_op (ilxOp "sizeof unsigned int8 mul add ldind.u1") + IndexOffAddrOp_Word16 -> simp_op (ilxOp "sizeof unsigned int16 mul add ldind.u2") + IndexOffAddrOp_Word32 -> simp_op (ilxOp "sizeof unsigned int32 mul add ldind.u4") + IndexOffAddrOp_Word64 -> simp_op (ilxOp "sizeof int64 mul add ldind.u8") + + -- 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 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"]) + IndexOffForeignObjOp_Int16 -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof int16 mul add ldind.i2"]) + IndexOffForeignObjOp_Int32 -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof int32 mul add ldind.i4"]) + IndexOffForeignObjOp_Int64 -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof int64 mul add ldind.i8"]) + IndexOffForeignObjOp_Word8 -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof unsigned int8 mul add ldind.u1"]) + IndexOffForeignObjOp_Word16 -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof unsigned int16 mul add ldind.u2"]) + IndexOffForeignObjOp_Word32 -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof unsigned int32 mul add ldind.u4"]) + IndexOffForeignObjOp_Word64 -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof unsigned int64 mul add ldind.u8"]) + + ReadOffAddrOp_Char -> simp_op (ilxOp "sizeof unsigned int8 mul add ldind.u1") + 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 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 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") + ReadOffAddrOp_Int64 -> simp_op (ilxOp "sizeof int64 mul add ldind.i8") + ReadOffAddrOp_Word8 -> simp_op (ilxOp "sizeof unsigned int8 mul add ldind.u1") + ReadOffAddrOp_Word16 -> simp_op (ilxOp "sizeof unsigned int16 mul add ldind.u2") + ReadOffAddrOp_Word32 -> simp_op (ilxOp "sizeof unsigned int32 mul add ldind.u4") + ReadOffAddrOp_Word64 -> simp_op (ilxOp "sizeof unsigned int64 mul add ldind.u8") + {- Addr# -> Int# -> Char# -> State# s -> State# s -} + + WriteOffAddrOp_Char -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr, n, ilxOp "add", v, ilxOp "stind.u1"]) + 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 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 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"]) + WriteOffAddrOp_Int32 -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof int32 mul add",v,ilxOp "stind.i4"]) + WriteOffAddrOp_Int64 -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof int64 mul add",v,ilxOp "stind.i8"]) + WriteOffAddrOp_Word8 -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof unsigned int8 mul add",v,ilxOp "stind.u1"]) + WriteOffAddrOp_Word16 -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof unsigned int16 mul add",v,ilxOp "stind.u2"]) + WriteOffAddrOp_Word32 -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof unsigned int32 mul add",v,ilxOp "stind.u4"]) + WriteOffAddrOp_Word64 -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof unsigned int64 mul add",v,ilxOp "stind.u8"]) + {- Addr# -> Int# -> Char# -> State# s -> State# s -} {- should be monadic??? -} - NewByteArrayOp_Char -> simp_op (text "newarr [mscorlib]System.Byte") --- NewByteArrayOp_Int -> simp_op (text "newarr [mscorlib]System.Int32") --- NewByteArrayOp_Word -> simp_op (text "newarr [mscorlib]System.UInt32") --- NewByteArrayOp_Addr -> simp_op (text "newarr [mscorlib]System.UInt64") --- NewByteArrayOp_Float -> simp_op (text "newarr [mscorlib]System.Single") --- NewByteArrayOp_Double -> simp_op (text "newarr [mscorlib]System.Double") --- NewByteArrayOp_StablePtr -> simp_op (text "newarr [mscorlib]System.UInt32") --- NewByteArrayOp_Int64 -> simp_op (text "newarr [mscorlib]System.Int64") TODO: there is no unique for this one -} --- NewByteArrayOp_Word64 -> simp_op (text "newarr [mscorlib]System.UInt64") -} + 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") +-- NewByteArrayOp_Addr -> simp_op (ilxOp "newarr [mscorlib]System.UInt64") +-- NewByteArrayOp_Float -> simp_op (ilxOp "newarr [mscorlib]System.Single") +-- NewByteArrayOp_Double -> simp_op (ilxOp "newarr [mscorlib]System.Double") +-- NewByteArrayOp_StablePtr -> simp_op (ilxOp "newarr [mscorlib]System.UInt32") +-- 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 -> text "nop ") + UnsafeFreezeByteArrayOp -> ty1_op (\ty1 -> ilxOp "nop ") {- MutByteArr# s -> State# s -> (# State# s, ByteArr# #) -} - SizeofByteArrayOp -> simp_op (text "ldlen") + SizeofByteArrayOp -> simp_op (ilxOp "ldlen") {- ByteArr# -> Int# -} - SameMutableByteArrayOp -> ty1_op (\ty1 -> text "ceq " <+> ilxMkBool) + SameMutableByteArrayOp -> ty1_op (\ty1 -> ilxCeq) {- MutByteArr# s -> MutByteArr# s -> Bool -} - SizeofMutableByteArrayOp -> ty1_op (\ty1 -> text "ldlen") + SizeofMutableByteArrayOp -> ty1_op (\ty1 -> ilxOp "ldlen") {- MutByteArr# s -> Int# -} - SameMutVarOp -> ty2_op (\ty1 ty2 -> text "ceq " <+> ilxMkBool) + SameMutVarOp -> ty2_op (\ty1 ty2 -> ilxCeq) {- MutVar# s a -> MutVar# s a -> Bool -} - NewMutVarOp -> ty2_op (\ty1 ty2 -> text "newobj void" <+> repMutVar ty1 ty2 <+> text "::.ctor(!0)") + NewMutVarOp -> ty2_op (\ty1 ty2 -> ilxOpSeq [ilxOp "newobj void" , repMutVar ty1 ty2 , ilxOp "::.ctor(!0)"]) {- a -> State# s -> (# State# s, MutVar# s a #) -} - ReadMutVarOp -> ty2_op (\ty1 ty2 -> text "ldfld !0" <+> repMutVar ty1 ty2 <+> text "::contents") + ReadMutVarOp -> ty2_op (\ty1 ty2 -> ilxOpSeq [ilxOp "ldfld !0" , repMutVar ty1 ty2 , ilxOp "::contents"]) {- MutVar# s a -> State# s -> (# State# s, a #) -} - WriteMutVarOp -> ty2_op (\ty1 ty2 -> text "stfld !0" <+> repMutVar ty1 ty2 <+> text "::contents") + 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 -> text "call !!0[] " <+> ilxSupportClass <+> text "::newArray<" <> ty1 <> text ">(" <> repInt <> text ", !!0)") + 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 -> text "ldelem.ref") + IndexArrayOp -> ty1_op (\ty1 -> ilxOp "ldelem.ref") {- Array# a -> Int# -> (# a #) -} - WriteArrayOp -> ty2_op (\ty1 ty2 -> text "stelem.ref") + WriteArrayOp -> ty2_op (\ty1 ty2 -> ilxOp "stelem.ref") {- MutArr# s a -> Int# -> a -> State# s -> State# s -} - ReadArrayOp -> ty2_op (\ty1 ty2 -> text "ldelem.ref") + ReadArrayOp -> ty2_op (\ty1 ty2 -> ilxOp "ldelem.ref") {- MutArr# s a -> Int# -> State# s -> (# State# s, a #) -} - UnsafeFreezeArrayOp -> ty2_op (\ty1 ty2 -> text "nop") + UnsafeFreezeArrayOp -> ty2_op (\ty1 ty2 -> ilxOp "nop") {- MutArr# s a -> State# s -> (# State# s, Array# a #) -} - UnsafeThawArrayOp -> ty2_op (\ty1 ty2 -> text "nop") + UnsafeThawArrayOp -> ty2_op (\ty1 ty2 -> ilxOp "nop") {- Array# a -> State# s -> (# State# s, MutArr# s a #) -} - SameMutableArrayOp -> ty2_op (\ty1 ty2 -> text "ceq " <+> ilxMkBool) + SameMutableArrayOp -> ty2_op (\ty1 ty2 -> ilxCeq) {- MutArr# s a -> MutArr# s a -> Bool -} - RaiseOp -> ty2_op (\ty1 ty2 -> text "throw") + RaiseOp -> ty2_op (\ty1 ty2 -> ilxOp "throw") CatchOp -> ty2_op (\ty1 ty2 -> - text "call" <+> ilxSuppMeth ilxMethA "catch" [ty1,ty2] [text "(func () --> !!0)", text "(func (!!1) --> (func () --> !!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 @@ -1970,14 +2153,14 @@ ilxPrimOpTable op -} BlockAsyncExceptionsOp -> ty1_op (\ty1 -> - text "call" <+> ilxSuppMeth ilxMethA "blockAsyncExceptions" [ty1] [text "(func () --> !!0)"]) + ilxCallSuppMeth ilxMethTyVarA "blockAsyncExceptions" [ty1] [ilxLift (ilxTyIO (ilxType "!!0"))]) {- (State# RealWorld -> (# State# RealWorld, a #)) -> (State# RealWorld -> (# State# RealWorld, a #)) -} UnblockAsyncExceptionsOp -> ty1_op (\ty1 -> - text "call" <+> ilxSuppMeth ilxMethA "unblockAsyncExceptions" [ty1] [text "(func () --> !!0)"]) + ilxCallSuppMeth ilxMethTyVarA "unblockAsyncExceptions" [ty1] [ilxLift (ilxTyIO (ilxType "!!0"))]) {- State# RealWorld -> (# State# RealWorld, a #)) @@ -1985,100 +2168,236 @@ ilxPrimOpTable op -} NewMVarOp -> ty2_op (\sty ty -> - text "newobj void " <+> repMVar ty <+> text "::.ctor()") + ilxOpSeq [ilxOp "newobj void " , repMVar ty , ilxOp "::.ctor()"]) {- State# s -> (# State# s, MVar# s a #) -} TakeMVarOp -> ty2_op (\sty ty -> - text "call" <+> ilxSuppMeth 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 ilxMethTyVarA) "tryTakeMVar" [ty] [repMVar ilxMethTyVarA]) + {- MVar# s a -> State# s -> (# State# s, a #) -} + + TryPutMVarOp -> ty2_op (\sty ty -> + ilxCallSuppMeth repInt "tryPutMVar" [ty] [repMVar ilxMethTyVarA,ilxMethTyVarA]) {- MVar# s a -> State# s -> (# State# s, a #) -} PutMVarOp -> ty2_op (\sty ty -> - text "call" <+> ilxSuppMeth (text "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 -> text "ceq " <+> ilxMkBool) + SameMVarOp -> ty2_op (\sty ty -> ilxCeq) {- MVar# s a -> MVar# s a -> Bool -} -- TakeMaybeMVarOp -> ty2_op (\sty ty -> --- text "call" <+> ilxSuppMeth (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 -> - text "call" <+> ilxSuppMeth 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 -> - text "call" <+> ilxSuppMeth repInt "dataToTag" [ty1] [ilxMethA]) + ilxCallSuppMeth repInt "dataToTag" [ty1] [ilxMethTyVarA]) {- a -> Int# -} TagToEnumOp -> ty1_op (\ty1 -> - text "call" <+> ilxSuppMeth ilxMethA "tagToEnum" [ty1] [repInt]) + ilxCallSuppMeth ilxMethTyVarA "tagToEnum" [ty1] [repInt]) {- Int# -> a -} - MakeStablePtrOp -> ty1_op (\ty1 -> text "newobj void class " <+> prelGHCReference <+> text "PrelGHC_StablePtrzh<" <> ty1 <> text ">::.ctor(!0)") + MakeStablePtrOp -> ty1_op (\ty1 -> ilxOpSeq [ilxOp "box", ty1, ilxOp "newobj void", repStablePtr {- ty1 -}, ilxOp "::.ctor(class [mscorlib]System.Object)"]) {- a -> State# RealWorld -> (# State# RealWorld, StablePtr# a #) -} + MakeStableNameOp -> ty1_op (\ty1 -> ilxOpSeq [ilxOp "pop newobj void", repStableName {- ty1 -}, ilxOp "::.ctor()"]) + -- primOpInfo MakeStableNameOp = mkGenPrimOp SLIT("makeStableName#") [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed 2 [mkStatePrimTy realWorldTy, mkStableNamePrimTy alphaTy])) + + EqStableNameOp -> ty1_op (\ty1 -> ilxOp "ceq") + -- [alphaTyVar] [mkStableNamePrimTy alphaTy, mkStableNamePrimTy alphaTy] (intPrimTy) + StableNameToIntOp -> warn_op "StableNameToIntOp" (ty1_op (\ty1 -> ilxOp "pop ldc.i4 0")) + -- [alphaTyVar] [mkStableNamePrimTy alphaTy] (intPrimTy) - DeRefStablePtrOp -> ty1_op (\ty1 -> text "ldfld !0 class " <+> prelGHCReference <+> text "PrelGHC_StablePtrzh<" <> ty1 <> text ">::contents") + DeRefStablePtrOp -> ty1_op (\ty1 -> ilxOpSeq [ilxOp "ldfld class [mscorlib]System.Object", repStablePtr {- ty1 -}, ilxOp "::contents"]) {- StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #) -} - EqStablePtrOp -> ty1_op (\ty1 -> text "ceq " <+> ilxMkBool) + EqStablePtrOp -> ty1_op (\ty1 -> ilxOp "ceq") {- StablePtr# a -> StablePtr# a -> Int# -} - MkWeakOp -> ty3_op (\ty1 ty2 ty3 -> text "call" <+> ilxMethodRef (repWeak (text "!!1")) (text "class " <+> prelGHCReference <+> text "PrelGHC_Weakzh") "bake" [ty1,ty2,ty3] [text "!!0", text "!!1", text "!!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 -> text "call" <+> ilxMethodRef (ilxUnboxedPairRep repInt (text "!0")) (repWeak ty1) "deref" [] []) - FinalizeWeakOp -> ty1_op (\ty1 -> text "call" <+> ilxMethodRef (ilxUnboxedPairRep repInt (text "(func () --> class '()')")) (repWeak ty1) "finalizer" [] []) + 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 #)) #) -} - MkForeignObjOp -> simp_op (text "nop /* newobj void class " <+> prelGHCReference <+> text "PrelGHC_ForeignObjzh::.ctor(void *) */") - WriteForeignObjOp -> simp_op (text "pop /* stfld void * class " <+> prelGHCReference <+> text "PrelGHC_ForeignObjzh::contents */ ") - -- (ForeignObjToAddrOp -> simp_op (text "ldfld void * class " <+> prelGHCReference <+> text "PrelGHC_ForeignObjzh::contents")) - YieldOp -> simp_op (text "call class [mscorlib]System.Threading.Thread class [mscorlib]System.Threading.Thread::get_CurrentThread() - call void class [mscorlib]System.Threading.Thread::Suspend()") - MyThreadIdOp -> simp_op (text "call default class [mscorlib]System.Threading.Thread class [mscorlib]System.Threading.Thread::get_CurrentThread() ") - KillThreadOp -> simp_op (text "call instance void class [mscorlib]System.Threading.Thread::Abort(class [mscorlib]System.Object) ") + MkForeignObjOp -> simp_op (ilxOpSeq [ilxOp "newobj void", repForeign, ilxOp "::.ctor(void *)"]) + WriteForeignObjOp -> ty1_op (\sty -> ilxOpSeq [ilxOp "stfld void *", repForeign, ilxOp "::contents"]) + ForeignObjToAddrOp -> simp_op ilxAddrOfForeignOp + 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() "]) + -- 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 -> ty1_op (\ty -> text "call default class [mscorlib]System.Threading.Thread " <+> ilxSupportClass <+> text "::fork<" <> ty <> text ">(thunk)") + ForkOp -> warn_op "ForkOp" (simp_op (ilxOp "/* ForkOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw")) + ParOp -> warn_op "ParOp" (simp_op (ilxOp "/* ParOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw")) + DelayOp -> simp_op (ilxOp "call void class [mscorlib]System.Threading.Thread::Sleep(int32) ") + {- Int# -> State# s -> State# s -} - ParOp -> warn_op "ParOp" (simp_op (text "/* ParOp skipped... */ pop ldc.i4 0")) + WaitReadOp -> warn_op "WaitReadOp" (simp_op (ilxOp "/* WaitReadOp skipped... */ pop")) + WaitWriteOp -> warn_op "WaitWriteOp" (simp_op (ilxOp " /* WaitWriteOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw")) + ParAtForNowOp -> warn_op "ParAtForNowOp" (simp_op (ilxOp " /* ParAtForNowOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw")) + ParAtRelOp -> warn_op "ParAtRelOp" (simp_op (ilxOp " /* ParAtRelOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw")) + ParAtAbsOp -> warn_op "ParAtAbsOp" (simp_op (ilxOp " /* ParAtAbsOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw")) + ParAtOp -> warn_op "ParAtOp" (simp_op (ilxOp " /* ParAtOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw")) + ParLocalOp -> warn_op "ParLocalOp" (simp_op (ilxOp " /* ParLocalOp 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") + + 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 +ty1_op op ((StgTypeArg ty1):rest) = + ilxOpSeq [getArgsStartingAt 1 rest, + op (ilxTypeR2 (deepIlxRepType ty1))] + +ty2_op :: (IlxTyFrag -> IlxTyFrag -> IlxOpFrag) -> [StgArg] -> IlxOpFrag +ty2_op op ((StgTypeArg ty1):(StgTypeArg ty2):rest) = + ilxOpSeq [getArgsStartingAt 2 rest, + op (ilxTypeR2 (deepIlxRepType ty1)) + (ilxTypeR2 (deepIlxRepType ty2))] + +ty3_op :: (IlxTyFrag -> IlxTyFrag -> IlxTyFrag -> IlxOpFrag) -> [StgArg] -> IlxOpFrag +ty3_op op ((StgTypeArg ty1):(StgTypeArg ty2):(StgTypeArg ty3):rest) = + ilxOpSeq [getArgsStartingAt 3 rest, + op (ilxTypeR2 (deepIlxRepType ty1)) + (ilxTypeR2 (deepIlxRepType ty2)) + (ilxTypeR2 (deepIlxRepType ty3))] + +arg2_op :: (IlxTyFrag -> IlxOpFrag -> IlxOpFrag) -> [StgArg] -> IlxOpFrag +arg2_op op [a1, a2] = + op (getAsArg 1 a1) + (getAsArg 2 a2) + +ty1_arg2_op :: (IlxTyFrag -> IlxOpFrag -> IlxOpFrag -> IlxOpFrag) -> [StgArg] -> IlxOpFrag +ty1_arg2_op op [(StgTypeArg ty1), a1, a2] = + op (ilxTypeR2 (deepIlxRepType ty1)) + (getAsArg 1 a1) + (getAsArg 2 a2) + +ty1_arg4_op :: (IlxTyFrag -> IlxOpFrag -> IlxOpFrag -> IlxOpFrag -> IlxOpFrag -> IlxOpFrag) -> [StgArg] -> IlxOpFrag +ty1_arg4_op op [(StgTypeArg ty1), a1, a2, a3, a4] = + op (ilxTypeR2 (deepIlxRepType ty1)) + (getAsArg 1 a1) + (getAsArg 2 a2) + (getAsArg 3 a3) + (getAsArg 4 a4) + +ty2_arg4_op :: (IlxTyFrag -> IlxTyFrag -> IlxOpFrag -> IlxOpFrag -> IlxOpFrag -> IlxOpFrag -> IlxOpFrag) -> [StgArg] -> IlxOpFrag +ty2_arg4_op op [(StgTypeArg ty1), (StgTypeArg ty2),a1, a2, a3, a4] = + op (ilxTypeR2 (deepIlxRepType ty1)) + (ilxTypeR2 (deepIlxRepType ty2)) + (getAsArg 2 a1) + (getAsArg 3 a2) + (getAsArg 4 a3) + (getAsArg 5 a4) - DelayOp -> simp_op (text "call void class [mscorlib]System.Threading.Thread::Sleep(int32) ") - {- Int# -> State# s -> State# s -} +hd (h:t) = h + +getAsArg n a env = hd (ilxMapPlaceArgs n pushArg env [a]) +getArgsStartingAt n a env = vcat (ilxMapPlaceArgs n pushArg env a) + +simp_op :: IlxOpFrag -> [StgArg] -> IlxOpFrag +simp_op op args env = vcat (ilxMapPlaceArgs 0 pushArg env args) $$ op env +warn_op warning f args = trace ("WARNING! IlxGen cannot translate primop " ++ warning) (f args) +\end{code} + +%************************************************************************ +%* * +\subsection{C Calls} +%* * +%************************************************************************ + +\begin{code} +-- Call the P/Invoke stub wrapper generated in the import section. +-- We eliminate voids in and around an IL C Call. +-- 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) <+> + vcat [vcat (ilxMapPlaceArgs 0 pushCArg env 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" + | otherwise = ilxTypeR env (deepIlxRepType ret_ty) + (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") <+> + vcat [vcat (ilxMapPlaceArgs 0 pushEvalArg env tm_args), + ptext call_instr + -- In due course we'll need to pass the type arguments + -- and to do that we'll need to have more than just a string + -- for call_instr + ] + where + (ty_args,tm_args) = splitTyArgs1 args + +-- Push and argument and force its evaluation if necessary. +pushEvalArg _ (StgTypeArg _) = empty +pushEvalArg env (StgVarArg arg) = ilxFunApp env arg [] False +pushEvalArg env (StgLitArg lit) = pushLit env lit - WaitReadOp -> warn_op "WaitReadOp" (simp_op (text "/* WaitReadOp skipped... */ pop")) - WaitWriteOp -> warn_op "WaitWriteOp" (simp_op (text " /* WaitWriteOp skipped... */ pop")) - -- DEFAULT CASE - other -> \env args -> ilxComment (simp_op (text "Unknown primop!:" <+> pprId op) env args) +hasTyCon (TyConApp tc _) tc2 = tc == tc2 +hasTyCon _ _ = False + +isByteArrayCArgTy ty = hasTyCon ty byteArrayPrimTyCon || hasTyCon ty mutableByteArrayPrimTyCon +isByteArrayCArg v = isByteArrayCArgTy (deepIlxRepType (idType v)) +isForeignObjCArgTy ty = hasTyCon ty foreignObjPrimTyCon +isForeignObjCArg v = isForeignObjCArgTy (deepIlxRepType (idType v)) +pinCCallArg v = isByteArrayCArg v || isForeignObjCArg v -ty1_op op env ((StgTypeArg ty1):rest) = - vcat (ilxMapPlaceArgs 1 pushArg env rest) $$ op (pprIlxTypeR env (deepIlxRepType ty1)) ---ty1_after1_op op env (h:(StgTypeArg ty1):rest) = --- vcat (ilxMapPlaceArgs 0 pushArg env [h]) $$ vcat (ilxMapPlaceArgs 2 pushArg env rest) $$ op (pprIlxTypeR env (deepIlxRepType ty1)) -ty2_op op env ((StgTypeArg ty1):(StgTypeArg ty2):rest) = - vcat (ilxMapPlaceArgs 2 pushArg env rest) $$ op (pprIlxTypeR env (deepIlxRepType ty1)) (pprIlxTypeR env (deepIlxRepType ty2)) +pinCArg env arg v = pushArg env arg <+> text "dup stloc" <+> singleQuotes (ilxEnvQualifyByExact env (ppr v) <> text "pin") +pushCArg env arg@(StgVarArg v) | isByteArrayCArg v = pinCArg env arg v <+> ilxAddrOfByteArrOp env +pushCArg env arg@(StgVarArg v) | isForeignObjCArg v = pinCArg env arg v <+> ilxAddrOfForeignOp env +pushCArg env arg | otherwise = pushArg env arg -ty3_op op env ((StgTypeArg ty1):(StgTypeArg ty2):(StgTypeArg ty3):rest) = - vcat (ilxMapPlaceArgs 2 pushArg env rest) $$ - op (pprIlxTypeR env (deepIlxRepType ty1)) - (pprIlxTypeR env (deepIlxRepType ty2)) - (pprIlxTypeR env (deepIlxRepType ty3)) +pprCValArgTys f env tys = parens (pprSepWithCommas (pprCValArgTy f env) tys) +pprCValArgTy f env ty | isByteArrayCArgTy ty = text "void *" <+> ilxComment (text "interior pointer into ByteArr#") +pprCValArgTy f env ty | isForeignObjCArgTy ty = text "void *" <+> ilxComment (text "foreign object") +pprCValArgTy f env ty | otherwise = f env ty -ty1_arg4_op op env [(StgTypeArg ty1), a1, a2, a3, a4] = - op (pprIlxTypeR env (deepIlxRepType ty1)) - (hd2 (ilxMapPlaceArgs 1 pushArg env [a1]) ) - (hd2 (ilxMapPlaceArgs 2 pushArg env [a2]) ) - (hd2 (ilxMapPlaceArgs 3 pushArg env [a3]) ) - (hd2 (ilxMapPlaceArgs 4 pushArg env [a4]) ) -hd (h:t) = h -hd2 (h:t) = h +foldR :: (a -> b -> b) -> [a] -> b -> b +-- foldR _ [] z = z +-- foldR f (x:xs) z = f x (foldR f xs z) +{-# INLINE foldR #-} +foldR k xs z = go xs + where + go [] = z + go (y:ys) = y `k` go ys -simp_op op env args = vcat (ilxMapPlaceArgs 0 pushArg env args) $$ op -warn_op warning f args = trace ("WARNING! IlxGen cannot translate primop " ++ warning) (f args) \end{code} +