diff options
Diffstat (limited to 'compiler/ilxGen/IlxGen.lhs')
| -rw-r--r-- | compiler/ilxGen/IlxGen.lhs | 2403 |
1 files changed, 2403 insertions, 0 deletions
diff --git a/compiler/ilxGen/IlxGen.lhs b/compiler/ilxGen/IlxGen.lhs new file mode 100644 index 0000000000..19e9f76ecf --- /dev/null +++ b/compiler/ilxGen/IlxGen.lhs @@ -0,0 +1,2403 @@ +% +\section{Generate .NET extended IL} + +\begin{code} +module IlxGen( ilxGen ) where + +#include "HsVersions.h" + +import Char ( ord, chr ) +import StgSyn +import Id ( idType, idName, isDeadBinder, idArity ) +import Var ( Var, Id, TyVar, isId, isTyVar, tyVarKind, tyVarName ) +import VarEnv +import VarSet ( isEmptyVarSet ) +import TyCon ( TyCon, tyConPrimRep, isUnboxedTupleTyCon, tyConDataCons, + tyConTyVars, isDataTyCon, isAlgTyCon, tyConArity + ) +import Type ( liftedTypeKind, openTypeKind, unliftedTypeKind, + isUnLiftedType, isTyVarTy, mkTyVarTy, predTypeRep, pprType, + splitForAllTys, splitFunTys, applyTy, applyTys, eqKind, tyVarsOfTypes + ) +import TypeRep ( Type(..) ) +import DataCon ( isUnboxedTupleCon, dataConTyCon, dataConRepType, dataConRepArgTys, DataCon(..) ) +import Literal ( Literal(..) ) +import PrelNames -- Lots of keys +import PrimOp ( PrimOp(..) ) +import ForeignCall ( CCallConv(..), ForeignCall(..), CCallSpec(..), CCallTarget(..), DNCallSpec(..) ) +import TysWiredIn ( mkTupleTy, tupleCon ) +import PrimRep ( PrimRep(..) ) +import Name ( nameModule, nameOccName, isExternalName, isInternalName, NamedThing(getName) ) +import Subst ( substTyWith ) + +import Module ( Module, PackageName, ModuleName, moduleName, + modulePackage, basePackage, + isHomeModule, isVanillaModule, + pprModuleName, mkHomeModule, mkModuleName + ) + +import UniqFM +import BasicTypes ( Boxity(..) ) +import CStrings ( CLabelString, pprCLabelString ) +import Outputable +import Char ( ord ) +import List ( partition, elem, insertBy,any ) +import UniqSet + +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 DynFlags ( opt_InPackage, opt_SimplDoEtaReduction ) + +import Util ( lengthIs, equalLength ) + +\end{code} + + + +%************************************************************************ +%* * +\subsection{Main driver} +%* * +%************************************************************************ + +\begin{code} +ilxGen :: Module -> [TyCon] -> [(StgBinding,[Id])] -> SDoc + -- The TyCons should include those arising from classes +ilxGen mod tycons binds_w_srts + = 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 + 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} + +%************************************************************************ +%* * +\subsection{Find Imports} +%* * +%************************************************************************ + +\begin{code} + +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 + +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 + +importsExpr env (StgOpApp _ args res_ty) = importsType env res_ty. importsStgArgs env args + + +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 _ alg_alts deflt) -- The Maybe TyCon part is dealt with + -- by the case-binder's type + = foldR imports_alg_alt alg_alts . imports_deflt deflt + where + imports_alg_alt (con, bndrs, _, rhs) + = importsExpr env rhs . importsDataCon env con. importsVars env bndrs + + imports_alts (StgPrimAlts _ alg_alts deflt) + = foldR imports_prim_alt alg_alts . imports_deflt deflt + where + imports_prim_alt (_, rhs) = importsExpr env rhs + imports_deflt StgNoDefault = importsNone + imports_deflt (StgBindDefault rhs) = importsExpr env rhs + + +importsExpr env (StgLetNoEscape _ _ bind body) = importsExpr env (StgLet bind body) +importsExpr env (StgLet bind body) + = importsBind env bind . importsExpr env body + +importsApp env v args = importsVar env v. importsStgArgs env args +importsStgArgs env args = foldR (importsStgArg env) args + +importsStgArg :: IlxEnv -> StgArg -> ImportsInfo -> ImportsInfo +importsStgArg env (StgTypeArg ty) = importsType env ty +importsStgArg env (StgVarArg v) = importsVar env v +importsStgArg env _ = importsNone + +importsVars env vs = foldR (importsVar env) vs +importsVar env v = importsName env (idName v). importsType env (idType v) + +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)) + + +importsPrelude | inPrelude = addModuleImpInfo (mkModuleName "PrelGHC") + | otherwise = addPackageImpInfo basePackage + + +importsType :: IlxEnv -> Type -> ImportsInfo -> ImportsInfo +importsType env ty = importsType2 env (deepIlxRepType ty) + +importsType2 :: IlxEnv -> Type -> ImportsInfo -> ImportsInfo +importsType2 env (AppTy f x) = importsType2 env f . importsType2 env x +importsType2 env (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 + +importsDataCon env dcon = importsTyCon env (dataConTyCon dcon) + +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) + + +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) + + +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 = ilxTyConDef True env tycon +ilxImportTyCon _ _ | otherwise = empty + +ilxImportPackage :: IlxEnv -> PackageName -> SDoc +ilxImportPackage _ p = text ".assembly extern" <+> singleQuotes (ppr p <> hscOptionQual) <+> text "{ }" + +ilxImportModule :: IlxEnv -> ModuleName -> SDoc +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} + +%************************************************************************ +%* * +\subsection{Type declarations} +%* * +%************************************************************************ + +\begin{code} + + +ilxTyCon :: IlxEnv -> TyCon -> SDoc +ilxTyCon env tycon = ilxTyConDef False env tycon + +-- filter to get only dataTyCons? +ilxTyConDef importing env tycon = + vcat [empty $$ line, + 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, _) = categorizeTyVars tyvars + alts_env = extendIlxEnvWithFormalTyVars env ilx_tvs + tyvars_text = pprTyVarBinders alts_env ilx_tvs + alts = vcat (map (pprIlxDataCon alts_env) (tyConDataCons tycon)) + alts_text = nest 2 (braces alts) + +pprIlxDataCon env dcon = + text ".alternative" <+> pprId dcon <+> + parens (pprSepWithCommas (ilxTypeL env) (map deepIlxRepType (filter (not. isVoidIlxRepType) (dataConRepArgTys dcon)))) +\end{code} + + +%************************************************************************ +%* * +\subsection{Getting the .closures and literals out} * +%************************************************************************ + +\begin{code} + +ilxBindClosures :: IlxEnv -> StgBinding -> SDoc +ilxBindClosures env (StgNonRec _ b rhs) = ilxRhsClosures env (b,rhs) +ilxBindClosures env (StgRec _ pairs) + = vcat (map (ilxRhsClosures new_env) pairs) + where + new_env = extendIlxEnvWithBinds env pairs + +--------------- +ilxRhsClosures _ (_, StgRhsCon _ _ _) + = empty + +ilxRhsClosures env (bndr, StgRhsClosure _ _ fvs upd args rhs) + = vcat [ilxExprClosures next_env rhs, + + empty $$ line, + kind_text <+> singleQuotes cloname <+> free_vs_text, + nest 2 (braces ( + nest 2 (vcat [empty, + vcat [text ".apply" <+> closure_sig_text, + body_text + ], + empty + ]) + )) + ] + where + kind_of_thing = case upd of + Updatable -> ASSERT( null args ) ".thunk" + otherwise -> ".closure" + kind_text = text kind_of_thing + + cloname = ilxEnvQualifyByModule env (ppr bndr) + next_env = ilxPlaceStgRhsClosure env bndr + (free_vs_text,env_with_fvs) = pprFreeBinders next_env fvs + + + closure_sig_text = + vcat [ text "()", + (case args of + [] -> empty + otherwise -> args_text), + text "-->" <+> rty_text] + + (args_text,env_with_args) = pprArgBinders env_with_fvs args + + -- 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) -> + 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 + -- we go. + retType env ty [] = Just (env, ty) + retType env (ForAllTy tv ty) (arg:args) = retType (extendIlxEnvWithTyArgs env [tv]) ty args + retType env (FunTy l r) (arg:args) = retType env r args + retType _ _ _ = Nothing + + -- Code for the local variables + locals = ilxExprLocals env_with_args rhs + + env_with_locals = extendIlxEnvWithLocals env_with_args locals + + -- Code for the body of the main apply method + body_code = vcat [empty, + pprIlxLocals env_with_args locals, + ilxExpr (IlxEEnv env_with_locals (mkUniqSet (filter (not.isTyVar) args))) rhs Return, + empty + ] + + body_text = nest 2 (braces (text ".maxstack 100" <+> nest 2 body_code)) + + +pprIlxLocals env [] = empty +pprIlxLocals env vs + = text ".locals" <+> parens (pprSepWithCommas (pprIlxLocal env) (filter nonVoidLocal vs)) + where + nonVoidLocal (LocalId v,_) = not (isVoidIlxRepId v) + nonVoidLocal _ = True + +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_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 = ilxTypeL env1 (idIlxRepType v) <+> pprId v + env2 = extendIlxEnvWithFreeVars env1 real_free_vs + +pprIdBinder env v = parens (ilxTypeL env (idIlxRepType v) <+> pprId v) + + -- Declarations for the arguments of the main apply method +pprArgBinders env [] = (empty,env) +pprArgBinders env (arg:args) + = (arg_text <+> rest_text, res_env) + where + (arg_text,env') = pprArgBinder env arg + (rest_text,res_env) = pprArgBinders env' args + +-- We could probably omit some void argument binders, but +-- don't... +pprArgBinder env arg + | isVoidIlxRepId arg = (text "()", extendIlxEnvWithArgs env [arg]) + | otherwise + = if isTyVar arg then + let env' = extendIlxEnvWithTyArgs env [arg] in + (pprTyVarBinder env' arg, env') + else (pprIdBinder env arg,extendIlxEnvWithArgs env [arg]) + +-------------- +-- Compute local variables used by generated method. +-- The names of some generated locals are recorded as SDocs. + +data LocalSpec = LocalId Id | LocalSDoc (Type, SDoc, Bool) -- flag is for pinning + +ilxExprLocals :: IlxEnv -> StgExpr -> [(LocalSpec,Maybe (IlxEnv,StgRhs))] +ilxExprLocals env (StgLet bind body) = ilxBindLocals env bind ++ ilxExprLocals env body +ilxExprLocals env (StgLetNoEscape _ _ bind body) = ilxBindLocals env bind ++ ilxExprLocals env body -- TO DO???? +ilxExprLocals env (StgCase scrut _ _ bndr _ alts) + = ilxExprLocals (ilxPlaceStgCaseScrut env) scrut ++ + (if isDeadBinder bndr then [] else [(LocalId bndr,Nothing)]) ++ + ilxAltsLocals env alts +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 (StgVarArg v) | pinCCallArg v = + [(LocalSDoc (idType v, ilxEnvQualifyByExact env (ppr v) <> text "pin", True), Nothing)] +ilxCCallArgLocals _ _ | otherwise = [] + +ilxBindLocals env (StgNonRec _ b rhs) = [(LocalId b,Just (env, rhs))] +ilxBindLocals env (StgRec _ pairs) = map (\(x,y) -> (LocalId x,Just (env, y))) pairs + +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 (_, 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 _ StgNoDefault = [] +ilxDefltLocals env (StgBindDefault rhs) = ilxExprLocals (ilxPlaceStgBindDefault env) rhs + +-------------- +ilxExprClosures :: IlxEnv -> StgExpr -> SDoc +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 (StgOpApp _ args _) + = vcat (ilxMapPlaceArgs 0 (ilxArgClosures) env args) -- get strings +ilxExprClosures env (StgLet bind body) + = ilxBindClosures env bind $$ ilxExprClosures (extendIlxEnvWithBinds env (ilxPairs1 bind)) body +ilxExprClosures env (StgLetNoEscape _ _ bind body) -- TO DO???? + = ilxBindClosures env bind $$ ilxExprClosures (extendIlxEnvWithBinds env (ilxPairs1 bind)) body +ilxExprClosures env (StgCase scrut _ _ _ _ alts) + = ilxExprClosures (ilxPlaceStgCaseScrut env) scrut $$ ilxAltsClosures env alts +ilxExprClosures env (StgLit lit) + = ilxGenLit env lit +ilxExprClosures _ _ + = empty + +ilxAltsClosures env (StgAlgAlts _ alts deflt) + = vcat [ilxExprClosures (ilxPlaceAlt env i) rhs | (i,(_, _, _, rhs)) <- [1..] `zip` alts] + $$ + ilxDefltClosures env deflt + +ilxAltsClosures env (StgPrimAlts _ alts deflt) + = vcat [ilxExprClosures (ilxPlaceAlt env i) rhs | (i,(_, rhs)) <- [1..] `zip` alts] + $$ + vcat [ ilxGenLit (ilxPlacePrimAltLit env i) lit | (i,(lit,_)) <- [1..] `zip` alts] + $$ + ilxDefltClosures env deflt + +ilxDefltClosures env (StgBindDefault rhs) = ilxExprClosures (ilxPlaceStgBindDefault env) rhs +ilxDefltClosures _ StgNoDefault = empty + +ilxArgClosures env (StgLitArg lit) = ilxGenLit env lit +ilxArgClosures _ _ = empty + + + +ilxGenLit env (MachStr fs) + = vcat [text ".field static assembly char " <+> singleQuotes nm <+> text "at" <+> nm <> text "L", + text ".data" <+> nm <> text "L" <+> text "= char *(" <> pprFSInILStyle fs <> text ")" + ] + where + nm = ilxEnvQualifyByExact env (text "string") + +ilxGenLit _ _ = empty + +\end{code} + + +%************************************************************************ +%* * +\subsection{Generating code} +%* * +%************************************************************************ + + +\begin{code} + +-- Environment when generating expressions +data IlxEEnv = IlxEEnv IlxEnv (UniqSet Id) + +data Sequel = Return | Jump IlxLabel + +ilxSequel Return = text "ret" +ilxSequel (Jump lbl) = text "br" <+> pprIlxLabel lbl + +isReturn Return = True +isReturn (Jump _) = False + + +ilxExpr :: IlxEEnv -> StgExpr + -> Sequel -- What to do at the end + -> SDoc + +ilxExpr (IlxEEnv env _) (StgApp fun args) sequel + = ilxFunApp env fun args (isReturn sequel) $$ ilxSequel sequel + +-- ilxExpr eenv (StgLit lit) sequel +ilxExpr (IlxEEnv env _) (StgLit lit) sequel + = pushLit env lit $$ ilxSequel sequel + +-- ilxExpr eenv (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 (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 _ _ _ _ [] rhs)) (StgApp fun [])) sequel + | (bndr == fun && null (ilxExprLocals env rhs)) -- TO DO??? + = ilxExpr eenv rhs 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 + +ilxExpr eenv (StgLet bind body) sequel + = ilxBind eenv bind $$ ilxExpr eenv body sequel + + +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 + = 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 + ilxAlts (IlxEEnv env live_in_case) bndr alts sequel + ] + +-- StgCase: Special case 2 to avoid spurious branch. +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)), + 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 + = 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 + 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 +-- in the JIT would tell the GC that these locals and arguments are +-- no longer live. However I'm putting it in here so we can +-- check out if it helps. +-- +-- Also, in any case this doesn't capture everything we need. e.g. +-- when making a call: +-- case f x of ... +-- where x is not used in the alternatives, then the variable x +-- is no longer live from the point it is transferred to the call +-- onwards. We should expunge "live_in_case - live_in_alts" right +-- before making the call, not after returning from the call.... +-- +-- Strictly speaking we also don't need to do this for primitive +-- values such as integers and addresses, i.e. things not +-- mapped down to GC'able objects. +ilxWipe env ids + = vcat (map (ilxWipeOne env) (filter (not.isVoidIlxRepId) ids)) + +ilxWipeOne env id + = case lookupIlxVarEnv env id of + 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 + + +---------------------- + +ilxAlts :: IlxEEnv -> Id -> StgCaseAlts -> Sequel -> SDoc +ilxAlts (IlxEEnv env live) bndr alts sequel + -- At the join label, the result is on top + -- of the stack + = vcat [store_in_bndr, + do_case_analysis alts + ] + where + scrut_rep_ty = deepIlxRepType (idType bndr) + + store_in_bndr | isDeadBinder bndr = empty + | isVoidIlxRepId bndr + = ilxComment (text "ignoring store of zero-rep value to be analyzed") + | otherwise = text "dup" $$ (text "stloc" <+> pprId bndr) + + do_case_analysis (StgAlgAlts _ [] deflt) + = do_deflt deflt + + do_case_analysis (StgAlgAlts _ args deflt) + = do_alg_alts ([1..] `zip` args) deflt + + do_case_analysis (StgPrimAlts _ alts deflt) + = do_prim_alts ([1..] `zip` alts) $$ do_deflt deflt + + do_alg_alts [(i, alt@(data_con,bndrs,used_flags, rhs))] StgNoDefault | isUnboxedTupleCon data_con + -- Collapse the analysis of unboxed tuples where + -- some or all elements are zero-sized + -- + -- TO DO: add bndrs to set of live variables + = case bndrs' of + [h] -> bind_collapse bndrs used_flags <+> do_rhs_no_pop alt_env rhs + _ -> bind_components alt_env dcon' bndrs 0 used_flags <+> do_rhs alt_env rhs + where + bndrs' = filter (not. isVoidIlxRepId) bndrs + -- Replacement unboxed tuple type constructor, used if any of the + -- arguments have zero-size and more than one remains. + dcon' = tupleCon Unboxed (length bndrs') + + alt_env = IlxEEnv (ilxPlaceAlt env i) live + --alt_env = IlxEEnv (ilxPlaceAlt env i) + + bind_collapse [] _ = panic "bind_collapse: unary element not found" + bind_collapse (h:t) (is_used:used_flags) + | isVoidIlxRepId h = ilxComment (text "zero-rep binding eliminated") <+> (bind_collapse t used_flags) + | not is_used = ilxComment (text "not used") <+> text "pop" + | otherwise = text "stloc" <+> pprId h + + + do_alg_alts [(i, alt@(data_con,bndrs,used_flags, rhs))] StgNoDefault + = 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 [ilxTypeR env scrut_rep_ty,text ",", + pprSepWithCommas pp_case labels_w_alts], + do_deflt deflt, + vcat (map do_labelled_alg_alt labels_w_alts) + ] + where + pp_case (i, (lbl, (data_con, _, _, _))) = parens (ilxConRef env data_con <> comma <> pprIlxLabel lbl) + labels_w_alts = [(i,(mkAltLabel bndr i, alt)) | (i, alt) <- alts] + + do_prim_alts [] = empty + do_prim_alts ((i, (lit,alt)) : alts) + = vcat [text "dup", pushLit (ilxPlacePrimAltLit env i) lit, text "bne.un" <+> pprIlxLabel lbl, + do_rhs (IlxEEnv (ilxPlaceAlt env i) live) alt, + ilxLabel lbl, do_prim_alts alts] + where + lbl = mkAltLabel bndr i + + do_labelled_alg_alt (i,(lbl, alt)) + = ilxLabel lbl $$ do_alg_alt (IlxEEnv (ilxPlaceAlt env i) live) alt + + do_alg_alt alt_eenv (data_con, bndrs, used_flags, rhs) + = vcat [bind_components alt_eenv data_con bndrs 0 used_flags, + do_rhs alt_eenv rhs + ] + + bind_components alt_eenv data_con [] n _ = empty + bind_components alt_eenv data_con (h:t) n (is_used:used_flags) + | isVoidIlxRepId h + -- don't increase the count in this case + = ilxComment (text "zero-rep binding eliminated") + <+> bind_components alt_eenv data_con t n used_flags + | otherwise + = bind_component alt_eenv data_con h is_used n + <+> bind_components alt_eenv data_con t (n + 1) used_flags + + bind_component alt_eenv@(IlxEEnv alt_env _) data_con bndr is_used reduced_fld_no + | not is_used + = ilxComment (text "not used") + | isVoidIlxRepId bndr + = ilxComment (text "ignoring bind of zero-rep variable") + | otherwise = vcat [text "dup", + ld_data alt_env data_con reduced_fld_no bndr, + text "stloc" <+> pprId bndr] + + do_deflt (StgBindDefault rhs) = do_rhs (IlxEEnv (ilxPlaceStgBindDefault env) live) rhs + do_deflt StgNoDefault = empty + + do_rhs alt_eenv rhs + | isVoidIlxRepId bndr = do_rhs_no_pop alt_eenv rhs -- void on the stack, nothing to pop + | otherwise = text "pop" $$ do_rhs_no_pop alt_eenv rhs -- drop the value + + do_rhs_no_pop alt_env rhs = ilxExpr alt_env rhs sequel + + ld_data alt_env data_con reduced_fld_no bndr + | isUnboxedTupleCon data_con + = text "ldfld" <+> sep [text "!" <> integer reduced_fld_no, + ilxTypeR alt_env scrut_rep_ty <> text "::fld" <> integer reduced_fld_no] + | otherwise + = text "lddata" <+> sep [ilxTypeR alt_env scrut_rep_ty <> comma, + ilxConRef env data_con <> comma, + integer reduced_fld_no] + + +------------------------- + +ilxBestTermArity = 3 +ilxBestTypeArity = 7 + + +-- Constants of unlifted types are represented as +-- applications to no arguments. +ilxFunApp env fun [] _ | isUnLiftedType (idType fun) + = pushId env fun + +ilxFunApp env fun args tail_call + = -- For example: + -- ldloc f function of type forall a. a->a + -- ldloc x arg of type Int + -- .tail callfunc <Int32> (!0) --> !0 + -- + 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 <Int32> (!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 (_, StgRhsClosure _ _ _ Updatable _ _) -> Nothing + Just (place, StgRhsClosure _ _ fvs _ args _) -> Just (place,fun,args,fvs) + _ -> 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, 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 <+> (if num_sofar == 0 then text "() /* first step in every Haskell app. is to a thunk */ " else empty) + <+> now_args_text + <+> text "-->" + <+> later_ty_text, + later + ] + where + 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 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 + -- arbitrary numbers, but you will get more succinct + -- (and perhaps more efficient) IL code + -- if you apply in clumps according to its maxArity setting. + -- This is because it has to unwind the stack and store it away + -- in local variables to do the partial applications. + -- + -- Similarly, ILX only allows one type application at a time, at + -- least until we implement unwinding the stack for this case. + -- + -- NB: In the future we may have to be more careful + -- all the way through + -- this file to bind type variables as we move through + -- type abstractions and "forall" types. This would apply + -- especially if the type variables were ever bound by expressions + -- involving the type variables. + + -- This part strips off at most "max" term applications or one type application + get_type_args 0 args env funty = ([],[],env,args,funty) + get_type_args max args env (NoteTy _ ty) = + trace "IlxGen Internal Error: non representation type passed to get_args" (get_type_args max args env ty) + 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 (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) + else + get_type_args max rest env rem_funty -- ? subst?? + 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) + + 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 + [] -> True + _ -> False + + -- If so, generate the subsequent calls. + later = if done then text "// done" + else ilxFunAppArgs env (num_sofar + length now_args) later_ty later_args tail_call Nothing + + -- Work out whether to issue a direct call a known closure (callclo) or + -- an indirect call (callfunc). Basically, see if the identifier has + -- been let-bound, and then check we are applying exactly the right + -- number of arguments. Also check that it's not a thunk (actually, this + -- is done up above). + -- + -- The nasty "all" check makes sure that + -- the set of type variables in scope at the callsite is a superset + -- of the set of type variables needed for the direct call. This is + -- is needed because not all of the type variables captured by a + -- let-bound binding will get propogated down to the callsite, and + -- the ILX system of polymorphism demands that the free type variables + -- get reapplied when we issue the direct "callclo". The + -- type variables are in reality also "bound up" in the closure that is + -- passed as the first argument, so when we do an indirect call + -- to that closure we're fine, which is why we don't need them in + -- the "callfunc" case. + basic_call_instr = + case known_clo of + Just (known_env,fun,needed,fvs) | (equalLength needed now_args) && + all (\x -> elemIlxTyEnv x env) free_ilx_tvs -> + vcat [text "callclo class", + nameReference env (idName fun) <+> singleQuotes (ilxEnvQualifyByModule env (ppr fun)), + pprTypeArgs ilxTypeR env (map mkTyVarTy free_ilx_tvs)] + <> text "," + where + (free_ilx_tvs, free_non_ilx_tvs,free_vs) = categorizeVars fvs + otherwise -> text "callfunc" + call_instr = + if (tail_call && done) then text "tail." <+> basic_call_instr + else basic_call_instr + + +-------------------------- +-- Print the arg info at the call site +-- For type args we are, at the moment, required to +-- give both the actual and the formal (bound). The formal +-- bound is always System.Object at the moment (bounds are +-- not properly implemented in ILXASM in any case, and nor do +-- we plan on making use og them) For +-- non-type args the actuals are on the stack, and we just give the +-- formal type. +pprIlxArgInfo env (StgTypeArg arg,ty) = + angleBrackets (ilxTypeR env (deepIlxRepType arg) <+> ilxComment (text "actual for tyvar")) <+> text "<class [mscorlib] System.Object>" +pprIlxArgInfo env (_,ty) = + parens (ilxTypeL env ty) + + +---------------------------- +-- Code for a binding +ilxBind :: IlxEEnv -> StgBinding -> SDoc +ilxBind eenv@(IlxEEnv env _) bind = + vcat [vcat (map (ilxRhs env rec) pairs), + vcat (map (ilxFixupRec env rec) pairs)] + where + rec = ilxRecIds1 bind + pairs = ilxPairs1 bind + + +---------------------------- +-- Allocate a closure or constructor. Fix up recursive definitions. +ilxRhs :: IlxEnv -> [Id] -> (Id, StgRhs) -> SDoc + +ilxRhs env rec (bndr, _) | isVoidIlxRepId bndr + = empty + +ilxRhs env rec (bndr, StgRhsCon _ con args) + = vcat [text " /* ilxRhs:StgRhsCon */ " <+> ilxConApp env con args, + text "stloc" <+> pprId bndr + ] + +ilxRhs env rec (bndr, StgRhsClosure _ _ fvs upd args rhs) + = -- Assume .closure v<any A>(int64,!A) { + -- .apply <any B> (int32) (B) { ... } + -- } + -- Then + -- let v = \B (x:int32) (y:B). ... + -- becomes: + -- newclo v<int32>(int64,!0) + -- stloc v + vcat [vcat (map pushFv 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" <+> clotext, + text "stloc" <+> pprId bndr + ] + 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 = 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") + +ilxFixupRec env rec (bndr, StgRhsCon _ con args) + = text "// no recursive fixup" + +ilxFixupRec env rec (bndr, StgRhsClosure _ _ fvs upd args rhs) + = vcat [vcat (map fixFv rec)] + where + fixFv recid = if elem recid fvs then + vcat [pushId env bndr, + pushId env recid, + 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 = pprIlxNamedTyConApp env (ilxEnvQualifyByModule env (ppr bndr)) (map mkTyVarTy free_ilx_tvs) + + + +--------------------------------------------- +-- Code for a top-level binding in a module +ilxPairs binds = concat (map ilxPairs1 binds) + +ilxPairs1 (StgNonRec _ bndr rhs) = [(bndr,rhs)] +ilxPairs1 (StgRec _ pairs) = pairs + +ilxRecIds1 (StgNonRec _ bndr rhs) = [] +ilxRecIds1 (StgRec _ pairs) = map fst pairs + +--------------------------------------------- +-- Code for a top-level binding in a module +-- TODO: fix up recursions amongst CAF's +-- e.g. +-- x = S x +-- for infinity... +-- +-- For the moment I've put in a completely spurious "reverse"... +-- +-- Consider: make fixing up of CAF's part of ILX? i.e. +-- put static, constant, allocated datastructures into ILX. + +stableSortBy :: (a -> a -> Ordering) -> [a] -> [a] +stableSortBy f (h:t) = insertBy f h (stableSortBy f t) +stableSortBy f [] = [] + +usedBy :: (Id,StgRhs) -> (Id,StgRhs) -> Ordering +usedBy (m,_) (_,StgRhsCon _ data_con args) | any (isArg m) args = LT +usedBy (m,_) (n,_) | m == n = EQ +usedBy (m,_) (_,_) = GT + +isArg m (StgVarArg n) = (n == m) +isArg m _ = False + + +ilxTopBind :: Module -> IlxEnv -> [(Id,StgRhs)] -> SDoc +--ilxTopBind mod env (StgNonRec _ bndr rhs) = +--ilxTopRhs env (bndr,rhs) +ilxTopBind mod env pairs = + vcat [text ".class" <+> pprId mod, + nest 2 (braces (nest 2 (vcat [empty,cctor, flds, empty])))] + where + cctor = vcat [text ".method static rtspecialname specialname void .cctor()", + nest 2 (braces + (nest 2 (vcat [text ".maxstack 100", + text "ldstr \"LOG: initializing module" <+> pprId mod <+> text "\" call void ['mscorlib']System.Console::WriteLine(class [mscorlib]System.String)", + vcat (map (ilxTopRhs mod env) (stableSortBy usedBy pairs)), + text "ldstr \"LOG: initialized module" <+> pprId mod <+> text "\" call void ['mscorlib']System.Console::WriteLine(class [mscorlib]System.String)", + text "ret", + empty])))] + flds = vcat (map (ilxTopRhsStorage mod env) pairs) + +--ilxTopRhs mod env (bndr, _) | isVoidIlxRepId bndr +-- = empty + +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" <+> pprIlxNamedTyConApp env (ilxEnvQualifyByModule env (ppr bndr)) (map mkTyVarTy free_ilx_tvs), + text "stsfld" <+> pprFieldRef env (mod,bndTy,bndr) + ] + where + (free_ilx_tvs, free_non_ilx_tvs,free_vs) = categorizeVars fvs + bndTy = idIlxRepType bndr + +ilxTopRhs mod env (bndr, StgRhsCon _ data_con args) + = vcat [ text " /* ilxTopRhs: StgRhsCon */ " <+> ilxConApp env data_con args, + text "stsfld" <+> pprFieldRef env (mod,bndTy,bndr) + ] + where + bndTy = idIlxRepType bndr + +pprFieldRef env (mod,ty,id) + = ilxTypeL env ty <+> moduleReference env mod <+> pprId mod <> text "::" <> pprId id + +ilxTopRhsStorage mod env (bndr, StgRhsClosure _ _ _ _ _ _) + = text ".field public static " <+> ilxTypeL env bndTy <+> pprId bndr + where + bndTy = idIlxRepType bndr +ilxTopRhsStorage mod env (bndr, StgRhsCon _ _ _) + = text ".field public static " <+> ilxTypeL env bndTy <+> pprId bndr + where + bndTy = idIlxRepType bndr + +-------------------------------------- +-- Push an argument +pushArgWithVoids = pushArg_aux True +pushArg = pushArg_aux False + +pushArg_aux voids env (StgTypeArg ty) = empty +pushArg_aux voids env (StgVarArg var) = pushId_aux voids env var +pushArg_aux voids env (StgLitArg lit) = pushLit env lit + + +mapi f l = mapi_aux f l 0 + +mapi_aux f [] n = [] +mapi_aux f (h:t) n = f n h : mapi_aux f t (n+1) + +-------------------------------------- +-- Push an Id +pushId = pushId_aux False + +pushId_aux :: Bool -> IlxEnv -> Id -> SDoc +pushId_aux voids _ id | isVoidIlxRepId id = + /* 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 + Just (CloVar n) -> text "ldenv" <+> int n + Just Local -> text "ldloc" <+> pprId var + Just (Top m) -> + vcat [ilxComment (text "pushId (Top) " <+> pprId m), + 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" <+> ilxTypeL env (idIlxRepType var) + <+> pprIlxTopVar env var] + +-------------------------------------- +-- Push a literal +pushLit env (MachChar c) = text "ldc.i4" <+> int c +pushLit env (MachStr s) = text "ldsflda char " <+> ilxEnvQualifyByExact env (text "string") -- pprFSInILStyle s +pushLit env (MachInt i) = text "ldc.i4" <+> integer i +pushLit env (MachInt64 i) = text "ldc.i8" <+> integer i +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 (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 + | 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 + +\end{code} + + +%************************************************************************ +%* * +\subsection{Printing types} +%* * +%************************************************************************ + + +\begin{code} + +isVoidIlxRepType (NoteTy _ ty) = isVoidIlxRepType ty +isVoidIlxRepType (TyConApp tc _) | (tyConPrimRep tc == VoidRep) = True +isVoidIlxRepType (TyConApp tc tys) + = isUnboxedTupleTyCon tc && null (filter (not. isVoidIlxRepType) tys) +isVoidIlxRepType _ = False + +isVoidIlxRepId id = isVoidIlxRepType (idType id) + + + +-- Get rid of all NoteTy and NewTy artifacts +deepIlxRepType :: Type -> Type +deepIlxRepType (FunTy l r) + = FunTy (deepIlxRepType l) (deepIlxRepType r) + +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 + [h] -> h + _ -> mkTupleTy Unboxed (length tys') tys' + else + TyConApp tc (map deepIlxRepType tys) +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 (predTypeRep p) +deepIlxRepType ty@(TyVarTy tv) = ty + +idIlxRepType id = deepIlxRepType (idType id) + +-------------------------- +-- Some primitive type constructors are not thunkable. +-- Everything else needs to be marked thunkable. +ilxTypeL :: IlxEnv -> Type -> SDoc + +ilxTypeL env ty | isUnLiftedType ty || isVoidIlxRepType ty = ilxTypeR env ty +ilxTypeL env ty = text "thunk" <> angleBrackets (ilxTypeR env ty) + + +-------------------------- +-- Print non-thunkable version of type. +-- + +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. +-- +-- 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. +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. +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] + +ilxTypeR env ty@(ForAllTy tv body_ty) | otherwise + = ilxComment (text "higher order type var " <+> pprId tv) <+> + 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]) + +ilxTyConApp env tcon args = + case lookupUFM tyPrimConTable (getUnique tcon) of + Just f -> f args env + Nothing -> + (if isUnboxedTupleTyCon tcon then pprIlxUnboxedTupleTyConApp else pprIlxBoxedTyConApp) + env tcon args + +pprIlxTyCon env tcon = nameReference env (getName tcon) <> ppr tcon +pprIlxUnboxedTupleTyConApp env tcon args + = text "/* unboxed */ value class" <+> pprIlxTyCon env tcon' <> pprTypeArgs ilxTypeL env non_void + where + non_void = filter (not . isVoidIlxRepType) args + tcon' = dataConTyCon (tupleCon Unboxed (length non_void)) +pprIlxBoxedTyConApp env tcon args + = pprIlxNamedTyConApp env (pprIlxTyCon env tcon) args +pprIlxNamedTyConApp env tcon_text args + = text "class" <+> tcon_text <> pprTypeArgs ilxTypeR env args + +-- Returns e.g: <Int32, Bool> +-- Void-sized type arguments are _always_ eliminated, everywhere. +-- If the type constructor is an unboxed tuple type then it should already have +-- been adjusted to be the correct constructor. +pprTypeArgs f env tys = pprTypeArgs_aux f env (filter (not . isVoidIlxRepType) tys) + +pprTypeArgs_aux f env [] = empty +pprTypeArgs_aux f env tys = angleBrackets (pprSepWithCommas (f env) tys) + + +pprTyVarBinders :: IlxEnv -> [TyVar] -> SDoc +-- Returns e.g: <class [mscorlib]System.Object> <class [mscorlib]System.Object> +-- plus a new environment with the type variables added. +pprTyVarBinders env [] = empty +pprTyVarBinders env tvs = angleBrackets (pprSepWithCommas (pprTyVarBinder_aux env) tvs) + +pprTyVarBinder :: IlxEnv -> TyVar -> SDoc +pprTyVarBinder env tv = + if isIlxTyVar tv then + angleBrackets (pprTyVarBinder_aux env tv) + else + ilxComment (text "higher order tyvar" <+> pprId 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 ":" <+> + 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 `eqKind` liftedTypeKind) || + ( h `eqKind` unliftedTypeKind) || + ( h `eqKind` openTypeKind) + +isIlxTyVar v = isTyVar v && isIlxForAllKind (tyVarKind v) + +categorizeVars fvs = (ilx_tvs, non_ilx_tvs, vs) + where + (tvs, vs) = partition isTyVar fvs + (ilx_tvs, non_ilx_tvs) = categorizeTyVars tvs + +categorizeTyVars tyvs = partition isIlxTyVar tyvs + +pprValArgTys ppr_ty env tys = parens (pprSepWithCommas (ppr_ty env) tys) + +pprId id = singleQuotes (ppr id) + +\end{code} + +%************************************************************************ +%* * +\subsection{IlxEnv} +%* * +%************************************************************************ + +\begin{code} +type IlxTyEnv = [TyVar] +emptyIlxTyEnv = [] + +-- Nb. There is currently no distinction between the kinds of type variables. +-- We may need to add this to print out correct numbers, esp. for +-- "forall" types +extendIlxTyEnvWithFreeTyVars env tyvars = env ++ mkIlxTyEnv tyvars -- bound by .closure x<...> in a closure declared with type parameters +extendIlxTyEnvWithFormalTyVars env tyvars = env ++ mkIlxTyEnv tyvars -- bound by "forall <...>" in a type +extendIlxTyEnvWithTyArgs env tyvars = env ++ mkIlxTyEnv tyvars -- bound by "<...>" in a closure implementing a universal type + +formalIlxTyEnv tyvars = mkIlxTyEnv tyvars +mkIlxTyEnv tyvars = [ v | v <- tyvars, isIlxTyVar v ] + +data HowBound = Top Module -- Bound in a modules + | Arg -- Arguments to the enclosing closure + | CloVar Int -- A free variable of the enclosing closure + -- The int is the index of the field in the + -- environment + | Local -- Local let binding + +-- The SDoc prints a unique name for the syntactic block we're currently processing, +-- 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) + +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) + +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 + = IlxEnv (m, tv_env, id_env, bind_env, (mod, nextPlace exact sdoc),tr) +ilxEnvQualifyByModule (IlxEnv (_, _, _, _,(mod,_),_)) sdoc = usePlace mod sdoc +ilxEnvQualifyByExact (IlxEnv (_, _, _, _,(mod,exact),_)) sdoc = usePlace mod sdoc <> usePlace exact sdoc + +ilxPlaceStgBindDefault env = ilxEnvNextPlace env (text "D") +ilxPlaceStgRhsClosure env bndr = ilxEnvSetPlace env (ppr bndr) -- binders are already unique +ilxPlaceStgCaseScrut env = ilxEnvNextPlace env (text "S") + +ilxPlaceAlt :: IlxEnv -> Int -> IlxEnv +ilxPlaceAlt env i = ilxEnvNextPlace env (text "a" <> int i) +ilxPlacePrimAltLit env i = ilxEnvNextPlace env (text "P" <> int i) +ilxMapPlaceArgs start f env args = [ f (ilxEnvNextPlace env (text "A" <> int i)) a | (i,a) <- [start..] `zip` args ] +ilxMapPlaceAlts f env alts = [ f (ilxPlaceAlt env i) alt | (i,alt) <- [1..] `zip` alts ] + +extendIlxEnvWithFreeTyVars (IlxEnv (mod, tv_env, id_env, bind_env, place,tr)) tyvars + = IlxEnv (mod, extendIlxTyEnvWithFreeTyVars tv_env tyvars,id_env, bind_env, place,tr) + +extendIlxEnvWithFormalTyVars (IlxEnv (mod, tv_env, id_env, bind_env, place,tr)) tyvars + = IlxEnv (mod, extendIlxTyEnvWithFormalTyVars tv_env tyvars,id_env, bind_env, place,tr) + +extendIlxEnvWithTyArgs (IlxEnv (mod, tv_env, id_env, bind_env, place,tr)) tyvars + = IlxEnv (mod, extendIlxTyEnvWithTyArgs tv_env tyvars,id_env, bind_env, place,tr) + +extendIlxEnvWithArgs :: IlxEnv -> [Var] -> IlxEnv +extendIlxEnvWithArgs (IlxEnv (mod, tv_env, id_env, bind_env, place,tr)) args + = IlxEnv (mod, extendIlxTyEnvWithTyArgs tv_env [tv | tv <- args, isIlxTyVar tv], + extendVarEnvList id_env [(v,Arg) | v <- args, not (isIlxTyVar v)], + bind_env, place,tr) + +extendIlxEnvWithFreeVars (IlxEnv (mod, tv_env, id_env, bind_env, place,tr)) args + = IlxEnv (mod, + extendIlxTyEnvWithFreeTyVars tv_env [tv | tv <- args, isIlxTyVar tv], + extendVarEnvList id_env (clovs 0 args), + bind_env, + place,tr) + where + clovs _ [] = [] + clovs n (x:xs) = if not (isIlxTyVar x) then (x,CloVar n):clovs (n+1) xs else clovs n xs + +extendIlxEnvWithBinds env@(IlxEnv (mod, tv_env, id_env, bind_env, place,tr)) bnds + = IlxEnv (mod, tv_env, id_env, + extendVarEnvList bind_env [(v,(env,rhs)) | (v,rhs) <- bnds], + place,tr) + +extendIlxEnvWithLocals (IlxEnv (m, tv_env, id_env, bind_env, p,tr)) locals + = IlxEnv (m, tv_env, + extendVarEnvList id_env [(v,Local) | (LocalId v,_) <- locals], + extendVarEnvList bind_env [(v,(env,rhs)) | (LocalId v,Just (env,rhs)) <- locals], + p,tr) +extendIlxEnvWithTops env@(IlxEnv (m, tv_env, id_env, bind_env, place,tr)) mod binds + = IlxEnv (m, tv_env, + extendVarEnvList id_env [(bndr,Top mod) | (bndr,rhs) <- binds], + extendVarEnvList bind_env [(bndr,(env, rhs)) | (bndr,rhs) <- binds], + place,tr) + +formalIlxEnv (IlxEnv (m, tv_env, id_env, bind_env, place, tr)) tyvars + = IlxEnv (m, formalIlxTyEnv tyvars, id_env, bind_env, place, tr) + +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} + + +\begin{code} +type IlxLabel = SDoc + +pprIlxLabel lbl = lbl + +mkJoinLabel :: Id -> IlxLabel +mkJoinLabel v = text "J_" <> ppr v + +mkAltLabel :: Id -> Int -> IlxLabel +mkAltLabel v n = text "A" <> int n <> ppr v + +ilxLabel :: IlxLabel -> SDoc +ilxLabel lbl = line $$ (pprIlxLabel lbl <> colon) +\end{code} + + +%************************************************************************ +%* * +\subsection{Local pretty helper functions} +%* * +%************************************************************************ + +\begin{code} +pprSepWithCommas :: (a -> SDoc) -> [a] -> SDoc +pprSepWithCommas pp xs = sep (punctuate comma (map pp xs)) +ilxComment pp = text "/*" <+> pp <+> text "*/" +singleQuotes pp = char '\'' <> pp <> char '\'' + +line = text "// ----------------------------------" + +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, +-- and modified to do the correct thing! It's +-- still a mess though. Also, still have to do the +-- right thing for embedded nulls. + +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 +-- Tthe hassle is what to do w/ strings like "ESC 0"... +stringToC "" = "" +stringToC [c] = charToC c +stringToC (c:cs) + -- if we have something "octifiable" in "c", we'd better "octify" + -- the rest of the string, too. + = if (c < ' ' || c > '~') + then (charToC c) ++ (concat (map char_to_C cs)) + else (charToC c) ++ (stringToC cs) + where + char_to_C c | c == '\n' = "\\n" -- use C escapes when we can + | c == '\a' = "\\a" + | c == '\b' = "\\b" -- ToDo: chk some of these... + | c == '\r' = "\\r" + | c == '\t' = "\\t" + | c == '\f' = "\\f" + | c == '\v' = "\\v" + | otherwise = '\\' : (trigraph (ord c)) + +charToC :: Char -> String +-- Convert a character to the form reqd in a C character literal +charToC c = if (c >= ' ' && c <= '~') -- non-portable... + then case c of + '\'' -> "\\'" + '\\' -> "\\\\" + '"' -> "\\\"" + '\n' -> "\\n" + '\a' -> "\\a" + '\b' -> "\\b" + '\r' -> "\\r" + '\t' -> "\\t" + '\f' -> "\\f" + '\v' -> "\\v" + _ -> [c] + else '\\' : (trigraph (ord c)) + +trigraph :: Int -> String +trigraph n + = [chr ((n `div` 100) `rem` 10 + ord '0'), + chr ((n `div` 10) `rem` 10 + ord '0'), + chr (n `rem` 10 + ord '0')] + + +\end{code} + +%************************************************************************ +%* * +\subsection{PrimOps and Constructors} +%* * +%************************************************************************ + +\begin{code} +---------------------------- +-- Allocate a fresh constructor + +ilxConApp env data_con args + | isUnboxedTupleCon data_con + = let tm_args' = filter (not. isVoidIlxRepType . stgArgType) tm_args in + case tm_args' of + [h] -> + -- Collapse the construction of an unboxed tuple type where + -- every element is zero-sized + vcat (ilxMapPlaceArgs 0 pushArg env tm_args') + _ -> + -- Minimize the construction of an unboxed tuple type, which + -- may contain zero-sized elements. Recompute all the + -- bits and pieces from the simpler case below for the new data + -- type constructor.... + let data_con' = tupleCon Unboxed (length tm_args') in + let rep_ty_args' = filter (not . isVoidIlxRepType) rep_ty_args in + + let tycon' = dataConTyCon data_con' in + let (formal_tyvars', formal_tau_ty') = splitForAllTys (dataConRepType data_con') in + let (formal_arg_tys', _) = splitFunTys formal_tau_ty' in + let formal_env' = formalIlxEnv env formal_tyvars' in + + vcat [vcat (ilxMapPlaceArgs 0 pushArg env tm_args'), + sep [text "newobj void ", + ilxTyConApp env tycon' rep_ty_args', + text "::.ctor", + pprValArgTys ilxTypeR formal_env' (map deepIlxRepType formal_arg_tys') + ] + ] + | otherwise + -- Now all other constructions + = -- Assume C :: forall a. a -> T a -> T a + -- ldloc x arg of type Int + -- ldloc y arg of type T Int + -- newdata classunion T<Int32>, C(!0, T <!0>) + -- + let tycon = dataConTyCon data_con in + let (formal_tyvars, formal_tau_ty) = splitForAllTys (dataConRepType data_con) in + let (formal_arg_tys, _) = splitFunTys formal_tau_ty in + + vcat [vcat (ilxMapPlaceArgs 0 pushArg env tm_args), + sep [ text "newdata", + nest 2 (ilxTyConApp env tycon rep_ty_args <> comma), + nest 2 (ilxConRef env data_con) + ] + ] + where + tycon = dataConTyCon data_con + 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. +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 :: [StgArg] -> ([Type], [StgArg]) +splitTyArgs1 (StgTypeArg ty : args) = (ty:tys, args') + where + (tys, args') = splitTyArgs1 args +splitTyArgs1 args = ([], args) + +ilxConRef env data_con + | 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 + + + + +\end{code} + + +%************************************************************************ +%* * +\subsection{PrimOps and Prim Representations} * +%************************************************************************ + +\begin{code} + +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"] + +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] + +ilxTyIO b = ilxTypeSeq [ilxType "(func ( /* unit skipped */ ) --> ", b, ilxType ")"] + +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 + + +type IlxOpFrag = IlxEnv -> SDoc +ilxOp :: String -> IlxOpFrag +ilxOp s env = text s +ilxOpSeq :: [IlxOpFrag] -> IlxOpFrag +ilxOpSeq ops env = hsep (map (\x -> x env) ops) + +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 + + +ilxMethodRef rty cls nm tyargs args = + ilxOpSeq [rty,cls,ilxOp "::",ilxOp nm, + ilxTyParams tyargs,ilxParams args] + +ilxCall m = ilxOpSeq [ilxOp "call", m] + +ilxSupportClass = ilxOpSeq [prelGHCReference, ilxOp "'GHC.support'"] +ilxSuppMeth rty nm tyargs args = ilxMethodRef rty ilxSupportClass nm tyargs args + +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 + CharGeOp -> simp_op ilxCge + CharEqOp -> simp_op ilxCeq + CharNeOp -> simp_op ilxCne + CharLtOp -> simp_op ilxClt + CharLeOp -> simp_op ilxCle + + 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 + IntEqOp -> simp_op ilxCeq + IntNeOp -> simp_op ilxCne + IntLtOp -> simp_op ilxClt + IntLeOp -> simp_op ilxCle + + 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 + WordLtOp -> simp_op ilxCltUn + WordLeOp -> simp_op ilxCleUn + + AddrGtOp -> simp_op ilxCgt + AddrGeOp -> simp_op ilxCge + AddrEqOp -> simp_op ilxCeq + AddrNeOp -> simp_op ilxCne + AddrLtOp -> simp_op ilxClt + AddrLeOp -> simp_op ilxCle + + FloatGtOp -> simp_op ilxCgt + FloatGeOp -> simp_op ilxCge + FloatEqOp -> simp_op ilxCeq + FloatNeOp -> simp_op ilxCne + FloatLtOp -> simp_op ilxClt + FloatLeOp -> simp_op ilxCle + + DoubleGtOp -> simp_op ilxCgt + DoubleGeOp -> simp_op ilxCge + DoubleEqOp -> simp_op ilxCeq + DoubleNeOp -> simp_op ilxCne + DoubleLtOp -> simp_op ilxClt + DoubleLeOp -> simp_op ilxCle + + -- Int#-related ops: + 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 (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 (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 (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 (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 (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 (ilxOp "call float64 [mscorlib]System.Math::Pow(float64, float64)") + + -- Integer (and related...) ops: bail out to support routines + 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 (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 -} + + 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??? -} + 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 -> ilxOp "nop ") + {- MutByteArr# s -> State# s -> (# State# s, ByteArr# #) -} + SizeofByteArrayOp -> simp_op (ilxOp "ldlen") + {- ByteArr# -> Int# -} + + SameMutableByteArrayOp -> ty1_op (\ty1 -> ilxCeq) + {- MutByteArr# s -> MutByteArr# s -> Bool -} + SizeofMutableByteArrayOp -> ty1_op (\ty1 -> ilxOp "ldlen") + {- MutByteArr# s -> Int# -} + + SameMutVarOp -> ty2_op (\ty1 ty2 -> ilxCeq) + {- MutVar# s a -> MutVar# s a -> Bool -} + 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 -> ilxOpSeq [ilxOp "ldfld !0" , repMutVar ty1 ty2 , ilxOp "::contents"]) + {- MutVar# s a -> State# s -> (# State# s, a #) -} + WriteMutVarOp -> ty2_op (\ty1 ty2 -> ilxOpSeq [ilxOp "stfld !0" , repMutVar ty1 ty2 , ilxOp "::contents"]) + {- MutVar# s a -> a -> State# s -> State# s -} + + NewArrayOp -> ty2_op (\ty1 ty2 -> ilxCallSuppMeth (ilxType "!!0[]") "newArray" [ty1] [repInt,ilxMethTyVarA]) + {- Int# -> a -> State# s -> (# State# s, MutArr# s a #) -} + IndexArrayOp -> ty1_op (\ty1 -> ilxOp "ldelem.ref") + {- Array# a -> Int# -> (# a #) -} + WriteArrayOp -> ty2_op (\ty1 ty2 -> ilxOp "stelem.ref") + {- MutArr# s a -> Int# -> a -> State# s -> State# s -} + ReadArrayOp -> ty2_op (\ty1 ty2 -> ilxOp "ldelem.ref") + {- MutArr# s a -> Int# -> State# s -> (# State# s, a #) -} + UnsafeFreezeArrayOp -> ty2_op (\ty1 ty2 -> ilxOp "nop") + {- MutArr# s a -> State# s -> (# State# s, Array# a #) -} + UnsafeThawArrayOp -> ty2_op (\ty1 ty2 -> ilxOp "nop") + {- Array# a -> State# s -> (# State# s, MutArr# s a #) -} + + SameMutableArrayOp -> ty2_op (\ty1 ty2 -> ilxCeq) + {- MutArr# s a -> MutArr# s a -> Bool -} + + + RaiseOp -> ty2_op (\ty1 ty2 -> ilxOp "throw") + CatchOp -> ty2_op (\ty1 ty2 -> + 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 + -> (# State# RealWorld, a #) + -} + + BlockAsyncExceptionsOp -> ty1_op (\ty1 -> + ilxCallSuppMeth ilxMethTyVarA "blockAsyncExceptions" [ty1] [ilxLift (ilxTyIO (ilxType "!!0"))]) + + {- (State# RealWorld -> (# State# RealWorld, a #)) + -> (State# RealWorld -> (# State# RealWorld, a #)) + -} + + UnblockAsyncExceptionsOp -> ty1_op (\ty1 -> + ilxCallSuppMeth ilxMethTyVarA "unblockAsyncExceptions" [ty1] [ilxLift (ilxTyIO (ilxType "!!0"))]) + + {- + State# RealWorld -> (# State# RealWorld, a #)) + -> (State# RealWorld -> (# State# RealWorld, a #)) + -} + + NewMVarOp -> ty2_op (\sty ty -> + ilxOpSeq [ilxOp "newobj void " , repMVar ty , ilxOp "::.ctor()"]) + {- State# s -> (# State# s, MVar# s a #) -} + + TakeMVarOp -> ty2_op (\sty ty -> + 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 -> + ilxCallSuppMeth (ilxOp "void") "putMVar" [ty] [repMVar ilxMethTyVarA, ilxMethTyVarA]) + {- MVar# s a -> a -> State# s -> State# s -} + + SameMVarOp -> ty2_op (\sty ty -> ilxCeq) + {- MVar# s a -> MVar# s a -> Bool -} + +-- TakeMaybeMVarOp -> ty2_op (\sty ty -> +-- (ilxCallSuppMeth (ilxUnboxedPairRep repInt ilxMethTyVarA) "tryTakeMVar" [ty] [repMVar ilxMethTyVarA])) +-- {- MVar# s a -> State# s -> (# State# s, Int#, a #) -} + + IsEmptyMVarOp -> ty2_op (\sty ty -> + ilxCallSuppMeth repInt "isEmptyMVar" [ty] [repMVar ilxMethTyVarA]) + {- MVar# s a -> State# s -> (# State# s, Int# #) -} + + TouchOp -> warn_op "touch" (ty1_op (\ty1 -> ilxOp "pop /* PrimOp touch */ ")) + + {- a -> Int# -} + DataToTagOp -> ty1_op (\ty1 -> + ilxCallSuppMeth repInt "dataToTag" [ty1] [ilxMethTyVarA]) + {- a -> Int# -} + + TagToEnumOp -> ty1_op (\ty1 -> + ilxCallSuppMeth ilxMethTyVarA "tagToEnum" [ty1] [repInt]) + {- Int# -> a -} + + MakeStablePtrOp -> ty1_op (\ty1 -> ilxOpSeq [ilxOp "box", ty1, ilxOp "newobj void", repStablePtr {- ty1 -}, ilxOp "::.ctor(class [mscorlib]System.Object)"]) + {- 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 -> ilxOpSeq [ilxOp "ldfld class [mscorlib]System.Object", repStablePtr {- ty1 -}, ilxOp "::contents"]) + {- StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #) -} + + EqStablePtrOp -> ty1_op (\ty1 -> ilxOp "ceq") + {- StablePtr# a -> StablePtr# a -> Int# -} + + -- The 3rd argument to MkWeakOp is always a IO Monad action, i.e. passed as () --> () + MkWeakOp -> ty3_op (\ty1 ty2 ty3 -> ilxCall (ilxMethodRef (repWeak ilxMethTyVarB) classWeak "bake" [ilxLift ty1,ilxLift ty2] [ilxMethTyVarA, ilxMethTyVarB, ilxLift (ilxTyIO ilxUnboxedEmptyRep)])) + {- o -> b -> c -> State# RealWorld -> (# State# RealWorld, Weak# b #) -} + + DeRefWeakOp -> ty1_op (\ty1 -> ilxCall (ilxMethodRef (ilxUnboxedPairRep repInt 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 (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 -> 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 -} + + 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) + +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 + + +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 + +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 + +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 + + +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 + +\end{code} + |