From: rrt Date: Mon, 26 Feb 2001 15:44:59 +0000 (+0000) Subject: [project @ 2001-02-26 15:44:59 by rrt] X-Git-Tag: Approximately_9120_patches~2547 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=81027250abf0099f1dbaef1ddb8534547268ad41;p=ghc-hetmet.git [project @ 2001-02-26 15:44:59 by rrt] ILX back-end. WARNING: this is code copied in that was previously added to 4.06. It's not remotely sane to try to compile it at the moment; that's what I've got to do next. Don't worry, it's all #ifdefed at the moment. --- diff --git a/ghc/compiler/ilxGen/Entry.ilx b/ghc/compiler/ilxGen/Entry.ilx new file mode 100644 index 0000000..fe8b618 --- /dev/null +++ b/ghc/compiler/ilxGen/Entry.ilx @@ -0,0 +1,57 @@ +.assembly test { } +// ENTRYPOINT +.class MainMain { + .method public static void Main(class [mscorlib]System.String[]) { + .entrypoint + ldstr "LOG: loading main value\n" call void [mscorlib]System.Console::WriteLine(class [mscorlib]System.String) + ldsfld (func () --> class [ilx std]'()') class Main::'Main_main' + + ldstr "LOG: evaluating main value\n" + call void [mscorlib]System.Console::WriteLine(class [mscorlib]System.String) + callfunc --> (func () --> class [ilx std]PrelBase_Z0T) + ldstr "LOG: calling main value\n" + call void [mscorlib]System.Console::WriteLine(class [mscorlib]System.String) + ldvoid + callfunc (void) --> class [ilx std]PrelBase_Z0T + + pop + + +// HACK HACK HACK +// Call the "finalizers" for stdin, stdout and stderr, because COM+ doesn't +// guarantee that finalizers will be run. WE DON'T GUARANTEE TO RUN ANY +// OTHER FINALIZERS... + + ldstr "LOG: calling critical finalizers manually in main()\n" + call void [mscorlib]System.Console::WriteLine(class [mscorlib]System.String) + +ldsfld (func (thunk>) --> (func () --> class [ilx std]PrelBase_Z0T)) [ilx std]'PrelHandle'::'PrelHandle_stdHandleFinalizzer' +ldsfld thunk> [ilx std]'PrelHandle'::'PrelHandle_stdin' + callfunc (thunk>) --> (func () --> class [ilx std]PrelBase_Z0T) + callfunc --> (func () --> class [ilx std]PrelBase_Z0T) + ldvoid + callfunc (void) --> class [ilx std]PrelBase_Z0T + pop + +ldsfld (func (thunk>) --> (func () --> class [ilx std]PrelBase_Z0T)) [ilx std]'PrelHandle'::'PrelHandle_stdHandleFinalizzer' +ldsfld thunk> [ilx std]'PrelHandle'::'PrelHandle_stdout' + callfunc (thunk>) --> (func () --> class [ilx std]PrelBase_Z0T) + callfunc --> (func () --> class [ilx std]PrelBase_Z0T) + ldvoid + callfunc (void) --> class [ilx std]PrelBase_Z0T + pop + +ldsfld (func (thunk>) --> (func () --> class [ilx std]PrelBase_Z0T)) [ilx std]'PrelHandle'::'PrelHandle_stdHandleFinalizzer' +ldsfld thunk> [ilx std]'PrelHandle'::'PrelHandle_stderr' + callfunc (thunk>) --> (func () --> class [ilx std]PrelBase_Z0T) + callfunc --> (func () --> class [ilx std]PrelBase_Z0T) + ldvoid + callfunc (void) --> class [ilx std]PrelBase_Z0T + pop + + ldstr "LOG: exit main()\n" + call void [mscorlib]System.Console::WriteLine(class [mscorlib]System.String) + ret + } +} + diff --git a/ghc/compiler/ilxGen/IlxGen.lhs b/ghc/compiler/ilxGen/IlxGen.lhs new file mode 100644 index 0000000..02d0689 --- /dev/null +++ b/ghc/compiler/ilxGen/IlxGen.lhs @@ -0,0 +1,2074 @@ +% +\section{Generate COM+ extended assembler} + +\begin{code} +module IlxGen( ilxGen ) where + +#include "HsVersions.h" + +import Char ( ord, chr ) +import StgSyn +import Id ( idType, idName, isDeadBinder, idPrimRep, idArityInfo ) +import IdInfo ( arityLowerBound ) +import Var ( Var, Id, TyVar, isId, isTyVar, tyVarKind, tyVarName ) +import VarEnv +import TyCon ( TyCon, tyConPrimRep, isUnboxedTupleTyCon, tyConDataCons, newTyConRep, tyConTyVars, isDataTyCon, isAlgTyCon ) +import Class ( Class, classTyCon ) +import Type ( isUnboxedTupleType, isUnLiftedType, isTyVarTy, mkTyVarTy, splitForAllTys, splitFunTys, applyTy, splitNewType_maybe, applyTys,typeKind,getTyVar ) +import TypeRep ( Type(..), boxedKind,boxedTypeKind,openTypeKind,anyBoxKind, unboxedTypeKind ) +import DataCon ( isUnboxedTupleCon, dataConTyCon, dataConRepType, dataConRepArgTys ) +import Literal ( Literal(..), literalType ) +import PrimOp ( PrimOp(..), CCallTarget(..),CCall(..) ) +import PrimRep ( PrimRep(..) ) +import Name ( nameModule, nameOccName, isGlobalName, isLocalName, isDllName, NamedThing(getName) ) +import Unique -- Lots of keys +import FiniteMap +import UniqFM +import Subst ( substTy, mkTyVarSubst ) +import Module ( Module, PackageName, ModuleName, moduleName, modulePackageName, isLocalModule, pprModuleName, mkThisModule, mkSrcModule, mkPrelModule ) +import CStrings ( CLabelString, pprCLabelString ) +import TysWiredIn ( unboxedTupleTyCon, unboxedTupleCon, mkUnboxedTupleTy ) +import Outputable +import Char ( ord ) +import List ( partition, elem, sortBy, insertBy,any ) +import UniqSet +import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon ) +-- opt_DoEtaReduction 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. One day this will be configured by the command line. +import CmdLineOpts ( opt_Static, opt_InPackage, opt_DoEtaReduction ) + +\end{code} + + + +%************************************************************************ +%* * +\subsection{Main driver} +%* * +%************************************************************************ + +\begin{code} +ilxGen :: Module -> [TyCon] -> [Class] -> [(StgBinding,[Id])] -> SDoc +ilxGen mod tycons classes binds_w_srts + = vcat [vcat (map (ilxImportPackage topenv) (uniqSetToList import_packages)), + vcat (map (ilxImportModule topenv) (uniqSetToList import_modules)), + vcat (map (ilxImportTyCon topenv) (uniqSetToList import_tycons)), + vcat (map (ilxTyCon topenv) data_tycons), + vcat (map (ilxBindClosures topenv) binds), + ilxTopBind mod topenv toppairs + ] + where + binds = map fst binds_w_srts + (import_packages,import_modules,import_tycons) = importsBinds binds `unionImpInfo` importsPrelude + toppairs = ilxPairs binds + topenv = extendIlxEnvWithTops (emptyIlxEnv False mod) mod toppairs + -- Generate info from class decls as well + data_tycons = filter isDataTyCon (tycons ++ map classTyCon classes) +\end{code} + +%************************************************************************ +%* * +\subsection{Find Imports} +%* * +%************************************************************************ + +\begin{code} + +importsBinds :: [StgBinding] -> ImportsInfo +importsBinds binds = unionImpInfos (map importsBind binds) + +importsBind :: StgBinding -> ImportsInfo +importsBind (StgNonRec b rhs) = importsRhs rhs `unionImpInfo` importsVar b +importsBind (StgRec pairs) = unionImpInfos (map (\(b,rhs) -> importsRhs rhs `unionImpInfo` importsVar b) pairs) + +importsRhs (StgRhsCon _ con args) = importsDataCon con `unionImpInfo` importsStgArgs args +importsRhs (StgRhsClosure _ _ srt _ upd args body) = importsExpr body `unionImpInfo` importsVars args + +importsExpr :: StgExpr -> ImportsInfo +importsExpr (StgLit l) = emptyImpInfo +importsExpr (StgApp f args) = importsVar f `unionImpInfo` importsStgArgs args +importsExpr (StgConApp con args) = importsDataCon con `unionImpInfo` importsStgArgs args +importsExpr (StgPrimApp op args res_ty) = importsType res_ty `unionImpInfo` importsStgArgs args +importsExpr (StgSCC cc expr) = importsExpr expr +importsExpr (StgCase scrut _ _ bndr srt alts) + = importsExpr scrut `unionImpInfo` imports_alts alts `unionImpInfo` importsVar bndr + where + imports_alts (StgAlgAlts ty alts deflt) + = unionImpInfos (map imports_alg_alt alts) `unionImpInfo` imports_deflt deflt `unionImpInfo` importsType ty + where + imports_alg_alt (con, bndrs, _, rhs) + = importsExpr rhs `unionImpInfo` importsDataCon con `unionImpInfo` importsVars bndrs + + imports_alts (StgPrimAlts ty alts deflt) + = unionImpInfos (map imports_prim_alt alts) `unionImpInfo` imports_deflt deflt `unionImpInfo` importsType ty + where + imports_prim_alt (lit, rhs) = importsExpr rhs + imports_deflt StgNoDefault = emptyImpInfo + imports_deflt (StgBindDefault rhs) = importsExpr rhs + +importsExpr (StgLetNoEscape _ _ bind body) = importsExpr (StgLet bind body) +importsExpr (StgLet bind body) + = importsBind bind `unionImpInfo` importsExpr body + +importsApp v args = importsVar v `unionImpInfo` importsStgArgs args +importsStgArgs args = unionImpInfos (map importsStgArg args) + +importsStgArg :: StgArg -> ImportsInfo +importsStgArg (StgTypeArg ty) = importsType ty +importsStgArg (StgVarArg v) = importsVar v +importsStgArg _ = emptyImpInfo + +importsVars vs = unionImpInfos (map importsVar vs) +importsVar v = importsName (idName v) `unionImpInfo` importsType (idType v) + +importsName n + | isLocalName n = emptyImpInfo + | thisModule == nameModule n = emptyImpInfo + | isDllName n = singlePackageImpInfo (modulePackageName (nameModule n)) + | otherwise = singleModuleImpInfo (moduleName (nameModule n)) + +importsModule m + | thisModule == m = emptyImpInfo + | isLocalModule m = singleModuleImpInfo (moduleName m) + | otherwise = singlePackageImpInfo (modulePackageName m) + +importsType :: Type -> ImportsInfo +importsType ty = importsType2 (deepIlxRepType ty) + +importsType2 :: Type -> ImportsInfo +importsType2 (AppTy f x) = importsType2 f `unionImpInfo` importsType2 x +importsType2 (TyVarTy _) = emptyImpInfo +importsType2 (TyConApp tc args) =importsTyCon tc `unionImpInfo` importsTypeArgs2 args +importsType2 (FunTy arg res) = importsType arg `unionImpInfo` importsType2 res +importsType2 (ForAllTy tv body_ty) = importsType2 body_ty +importsType2 (NoteTy _ ty) = importsType2 ty +importsTypeArgs2 tys =unionImpInfos (map importsType2 tys) + +importsDataCon dcon = importsTyCon (dataConTyCon dcon) +importsTyCon tc | (not (isDataTyCon tc) || + isLocalName (getName tc) || + thisModule == nameModule (getName tc)) = emptyImpInfo +importsTyCon tc | otherwise = importsName (getName tc) `unionImpInfo` (emptyUniqSet, emptyUniqSet,unitUniqSet tc) + +importsPrelude = + if preludePackage == opt_InPackage then singleModuleImpInfo (mkSrcModule "PrelGHC") + else singlePackageImpInfo preludePackage + + +-- hack to get at Module.preludePackage - we should reveal it.... +preludePackage + = if isLocalModule dummy then opt_InPackage else modulePackageName dummy + where + dummy = mkPrelModule (mkSrcModule "") + +type ImportsInfo = (UniqSet PackageName, UniqSet ModuleName, UniqSet TyCon) -- (Packages, Modules, Datatypes) + +emptyImpInfo :: ImportsInfo +emptyImpInfo = (emptyUniqSet, emptyUniqSet, emptyUniqSet) +singlePackageImpInfo p = (unitUniqSet p, emptyUniqSet, emptyUniqSet) +singleModuleImpInfo m = (emptyUniqSet, unitUniqSet m, emptyUniqSet) + +unionImpInfo :: ImportsInfo -> ImportsInfo -> ImportsInfo +unionImpInfo (w1,x1,y1) (w2,x2,y2) = (unionUniqSets w1 w2, unionUniqSets x1 x2, unionUniqSets y1 y2) + +unionImpInfos :: [ImportsInfo] -> ImportsInfo +unionImpInfos fvs = foldr unionImpInfo emptyImpInfo fvs + +ilxImportTyCon :: IlxEnv -> TyCon -> SDoc +ilxImportTyCon env tycon | isDataTyCon tycon = pprIlxTyConDef True env tycon +ilxImportTyCon env tycon | otherwise = empty + +ilxImportPackage :: IlxEnv -> PackageName -> SDoc +ilxImportPackage env p = text ".assembly extern ilx" <+> singleQuotes (text (_UNPK_ p) <> hscOptionQual) <+> text "{ }" + +ilxImportModule :: IlxEnv -> ModuleName -> SDoc +ilxImportModule env m = text ".module extern ilx" <+> singleQuotes (ppr m <> hscOptionQual) + + +\end{code} + +%************************************************************************ +%* * +\subsection{Type declarations} +%* * +%************************************************************************ + +\begin{code} + + +ilxTyCon :: IlxEnv -> TyCon -> SDoc +ilxTyCon env tycon = pprIlxTyConDef False env tycon + +-- filter to get only dataTyCons? +pprIlxTyConDef importing env tycon = + vcat [empty $$ line, + text ".classunion" <+> (if importing then text "extern" else empty) <+> text "thunk" + <+> ((nameReference env (getName tycon)) <> (ppr tycon)) <+> tyvars_text <+> alts_text] + where + tyvars = tyConTyVars tycon + (ilx_tvs, non_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 (pprIlxTypeL 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 env (bndr, StgRhsCon _ _ _) + = empty + +ilxRhsClosures env (bndr, StgRhsClosure _ _ _ fvs upd args rhs) + = vcat [ilxExprClosures next_env rhs, + + empty $$ line, + kind_text <+> squotes 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" + other -> ".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 [(case args of + [] -> empty + other -> 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) -> pprIlxTypeR env ty + Nothing -> trace "WARNING! IlxGen.trace could not find return type - see generated ILX for context where this occurs." (text "// Could not find return type:" <+> pprIlxTypeR env_with_fvs (idIlxRepType bndr)<+> text ", non representation: " <+> pprIlxTypeR env_with_fvs (idType bndr)) + + -- 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,_) = pprIlxTypeL env (idIlxRepType v) <+> pprId v +pprIlxLocal env (LocalSDoc (ty,doc,pin),_) = pprIlxTypeL env (deepIlxRepType ty) <+> (if pin then text "pinned" else empty) <+> doc + + +pprFreeBinders env fvs + = (ilx_tvs_text <+> vs_text, env2) + where + (free_ilx_tvs, free_non_ilx_tvs,free_vs) = categorizeVars fvs + real_free_vs = filter (not . isVoidIlxRepId) free_vs + -- ignore the higher order type parameters for the moment + env1 = extendIlxEnvWithFreeTyVars env free_ilx_tvs + ilx_tvs_text = pprTyVarBinders env1 free_ilx_tvs + vs_text = parens (pprSepWithCommas ppr_id real_free_vs) + ppr_id v = pprIlxTypeL env1 (idIlxRepType v) <+> pprId v + env2 = extendIlxEnvWithFreeVars env1 real_free_vs + +pprIdBinder env v = parens (pprIlxTypeL 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 (StgPrimApp (CCallOp (CCall (StaticTarget c) casm gc cconv)) args ret_ty) + = concat (ilxMapPlaceArgs 0 ilxCCallArgLocals env args) +ilxExprLocals _ _ = [] + +-- Generate locals to use for pinning arguments as we cross the boundary +-- to C. +ilxCCallArgLocals env arg@(StgVarArg v) | pinCCallArg v = + [(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 (con, bndrs, _, rhs) = map (\x -> (LocalId x,Nothing)) (filter (\v -> isId v && not (isDeadBinder v)) bndrs) ++ ilxExprLocals env rhs +ilxPrimAltLocals env (lit, rhs) = ilxExprLocals env rhs + +ilxDefltLocals env 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 (StgPrimApp _ 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 env other + = 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 env StgNoDefault = empty + +ilxArgClosures env (StgLitArg lit) = ilxGenLit env lit +ilxArgClosures _ _ = empty + + + +ilxGenLit env (MachStr fs) + = vcat [text ".field static assembly char " <+> squotes 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 eenv@(IlxEEnv env _) (StgApp fun args) sequel + = ilxFunApp env fun args (isReturn sequel) $$ ilxSequel sequel + +-- ilxExpr eenv (StgLit lit) sequel +ilxExpr eenv@(IlxEEnv env _) (StgLit lit) sequel + = pushLit env lit $$ ilxSequel sequel + +-- ilxExpr eenv (StgConApp data_con args) sequel +ilxExpr eenv@(IlxEEnv env _) (StgConApp data_con args) sequel + = text " /* ilxExpr:StgConApp */ " <+> ilxConApp env data_con args $$ ilxSequel sequel + +-- ilxExpr eenv (StgPrimApp primop args _) sequel +ilxExpr eenv@(IlxEEnv env _) (StgPrimApp primop args ret_ty) sequel + = ilxPrimApp env primop args ret_ty $$ ilxSequel sequel + +--BEGIN TEMPORARY +-- The following are versions of a peephole optimizations for "let t = \[] t2[fvs] in t" +-- I think would be subsumed by a general treatmenet of let-no-rec bindings?? +ilxExpr eenv@(IlxEEnv env _) (StgLet (StgNonRec bndr (StgRhsClosure _ _ _ fvs upd [] rhs)) (StgApp fun [])) sequel + | (bndr == fun && null (ilxExprLocals env rhs)) -- TO DO??? + = ilxExpr eenv rhs sequel +ilxExpr eenv@(IlxEEnv env _) (StgLetNoEscape _ _ (StgNonRec bndr (StgRhsClosure _ _ _ fvs upd [] rhs)) (StgApp fun [])) sequel + | (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 (StgPrimApp primop args ret_ty) live_in_case live_in_alts bndr _ alts) sequel + = vcat [ilxWipe env (uniqSetToList (live `minusUniqSet` live_in_case)), + ilxPrimApp (ilxPlaceStgCaseScrut env) primop args ret_ty, + --ilxWipe env (uniqSetToList (live_in_case `minusUniqSet` live_in_alts)), + --ilxAlts (IlxEEnv env live_in_alts) bndr alts sequel + 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 + +-- 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" <+> (pprIlxTypeL env (idIlxRepType id)) + Just Arg -> text "deadarg " <+> pprId id <+> text "," <+> (pprIlxTypeL 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 eenv@(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 + 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 ty args deflt) + = do_alg_alts (deepIlxRepType ty) ([1..] `zip` args) deflt + + do_case_analysis (StgPrimAlts ty alts deflt) + = do_prim_alts ([1..] `zip` alts) $$ do_deflt deflt + + do_alg_alts ty [(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 ty 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' = unboxedTupleCon (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 ty [(i, alt@(data_con,bndrs,used_flags, rhs))] StgNoDefault + = vcat [text "castdata" <+> sep [pprIlxTypeR env ty <> comma, + ilxConRef env data_con], + do_alg_alt (IlxEEnv (ilxPlaceAlt env i) live) ty alt + ] + + do_alg_alts ty alts deflt + = vcat [text "datacase" <+> sep [pprIlxTypeR env ty,text ",", + pprSepWithCommas pp_case labels_w_alts], + do_deflt deflt, + vcat (map (do_labelled_alg_alt ty) 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 ty (i,(lbl, alt)) + = ilxLabel lbl $$ do_alg_alt (IlxEEnv (ilxPlaceAlt env i) live) ty alt + + do_alg_alt alt_eenv ty (data_con, bndrs, used_flags, rhs) + = vcat [bind_components alt_eenv ty data_con bndrs 0 used_flags, + do_rhs alt_eenv rhs + ] + + bind_components alt_eenv ty data_con [] n _ = empty + bind_components alt_eenv ty 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 ty data_con t n used_flags + | otherwise + = bind_component alt_eenv ty data_con h is_used n + <+> bind_components alt_eenv ty data_con t (n + 1) used_flags + + bind_component alt_eenv@(IlxEEnv alt_env _) ty 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 ty 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 ty data_con reduced_fld_no bndr + | isUnboxedTupleCon data_con + = text "ldfld" <+> text "!" <> integer reduced_fld_no <+> pprIlxTypeR alt_env ty <> text "::fld" <> integer reduced_fld_no + | otherwise + = text "lddata" <+> sep [pprIlxTypeR alt_env 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 (!0) --> !0 + -- + vcat [pushId env fun,ilxFunAppArgs env 0 (idIlxRepType fun) args tail_call known_clo] + where + known_clo = + case lookupIlxBindEnv env fun of + Just (place, StgRhsClosure _ _ _ _ Updatable _ _) -> Nothing + Just (place, StgRhsClosure _ _ _ fvs _ args _) -> Just (place,fun,args,fvs) + _ -> trace (show fun ++ " --> " ++ show (arityLowerBound (idArityInfo fun))) Nothing + +-- Push as many arguments as ILX allows us to in one go. +-- Recurse until we're done. +ilxFunAppArgs env num_sofar funty args tail_call known_clo + = vcat [vcat (ilxMapPlaceArgs num_sofar pushArgWithVoids env now_args), + call_instr <+> now_args_text + <+> text "-->" + <+> (pprIlxTypeR env_after_now_tyvs later_ty), + later + ] + where + now_args_text = hsep (map (pprIlxArgInfo env_after_now_tyvs) now_arg_tys) + + (now_args,now_arg_tys,env_after_now_tyvs,later_args,later_ty) = + case args of + (StgTypeArg v:rest) -> get_type_args ilxBestTypeArity args env funty + _ -> get_term_args ilxBestTermArity args env funty + + -- 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 (substTy (mkTyVarSubst [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) + + -- We could probably skip some void-rep arguments. Instead we + -- emit "ldvoid" for these and let ILXASM optimize them away. + -- get_term_args max (h@(StgVarArg v):t) env (FunTy dom ran) | isVoidIlxRepId v + -- = get_term_args max t env ran + get_term_args max args env (NoteTy _ ty) = + -- Skip NoteTy types + trace "IlxGen Internal Error: non representation type passed to get_term_args" (get_term_args max args env ty) + get_term_args 0 args env funty = ([],[],env,args,funty) + -- Stop if no more + get_term_args _ (args@(StgTypeArg _:_)) env funty = ([],[],env,args,funty) + get_term_args max (h:t) env (FunTy dom ran) = + let (now,now_tys,env2,later,later_ty) = get_term_args (max - 1) t env ran in + (h:now, (h,dom):now_tys,env2,later,later_ty) + get_term_args max (h:t) env funty = trace "IlxGen Internal Error: get_term_args could not get FunTy or ForAllTy for corresponding arg" ([],[],env,[],funty) + get_term_args max args env funty = ([],[],env,args,funty) + + -- 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) | (length needed == length args) && + all (\x -> elemIlxTyVarEnv x env) free_ilx_tvs -> + vcat [text "callclo class", + nameReference env (idName fun) <+> squotes (ilxEnvQualifyByModule env (ppr fun)), + pprTypeArgs pprIlxTypeR env (map mkTyVarTy free_ilx_tvs)] + <> 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 (pprIlxTypeR env (deepIlxRepType arg) <+> ilxComment (text "actual for tyvar")) <+> text "" +pprIlxArgInfo env (_,ty) = + parens (pprIlxTypeL 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(int64,!A) { + -- .apply (int32) (B) { ... } + -- } + -- Then + -- let v = \B (x:int32) (y:B). ... + -- becomes: + -- newclo v(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 = pprIlxBoxedTyConApp 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 = pprIlxBoxedTyConApp 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" <+> pprIlxBoxedTyConApp 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) + = pprIlxTypeL env ty <+> moduleReference env mod <+> pprId mod <> text "::" <> pprId id + +ilxTopRhsStorage mod env (bndr, StgRhsClosure _ _ _ _ _ _ _) + = text ".field public static " <+> pprIlxTypeL env bndTy <+> pprId bndr + where + bndTy = idIlxRepType bndr +ilxTopRhsStorage mod env (bndr, StgRhsCon _ _ _) + = text ".field public static " <+> pprIlxTypeL 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 "ldvoid" 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" <+> pprIlxTypeL env (idIlxRepType var) + <+> moduleReference env m <+> pprId (moduleName m) <> text "::" <> pprId var] + + Nothing -> + vcat [ilxComment (text "pushId (import) " <+> pprIlxTopVar env var), + text "ldsfld" <+> pprIlxTypeL env (idIlxRepType var) + <+> pprIlxTopVar env var] + +-------------------------------------- +-- Push a literal +pushLit env (MachChar c) = text "ldc.i4" <+> int (ord 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 (MachLitLit _ _) = trace "WARNING: Cannot compile MachLitLit to ILX in IlxGen.lhs" (text "// MachLitLit!!! Not valid in ILX!!") +pushLit env (MachAddr w) = text "ldc.i4 conv.i " <+> integer w + + +pprIlxTopVar env v + | isGlobalName n = (nameReference env n) <> pprId (nameModule n) <> text "::" <> squotes (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) + = case newTyConRep tc of + Just rep_ty -> isVoidIlxRepType (applyTys rep_ty tys) + Nothing -> + 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 + +-- Eliminate state variables on left of arrow types... +-- We have to be careful not to erase too much information here - +-- the type may not accurately describe +-- the "functionness" of the result. For example, +-- State# -> Int# +-- reduces to +-- Int# +-- which looks like an unboxed type. It isn't - it's +-- just a function taking no arguments. As such, we +-- have to rely on the context in which a function type is being +-- used to know what to do. +-- +-- deepIlxRepType (FunTy l r) | isVoidIlxRepType l +-- = deepIlxRepType r + +deepIlxRepType (FunTy l r) + = FunTy (deepIlxRepType l) (deepIlxRepType r) + +deepIlxRepType (TyConApp tc tys) + = case newTyConRep tc of + Just rep_ty -> ASSERT( length tys == tyConArity tc ) + -- The assert should hold because deepIlxRepType should + -- only be applied to *types* (of kind *) + deepIlxRepType (applyTys rep_ty tys) + Nothing -> + -- collapse UnboxedTupleTyCon down when it contains VoidRep types. + if isUnboxedTupleTyCon tc then + let tys' = map deepIlxRepType (filter (not. isVoidIlxRepType) tys) in + case tys' of + [h] -> h + _ -> mkUnboxedTupleTy (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 ty@(TyVarTy tv) = ty + +idIlxRepType id = deepIlxRepType (idType id) + +-------------------------- +-- Function types and type functions are implicitly thunkable. +-- Some primitive type constructors are not thunkable. +-- Everything else needs to be marked thunkable. +pprIlxTypeL :: IlxEnv -> Type -> SDoc + +pprIlxTypeL env ty | isVoidIlxRepType ty + = trace "pprIlxTypeL: VoidRep" pprIlxTypeR env ty + +pprIlxTypeL env ty@(FunTy arg res) + = pprIlxTypeR env ty + +pprIlxTypeL env ty@(ForAllTy arg res) + = pprIlxTypeR env ty + +pprIlxTypeL env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && null (tyConTyVars tc) + = ilxComment (text "what the fuck?") <+> (pprIlxTypeR env ty) +pprIlxTypeL env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && not (isIlxTyVar (hd (tyConTyVars tc))) + = pprIlxTypeR env ty + +pprIlxTypeL env ty | isUnLiftedType ty -- must come after cases above because isUnLiftedType strips Forall's + = pprIlxTypeR env ty + +pprIlxTypeL env ty + = text "thunk" <> angleBrackets (pprIlxTypeR env ty) + +-------------------------- +-- Print non-thunkable version of type. +-- + +pprIlxTypeR :: IlxEnv -> Type -> SDoc +pprIlxTypeR env ty | isVoidIlxRepType ty = text "void" +pprIlxTypeR env ty = pprIlxTypeR2 env ty + +pprIlxTypeR2 env ty@(AppTy f _) | isTyVarTy f = ilxComment (text "type app:" <+> pprId ty) <+> (text "class [mscorlib]System.Object") +pprIlxTypeR2 env ty@(AppTy f x) = trace "pprIlxTypeR: should I be beta reducing types?!" (ilxComment (text "pprIlxTypeR: should I be beta reducing types...") <+> pprIlxTypeR env (applyTy f x)) +pprIlxTypeR2 env (TyVarTy tv) = pprIlxTyVar env tv + +-- 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. +pprIlxTypeR2 env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && null (tyConTyVars tc) + = ilxComment (text "what the fuck? 2") <+> (pprIlxTypeR env (TyConApp tc t)) +pprIlxTypeR2 env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && not (isIlxTyVar (hd (tyConTyVars tc))) + = pprIlxTypeR env (TyConApp tc t) +pprIlxTypeR2 env (TyConApp tc args) = pprIlxTyConApp env tc args + + -- nb. the only legitimate place for VoidIlxRepTypes to occur in normalized IlxRepTypes + -- is on the left of an arrow + -- We could probably eliminate all but a final occurrence of these. + --pprIlxTypeR2 env (FunTy arg res@(FunTy _ _)) | isVoidIlxRepType arg + -- = pprIlxTypeR env res +pprIlxTypeR2 env (FunTy arg res) | isVoidIlxRepType arg + = parens (text "func () -->" <+> pprIlxTypeR env res) +pprIlxTypeR2 env (FunTy arg res) + = pprIlxFunTy (pprIlxTypeL env arg) (pprIlxTypeR env res) + +pprIlxTypeR2 env ty@(ForAllTy tv body_ty) | isIlxTyVar tv + = parens (text "forall" <+> pprTyVarBinders env' [tv] <+> nest 2 (pprIlxTypeR env' body_ty)) + where + env' = extendIlxEnvWithFormalTyVars env [tv] + +pprIlxTypeR2 env ty@(ForAllTy tv body_ty) | otherwise + = ilxComment (text "higher order type var " <+> pprId tv) <+> + pprIlxFunTy (text "class [mscorlib]System.Object") (pprIlxTypeR env body_ty) + +pprIlxTypeR2 env (NoteTy _ ty) + = trace "WARNING! non-representation type given to pprIlxTypeR: see generated ILX for context where this occurs" + (vcat [text "/* WARNING! non-representation type given to pprIlxTypeR! */", + pprIlxTypeR env ty ]) + + +pprIlxFunTy dom ran = parens (hsep [text "func",parens dom,text "-->", ran]) + +pprIlxTyConApp env tc args = + case lookupUFM tyPrimConTable (getUnique tc) of + Just f -> f env args + Nothing -> + (if isUnboxedTupleTyCon tc then pprIlxUnBoxedTyConApp else pprIlxBoxedTyConApp) + env ((nameReference env (getName tc)) <> (ppr tc)) args + +pprIlxUnBoxedTyConApp env tcdoc args = text "value class" <+> tcdoc <> pprTypeArgs pprIlxTypeL env args +pprIlxBoxedTyConApp env tcdoc args = text "class" <+> tcdoc <> pprTypeArgs pprIlxTypeR env args + +-- Returns e.g: +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: +-- 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 ":" <+> pprIlxTypeR env (tyVarKind tv)) <+> + ilxComment (text "omitted") + -- parens (text "class [mscorlib]System.Object" <+> pprId tv) + + +pprTyVarBinder_aux env tv = + ilxComment (text "tyvar" <+> pprId tv <+> text ":" <+> + pprIlxTypeR env (tyVarKind tv)) <+> + (text "class [mscorlib]System.Object") + +-- Only a subset of Haskell types can be generalized using the type quantification +-- of ILX +isIlxForAllKind h = + ( h == boxedTypeKind) || + ( h == unboxedTypeKind) || + ( h == openTypeKind) || + ( h == anyBoxKind) + +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 = squotes (ppr id) +squotes s = text "'" <> s <> text "'" + +\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 ] + +pprIlxTyVarInIlxTyEnv :: IlxTyEnv -> TyVar -> SDoc +pprIlxTyVarInIlxTyEnv tv_env tv + = go 0 tv_env + where + go n [] + = pprTrace "pprIlxTyVar" (pprId tv <+> text "tv_env = { " + <+> pprSepWithCommas (\x -> pprId x <+> text ":" + <+> pprIlxTypeR (IlxEnv (thisModule, tv_env, emptyVarEnv, emptyVarEnv, (empty,empty),False)) (tyVarKind x)) tv_env <+> text "}") + (char '!' <> pprId tv) + go n (x:xs) + = {- pprTrace "go" (ppr (tyVarName tv) <+> ppr (tyVarName x)) -} + (if tyVarName x== tyVarName tv then char '!' <> int n <+> ilxComment (char '!' <> pprId tv) + else go (n+1) xs) + + +data HowBound = Top Module -- Bound in a modules + | Arg -- Arguments to the enclosing closure + | CloVar Int -- A free variable of the enclosing closure + -- 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) +thisModule = mkThisModule (mkSrcModule "") + +pprIlxTyVar (IlxEnv (_, tv_env, _, _,_,_)) tv = pprIlxTyVarInIlxTyEnv tv_env tv + +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 + +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) + +elemIlxTyVarEnv var env@(IlxEnv (_, tv_env, _,_,_,_)) = elem var tv_env +elemIlxVarEnv var env@(IlxEnv (_, _, id_env,_,_,_)) = elemVarEnv var id_env +lookupIlxVarEnv env@(IlxEnv (_, _, id_env,_,_,_)) var = lookupVarEnv id_env var +lookupIlxBindEnv env@(IlxEnv (_, _, _, bind_env,_,_)) var = lookupVarEnv bind_env var + +\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 '\'' +squareBrackets pp = char '[' <> pp <> char ']' + +line = text "// ----------------------------------" + +nameReference (IlxEnv (thisMod, _, _, _, _, _)) n + | isLocalName n = text "/* local */" + | thisMod == nameModule n = text "" + | isDllName n = squareBrackets ((text "ilx") <+> singleQuotes (text (_UNPK_ (modulePackageName (nameModule n))) <> hscOptionQual)) + | otherwise = squareBrackets ((text ".module") <+> (text "ilx") <+> singleQuotes (pprModuleName (moduleName (nameModule n)) <> hscOptionQual)) + +hscOptionQual = if opt_DoEtaReduction then text ".O" else text ".Onot" +moduleReference (IlxEnv (thisMod, _, _, _, _, _)) m + | thisMod == m = text "" + | isLocalModule m = squareBrackets ((text ".module") <+> (text "ilx") <+>singleQuotes (pprModuleName (moduleName m) <> hscOptionQual)) + | otherwise = squareBrackets ((text "ilx") <+> singleQuotes (text (_UNPK_ (modulePackageName m)) <> hscOptionQual)) + +prelGHCReference = + if preludePackage == opt_InPackage then squareBrackets (text ".module ilx PrelGHC" <> hscOptionQual) + else squareBrackets (text "ilx" <+> text (_UNPK_ preludePackage) <> hscOptionQual) + +prelBaseReference = + if preludePackage == opt_InPackage then squareBrackets (text ".module ilx PrelBase" <> hscOptionQual) + else squareBrackets (text "ilx" <+> text (_UNPK_ preludePackage) <> hscOptionQual) + +------------------------------------------------ +-- 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 :: FAST_STRING -> SDoc +pprFSInILStyle fs = doubleQuotes (text (stringToC (_UNPK_ 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' = unboxedTupleCon (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 ", + pprIlxTyConApp env tycon' rep_ty_args', + text "::.ctor", + pprValArgTys pprIlxTypeR 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, C(!0, T ) + -- + 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 (pprIlxTyConApp 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 (htv:ttv) (StgTypeArg h:t) + | isIlxTyVar htv = ((h:l), r) + | otherwise = trace "splitTyArgs: threw away higher kinded type arg" (l, r) + where (l,r) = splitTyArgs ttv t +splitTyArgs _ l = ([],l) + +-- split some type arguments off, where none should be higher kinded +splitTyArgs1 (StgTypeArg h:t) + = ((h:l), r) + where (l,r) = splitTyArgs1 t +splitTyArgs1 l = ([],l) + + +ilxConRef env data_con + = pprId data_con <> pprValArgTys pprIlxTypeL env' (map deepIlxRepType (filter (not . isVoidIlxRepType) arg_tys)) + where + (tyvars, tau_ty) = splitForAllTys (dataConRepType data_con) + (arg_tys, _) = splitFunTys tau_ty + env' = formalIlxEnv env tyvars + + +tyPrimConTable :: UniqFM (IlxEnv -> [Type] -> SDoc) +tyPrimConTable = listToUFM [(addrPrimTyConKey, (\_ _ -> repAddr)), + (fileStreamPrimTyConKey, (\_ _ -> repFileStream)), + (foreignObjPrimTyConKey, (\_ _ -> text "/* ForeignObj */ void *")), + -- (stablePtrPrimTyConKey, (\_ _ -> text "/* StablePtr */ void *")), + (charPrimTyConKey, (\_ _ -> repChar)), + (wordPrimTyConKey, (\_ _ -> repWord)), + (byteArrayPrimTyConKey, (\_ _ -> repByteArray)), + (intPrimTyConKey, (\_ _ -> repInt)), + (int64PrimTyConKey, (\_ _ -> repInt64)), + (word64PrimTyConKey, (\_ _ -> repWord64)), + (floatPrimTyConKey, (\_ _ -> text "float32")), + (arrayPrimTyConKey, (\env [ty] -> pprIlxTypeL env ty <> text "[]")), + (mutableArrayPrimTyConKey, (\env [_, ty] -> pprIlxTypeL env ty <> text "[]")), + (mVarPrimTyConKey, (\env [_, ty] -> repMVar (pprIlxTypeL env ty))), + (mutVarPrimTyConKey, (\env [ty1, ty2] -> repMutVar (pprIlxTypeL env ty1) (pprIlxTypeL env ty2))), + (mutableByteArrayPrimTyConKey, (\_ _ -> repByteArray)), + (threadIdPrimTyConKey, (\_ _ -> text "class [mscorlib]System.Threading.Thread /* ThreadId# */ ")), + (doublePrimTyConKey, (\_ _ -> text "float64")) + ] + + +\end{code} + +%************************************************************************ +%* * +\subsection{C Calls} +%* * +%************************************************************************ + +\begin{code} + +-- We eliminate voids in and around an IL C Call. We don't yet emit PInvoke stubs. +-- We also do some type-directed translation for pinning Haskell-managed blobs +-- of data as we throw them across the boundary. +ilxCCall env (CCall (StaticTarget c) casm gc cconv) args ret_ty = + ilxComment (text "C call <+> pprCLabelString c") <+> + vcat [vcat (ilxMapPlaceArgs 0 pushCArg env args), + text "call" <+> retdoc <+> text "class " <+> prelGHCReference <+> text "PrelGHC::" <+> pprCLabelString c <+> pprTypeArgs pprIlxTypeR env ty_args + <+> pprCValArgTys pprIlxTypeL env (map deepIlxRepType (filter (not. isVoidIlxRepType) (map stgArgType tm_args))) ] + where + retdoc = + if isVoidIlxRepType ret_ty then text "void" + else pprIlxTypeR env (deepIlxRepType ret_ty) + (ty_args,tm_args) = splitTyArgs1 args + + +hasTyCon (TyConApp tc _) tc2 = tc == tc2 +hasTyCon _ _ = False + +isByteArrayCArgTy ty = hasTyCon ty byteArrayPrimTyCon || hasTyCon ty mutableByteArrayPrimTyCon +isByteArrayCArg v = isByteArrayCArgTy (deepIlxRepType (idType v)) +pinCCallArg v = isByteArrayCArg v + +ilxAddrOfPinnedByteArr = text "ldc.i4 0 ldelema unsigned int8" + +pushCArg env arg@(StgVarArg v) | isByteArrayCArg v = pushArg env arg <+> text "dup stloc" <+> squotes (ilxEnvQualifyByExact env (ppr v) <> text "pin") <+> ilxAddrOfPinnedByteArr +pushCArg env arg | otherwise = pushArg env arg + +pprCValArgTys f env tys = parens (pprSepWithCommas (pprCValArgTy f env) tys) +pprCValArgTy f env ty | isByteArrayCArgTy ty = text "void *" <+> ilxComment (text "interior pointer into ByteArr#") +pprCValArgTy f env ty | otherwise = f env ty + + +\end{code} + +%************************************************************************ +%* * +\subsection{PrimOps} +%* * +%************************************************************************ + +\begin{code} + +ilxPrimApp env (CCallOp ccall) args ret_ty = ilxCCall env ccall args ret_ty + +ilxPrimApp env op args ret_ty + = case lookupFM ilxPrimOpTable op of + Just fn -> fn env args + Nothing -> ilxComment (simp_op (text "Unknown primop!:" <+> pprId op) env args) + + + +ilxMkBool = text "call class" <+> prelBaseReference <+> + text "PrelBase_Bool" <+> + prelGHCReference <+> text "GHC.support::mkBool(bool)" +ilxCgt = text "cgt " <+> ilxMkBool +ilxCge = text "clt ldc.i4 0 ceq " <+> ilxMkBool +ilxClt = text "clt " <+> ilxMkBool +ilxCle = text "cgt ldc.i4 0 ceq " <+> ilxMkBool +ilxCeq = text "ceq " <+> ilxMkBool +ilxCne = text "ceq ldc.i4 0 ceq " <+> ilxMkBool +ilxCgtUn = text "cgt.un " <+> ilxMkBool +ilxCgeUn = text "clt.un ldc.i4 0 ceq " <+> ilxMkBool +ilxCltUn = text "clt.un " <+> ilxMkBool +ilxCleUn = text "cgt.un ldc.i4 0 ceq " <+> ilxMkBool +ldDummyInteger = text " ldc.i4 0 ldnull newobj void" <+> ilxUnboxedPairRep repInt repByteArray <+> text "::.ctor(!0,!1)" +ldDummyInteger2 = text " ldc.i4 0 ldnull ldc.i4 0 ldnull newobj void" <+> ilxUnboxedQuadRep repInt repByteArray repInt repByteArray <+> text "::.ctor(!0,!1,!2,!3)" + +repByteArray = text "unsigned int8[] /* ByteArr# */ " +repFileStream = text "void * /* FileStream# */ " -- text "class [mscorlib]System.IO.FileStream" +repInt = text "int32" +repWord = text "unsigned int32" +repAddr = text "/* Addr */ void *" +repInt64 = text "int64" +repWord64 = text "unsigned int64" +repChar = text "/* Char */ unsigned int8" +repInteger = ilxUnboxedPairRep repInt repByteArray +repIntegerPair = ilxUnboxedQuadRep repInt repByteArray repInt repByteArray +repMVar ty = text "class " <+> prelGHCReference <+> text "PrelGHC_MVarzh" <+> ilxTyParams [ty] +repMutVar _ ty2 = text "class " <+> prelGHCReference <+> text "PrelGHC_MutVarzh" <+> ilxTyParams [ty2] +repWeak ty1 = text "class " <+> prelGHCReference <+> text "PrelGHC_Weakzh" <+> ilxTyParams [ty1] + +ilxParamsAux [] = empty +ilxParamsAux [h] = h +ilxParamsAux (h:t) = h <> text "," <+> ilxParamsAux t +ilxParams [] = empty +ilxParams l = parens (ilxParamsAux l) + +ilxTyParamsAux [] = empty +ilxTyParamsAux [h] = h +ilxTyParamsAux (h:t) = h <> text "," <+> ilxTyParamsAux t +ilxTyParams [] = empty +ilxTyParams l = angleBrackets (ilxTyParamsAux l) + +ilxMethA = text "!!0" + +ilxTyPair l r = ilxTyParams [l,r] +ilxTyTriple l m r = ilxTyParams [l,m,r] +ilxTyQuad l m1 m2 r = ilxTyParams [l,m1,m2,r] +ilxUnboxedPairRep l r = text "value class" <+> prelGHCReference <+> text "PrelGHC_ZLzhzx2czhZR" <+> ilxTyPair l r +ilxUnboxedTripleRep l m r = text "value class" <+> prelGHCReference <+> text "PrelGHC_ZLzhzx2czx2czhZR" <+> ilxTyTriple l m r +ilxUnboxedQuadRep l m1 m2 r = text "value class" <+> prelGHCReference <+> text "PrelGHC_ZLzhzx2czx2czx2czhZR" <+> ilxTyQuad l m1 m2 r + +ilxMethodRef rty cls nm tyargs args = rty <+> cls <+> text "::" <> squotes (text nm) <> ilxTyParams tyargs <> ilxParams args + +ilxSupportClass = prelGHCReference <+> text "GHC.support" +ilxSuppMeth rty nm tyargs args = ilxMethodRef rty ilxSupportClass nm tyargs args + +ilxPrimOpTable :: FiniteMap PrimOp (IlxEnv -> [StgArg] -> SDoc) +ilxPrimOpTable = + listToFM [(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 (text "conv.i4")), -- chars represented by UInt32 (u4) + (ChrOp, simp_op (text "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), + + (WordGtOp, simp_op ilxCgtUn), -- words represented by UInt32 (u4) + (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 (text "add")), + (IntSubOp, simp_op (text "sub")), + (IntMulOp, simp_op (text "mul")), + (IntQuotOp, simp_op (text "div")), + (IntNegOp, simp_op (text "neg")), + (IntRemOp, simp_op (text "rem")), + + (Addr2IntOp, simp_op (text "conv.i4")), -- Addresses are very dodgy for ILX. They are used for both C-strings and + (Int2AddrOp, simp_op (text "conv.i")), -- the FFI. This needs more work. + (ISllOp, simp_op (text "shl")), + (ISraOp, simp_op (text "shr")), + (ISrlOp, simp_op (text "shr.un")), + (IntAddCOp, simp_op (text "call" <+> ilxSuppMeth (ilxUnboxedPairRep repInt repInt) "IntAddCOp" [] [repInt, repInt])), + (IntAddCOp, simp_op (text "call" <+> ilxSuppMeth (ilxUnboxedPairRep repInt repInt) "IntSubCOp" [] [repInt, repInt])), + (IntAddCOp, simp_op (text "call" <+> ilxSuppMeth (ilxUnboxedPairRep repInt repInt) "IntMulCOp" [] [repInt, repInt])), + (IntGcdOp, simp_op (text "call" <+> ilxSuppMeth repInt "IntMulCOp" [] [repInt, repInt])), + + + -- Word#-related ops: + (AndOp, simp_op (text "and")), + (OrOp, simp_op (text "or")), + (NotOp, simp_op (text "not")), + (XorOp, simp_op (text "xor")), + (SllOp, simp_op (text "shl")), + (SrlOp, simp_op (text "shr")), + (Word2IntOp, simp_op (text "conv.i4")), + (Int2WordOp, simp_op (text "conv.u4")), + + -- Float#-related ops: + (FloatAddOp, simp_op (text "add")), + (FloatSubOp, simp_op (text "sub")), + (FloatMulOp, simp_op (text "mul")), + (FloatDivOp, simp_op (text "div")), + (FloatNegOp, simp_op (text "neg")), + (Float2IntOp, simp_op (text "conv.i4")), + (Int2FloatOp, simp_op (text "conv.r4")), + + (DoubleAddOp, simp_op (text "add")), + (DoubleSubOp, simp_op (text "sub")), + (DoubleMulOp, simp_op (text "mul")), + (DoubleDivOp, simp_op (text "div")), + (DoubleNegOp, simp_op (text "neg")), + (Double2IntOp, simp_op (text "conv.i4")), + (Int2DoubleOp, simp_op (text "conv.r4")), + (Double2FloatOp, simp_op (text "conv.r4")), + (Float2DoubleOp, simp_op (text "conv.r8")), + (DoubleDecodeOp, simp_op (text "call" <+> ilxSuppMeth (ilxUnboxedTripleRep repInt repInt repByteArray) "decodeDouble" [] [text "float64"])), + (FloatDecodeOp, simp_op (text "call" <+> ilxSuppMeth (ilxUnboxedTripleRep repInt repInt repByteArray) "decodeFloat" [] [text "float32"])), + + (FloatExpOp, simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Exp(float64) conv.r4")), + (FloatLogOp, simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Log(float64) conv.r4")), + (FloatSqrtOp, simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Sqrt(float64) conv.r4")), + (FloatSinOp, simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Sin(float64) conv.r4")), + (FloatCosOp, simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Cos(float64) conv.r4")), + (FloatTanOp, simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Tan(float64) conv.r4")), + (FloatAsinOp, simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Asin(float64) conv.r4")), + (FloatAcosOp, simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Acos(float64) conv.r4")), + (FloatAtanOp, simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Atan(float64) conv.r4")), + (FloatSinhOp, simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Sinh(float64) conv.r4")), + (FloatCoshOp, simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Cosh(float64) conv.r4")), + (FloatTanhOp, simp_op (text "conv.r8 call float64 [mscorlib]System.Math::Tanh(float64) conv.r4")), + (FloatPowerOp, simp_op (text "call float64 [mscorlib]System.Math::Pow(float64, float64) conv.r4")), -- ** op, make use of implicit cast to r8... + + (DoubleExpOp, simp_op (text "call float64 [mscorlib]System.Math::Exp(float64)")), + (DoubleLogOp, simp_op (text "call float64 [mscorlib]System.Math::Log(float64)")), + (DoubleSqrtOp, simp_op (text "call float64 [mscorlib]System.Math::Sqrt(float64)")), + + (DoubleSinOp, simp_op (text "call float64 [mscorlib]System.Math::Sin(float64)")), + (DoubleCosOp, simp_op (text "call float64 [mscorlib]System.Math::Cos(float64)")), + (DoubleTanOp, simp_op (text "call float64 [mscorlib]System.Math::Tan(float64)")), + + (DoubleAsinOp, simp_op (text "call float64 [mscorlib]System.Math::Asin(float64)")), + (DoubleAcosOp, simp_op (text "call float64 [mscorlib]System.Math::Acos(float64)")), + (DoubleAtanOp, simp_op (text "call float64 [mscorlib]System.Math::Atan(float64)")), + + (DoubleSinhOp, simp_op (text "call float64 [mscorlib]System.Math::Sinh(float64)")), + (DoubleCoshOp, simp_op (text "call float64 [mscorlib]System.Math::Cosh(float64)")), + (DoubleTanhOp, simp_op (text "call float64 [mscorlib]System.Math::Tanh(float64)")), + + (DoublePowerOp, simp_op (text "call float64 [mscorlib]System.Math::Pow(float64, float64)")), + + -- Integer (and related...) ops: bail out to support routines + (IntegerAddOp, simp_op (text "call" <+> ilxSuppMeth repInteger "IntegerAddOp" [] [repInt, repByteArray, repInt, repByteArray])), + (IntegerSubOp, simp_op (text "call" <+> ilxSuppMeth repInteger "IntegerSubOp" [] [repInt, repByteArray, repInt, repByteArray])), + (IntegerMulOp, simp_op (text "call" <+> ilxSuppMeth repInteger "IntegerMulOp" [] [repInt, repByteArray, repInt, repByteArray])), + (IntegerGcdOp, simp_op (text "call" <+> ilxSuppMeth repInteger "IntegerGcdOp" [] [repInt, repByteArray, repInt, repByteArray])), + (IntegerQuotRemOp, simp_op (text "call" <+> ilxSuppMeth repIntegerPair "IntegerQuotRemOp" [] [repInt, repByteArray, repInt, repByteArray])), + (IntegerDivModOp, simp_op (text "call" <+> ilxSuppMeth repIntegerPair "IntegerDivModOp" [] [repInt, repByteArray, repInt, repByteArray])), + (IntegerNegOp, simp_op (text "call" <+> ilxSuppMeth repInteger "IntegerNegOp" [] [repInt, repByteArray])), + (IntegerIntGcdOp, simp_op (text "call" <+> ilxSuppMeth repInt "IntegerIntGcdOp" [] [repInt, repByteArray, repInt])), + (IntegerDivExactOp, simp_op (text "call" <+> ilxSuppMeth repInteger "IntegerDivExactOp" [] [repInt, repByteArray, repInt, repByteArray])), + (IntegerQuotOp, simp_op (text "call" <+> ilxSuppMeth repInteger "IntegerQuotOp" [] [repInt, repByteArray, repInt, repByteArray])), + (IntegerRemOp, simp_op (text "call" <+> ilxSuppMeth repInteger "IntegerRemOp" [] [repInt, repByteArray, repInt, repByteArray])), + (IntegerCmpOp, simp_op (text "call" <+> ilxSuppMeth repInt "IntegerCmpOp" [] [repInt, repByteArray, repInt, repByteArray])), + (IntegerCmpIntOp, simp_op (text "call" <+> ilxSuppMeth repInt "IntegerCmpIntOp" [] [repInt, repByteArray, repInt])), + (Integer2IntOp, simp_op (text "call" <+> ilxSuppMeth repInt "Integer2IntOp" [] [repInt, repByteArray])), + (Integer2WordOp, simp_op (text "call" <+> ilxSuppMeth repWord "Integer2WordOp" [] [repInt, repByteArray])), + (Int2IntegerOp, simp_op (text "call" <+> ilxSuppMeth repInteger "Int2IntegerOp" [] [repInt])), + (Word2IntegerOp, simp_op (text "call" <+> ilxSuppMeth repInteger "Word2IntegerOp" [] [repWord])), + (Addr2IntegerOp, simp_op (text "call" <+> ilxSuppMeth repInteger "Addr2IntegerOp" [] [repAddr])), + (IntegerToInt64Op, simp_op (text "call" <+> ilxSuppMeth repAddr "IntegerToInt64Op" [] [repInt,repByteArray])), + (Int64ToIntegerOp, simp_op (text "call" <+> ilxSuppMeth repInteger "Int64ToIntegerOp" [] [repInt64])), + (IntegerToWord64Op, simp_op (text "call" <+> ilxSuppMeth repWord64 "IntegerToWord64Op" [] [repInt,repByteArray])), + (Word64ToIntegerOp, simp_op (text "call" <+> ilxSuppMeth repInteger "Word64ToIntegerOp" [] [repWord64])), + + (IndexOffForeignObjOp CharRep, simp_op (text "add ldind.u1")), + (IndexOffForeignObjOp IntRep, simp_op (text "ldc.i4 4 mul add ldind.i4")), + (IndexOffForeignObjOp WordRep, simp_op (text "ldc.i4 4 mul add ldind.u4")), + (IndexOffForeignObjOp AddrRep, warn_op "IndexOffForeignObjOp AddrRep: assuing 32 bit architecture" (simp_op (text "ldc.i4 4 mul add ldind.i "))), + (IndexOffForeignObjOp FloatRep, simp_op (text "ldc.i4 4 mul add ldind.r4")), + (IndexOffForeignObjOp DoubleRep, simp_op (text "ldc.i4 8 mul add ldind.r8")), + (IndexOffForeignObjOp Int64Rep, simp_op (text "ldc.i4 8 mul add ldind.i8")), + (IndexOffForeignObjOp Word64Rep, simp_op (text "ldc.i4 8 mul add ldind.u8")), + + (IndexOffAddrOp CharRep, simp_op (text "add ldind.u1")), + (IndexOffAddrOp IntRep, simp_op (text "ldc.i4 4 mul add ldind.i4")), + (IndexOffAddrOp WordRep, simp_op (text "ldc.i4 4 mul add ldind.u4")), + (IndexOffAddrOp AddrRep, warn_op "IndexOffAddrOp AddrRep: assuing 32 bit architecture" (simp_op (text "ldc.i4 4 mul add ldind.i"))), + (IndexOffAddrOp FloatRep, simp_op (text "ldc.i4 4 mul add ldind.r4")), + (IndexOffAddrOp DoubleRep, simp_op (text "ldc.i4 8 mul add ldind.r8")), + (IndexOffAddrOp Int64Rep, simp_op (text "ldc.i4 8 mul add ldind.i8")), + (IndexOffAddrOp Word64Rep, simp_op (text "ldc.i4 8 mul add ldind.u8")), + + + (WriteOffAddrOp CharRep, ty1_arg4_op (\sty addr n v s -> addr <+> n <+> text "add" <+> v <+> text "stind.u1")), + (WriteOffAddrOp IntRep, ty1_arg4_op (\sty addr n v s -> addr <+> n <+> text "ldc.i4 4 mul add" <+> v <+> text "stind.i4")), + (WriteOffAddrOp WordRep, ty1_arg4_op (\sty addr n v s -> addr <+> n <+> text "ldc.i4 4 mul add" <+> v <+> text "stind.u4")), + (WriteOffAddrOp AddrRep, ty1_arg4_op (\sty addr n v s -> addr <+> n <+> text "ldc.i4 4 mul add" <+> v <+> text "stind.i")), + (WriteOffAddrOp FloatRep, ty1_arg4_op (\sty addr n v s -> addr <+> n <+> text "ldc.i4 4 mul add" <+> v <+> text "stind.r4")), + (WriteOffAddrOp DoubleRep, ty1_arg4_op (\sty addr n v s -> addr <+> n <+> text "ldc.i4 8 mul add" <+> v <+> text "stind.r8")), + (WriteOffAddrOp Int64Rep, ty1_arg4_op (\sty addr n v s -> addr <+> n <+> text "ldc.i4 8 mul add" <+> v <+> text "stind.i8")), + (WriteOffAddrOp Word64Rep, ty1_arg4_op (\sty addr n v s -> addr <+> n <+> text "ldc.i4 8 mul add" <+> v <+> text "stind.u8")), + {- Addr# -> Int# -> Char# -> State# s -> State# s -} + + (ReadOffAddrOp CharRep, simp_op (text "add ldind.u1")), + (ReadOffAddrOp IntRep, simp_op (text "ldc.i4 4 mul add ldind.i4")), + (ReadOffAddrOp WordRep, simp_op (text "ldc.i4 4 mul add ldind.u4")), + (ReadOffAddrOp AddrRep, simp_op (text "ldc.i4 4 mul add ldind.i")), + (ReadOffAddrOp FloatRep, simp_op (text "ldc.i4 4 mul add ldind.r4")), + (ReadOffAddrOp DoubleRep, simp_op (text "ldc.i4 8 mul add ldind.r8")), + (ReadOffAddrOp Int64Rep, simp_op (text "ldc.i4 8 mul add ldind.i8")), + (ReadOffAddrOp Word64Rep, simp_op (text "ldc.i4 8 mul add ldind.u8")), + {- Addr# -> Int# -> Char# -> State# s -> State# s -} + + (RaiseOp, ty2_op (\ty1 ty2 -> text "throw")), + (CatchOp, ty2_op (\ty1 ty2 -> + text "call" <+> ilxSuppMeth ilxMethA "catch" [ty1,ty2] [text "(func () --> !!0)", text "(func (!!1) --> (func () --> !!0))"])), + {- (State# RealWorld -> (# State# RealWorld, a #) ) + -> (b -> State# RealWorld -> (# State# RealWorld, a #) ) + -> State# RealWorld + -> (# State# RealWorld, a #) + -} + + (BlockAsyncExceptionsOp, ty1_op (\ty1 -> + text "call" <+> ilxSuppMeth ilxMethA "blockAsyncExceptions" [ty1] [text "(func () --> !!0)"])), + + {- (State# RealWorld -> (# State# RealWorld, a #)) + -> (State# RealWorld -> (# State# RealWorld, a #)) + -} + + (UnblockAsyncExceptionsOp, ty1_op (\ty1 -> + text "call" <+> ilxSuppMeth ilxMethA "unblockAsyncExceptions" [ty1] [text "(func () --> !!0)"])), + + {- + (State# RealWorld -> (# State# RealWorld, a #)) + -> (State# RealWorld -> (# State# RealWorld, a #)) + -} + + (NewMVarOp, ty2_op (\sty ty -> + text "newobj void " <+> repMVar ty <+> text "::.ctor()")), + {- State# s -> (# State# s, MVar# s a #) -} + + (TakeMVarOp, ty2_op (\sty ty -> + text "call" <+> ilxSuppMeth ilxMethA "takeMVar" [ty] [repMVar ilxMethA])), + {- MVar# s a -> State# s -> (# State# s, a #) -} + + (PutMVarOp, ty2_op (\sty ty -> + text "call" <+> ilxSuppMeth (text "void") "putMVar" [ty] [repMVar ilxMethA, ilxMethA])), + {- MVar# s a -> a -> State# s -> State# s -} + + (SameMVarOp, ty2_op (\sty ty -> text "ceq " <+> ilxMkBool)), + {- MVar# s a -> MVar# s a -> Bool -} + + (TakeMaybeMVarOp, ty2_op (\sty ty -> + text "call" <+> ilxSuppMeth (ilxUnboxedPairRep repInt ilxMethA) "tryTakeMVar" [ty] [repMVar ilxMethA])), + + {- MVar# s a -> State# s -> (# State# s, Int#, a #) -} + + (IsEmptyMVarOp, ty2_op (\sty ty -> + text "call" <+> ilxSuppMeth repInt "isEmptyMVar" [ty] [repMVar ilxMethA])), + {- MVar# s a -> State# s -> (# State# s, Int# #) -} + + (DataToTagOp, ty1_op (\ty1 -> + text "call" <+> ilxSuppMeth repInt "dataToTag" [ty1] [ilxMethA])), + {- a -> Int# -} + + (TagToEnumOp, ty1_op (\ty1 -> + text "call" <+> ilxSuppMeth ilxMethA "tagToEnum" [ty1] [repInt])), + {- Int# -> a -} + + (IndexByteArrayOp CharRep, simp_op (text "ldelem.u1")), + (IndexByteArrayOp IntRep, simp_op (text "ldelem.i4")), + (IndexByteArrayOp WordRep, simp_op (text "ldelem.u4")), + (IndexByteArrayOp AddrRep, simp_op (text "ldelem.u")), + (IndexByteArrayOp FloatRep, simp_op (text "ldelem.r4")), + (IndexByteArrayOp DoubleRep, simp_op (text "ldelem.r8")), + (IndexByteArrayOp StablePtrRep, simp_op (text "ldelem.i4")), + (IndexByteArrayOp Int64Rep, simp_op (text "ldelem.i8")), + (IndexByteArrayOp Word64Rep, simp_op (text "ldelem.u8")), + + {- ByteArr# -> Int# -> Char# -} + + (WriteByteArrayOp CharRep, simp_op (text "stelem.u1")), + (WriteByteArrayOp IntRep, simp_op (text "stelem.i4")), + (WriteByteArrayOp WordRep, simp_op (text "stelem.u4")), + (WriteByteArrayOp AddrRep, simp_op (text "stelem.u")), + (WriteByteArrayOp FloatRep, simp_op (text "stelem.r4")), + (WriteByteArrayOp DoubleRep, simp_op (text "stelem.r8")), + (WriteByteArrayOp StablePtrRep, simp_op (text "stelem.i4")), + (WriteByteArrayOp Int64Rep, simp_op (text "stelem.i8")), + (WriteByteArrayOp Word64Rep, simp_op (text "stelem.u8")), + + {- MutByteArr# s -> Int# -> Char# -> State# s -> State# s -} + + {- should be monadic??? -} + (ReadByteArrayOp CharRep, simp_op (text "ldelem.u1")), + (ReadByteArrayOp IntRep, simp_op (text "ldelem.i4")), + (ReadByteArrayOp WordRep, simp_op (text "ldelem.u4")), + (ReadByteArrayOp AddrRep, simp_op (text "ldelem.u")), + (ReadByteArrayOp FloatRep, simp_op (text "ldelem.r4")), + (ReadByteArrayOp DoubleRep, simp_op (text "ldelem.r8")), + (ReadByteArrayOp StablePtrRep, simp_op (text "ldelem.i4")), + (ReadByteArrayOp Int64Rep, simp_op (text "ldelem.i8")), + (ReadByteArrayOp Word64Rep, simp_op (text "ldelem.u8")), + {- MutByteArr# s -> Int# -> State# s -> (# State# s, Char# #) -} + + {- should be monadic??? -} + (NewByteArrayOp CharRep, simp_op (text "newarr [mscorlib]System.Byte")), + (NewByteArrayOp IntRep, simp_op (text "newarr [mscorlib]System.Int32")), + (NewByteArrayOp WordRep, simp_op (text "newarr [mscorlib]System.UInt32")), + (NewByteArrayOp AddrRep, simp_op (text "newarr [mscorlib]System.UInt64")), + (NewByteArrayOp FloatRep, simp_op (text "newarr [mscorlib]System.Single")), + (NewByteArrayOp DoubleRep, simp_op (text "newarr [mscorlib]System.Double")), + (NewByteArrayOp StablePtrRep, simp_op (text "newarr [mscorlib]System.UInt32")), +{- (NewByteArrayOp Int64Rep, simp_op (text "newarr [mscorlib]System.Int64")), TODO: there is no unique for this one -} +{- (NewByteArrayOp Word64Rep, simp_op (text "newarr [mscorlib]System.UInt64")), -} + {- Int# -> State# s -> (# State# s, MutByteArr# s #) -} + + (UnsafeFreezeByteArrayOp, ty1_op (\ty1 -> text "nop ")), + {- MutByteArr# s -> State# s -> (# State# s, ByteArr# #) -} + (SizeofByteArrayOp, simp_op (text "ldlen")), + {- ByteArr# -> Int# -} + + (SameMutableByteArrayOp, ty1_op (\ty1 -> text "ceq " <+> ilxMkBool)), + {- MutByteArr# s -> MutByteArr# s -> Bool -} + (SizeofMutableByteArrayOp, ty1_op (\ty1 -> text "ldlen")), + {- MutByteArr# s -> Int# -} + + (SameMutVarOp, ty2_op (\ty1 ty2 -> text "ceq " <+> ilxMkBool)), + {- MutVar# s a -> MutVar# s a -> Bool -} + (NewMutVarOp, ty2_op (\ty1 ty2 -> text "newobj void" <+> repMutVar ty1 ty2 <+> text "::.ctor(!0)")), + {- a -> State# s -> (# State# s, MutVar# s a #) -} + (ReadMutVarOp, ty2_op (\ty1 ty2 -> text "ldfld !0" <+> repMutVar ty1 ty2 <+> text "::contents")), + {- MutVar# s a -> State# s -> (# State# s, a #) -} + (WriteMutVarOp, ty2_op (\ty1 ty2 -> text "stfld !0" <+> repMutVar ty1 ty2 <+> text "::contents")), + {- MutVar# s a -> a -> State# s -> State# s -} + + (NewArrayOp, ty2_op (\ty1 ty2 -> text "call !!0[] " <+> ilxSupportClass <+> text "::newArray<" <> ty1 <> text ">(" <> repInt <> text ", !!0)")), + {- Int# -> a -> State# s -> (# State# s, MutArr# s a #) -} + (IndexArrayOp, ty1_op (\ty1 -> text "ldelem.ref")), + {- Array# a -> Int# -> (# a #) -} + (WriteArrayOp, ty2_op (\ty1 ty2 -> text "stelem.ref")), + {- MutArr# s a -> Int# -> a -> State# s -> State# s -} + (ReadArrayOp, ty2_op (\ty1 ty2 -> text "ldelem.ref")), + {- MutArr# s a -> Int# -> State# s -> (# State# s, a #) -} + (UnsafeFreezeArrayOp, ty2_op (\ty1 ty2 -> text "nop")), + {- MutArr# s a -> State# s -> (# State# s, Array# a #) -} + (UnsafeThawArrayOp, ty2_op (\ty1 ty2 -> text "nop")), + {- Array# a -> State# s -> (# State# s, MutArr# s a #) -} + + (SameMutableArrayOp, ty2_op (\ty1 ty2 -> text "ceq " <+> ilxMkBool)), + {- MutArr# s a -> MutArr# s a -> Bool -} + + (MakeStablePtrOp, ty1_op (\ty1 -> text "newobj void class " <+> prelGHCReference <+> text "PrelGHC_StablePtrzh<" <> ty1 <> text ">::.ctor(!0)")), + {- a -> State# RealWorld -> (# State# RealWorld, StablePtr# a #) -} + + (DeRefStablePtrOp, ty1_op (\ty1 -> text "ldfld !0 class " <+> prelGHCReference <+> text "PrelGHC_StablePtrzh<" <> ty1 <> text ">::contents")), + {- StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #) -} + + (EqStablePtrOp, ty1_op (\ty1 -> text "ceq " <+> ilxMkBool)), + {- StablePtr# a -> StablePtr# a -> Int# -} + + (MkWeakOp, ty3_op (\ty1 ty2 ty3 -> text "call" <+> ilxMethodRef (repWeak (text "!!1")) (text "class " <+> prelGHCReference <+> text "PrelGHC_Weakzh") "bake" [ty1,ty2,ty3] [text "!!0", text "!!1", text "!!2"])), + {- o -> b -> c -> State# RealWorld -> (# State# RealWorld, Weak# b #) -} + + (DeRefWeakOp, ty1_op (\ty1 -> text "call" <+> ilxMethodRef (ilxUnboxedPairRep repInt (text "!0")) (repWeak ty1) "deref" [] [])), + (FinalizeWeakOp, ty1_op (\ty1 -> text "call" <+> ilxMethodRef (ilxUnboxedPairRep repInt (text "(func () --> class '()')")) (repWeak ty1) "finalizer" [] [])), + {- Weak# a -> State# RealWorld -> (# State# RealWorld, Int#, + (State# RealWorld -> (# State# RealWorld, Unit #)) #) -} + + (MkForeignObjOp, simp_op (text "nop /* newobj void class " <+> prelGHCReference <+> text "PrelGHC_ForeignObjzh::.ctor(void *) */")), + (WriteForeignObjOp, simp_op (text "pop /* stfld void * class " <+> prelGHCReference <+> text "PrelGHC_ForeignObjzh::contents */ ")), + -- (ForeignObjToAddrOp, simp_op (text "ldfld void * class " <+> prelGHCReference <+> text "PrelGHC_ForeignObjzh::contents"), + (YieldOp, simp_op (text "call class [mscorlib]System.Threading.Thread class [mscorlib]System.Threading.Thread::get_CurrentThread() + call void class [mscorlib]System.Threading.Thread::Suspend()")), + (MyThreadIdOp, simp_op (text "call default class [mscorlib]System.Threading.Thread class [mscorlib]System.Threading.Thread::get_CurrentThread() ")), + (KillThreadOp, simp_op (text "call instance void class [mscorlib]System.Threading.Thread::Abort(class [mscorlib]System.Object) ")), + {- ThreadId# -> a -> State# RealWorld -> State# RealWorld -} + + (ForkOp, ty1_op (\ty -> text "call default class [mscorlib]System.Threading.Thread " <+> ilxSupportClass <+> text "::fork<" <> ty <> text ">(thunk)")), + + (ParOp, warn_op "ParOp" (simp_op (text "/* ParOp skipped... */ pop ldc.i4 0"))), + + (DelayOp, simp_op (text "call void class [mscorlib]System.Threading.Thread::Sleep(int32) ")), + {- Int# -> State# s -> State# s -} + (WaitReadOp, warn_op "WaitReadOp" (simp_op (text "/* WaitReadOp skipped... */ pop"))), + (WaitWriteOp, warn_op "WaitWriteOp" (simp_op (text " /* WaitWriteOp skipped... */ pop"))) + + + + ] + +ty1_op op env ((StgTypeArg ty1):rest) = + vcat (ilxMapPlaceArgs 1 pushArg env rest) $$ op (pprIlxTypeR env (deepIlxRepType ty1)) +--ty1_after1_op op env (h:(StgTypeArg ty1):rest) = +-- vcat (ilxMapPlaceArgs 0 pushArg env [h]) $$ vcat (ilxMapPlaceArgs 2 pushArg env rest) $$ op (pprIlxTypeR env (deepIlxRepType ty1)) +ty2_op op env ((StgTypeArg ty1):(StgTypeArg ty2):rest) = + vcat (ilxMapPlaceArgs 2 pushArg env rest) $$ op (pprIlxTypeR env (deepIlxRepType ty1)) (pprIlxTypeR env (deepIlxRepType ty2)) + +ty3_op op env ((StgTypeArg ty1):(StgTypeArg ty2):(StgTypeArg ty3):rest) = + vcat (ilxMapPlaceArgs 2 pushArg env rest) $$ + op (pprIlxTypeR env (deepIlxRepType ty1)) + (pprIlxTypeR env (deepIlxRepType ty2)) + (pprIlxTypeR env (deepIlxRepType ty3)) + +ty1_arg4_op op env [(StgTypeArg ty1), a1, a2, a3, a4] = + op (pprIlxTypeR env (deepIlxRepType ty1)) + (hd2 (ilxMapPlaceArgs 1 pushArg env [a1]) ) + (hd2 (ilxMapPlaceArgs 2 pushArg env [a2]) ) + (hd2 (ilxMapPlaceArgs 3 pushArg env [a3]) ) + (hd2 (ilxMapPlaceArgs 4 pushArg env [a4]) ) + +hd (h:t) = h +hd2 (h:t) = h + +simp_op op env args = vcat (ilxMapPlaceArgs 0 pushArg env args) $$ op +warn_op warning f args = trace ("WARNING! IlxGen cannot translate primop " ++ warning) (f args) +\end{code} diff --git a/ghc/compiler/ilxGen/Makefile.stdlib b/ghc/compiler/ilxGen/Makefile.stdlib new file mode 100644 index 0000000..bab9933 --- /dev/null +++ b/ghc/compiler/ilxGen/Makefile.stdlib @@ -0,0 +1,82 @@ +PrelAll_SRC=Array.lhs Maybe.lhs PrelDynamic.lhs PrelIOBase.lhs PrelShow.lhs \ +CPUTime.lhs Monad.lhs PrelEnum.lhs PrelList.lhs PrelStable.lhs \ +Char.lhs Numeric.lhs PrelErr.lhs PrelTup.lhs \ +Complex.lhs PrelAddr.lhs PrelException.lhs PrelMaybe.lhs PrelWeak.lhs \ +Directory.lhs PrelArr.lhs PrelFloat.lhs PrelNum.lhs Prelude.lhs \ +IO.lhs PrelArrExtra.lhs PrelForeign.lhs PrelPack.lhs Random.lhs \ +Ix.lhs PrelBase.lhs PrelHandle.lhs PrelRead.lhs Ratio.lhs \ +List.lhs PrelByteArr.lhs PrelHugs.lhs PrelReal.lhs System.lhs \ +Locale.lhs PrelConc.lhs PrelIO.lhs PrelST.lhs Time.lhs + +PrelAll_ILX=$(patsubst %.lhs,%.ilx,$(PrelAll_SRC)) +CLEAN_FILES += $(PrelAll_ILX) +PrelAll_ILX_FWD=$(patsubst %.lhs,%.ilx.fwd.ok,$(PrelAll_SRC)) +PrelAll_IL=$(patsubst %.lhs,%.il,$(PrelAll_SRC)) PrelGHC.il +PrelAll_MOD=$(patsubst %.il,%.mod,$(PrelAll_IL)) + + +%.ilx %.ilx.fwd: %.lhs + $(HC_PRE_OPTS) + $(HC) $(HC_OPTS) -Onot -D__ILX__ --ilx $*.lhs -o $*.ilx + $(HC_POST_OPTS) + + +CORRUN= +LOCALRUN=./ +ifeq ($(HOSTNAME),msrc-hilda) +CORRUN=cmd /c "devvs && " +LOCALRUN=.\\ +endif + +ILXASM=/devel/fcom/src/bin/ilxasmx.exe -l /devel/fcom/src/ilxasm --no-ilasm --box-everything +ILASM=$(CORRUN)ilasm +AL=$(CORRUN)al + +%.ilx.fwd.ok: %.ilx.fwd + if diff -q $< $@; then true; else cp $< $@; fi + +%.mod : %.il + $(ILASM) /QUIET /DLL /OUT=$@ $< + +PrelGHC.il: ../../compiler/ilxGen/PrelGHC.il + cp $< $@ + +PrelAll.dll : ilxasm-stdlib.mod $(PrelAll_MOD) + $(AL) ilxasm-stdlib.mod $(PrelAll_MOD) -out:$@ + +%.ilx_with_fwd: %.ilx $(PrelAll_ILX_FWD) + cat $(PrelAll_ILX_FWD) $*.ilx > $@ + +%.il : %.ilx_with_fwd /devel/fcom/src/bin/ilxasmx.exe + $(ILXASM) --no-stdlib -o $@ $*.ilx_with_fwd + +ilxasm-stdlib.il : /devel/fcom/src/bin/ilxasmx.exe /devel/fcom/src/ilxasm/stdlib-func-by-mcalli.ilx + rm -f tmp.ilx + touch tmp.ilx + $(ILXASM) -o $@ tmp.ilx + rm -f tmp.ilx + + +#-------------------- +# For validation only: + +PrelAll.il: $(PrelAll_IL) ilxasm-stdlib.il + cat ilxasm-stdlib.il $(PrelAll_IL) > $@ + +%.mvl: %.il + make -C ../../compiler/ilxGen/tests ilvalidx + ILVALID_HOME=/devel/fcom/src /devel/fcom/src/bin/ilvalidx.exe $*.il + + +ilxasm: + make -C ../../compiler/ilxGen/tests ilxasmx + +ilvalid: + $(MAKE) -C /devel/fcom/src bin/ilvalidx.exe + + +ghc: + make -C ../../compiler/ilxGen/tests ghc + + +.PRECIOUS: %.ilx.fwd %.ilx.fwd.ok %.il %.ilx_with_fwd diff --git a/ghc/compiler/ilxGen/primops.txt b/ghc/compiler/ilxGen/primops.txt new file mode 100644 index 0000000..be87f83 --- /dev/null +++ b/ghc/compiler/ilxGen/primops.txt @@ -0,0 +1,881 @@ +{- NOT YET DONE: + + +----------------------------------------------------------------------- +-- $Id: primops.txt,v 1.1 2001/02/26 15:44:59 rrt Exp $ +-- +-- Primitive Operations +-- +----------------------------------------------------------------------- + +-- To add a new primop, you currently need to update the following files: +-- +-- - this file (ghc/compiler/prelude/primops.txt), which includes +-- the type of the primop, and various other properties (its +-- strictness attributes, whether it is defined as a macro +-- or as out-of-line code, etc.) +-- +-- - ghc/lib/std/PrelGHC.hi-boot, to declare the primop +-- +-- - if the primop is inline (i.e. a macro), then: +-- ghc/includes/PrimOps.h +-- ghc/compiler/nativeGen/StixPrim.lhs +-- +-- - or, for an out-of-line primop: +-- ghc/includes/PrimOps.h (just add the declaration) +-- ghc/rts/PrimOps.hc (define it here) +-- +-- - the User's Guide +-- + +-- The default attribute values which apply if you don't specify +-- other ones. Attribute values can be True, False, or arbitrary +-- text between curly brackets. This is a kludge to enable +-- processors of this file to easily get hold of simple info +-- (eg, out_of_line), whilst avoiding parsing complex expressions +-- needed for strictness and usage info. + +defaults + has_side_effects = False + out_of_line = False + commutable = False + needs_wrapper = False + can_fail = False + strictness = { \ arity -> StrictnessInfo (replicate arity wwPrim) False } + usage = { nomangle other } + + +------------------------------------------------------------------------ +--- Support for the metacircular interpreter --- +------------------------------------------------------------------------ + +primop IndexOffClosureOp_Ptr "indexPtrOffClosure#" GenPrimOp + a -> Int# -> (# b #) +primop IndexOffClosureOp_Word "indexWordOffClosure#" GenPrimOp + a -> Int# -> Word# + + +primop Addr2IntOp "addr2Int#" GenPrimOp Addr# -> Int# + +primop DoubleDecodeOp "decodeDouble#" GenPrimOp + Double# -> (# Int#, Int#, ByteArr# #) + with out_of_line = True + +primop FloatDecodeOp "decodeFloat#" GenPrimOp + Float# -> (# Int#, Int#, ByteArr# #) + with out_of_line = True + +primop IntegerSubOp "minusInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + with out_of_line = True + +primop IntegerMulOp "timesInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + with commutable = True + out_of_line = True + +primop IntegerGcdOp "gcdInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + with commutable = True + out_of_line = True + +primop IntegerIntGcdOp "gcdIntegerInt#" GenPrimOp + Int# -> ByteArr# -> Int# -> Int# + with commutable = True + +primop IntegerDivExactOp "divExactInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + with out_of_line = True + +primop IntegerQuotOp "quotInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + with out_of_line = True + +primop IntegerRemOp "remInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + with out_of_line = True + +primop IntegerCmpOp "cmpInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> Int# + with needs_wrapper = True + +primop IntegerCmpIntOp "cmpIntegerInt#" GenPrimOp + Int# -> ByteArr# -> Int# -> Int# + with needs_wrapper = True + +primop IntegerQuotRemOp "quotRemInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr#, Int#, ByteArr# #) + with can_fail = True + out_of_line = True + +primop IntegerDivModOp "divModInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr#, Int#, ByteArr# #) + with can_fail = True + out_of_line = True + +primop Integer2IntOp "integer2Int#" GenPrimOp + Int# -> ByteArr# -> Int# + with needs_wrapper = True + +primop Integer2WordOp "integer2Word#" GenPrimOp + Int# -> ByteArr# -> Word# + with needs_wrapper = True + +primop IntegerToInt64Op "integerToInt64#" GenPrimOp + Int# -> ByteArr# -> Int64# + +primop IntegerToWord64Op "integerToWord64#" GenPrimOp + Int# -> ByteArr# -> Word64# + +------------------------------------------------------------------------ +--- Arrays --- +------------------------------------------------------------------------ + +primop NewByteArrayOp_Char "newCharArray#" GenPrimOp + Int# -> State# s -> (# State# s, MutByteArr# s #) + with out_of_line = True + +primop NewByteArrayOp_Int "newIntArray#" GenPrimOp + Int# -> State# s -> (# State# s, MutByteArr# s #) + with out_of_line = True + +primop NewByteArrayOp_Word "newWordArray#" GenPrimOp + Int# -> State# s -> (# State# s, MutByteArr# s #) + with out_of_line = True + +primop NewByteArrayOp_Addr "newAddrArray#" GenPrimOp + Int# -> State# s -> (# State# s, MutByteArr# s #) + with out_of_line = True + +primop NewByteArrayOp_Float "newFloatArray#" GenPrimOp + Int# -> State# s -> (# State# s, MutByteArr# s #) + with out_of_line = True + +primop NewByteArrayOp_Double "newDoubleArray#" GenPrimOp + Int# -> State# s -> (# State# s, MutByteArr# s #) + with out_of_line = True + +primop NewByteArrayOp_StablePtr "newStablePtrArray#" GenPrimOp + Int# -> State# s -> (# State# s, MutByteArr# s #) + with out_of_line = True + + + +primop ReadByteArrayOp_Char "readCharArray#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Char# #) + +primop ReadByteArrayOp_Int "readIntArray#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Int# #) + +primop ReadByteArrayOp_Word "readWordArray#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Word# #) + +primop ReadByteArrayOp_Addr "readAddrArray#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Addr# #) + +primop ReadByteArrayOp_Float "readFloatArray#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Float# #) + +primop ReadByteArrayOp_Double "readDoubleArray#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Double# #) + +primop ReadByteArrayOp_StablePtr "readStablePtrArray#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, StablePtr# a #) + +primop ReadByteArrayOp_Int64 "readInt64Array#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Int64# #) + +primop ReadByteArrayOp_Word64 "readWord64Array#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Word64# #) + + + +primop WriteByteArrayOp_Char "writeCharArray#" GenPrimOp + MutByteArr# s -> Int# -> Char# -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_Int "writeIntArray#" GenPrimOp + MutByteArr# s -> Int# -> Int# -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_Word "writeWordArray#" GenPrimOp + MutByteArr# s -> Int# -> Word# -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_Addr "writeAddrArray#" GenPrimOp + MutByteArr# s -> Int# -> Addr# -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_Float "writeFloatArray#" GenPrimOp + MutByteArr# s -> Int# -> Float# -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_Double "writeDoubleArray#" GenPrimOp + MutByteArr# s -> Int# -> Double# -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_StablePtr "writeStablePtrArray#" GenPrimOp + MutByteArr# s -> Int# -> StablePtr# a -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_Int64 "writeInt64Array#" GenPrimOp + MutByteArr# s -> Int# -> Int64# -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_Word64 "writeWord64Array#" GenPrimOp + MutByteArr# s -> Int# -> Word64# -> State# s -> State# s + with has_side_effects = True + + +primop IndexByteArrayOp_Char "indexCharArray#" GenPrimOp + ByteArr# -> Int# -> Char# + +primop IndexByteArrayOp_Int "indexIntArray#" GenPrimOp + ByteArr# -> Int# -> Int# + +primop IndexByteArrayOp_Word "indexWordArray#" GenPrimOp + ByteArr# -> Int# -> Word# + +primop IndexByteArrayOp_Addr "indexAddrArray#" GenPrimOp + ByteArr# -> Int# -> Addr# + +primop IndexByteArrayOp_Float "indexFloatArray#" GenPrimOp + ByteArr# -> Int# -> Float# + +primop IndexByteArrayOp_Double "indexDoubleArray#" GenPrimOp + ByteArr# -> Int# -> Double# + +primop IndexByteArrayOp_StablePtr "indexStablePtrArray#" GenPrimOp + ByteArr# -> Int# -> StablePtr# a + +primop IndexByteArrayOp_Int64 "indexInt64Array#" GenPrimOp + ByteArr# -> Int# -> Int64# + +primop IndexByteArrayOp_Word64 "indexWord64Array#" GenPrimOp + ByteArr# -> Int# -> Word64# + + + + +primop ReadOffAddrOp_Char "readCharOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Char# #) + +primop ReadOffAddrOp_Int "readIntOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Int# #) + +primop ReadOffAddrOp_Word "readWordOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Word# #) + +primop ReadOffAddrOp_Addr "readAddrOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Addr# #) + +primop ReadOffAddrOp_Float "readFloatOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Float# #) + +primop ReadOffAddrOp_Double "readDoubleOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Double# #) + +primop ReadOffAddrOp_StablePtr "readStablePtrOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, StablePtr# a #) + +primop ReadOffAddrOp_ForeignObj "readForeignObjOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, ForeignObj# #) + +primop ReadOffAddrOp_Int64 "readInt64OffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Int64# #) + +primop ReadOffAddrOp_Word64 "readWord64OffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Word64# #) + + +primop WriteOffAddrOp_Char "writeCharOffAddr#" GenPrimOp + Addr# -> Int# -> Char# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Int "writeIntOffAddr#" GenPrimOp + Addr# -> Int# -> Int# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Word "writeWordOffAddr#" GenPrimOp + Addr# -> Int# -> Word# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Addr "writeAddrOffAddr#" GenPrimOp + Addr# -> Int# -> Addr# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Float "writeFloatOffAddr#" GenPrimOp + Addr# -> Int# -> Float# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Double "writeDoubleOffAddr#" GenPrimOp + Addr# -> Int# -> Double# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_StablePtr "writeStablePtrOffAddr#" GenPrimOp + Addr# -> Int# -> StablePtr# a -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_ForeignObj "writeForeignObjOffAddr#" GenPrimOp + Addr# -> Int# -> ForeignObj# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Int64 "writeInt64OffAddr#" GenPrimOp + Addr# -> Int# -> Int64# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Word64 "writeWord64OffAddr#" GenPrimOp + Addr# -> Int# -> Word64# -> State# s -> State# s + with has_side_effects = True + + + +primop NewArrayOp "newArray#" GenPrimOp + Int# -> a -> State# s -> (# State# s, MutArr# s a #) + with + strictness = { \ arity -> StrictnessInfo [wwPrim, wwLazy, wwPrim] False } + usage = { mangle NewArrayOp [mkP, mkM, mkP] mkM } + out_of_line = True + +primop SameMutableArrayOp "sameMutableArray#" GenPrimOp + MutArr# s a -> MutArr# s a -> Bool + with + usage = { mangle SameMutableArrayOp [mkP, mkP] mkM } + +primop SameMutableByteArrayOp "sameMutableByteArray#" GenPrimOp + MutByteArr# s -> MutByteArr# s -> Bool + +primop ReadArrayOp "readArray#" GenPrimOp + MutArr# s a -> Int# -> State# s -> (# State# s, a #) + with + usage = { mangle ReadArrayOp [mkM, mkP, mkP] mkM } + +primop WriteArrayOp "writeArray#" GenPrimOp + MutArr# s a -> Int# -> a -> State# s -> State# s + with + usage = { mangle WriteArrayOp [mkM, mkP, mkM, mkP] mkR } + strictness = { \ arity -> StrictnessInfo [wwPrim, wwPrim, wwLazy, wwPrim] False } + has_side_effects = True + +primop IndexArrayOp "indexArray#" GenPrimOp + Array# a -> Int# -> (# a #) + with + usage = { mangle IndexArrayOp [mkM, mkP] mkM } + +primop UnsafeFreezeArrayOp "unsafeFreezeArray#" GenPrimOp + MutArr# s a -> State# s -> (# State# s, Array# a #) + with + usage = { mangle UnsafeFreezeArrayOp [mkM, mkP] mkM } + has_side_effects = True + +primop UnsafeFreezeByteArrayOp "unsafeFreezeByteArray#" GenPrimOp + MutByteArr# s -> State# s -> (# State# s, ByteArr# #) + with + has_side_effects = True + +primop UnsafeThawArrayOp "unsafeThawArray#" GenPrimOp + Array# a -> State# s -> (# State# s, MutArr# s a #) + with + usage = { mangle UnsafeThawArrayOp [mkM, mkP] mkM } + out_of_line = True + +primop SizeofByteArrayOp "sizeofByteArray#" GenPrimOp + ByteArr# -> Int# + +primop SizeofMutableByteArrayOp "sizeofMutableByteArray#" GenPrimOp + MutByteArr# s -> Int# + +------------------------------------------------------------------------ +--- Mutable variables --- +------------------------------------------------------------------------ + +primop NewMutVarOp "newMutVar#" GenPrimOp + a -> State# s -> (# State# s, MutVar# s a #) + with + usage = { mangle NewMutVarOp [mkM, mkP] mkM } + strictness = { \ arity -> StrictnessInfo [wwLazy, wwPrim] False } + out_of_line = True + +primop ReadMutVarOp "readMutVar#" GenPrimOp + MutVar# s a -> State# s -> (# State# s, a #) + with + usage = { mangle ReadMutVarOp [mkM, mkP] mkM } + +primop WriteMutVarOp "writeMutVar#" GenPrimOp + MutVar# s a -> a -> State# s -> State# s + with + strictness = { \ arity -> StrictnessInfo [wwPrim, wwLazy, wwPrim] False } + usage = { mangle WriteMutVarOp [mkM, mkM, mkP] mkR } + has_side_effects = True + +primop SameMutVarOp "sameMutVar#" GenPrimOp + MutVar# s a -> MutVar# s a -> Bool + with + usage = { mangle SameMutVarOp [mkP, mkP] mkM } + +------------------------------------------------------------------------ +--- Exceptions --- +------------------------------------------------------------------------ + +primop CatchOp "catch#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a #) ) + -> (b -> State# RealWorld -> (# State# RealWorld, a #) ) + -> State# RealWorld + -> (# State# RealWorld, a #) + with + strictness = { \ arity -> StrictnessInfo [wwLazy, wwLazy, wwPrim] False } + -- Catch is actually strict in its first argument + -- but we don't want to tell the strictness + -- analyser about that! + usage = { mangle CatchOp [mkM, mkM . (inFun CatchOp mkM mkM), mkP] mkM } + -- [mkO, mkO . (inFun mkM mkO)] mkO + -- might use caught action multiply + out_of_line = True + +primop RaiseOp "raise#" GenPrimOp + a -> b + with + strictness = { \ arity -> StrictnessInfo [wwLazy] True } + -- NB: True => result is bottom + usage = { mangle RaiseOp [mkM] mkM } + out_of_line = True + +primop BlockAsyncExceptionsOp "blockAsyncExceptions#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a #)) + -> (State# RealWorld -> (# State# RealWorld, a #)) + with + strictness = { \ arity -> StrictnessInfo [wwLazy] False } + out_of_line = True + +primop UnblockAsyncExceptionsOp "unblockAsyncExceptions#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a #)) + -> (State# RealWorld -> (# State# RealWorld, a #)) + with + strictness = { \ arity -> StrictnessInfo [wwLazy] False } + out_of_line = True + +------------------------------------------------------------------------ +--- MVars (not the same as mutable variables!) --- +------------------------------------------------------------------------ + +primop NewMVarOp "newMVar#" GenPrimOp + State# s -> (# State# s, MVar# s a #) + with + usage = { mangle NewMVarOp [mkP] mkR } + out_of_line = True + +primop TakeMVarOp "takeMVar#" GenPrimOp + MVar# s a -> State# s -> (# State# s, a #) + with + usage = { mangle TakeMVarOp [mkM, mkP] mkM } + has_side_effects = True + out_of_line = True + +primop PutMVarOp "putMVar#" GenPrimOp + MVar# s a -> a -> State# s -> State# s + with + strictness = { \ arity -> StrictnessInfo [wwPrim, wwLazy, wwPrim] False } + usage = { mangle PutMVarOp [mkM, mkM, mkP] mkR } + has_side_effects = True + out_of_line = True + +primop SameMVarOp "sameMVar#" GenPrimOp + MVar# s a -> MVar# s a -> Bool + with + usage = { mangle SameMVarOp [mkP, mkP] mkM } + +primop TakeMaybeMVarOp "tryTakeMVar#" GenPrimOp + MVar# s a -> State# s -> (# State# s, Int#, a #) + with + usage = { mangle TakeMaybeMVarOp [mkM, mkP] mkM } + has_side_effects = True + out_of_line = True + +primop IsEmptyMVarOp "isEmptyMVar#" GenPrimOp + MVar# s a -> State# s -> (# State# s, Int# #) + with + usage = { mangle IsEmptyMVarOp [mkP, mkP] mkM } + + +------------------------------------------------------------------------ +--- delay/wait operations --- +------------------------------------------------------------------------ + +primop DelayOp "delay#" GenPrimOp + Int# -> State# s -> State# s + with + needs_wrapper = True + has_side_effects = True + out_of_line = True + +primop WaitReadOp "waitRead#" GenPrimOp + Int# -> State# s -> State# s + with + needs_wrapper = True + has_side_effects = True + out_of_line = True + +primop WaitWriteOp "waitWrite#" GenPrimOp + Int# -> State# s -> State# s + with + needs_wrapper = True + has_side_effects = True + out_of_line = True + +------------------------------------------------------------------------ +--- concurrency primitives --- +------------------------------------------------------------------------ + +primop ForkOp "fork#" GenPrimOp + a -> State# RealWorld -> (# State# RealWorld, ThreadId# #) + with + usage = { mangle ForkOp [mkO, mkP] mkR } + strictness = { \ arity -> StrictnessInfo [wwLazy, wwPrim] False } + has_side_effects = True + out_of_line = True + +primop KillThreadOp "killThread#" GenPrimOp + ThreadId# -> a -> State# RealWorld -> State# RealWorld + with + usage = { mangle KillThreadOp [mkP, mkM, mkP] mkR } + has_side_effects = True + out_of_line = True + +primop YieldOp "yield#" GenPrimOp + State# RealWorld -> State# RealWorld + with + has_side_effects = True + out_of_line = True + +primop MyThreadIdOp "myThreadId#" GenPrimOp + State# RealWorld -> (# State# RealWorld, ThreadId# #) + +------------------------------------------------------------------------ +--- foreign objects --- +------------------------------------------------------------------------ + +primop MkForeignObjOp "mkForeignObj#" GenPrimOp + Addr# -> State# RealWorld -> (# State# RealWorld, ForeignObj# #) + with + has_side_effects = True + out_of_line = True + +primop WriteForeignObjOp "writeForeignObj#" GenPrimOp + ForeignObj# -> Addr# -> State# s -> State# s + with + has_side_effects = True + +primop ForeignObjToAddrOp "foreignObjToAddr#" GenPrimOp + ForeignObj# -> Addr# + +primop TouchOp "touch#" GenPrimOp + o -> State# RealWorld -> State# RealWorld + with + strictness = { \ arity -> StrictnessInfo [wwLazy, wwPrim] False } + +------------------------------------------------------------------------ +--- Bytecode objects --- +------------------------------------------------------------------------ + +primop NewBCOOp "newBCO#" GenPrimOp + Int# -> Int# -> Int# -> a -> State# RealWorld -> (# State# RealWorld, BCO# #) + with + has_side_effects = True + out_of_line = True + strictness = { \ arity -> StrictnessInfo + [wwPrim, wwPrim, wwPrim, wwLazy, wwPrim] False } + usage = { mangle NewBCOOp [mkP, mkP, mkP, mkM, mkP] mkR } + +primop WriteBCOPtrOp "writeBCOPtr#" GenPrimOp + BCO# -> Int# -> o -> State# RealWorld -> State# RealWorld + with + usage = { mangle WriteBCOPtrOp [mkP, mkP, mkM, mkP] mkR } + strictness = { \ arity -> StrictnessInfo + [wwPrim, wwPrim, wwLazy, wwPrim] False } + has_side_effects = True + +primop WriteBCONonPtrOp "writeBCONonPtr#" GenPrimOp + BCO# -> Int# -> Word# -> State# RealWorld -> State# RealWorld + with + has_side_effects = True + +primop WriteBCOInstrOp "writeBCOInstr#" GenPrimOp + BCO# -> Int# -> Word# -> State# RealWorld -> State# RealWorld + with + has_side_effects = True + +primop ReadBCOPtrOp "readBCOPtr#" GenPrimOp + BCO# -> Int# -> State# RealWorld -> (# State# RealWorld, Word# #) + with + usage = { mangle ReadBCOPtrOp [mkP, mkP] mkM } + +primop ReadBCONonPtrOp "readBCONonPtr#" GenPrimOp + BCO# -> Int# -> State# RealWorld -> (# State# RealWorld, Word# #) + +primop ReadBCOInstrOp "readBCOInstr#" GenPrimOp + BCO# -> Int# -> State# RealWorld -> (# State# RealWorld, Word# #) + +primop SameBCOOp "sameBCO#" GenPrimOp + BCO# -> BCO# -> Bool + with + -- is this usage right? + usage = { mangle SameMutableArrayOp [mkP, mkP] mkM } + + +------------------------------------------------------------------------ +--- Weak pointers --- +------------------------------------------------------------------------ + +-- note that tyvar "o" denoted openAlphaTyVar + +primop MkWeakOp "mkWeak#" GenPrimOp + o -> b -> c -> State# RealWorld -> (# State# RealWorld, Weak# b #) + with + strictness = { \ arity -> StrictnessInfo [wwLazy, wwLazy, wwLazy, wwPrim] False } + usage = { mangle MkWeakOp [mkZ, mkM, mkM, mkP] mkM } + has_side_effects = True + out_of_line = True + +primop DeRefWeakOp "deRefWeak#" GenPrimOp + Weak# a -> State# RealWorld -> (# State# RealWorld, Int#, a #) + with + usage = { mangle DeRefWeakOp [mkM, mkP] mkM } + has_side_effects = True + +primop FinalizeWeakOp "finalizeWeak#" GenPrimOp + Weak# a -> State# RealWorld -> (# State# RealWorld, Int#, + (State# RealWorld -> (# State# RealWorld, Unit #)) #) + with + usage = { mangle FinalizeWeakOp [mkM, mkP] + (mkR . (inUB FinalizeWeakOp + [id,id,inFun FinalizeWeakOp mkR mkM])) } + has_side_effects = True + out_of_line = True + + +------------------------------------------------------------------------ +--- Stable pointers and names --- +------------------------------------------------------------------------ + +primop MakeStablePtrOp "makeStablePtr#" GenPrimOp + a -> State# RealWorld -> (# State# RealWorld, StablePtr# a #) + with + strictness = { \ arity -> StrictnessInfo [wwLazy, wwPrim] False } + usage = { mangle MakeStablePtrOp [mkM, mkP] mkM } + has_side_effects = True + +primop DeRefStablePtrOp "deRefStablePtr#" GenPrimOp + StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #) + with + usage = { mangle DeRefStablePtrOp [mkM, mkP] mkM } + needs_wrapper = True + has_side_effects = True + +primop EqStablePtrOp "eqStablePtr#" GenPrimOp + StablePtr# a -> StablePtr# a -> Int# + with + usage = { mangle EqStablePtrOp [mkP, mkP] mkR } + has_side_effects = True + +primop MakeStableNameOp "makeStableName#" GenPrimOp + a -> State# RealWorld -> (# State# RealWorld, StableName# a #) + with + usage = { mangle MakeStableNameOp [mkZ, mkP] mkR } + strictness = { \ arity -> StrictnessInfo [wwLazy, wwPrim] False } + needs_wrapper = True + has_side_effects = True + out_of_line = True + +primop EqStableNameOp "eqStableName#" GenPrimOp + StableName# a -> StableName# a -> Int# + with + usage = { mangle EqStableNameOp [mkP, mkP] mkR } + +primop StableNameToIntOp "stableNameToInt#" GenPrimOp + StableName# a -> Int# + with + usage = { mangle StableNameToIntOp [mkP] mkR } + +------------------------------------------------------------------------ +--- Unsafe pointer equality (#1 Bad Guy: Alistair Reid :) --- +------------------------------------------------------------------------ + +primop ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp + a -> a -> Int# + with + usage = { mangle ReallyUnsafePtrEqualityOp [mkZ, mkZ] mkR } + +------------------------------------------------------------------------ +--- Parallelism --- +------------------------------------------------------------------------ + +primop SeqOp "seq#" GenPrimOp + a -> Int# + with + usage = { mangle SeqOp [mkO] mkR } + strictness = { \ arity -> StrictnessInfo [wwStrict] False } + -- Seq is strict in its argument; see notes in ConFold.lhs + has_side_effects = True + +primop ParOp "par#" GenPrimOp + a -> Int# + with + usage = { mangle ParOp [mkO] mkR } + strictness = { \ arity -> StrictnessInfo [wwLazy] False } + -- Note that Par is lazy to avoid that the sparked thing + -- gets evaluted strictly, which it should *not* be + has_side_effects = True + +-- HWL: The first 4 Int# in all par... annotations denote: +-- name, granularity info, size of result, degree of parallelism +-- Same structure as _seq_ i.e. returns Int# +-- KSW: v, the second arg in parAt# and parAtForNow#, is used only to determine +-- `the processor containing the expression v'; it is not evaluated + +primop ParGlobalOp "parGlobal#" GenPrimOp + a -> Int# -> Int# -> Int# -> Int# -> b -> Int# + with + usage = { mangle ParGlobalOp [mkO, mkP, mkP, mkP, mkP, mkM] mkM } + has_side_effects = True + +primop ParLocalOp "parLocal#" GenPrimOp + a -> Int# -> Int# -> Int# -> Int# -> b -> Int# + with + usage = { mangle ParLocalOp [mkO, mkP, mkP, mkP, mkP, mkM] mkM } + has_side_effects = True + +primop ParAtOp "parAt#" GenPrimOp + b -> a -> Int# -> Int# -> Int# -> Int# -> c -> Int# + with + usage = { mangle ParAtOp [mkO, mkZ, mkP, mkP, mkP, mkP, mkM] mkM } + has_side_effects = True + +primop ParAtAbsOp "parAtAbs#" GenPrimOp + a -> Int# -> Int# -> Int# -> Int# -> Int# -> b -> Int# + with + usage = { mangle ParAtAbsOp [mkO, mkP, mkP, mkP, mkP, mkM] mkM } + has_side_effects = True + +primop ParAtRelOp "parAtRel#" GenPrimOp + a -> Int# -> Int# -> Int# -> Int# -> Int# -> b -> Int# + with + usage = { mangle ParAtRelOp [mkO, mkP, mkP, mkP, mkP, mkM] mkM } + has_side_effects = True + +primop ParAtForNowOp "parAtForNow#" GenPrimOp + b -> a -> Int# -> Int# -> Int# -> Int# -> c -> Int# + with + usage = { mangle ParAtForNowOp [mkO, mkZ, mkP, mkP, mkP, mkP, mkM] mkM } + has_side_effects = True + +primop CopyableOp "copyable#" GenPrimOp + a -> Int# + with + usage = { mangle CopyableOp [mkZ] mkR } + has_side_effects = True + +primop NoFollowOp "noFollow#" GenPrimOp + a -> Int# + with + usage = { mangle NoFollowOp [mkZ] mkR } + has_side_effects = True + + +------------------------------------------------------------------------ +--- tag to enum stuff --- +------------------------------------------------------------------------ + +primop DataToTagOp "dataToTag#" GenPrimOp + a -> Int# + with + strictness = { \ arity -> StrictnessInfo [wwLazy] False } + +primop TagToEnumOp "tagToEnum#" GenPrimOp + Int# -> a + + +thats_all_folks + +------------------------------------------------------------------------ +--- --- +------------------------------------------------------------------------ + + + -- Char#-related ops: + + -- Int#-related ops: + + -- Float#-related ops: + + -- primitive ops for primitive arrays + + + | ReadOffAddrOp PrimRep + | WriteOffAddrOp PrimRep + | IndexOffAddrOp PrimRep + -- PrimRep can be one of : + -- {Char,Int,Word,Addr,Float,Double,StablePtr,Int64,Word64}Rep. + -- This is just a cheesy encoding of a bunch of ops. + -- Note that ForeignObjRep is not included -- the only way of + -- creating a ForeignObj is with a ccall or casm. + | IndexOffForeignObjOp PrimRep + + | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp + | SizeofByteArrayOp | SizeofMutableByteArrayOp + + + + -- exceptions + + -- foreign objects + | MkForeignObjOp + | WriteForeignObjOp + + -- weak pointers + | MkWeakOp + | DeRefWeakOp + | FinalizeWeakOp + + -- stable names + | MakeStableNameOp + | EqStableNameOp + | StableNameToIntOp + + -- stable pointers + | MakeStablePtrOp + | DeRefStablePtrOp + | EqStablePtrOp + + -- Foreign calls + | CCallOp CCall + -- Operation to test two closure addresses for equality (yes really!) + -- BLAME ALASTAIR REID FOR THIS! THE REST OF US ARE INNOCENT! + | ReallyUnsafePtrEqualityOp + + -- parallel stuff + | SeqOp + | ParOp + + -- concurrency + | ForkOp + | KillThreadOp + | YieldOp + | MyThreadIdOp + | DelayOp + | WaitReadOp + | WaitWriteOp + + -- more parallel stuff + | ParGlobalOp -- named global par + | ParLocalOp -- named local par + | ParAtOp -- specifies destination of local par + | ParAtAbsOp -- specifies destination of local par (abs processor) + | ParAtRelOp -- specifies destination of local par (rel processor) + | ParAtForNowOp -- specifies initial destination of global par + | CopyableOp -- marks copyable code + | NoFollowOp -- marks non-followup expression + + -- tag-related + | DataToTagOp + | TagToEnumOp +-} diff --git a/ghc/compiler/ilxGen/tests/Makefile b/ghc/compiler/ilxGen/tests/Makefile new file mode 100644 index 0000000..24aa4de --- /dev/null +++ b/ghc/compiler/ilxGen/tests/Makefile @@ -0,0 +1,299 @@ +include ../../../lib/std/Makefile.src + +# These settings are if you use a visual studio build +CVS=/cvs/cvs +CORENV_DEBUG= +CORENV_RETAIL= +LOCALRUN=./ +ILX_FAST=x +ifeq ($(HOSTNAME),msrc-hilda) +CORENV_DEBUG="call devvsnearerb1gen.bat" +CORENV_RETAIL="call devvsnearerb1gen.bat retail" +LOCALRUN=.\\ +ILX_FAST= +endif + +ILXASM_HOME=/devel/fcom/src +ILXASM=$(ILXASM_HOME)/bin/ilxasm$(ILX_FAST).exe +ILVALID=$(ILXASM_HOME)/bin/ilvalid$(ILX_FAST).exe +ILXASM_FLAGS=-l $(ILXASM_HOME)/ilxasm --no-ilasm --tailcall-indirect + +ghc: + $(MAKE) -C ../.. ilxGen/IlxGen.o hsc + +ilxasm: + $(MAKE) -C $(ILXASM_HOME) bin/ilxasm.exe + +ilxasmx: + $(MAKE) -C $(ILXASM_HOME) bin/ilxasmx.exe + +ilvalid: + $(MAKE) -C $(ILXASM_HOME) bin/ilvalid.exe + +ilvalidx: + $(MAKE) -C $(ILXASM_HOME) bin/ilvalidx.exe + +prel: + $(MAKE) -C ../../../lib/std ilxasm std.Onot.nongeneric.boxed.dll + $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.nongeneric.boxed.dll + +prelq: + $(MAKE) -C ../../../lib/std ilxasm std.Onot.nongeneric.boxed.trial.dll + $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.nongeneric.boxed.trial.dll + +oprel: + $(MAKE) -C ../../../lib/std ilxasm std.O.nongeneric.boxed.dll + $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.nongeneric.boxed.dll + +oprelq: + $(MAKE) -C ../../../lib/std ilxasm std.O.nongeneric.boxed.trial.dll + $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.nongeneric.boxed.trial.dll + +tprel: + $(MAKE) -C ../../../lib/std ilxasm std.Onot.nongeneric.boxed.traced.dll + $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.nongeneric.boxed.traced.dll + +otprel: + $(MAKE) -C ../../../lib/std ilxasm std.O.nongeneric.boxed.traced.dll + $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.nongeneric.boxed.traced.dll + +#gprel: +# $(MAKE) -C ../../../lib/std ilxasm std.Onot.generic.dll +# $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.generic.dll +# +#ogprel: +# $(MAKE) -C ../../../lib/std ilxasm std.O.generic.dll +# $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.generic.dll +# +#gtprel: +# $(MAKE) -C ../../../lib/std ilxasm std.Onot.generic.traced.dll +# $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.generic.traced.dll + +vgprel: + $(MAKE) -C ../../../lib/std ilxasm std.Onot.vmeth-erased.generic.dll + $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.vmeth-erased.generic.dll + +ovgprel: + $(MAKE) -C ../../../lib/std ilxasm std.O.vmeth-erased.generic.dll + $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.vmeth-erased.generic.dll + +ovgprelq: + $(MAKE) -C ../../../lib/std ilxasm std.O.vmeth-erased.generic.trial.dll + $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.vmeth-erased.generic.trial.dll + +vgtprel: + $(MAKE) -C ../../../lib/std ilxasm std.Onot.vmeth-erased.generic.traced.dll + $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.vmeth-erased.generic.traced.dll + +ovgtprel: + $(MAKE) -C ../../../lib/std ilxasm std.O.vmeth-erased.generic.traced.dll + $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.vmeth-erased.generic.traced.dll + +%.o: %.hs ../../hsc.exe + ../../../driver/ghc-inplace -o $@ -c $*.hs + +std_NONGENERIC_STATIC_IL=$(patsubst %.lhs,../../../lib/std/%.nongeneric.boxed.static.il,$(std_SRC)) ../../../lib/std/PrelGHC.nongeneric.boxed.static.il +std_GENERIC_STATIC_IL=$(patsubst %.lhs,../../../lib/std/%.generic.static.il,$(std_SRC)) ../../../lib/std/PrelGHC.generic.static.il + +#======================================================================== +# 1. From Haskell to ILX + +%.Onot.ilx: %.hs ../../hsc.exe + ../../../driver/ghc-inplace -fglasgow-exts -o $@ -i../../../lib/std/.Onot -Onot --ilx $*.hs + +%.O.ilx: %.hs ../../hsc.exe + ../../../driver/ghc-inplace -fglasgow-exts -o $@ -i../../../lib/std/.O -O --ilx $*.hs + +../Entry.Onot.ilx: ../Entry.ilx + sed -e "s|ilx std|ilx std.Onot|g" ../Entry.ilx > $@.tmp + mv $@.tmp $@ + +%.Onot.dlllib.ilx: %.Onot.ilx ../Entry.Onot.ilx + cat ../Entry.Onot.ilx $*.Onot.ilx > $@.tmp + mv $@.tmp $@ + +../Entry.O.ilx: ../Entry.ilx + sed -e "s|ilx std|ilx std.O|g" ../Entry.ilx > $@.tmp + mv $@.tmp $@ + +%.O.dlllib.ilx: %.O.ilx ../Entry.O.ilx + cat ../Entry.O.ilx $*.O.ilx > $@.tmp + mv $@.tmp $@ + +HSstd_cbits.dll: ../../../lib/std/cbits/HSstd_cbits.dll + cp $< $@ + + +#======================================================================== +# 2. From ILX to IL + +#------------------------------------------------------------------------ +# Compile for a vanilla VM against a vanilla library organised as a +# seperate assembly/DLL. + +%.nongeneric.boxed.dlllib.il: $(ILXASM) %.dlllib.ilx + $(ILXASM) --box-everything --no-stdlib $(ILXASM_FLAGS) -o $@.tmp $*.dlllib.ilx + mv $@.tmp $@ + +#------------------------------------------------------------------------ +# Same +# - running a trial optimization +# - for traced code on a vanilla VM +%.nongeneric.boxed.trial.dlllib.il: $(ILXASM) %.dlllib.ilx + $(ILXASM) --trial-opt --box-everything --no-stdlib $(ILXASM_FLAGS) -o $@.tmp $*.dlllib.ilx + mv $@.tmp $@ + +%.nongeneric.boxed.traced.dlllib.il: $(ILXASM) %.dlllib.ilx + $(ILXASM) --box-everything --trace-il --no-stdlib $(ILXASM_FLAGS) -o $@.tmp $*.dlllib.ilx + mv $@.tmp $@ + +#------------------------------------------------------------------------ +# Same, for a generic library and generic VM + +%.generic.dlllib.il: $(ILXASM) %.dlllib.ilx + $(ILXASM) --no-pp --no-stdlib $(ILXASM_FLAGS) -o $@.tmp $*.dlllib.ilx + mv $@.tmp $@ + +%.generic.trial.dlllib.il: $(ILXASM) %.dlllib.ilx + $(ILXASM) --trial-opt --no-pp --no-stdlib $(ILXASM_FLAGS) -o $@.tmp $*.dlllib.ilx + mv $@.tmp $@ + +%.generic.traced.dlllib.il: $(ILXASM) %.dlllib.ilx + $(ILXASM) --trace-il --no-pp --no-stdlib $(ILXASM_FLAGS) -o $@.tmp $*.dlllib.ilx + mv $@.tmp $@ + +%.vmeth-erased.generic.dlllib.il: $(ILXASM) %.dlllib.ilx + $(ILXASM) --poly-virtual-method-erase --no-pp --no-stdlib $(ILXASM_FLAGS) -o $@.tmp $*.dlllib.ilx + mv $@.tmp $@ + +%.vmeth-erased.generic.trial.dlllib.il: $(ILXASM) %.dlllib.ilx + $(ILXASM) --trial-opt --poly-virtual-method-erase --no-pp --no-stdlib $(ILXASM_FLAGS) -o $@.tmp $*.dlllib.ilx + mv $@.tmp $@ + +%.vmeth-erased.generic.traced.dlllib.il: $(ILXASM) %.dlllib.ilx + $(ILXASM) --poly-virtual-method-erase --trace-il --no-pp --no-stdlib $(ILXASM_FLAGS) -o $@.tmp $*.dlllib.ilx + mv $@.tmp $@ + + +#------------------------------------------------------------------------ +# Compile for a vanilla VM against a vanilla library compiled to IL code +# to be statically linked as one big module. We hack this up by textually +# stripping out all the assembly qualifications (apart from mscorlib) +# from the ILX forward files and IL code itself. We then just +# concatenate all the IL code together and compile it as a single .EXE. + +%.staticlib.ilx: %.ilx ../Entry.ilx + cat ../Entry.ilx $*.ilx | \ + sed -e "sQ\[std\]QQg" | \ + sed -e "sQ\['std'\]QQg" > $@.tmp + cat $@.tmp > $@.tmp2 + mv $@.tmp2 $@ + rm $@.tmp + + +%.generic.staticlib.il: $(ILXASM) %.staticlib.ilx + $(ILXASM) --static --no-pp $(ILXASM_FLAGS) -o $@.tmp $*.staticlib.ilx + cat $(std_GENERIC_STATIC_IL) $@.tmp > $@.tmp2 + mv $@.tmp2 $@ + rm $@.tmp + + +%.nongeneric.boxed.staticlib.il: $(ILXASM) %.staticlib.ilx + $(ILXASM) --box-everything --static $(ILXASM_FLAGS) -o $@.tmp $*.staticlib.ilx + cat $(std_NONGENERIC_STATIC_IL) $@.tmp > $@.tmp2 + mv $@.tmp2 $@ + rm $@.tmp + + +#------------------------------------------------------------------------ +# For compiling test cases that don't use the standard library at all. + +%.nolib.ilx: %.ilx PrelBase.test.ilx ../PrelGHC.ilx ../Entry.ilx + cat ../PrelGHC.ilx PrelBase.test.ilx ../Entry.ilx $*.ilx > $@.tmp + mv $@.tmp $@ + +%.nolib.il: $(ILXASM) $(ILXASM_HOME)/ilxasm/stdlib-func-by-mcalli.ilx %.nolib.ilx + $(ILXASM) $(ILXASM_FLAGS) -o $@.tmp $*.nolib.ilx + mv $@.tmp $@ + +%.nolib.traced.il: $(ILXASM) $(ILXASM_HOME)/ilxasm/stdlib-func-by-mcalli.ilx %.nolib.ilx + $(ILXASM) --trace-il $(ILXASM_FLAGS) $*.nolib.ilx > $@.tmp + mv $@.tmp $@ + + +#------------------------------------------------------------------------ +# From IL to .EXE + +%.retail.exe: %.il + echo "$(CORENV_RETAIL)" > $@.bat + echo "ilasm -exe -quiet -out=$(subst /,\\,$@) $(subst /,\\,$<)" >> $@.bat + time -p cmd /c $(subst /,\\,$@).bat + rm $@.bat + +%.debug.exe: %.il + echo "$(CORENV_RETAIL)" > $@.bat + echo "ilasm -exe -quiet -debug -out=$(subst /,\\,$@) $(subst /,\\,$<)" >> $@.bat + time -p cmd /c $(subst /,\\,$@).bat + rm $@.bat +#------------------------------------------------------------------------ +# From .HS to .EXE without using ILX + +%.Onot.exe: %.hs + ghc -Onot -o $@ $< + +%.O.exe: %.hs + ghc -O -o $@ $< + + + +#------------------------------------------------------------------------ +# Running: + +%.debug.run: HSstd_cbits.dll %.debug.exe + echo "$(CORENV_DEBUG)" > $@.bat + echo "set CORPATH=$(subst /,\\,$(ILXASM_HOME))\\bin;\\GHC\\fptools\\ghc\\lib\\std;%CORPATH%" >> $@.bat + echo "$(LOCALRUN)$(subst /,\\,$*).debug.exe 2>&1" >> $@.bat + time -p cmd /c $(subst /,\\,$@).bat + rm $@.bat + +%.retail.run: HSstd_cbits.dll %.retail.exe + echo "$(CORENV_RETAIL)" > $@.bat + echo "set CORPATH=$(subst /,\\,$(ILXASM_HOME))\\bin;\\GHC\\fptools\\ghc\\lib\\std;%CORPATH%" >> $@.bat + echo "$(LOCALRUN)$(subst /,\\,$*).retail.exe 2>&1" >> $@.bat + time -p cmd /c $(subst /,\\,$@).bat + rm $@.bat + + +%.run: %.exe + time -p $< + + + +#-------------------- + +%.debug.exe: %.nolib.il + echo "$(CORENV_RETAIL)" > $@.bat + echo "$(CORENV_RETAIL)ilasm /DEBUG /OUT=$(subst /,\\,$@) $(subst /,\\,$<)" >> $@.bat + time -p cmd /c $(subst /,\\,$@).bat + rm $@.bat + +%.trace-il.nolib.il: $(ILXASM) $(ILXASM_HOME)/ilxasm/stdlib-func-by-mcalli.ilx %.nolib.ilx + $(ILXASM) $(ILXASM_FLAGS) --trace-il $*.nolib.ilx > $@.tmp + mv $@.tmp $@ + +%.mvl: %.nolib.il + ILVALID_HOME=$(ILXASM_HOME) $(ILVALID) $*.nolib.il + +ci: + (cd $(ILXASM_HOME); $(CVS) ci -m "") + (cd ../..; cvs ci -m "") + (cd ../../../lib/std; $(CVS) ci -m "") + +upd: + (cd $(ILXASM_HOME); $(CVS) up) + (cd ../..; $(CVS) up) + (cd ../../../lib/std; $(CVS) up) + +.PRECIOUS: %.nongeneric.boxed.dlllib.il %.generic.dlllib.il %.generic.il %.nolib.il %.Onot.ilx %.O.ilx %.nolib.ilx %.dlllib.ilx %.exe %.debug.exe %.dll %.O.exe + +.PHONY: %.run diff --git a/ghc/compiler/ilxGen/tests/PrelNum.hs b/ghc/compiler/ilxGen/tests/PrelNum.hs new file mode 100644 index 0000000..ca23e14 --- /dev/null +++ b/ghc/compiler/ilxGen/tests/PrelNum.hs @@ -0,0 +1,120 @@ + + + + + + + + + + + + + + + + +{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-} + +module PrelNum where + +import {-# SOURCE #-} PrelErr +import PrelBase +import PrelList +import PrelEnum +import PrelShow + +infixl 7 * +infixl 6 +, - + +default () -- Double isn't available yet, + -- and we shouldn't be using defaults anyway + + + + + + + + + +class (Eq a, Show a) => Num a where + (+), (-), (*) :: a -> a -> a + negate :: a -> a + abs, signum :: a -> a + fromInteger :: Integer -> a + fromInt :: Int -> a -- partain: Glasgow extension + + x - y = x + negate y + negate x = 0 - x + fromInt (I# i#) = fromInteger (S# i#) + -- Go via the standard class-op if the + -- non-standard one ain't provided + + + + + +subtract :: (Num a) => a -> a -> a +{-# INLINE subtract #-} +subtract x y = y - x + +ord_0 :: Num a => a +ord_0 = fromInt (ord '0') + + + + + + + + + + +instance Num Int where + (+) x y = plusInt x y + (-) x y = minusInt x y + negate x = negateInt x + (*) x y = timesInt x y + abs n = if n `geInt` 0 then n else (negateInt n) + + signum n | n `ltInt` 0 = negateInt 1 + | n `eqInt` 0 = 0 + | otherwise = 1 + + fromInt n = n + + + + +-- These can't go in PrelBase with the defn of Int, because +-- we don't have pairs defined at that time! + +quotRemInt :: Int -> Int -> (Int, Int) +a@(I# _) `quotRemInt` b@(I# _) = (a `quotInt` b, a `remInt` b) + -- OK, so I made it a little stricter. Shoot me. (WDP 94/10) + +divModInt :: Int -> Int -> (Int, Int) +divModInt x@(I# _) y@(I# _) = (x `divInt` y, x `modInt` y) + -- Stricter. Sorry if you don't like it. (WDP 94/10) + + + + + + + + + + +data Integer + = S# Int# -- small integers + | J# Int# ByteArray# -- large integers + + + + + +zeroInteger :: Integer +zeroInteger = S# 0# + diff --git a/ghc/compiler/ilxGen/tests/foo.hs b/ghc/compiler/ilxGen/tests/foo.hs new file mode 100644 index 0000000..d66608b --- /dev/null +++ b/ghc/compiler/ilxGen/tests/foo.hs @@ -0,0 +1,9 @@ +{-# OPTIONS -fglasgow-exts #-} +module Foo where +import PrelGHC +import PrelNum +import PrelBase +integer2Intx :: Integer -> Int +integer2Intx (S# i) = I# i +integer2Intx (J# s d) = case (integer2Int# s d) of { n# -> I# n# } + diff --git a/ghc/compiler/ilxGen/tests/life.hs b/ghc/compiler/ilxGen/tests/life.hs new file mode 100644 index 0000000..d6bcd16 --- /dev/null +++ b/ghc/compiler/ilxGen/tests/life.hs @@ -0,0 +1,360 @@ +-------------------------------- +-- The Game of Life -- +-------------------------------- + +generations x = 30 + +data L a = N | C1 a (L a) + +data Tuple2 a b = T2 a b + +data Tuple3 a b c = T3 a b c + + +main = putStr (listChar_string + (append1 (C1 '\FF' N) + (life1 (generations ()) (start ())))) + +listChar_string :: L Char -> String +listChar_string N = [] +listChar_string (C1 x xs) = x : listChar_string xs + +start :: a -> L (L Int) +start x = (C1 N + (C1 N + (C1 N + (C1 N + (C1 N + (C1 N + (C1 N + (C1 N + (C1 N + (C1 N + (C1 N + (C1 N + (C1 N + (C1 N + (C1 + (C1 0 + (C1 0 + (C1 0 + (C1 1 + (C1 1 + (C1 1 + (C1 1 + (C1 1 + (C1 0 + (C1 1 + (C1 1 + (C1 1 + (C1 1 + (C1 1 + (C1 0 + (C1 1 + (C1 1 + (C1 1 + (C1 1 + (C1 1 + (C1 0 + (C1 1 + (C1 1 + (C1 1 + (C1 1 + (C1 1 + (C1 0 N))))))))))))))))))))))))))) N))))))))))))))) + +-- Calculating the next generation + +gen1 :: Int -> L (L Int) -> L (L Int) +gen1 n board = map1 row1 (shift1 (copy1 n 0) board) + +row1 :: Tuple3 (L Int) (L Int) (L Int) -> L Int +row1 (T3 last this next) + = zipWith31 elt1 (shift2 0 last) + (shift2 0 this) + (shift2 0 next) + + +elt1 :: Tuple3 Int Int Int + -> (Tuple3 Int Int Int) + -> (Tuple3 Int Int Int) -> Int +elt1 (T3 a b c) (T3 d e f) (T3 g h i) + = if (not (eq tot 2)) + && (not (eq tot 3)) + then 0 + else if (eq tot 3) then 1 else e + where tot = a `plus` b `plus` c `plus` d + `plus` f `plus` g `plus` h `plus` i + +eq :: Int -> Int -> Bool +eq x y = x == y + +plus :: Int -> Int -> Int +plus x y = x + y + +shiftr1 :: L Int -> L (L Int) -> L (L Int) +shiftr1 x xs = append2 (C1 x N) (init1 xs) + +shiftl1 :: L Int -> L (L Int) -> L (L Int) +shiftl1 x xs = append2 (tail1 xs) (C1 x N) + +shift1 :: L Int -> L (L Int) + -> L (Tuple3 (L Int) (L Int) (L Int)) +shift1 x xs = zip31 (shiftr1 x xs) xs (shiftl1 x xs) + +shiftr2 :: Int -> L Int -> L Int +shiftr2 x xs = append3 (C1 x N) (init2 xs) + +shiftl2 :: Int -> L Int -> L Int +shiftl2 x xs = append3 (tail2 xs) (C1 x N) + +shift2 :: Int -> L Int -> L (Tuple3 Int Int Int) +shift2 x xs = zip32 (shiftr2 x xs) xs (shiftl2 x xs) + +-- copy + +copy1 :: Int -> Int -> L Int +copy1 0 x = N +copy1 n x = C1 x (copy1 (n-1) x) + +copy2 :: Int -> L Int -> L (L Int) +copy2 0 x = N +copy2 n x = C1 x (copy2 (n-1) x) + +copy3 :: Int -> Char -> L Char +copy3 0 x = N +copy3 n x = C1 x (copy3 (n-1) x) + +-- Displaying one generation + +disp1 :: (Tuple2 (L Char) (L (L Int))) -> L Char +disp1 (T2 gen xss) + = append1 gen + (append1 (C1 '\n' (C1 '\n' N)) + (foldr_1 (glue1 (C1 '\n' N)) N + (map4 (compose2 concat1 (map2 star1)) xss))) + +star1 :: Int -> L Char +star1 i = case i of + 0 -> C1 ' ' (C1 ' ' N) + 1 -> C1 ' ' (C1 'o' N) + +glue1 :: L Char -> L Char -> L Char -> L Char +glue1 s xs ys = append1 xs (append1 s ys) + +-- Generating and displaying a sequence of generations + +life1 :: Int -> L (L Int) -> L Char +life1 n xss + = foldr_1 (glue1 (copy3 (n+2) '\VT')) N + (map5 disp1 + (zip1_ (map6 (string_ListChar.show) (ints 0)) + gens)) + where + gens = take3 (740::Int) (iterate1 (gen1 n) (initial1 n xss)) + +ints :: Int -> L Int +ints x = C1 x (ints (x+1)) + +string_ListChar :: String -> L Char +string_ListChar [] = N +string_ListChar (x:xs) = C1 x (string_ListChar xs) + +initial1 :: Int -> L (L Int) -> L (L Int) +initial1 n xss = take1 n (append2 (map3 (compose1 (take2 n) + (`append3` (copy1 n 0))) xss) + (copy2 n (copy1 n 0))) + +iterate1 :: (L (L Int) -> L (L Int)) + -> L (L Int) -> L (L (L Int)) +iterate1 f x = C1 x (iterate1 f (f x)) + +-- versions of built in functions + +-- take +take1 :: Int -> L (L Int) -> L (L Int) +take1 0 _ = N +take1 _ N = N +--should be:take1 (n+1) (C1 x xs) = C1 x (take1 n xs) +take1 n (C1 x xs) | n < 0 = error "Main.take1" + | otherwise = C1 x (take1 (n-1) xs) + +take2 :: Int -> L Int -> L Int +take2 0 _ = N +take2 _ N = N +--should be:take2 (n+1) (C1 x xs) = C1 x (take2 n xs) +take2 n (C1 x xs) | n < 0 = error "Main.take2" + | otherwise = C1 x (take2 (n-1) xs) + +take3 :: Int -> L (L (L Int)) + -> L (L (L Int)) +take3 0 _ = N +take3 _ N = N +take3 n (C1 x xs) = C1 x (take3 (n-1) xs) + +-- init + +init1 :: L (L Int) -> L (L Int) +init1 (C1 x N) = N +init1 (C1 x xs) = C1 x (init1 xs) +init1 N = error "init1 got a bad list" + +init2 :: L Int -> L Int +init2 (C1 x N) = N +init2 (C1 x xs) = C1 x (init2 xs) +init2 N = error "init1 got a bad list" + +-- tail + +tail1 :: L (L Int) -> L (L Int) +tail1 (C1 _ xs) = xs +tail1 N = error "tail1 got a bad list" + +tail2 :: L Int -> L Int +tail2 (C1 _ xs) = xs +tail2 N = error "tail2 got a bad list" + +-- maps + +map1 :: (Tuple3 (L Int) (L Int) (L Int) -> L Int) -> + L (Tuple3 (L Int) (L Int) (L Int)) + -> L (L Int) +map1 f N = N +map1 f (C1 x xs) = C1 (f x) (map1 f xs) + +map2 :: (Int -> L Char) -> L Int -> L (L Char) +map2 f N = N +map2 f (C1 x xs) = C1 (f x) (map2 f xs) + +map3 :: (L Int -> L Int) -> L (L Int) -> L (L Int) +map3 f N = N +map3 f (C1 x xs) = C1 (f x) (map3 f xs) + +map4 :: (L Int -> L Char) + -> L (L Int) -> L (L Char) +map4 f N = N +map4 f (C1 x xs) = C1 (f x) (map4 f xs) + +map5 :: (Tuple2 (L Char) (L (L Int)) -> L Char) + -> L (Tuple2 (L Char) (L (L Int))) + -> L (L Char) +map5 f N = N +map5 f (C1 x xs) = C1 (f x) (map5 f xs) + +map6 :: (Int -> L Char) -> L Int -> L (L Char) +map6 f N = N +map6 f (C1 x xs) = C1 (f x) (map6 f xs) + +-- compose + +compose2 :: (L (L Char) -> L Char) + -> (L Int -> L (L Char)) + -> L Int -> L Char +compose2 f g xs = f (g xs) + +compose1 :: (L Int -> L Int) + -> (L Int -> L Int) -> L Int -> L Int +compose1 f g xs = f (g xs) + +-- concat + +concat1 :: L (L Char) -> L Char +concat1 = foldr_1 append1 N + +-- foldr + +foldr_1 :: (L Char -> L Char -> L Char) + -> L Char -> L (L Char) -> L Char +foldr_1 f a N = a +foldr_1 f a (C1 x xs) = f x (foldr_1 f a xs) + +-- appends + +append1 :: L Char -> L Char -> L Char +append1 N ys = ys +append1 (C1 x xs) ys = C1 x (append1 xs ys) + +append2 :: L (L Int) -> L (L Int) -> L (L Int) +append2 N ys = ys +append2 (C1 x xs) ys = C1 x (append2 xs ys) + +append3 :: L Int -> L Int -> L Int +append3 N ys = ys +append3 (C1 x xs) ys = C1 x (append3 xs ys) + +-- zips + +pzip f (C1 x1 xs) (C1 y1 ys) + = C1 (f x1 y1) (pzip f xs ys) +pzip f _ _ = N + + +zip1_ :: L (L Char) + -> L (L (L Int)) + -> L (Tuple2 (L Char) (L (L Int))) +zip1_ = pzip T2 + +zip2_ :: L (L Int) + -> L (L Int) + -> L (Tuple2 (L Int) (L Int)) +zip2_ = pzip T2 + +zip3d :: L Int -> (Tuple2 (L Int) (L Int)) + -> (Tuple3 (L Int) (L Int) (L Int)) +zip3d x (T2 y z) = T3 x y z + +zip3_ :: L (L Int) + -> L (Tuple2 (L Int) (L Int)) + -> L (Tuple3 (L Int) (L Int) (L Int)) +zip3_ = pzip zip3d + +zip4_ :: L Int + -> L Int + -> L (Tuple2 Int Int) +zip4_ = pzip T2 + +zip5d :: Int -> (Tuple2 Int Int) -> (Tuple3 Int Int Int) +zip5d x (T2 y z) = T3 x y z + +zip5_ :: L Int + -> L (Tuple2 Int Int) + -> L (Tuple3 Int Int Int) +zip5_ = pzip zip5d + +zip6_ :: L (Tuple3 Int Int Int) + -> L (Tuple3 Int Int Int) + -> L (Tuple2 (Tuple3 Int Int Int) + (Tuple3 Int Int Int)) +zip6_ = pzip T2 + +zip31 :: L (L Int) -> L (L Int) + -> L (L Int) + -> L (Tuple3 (L Int) (L Int) (L Int)) +zip31 as bs cs + = zip3_ as (zip2_ bs cs) + +zip32 :: L Int -> L Int -> L Int + -> L (Tuple3 Int Int Int) +zip32 as bs cs + = zip5_ as (zip4_ bs cs) + +-- zipWith + +zipWith21 :: ((Tuple3 Int Int Int) + -> (Tuple2 (Tuple3 Int Int Int) + (Tuple3 Int Int Int)) -> Int) + -> L (Tuple3 Int Int Int) + -> L (Tuple2 (Tuple3 Int Int Int) + (Tuple3 Int Int Int)) + -> L Int +zipWith21 = pzip + +zipWith31 :: ((Tuple3 Int Int Int) + -> (Tuple3 Int Int Int) + -> (Tuple3 Int Int Int) -> Int) + -> L (Tuple3 Int Int Int) + -> L (Tuple3 Int Int Int) + -> L (Tuple3 Int Int Int) -> L Int +zipWith31 z as bs cs + = zipWith21 z' as (zip6_ bs cs) + where z' a (T2 b c) = z a b c diff --git a/ghc/compiler/ilxGen/tests/reduce.ml b/ghc/compiler/ilxGen/tests/reduce.ml new file mode 100644 index 0000000..cad379b --- /dev/null +++ b/ghc/compiler/ilxGen/tests/reduce.ml @@ -0,0 +1,101 @@ + + +type kind = + ARROW of kind * kind + | TYP + +type tycon = + | TyVar of int + | FUN + | LIST + | STRING + +type typ = + TyForall of kind * typ + | TyApp of tycon * typ list + +type exp = + | AbsTm of typ * exp + | Var of int + | App of exp * exp + | String of string + | AbsTy of kind * exp + | AppTy of exp * typ + +type ttyp = + | TTyFun of ttyp * ttyp + | TTyList of ttyp + | TTyString + | TTyAny + | TTyVar of int + | TTyForall of ttyp + +type texp = + | TAbsTm of ttyp * texp + | TVar of int + | TApp of texp * texp + | TString of string + | TLetTy of texp * texp + | TCast of texp * ttyp + + | TAppTy of texp * ttyp + | TAbsTy of texp + + +let (-->) x y = TyApp (FUN, [x;y]) +let (--->) x y = TTyFun (x,y) + +let rec trans_kind = function + ARROW (k1,k2) -> (trans_kind k1 ---> trans_kind k2) + | TYP -> (TTyForall TANY ---> TTyAny) + +let rec trans_typ_arg_aux = function + (* TyForall (k,ty) -> TAbsTm (trans_kind k, TAbsTy (trans_typ ty)) ??? *) + | TyApp (TyVar tv, args) -> failwith "unreduced" + | ty -> TAbsTm (trans_kind k, TAbsTy (trans_typ ty))failwith "unreduced" + | +let rec trans_typ_arg env = function + | TyApp (FUN, []) -> + TAbsTm + (trans_kind TYP, + TLetTy (TVar 0, + TAbsTm + (trans_kind TYP, + TLetTy (TVar 0, + TAbsTm + (TTyForall TANY, + TAppTy (TVar 0, TTyFun (TTyVar 0, TTyVar 1))))))) + | TyApp (TyVar tv, args) -> + try List.assoc (tv,args) env + with Not_found -> failwith "trans_typ: unreduced type variable" + | ty -> TAbsTm (TTyForall TANY, TAppTy (TVar 0, trans_typ env ty)) +(* + | TyApp (STRING, []) -> TAbsTm (TTyForall TANY, TAppTy (TVar 0, TTyString)) + | TyApp (FUN, [l;r]) -> TAbsTm (TTyForall TANY, TAppTy (TVar 0, TTyFun (trans_typ l, trans_typ r))) +*) + + +let rec trans_typ env = function + TyForall (k,ty) -> (trans_kind k ---> TTyAny) + | TyApp (TyVar tv, args) -> + try List.assoc (tv,args) env + with Not_found -> failwith "trans_typ: unreduced type variable" + | TyApp (FUN, [l;r]) -> TTyFun (trans_typ env l, trans_typ env r) + | TyApp (STRING, []) -> TTyString + | _ -> failwith "trans_typ: badly formed input type" + + +let rec trans_exp env = function + | AbsTm (ty,e) -> TAbsTm(trans_typ ty, trans_exp e) + | Var n -> TVar n + | App (l,r) -> TApp(trans_exp l, trans_exp r) + | String s -> TString s + | AbsTy (k,e) -> TAbsTm(trans_kind k, reduce env e) + | AppTy (tm,ty) -> TAppTy(trans_exp tm, trans_typ_arg env ty) + + +open Format;; + + +let rec pp_print_exp pps = function + L e -> fprintf pps "\ diff --git a/ghc/compiler/ilxGen/tests/test1.hs b/ghc/compiler/ilxGen/tests/test1.hs new file mode 100644 index 0000000..158c2a7 --- /dev/null +++ b/ghc/compiler/ilxGen/tests/test1.hs @@ -0,0 +1,89 @@ +-- To start: +-- source /bin/devghc + +-- To compile GHC +-- make ilxGen/IlxGen.o hsc + +-- To compile ILXASM +-- (cd /devel/fcom/src; make bin/ilxasm.exe) + +-- To compile to ILX +-- (cd ilxGen/tests; ../../../driver/ghc-inplace --ilx test.hs) + + + +-- To generate a complete ILX file, including preludes for GHC and ILX: +-- (cd ilxGen/tests/; cat prelude.ilx test.ilx /devel/fcom/src/ilxasm/stdlib-func.ilx > test.full.ilx) + +-- Run ILXASM to get a IL +-- ( cd ilxGen/tests/; /devel/fcom/src/bin/ilxasm.exe --no-ilasm --no-stdlib test.full.ilx > test.il) + +-- To compile IL to .EXE or .DLL: +-- With build of VS (e.g. Don & Andrew) +-- ( cd ilxGen/tests/; cmd /C "c:\\bin\\devvs.bat && ilasm test.il") +-- With Lightning SDK, where env. variables are on path (e.g. Reuben): +-- ( cd ilxGen/tests/; ilasm test.il) + +-- To validate .EXE: +-- (cd /devel/fcom/src; make bin/ilvalid.exe mscorlib.vlb) +-- (export ILVALID_HOME=/devel/fcom/src; cd ilxGen/tests/; /devel/fcom/src/bin/ilvalid.exe test.il) + +-- To run unverifiable code: +-- With build of VS (e.g. Don & Andrew) +-- (cd ilxGen/tests/; cmd /C "c:\\bin\\devvs.bat && .\test.exe") +-- With Lightning SDK, where env. variables are on path (e.g. Reuben): +-- (cd ilxGen/tests/; ./test.exe) + +-- To compile ILX to verifiable code and verify +-- (cd /devel/fcom/src; make bin/ilxasm.exe bin/ilverify.exe) && (cd ilxGen/tests/; export ILVALID_HOME=/devel/fcom/src; cat prelude.ilx test.ilx /devel/fcom/src/assem/stdlib-func.ilx > test.full.ilx && cd ilxGen/tests/; /devel/fcom/src/bin/ilxasm.exe --no-ilasm test.full.ilx > test.safe.il && /devel/fcom/src/bin/ilverify.exe test.safe.il) + +-- (cd ilxGen/tests/; cmd /C "c:\\bin\\devvs.bat && .\test.safe.exe") + +--append:: [Char] -> [Char] -> [Char] +--append [] l2 = l2 +--append (h:t) l2 = h:append t l2 + +data N = Z | S N + +chooseN n = + case n of + Z -> "even\n" + S Z -> "odd\n" + S (S m) -> chooseN m + +add n m = + case n of + Z -> m + S nn -> S (add nn m) + +mul n m = + case n of + Z -> Z + S nn -> add m (mul nn m) + +pow n m = + case m of + Z -> S Z + S mm -> mul n (pow n mm) + +sq n = mul n n + +n1 = S Z +n2 = add n1 n1 +n4 = add n2 n2 +n6 = add n2 n4 +n8 = add n2 n6 +n10 = add n2 n8 +n16 = add n6 n10 +n17 = add n1 n16 +n18 = add n8 n10 +n19 = add n1 n18 +n20 = add n4 n16 + +bign = pow n2 n20 +bign1 = add bign n1 + +main = putStr (chooseN bign1) + + + diff --git a/ghc/compiler/ilxGen/tests/test10.hs b/ghc/compiler/ilxGen/tests/test10.hs new file mode 100644 index 0000000..46c384d --- /dev/null +++ b/ghc/compiler/ilxGen/tests/test10.hs @@ -0,0 +1,45 @@ + +data N = Z | S N + +choose1 n1 = + case n1 of + Z -> "even\n" + S Z -> "odd\n" + S (S m) -> choose1 m +choose2 n1 n2 = + case n1 of + Z -> choose1 n2 + S Z -> "odd\n" + S (S m) -> choose2 m n2 +choose3 n1 n2 n3 = + case n1 of + Z -> choose2 n2 n3 + S Z -> "odd\n" + S (S m) -> choose3 m n2 n3 + +choose4 n1 n2 n3 n4 = + case n1 of + Z -> choose3 n2 n3 n4 + S Z -> "odd\n" + S (S m) -> choose4 m n2 n3 n4 + +choose5 n1 n2 n3 n4 n5 = + case n1 of + Z -> choose4 n2 n3 n4 n5 + S Z -> "odd\n" + S (S m) -> choose5 m n2 n3 n4 n5 + +add n m = + case n of + Z -> m + S nn -> S (add nn m) + +n1 = S Z +n2 = add n1 n1 +n4 = add n2 n2 +n6 = add n2 n4 + + + +main = putStr (choose5 n6 n4 n2 n2 n1) + diff --git a/ghc/compiler/ilxGen/tests/test11.hs b/ghc/compiler/ilxGen/tests/test11.hs new file mode 100644 index 0000000..ce53f71 --- /dev/null +++ b/ghc/compiler/ilxGen/tests/test11.hs @@ -0,0 +1,61 @@ +{-# OPTIONS -fglasgow-exts #-} + +import PrelGHC + +class EEq a where + (===), (/==) :: a -> a -> Bool + +-- x /= y = not (x == y) +-- x == y = not (x /= y) +-- x /= y = True + (/==) x y = mynot ((===) x y) + x === y = True + +data EOrdering = ELT | EEQ | EGT + +mynot True = False +mynot False = True + +{- +class (EEq a) => EOrd a where + ecompare :: a -> a -> EOrdering + (<<), (<<=), (>>>=), (>>>):: a -> a -> Bool + emax, emin :: a -> a -> a + +-- An instance of Ord should define either compare or <= +-- Using compare can be more efficient for complex types. + ecompare x y + | x === y = EEQ + | x <<= y = ELT -- NB: must be '<=' not '<' to validate the + -- above claim about the minimal things that can + -- be defined for an instance of Ord + | otherwise = EGT + + x <<= y = case ecompare x y of { EGT -> False; _other -> True } + x << y = case ecompare x y of { ELT -> True; _other -> False } + x >>>= y = case ecompare x y of { ELT -> False; _other -> True } + x >>> y = case ecompare x y of { EGT -> True; _other -> False } + + -- These two default methods use '>' rather than compare + -- because the latter is often more expensive + emax x y = if x >>> y then x else y + emin x y = if x >>> y then y else x +-} + +data EInt = EI Int# + +ezeroInt, eoneInt, etwoInt, emaxInt, eminInt :: EInt +ezeroInt = EI 0# +eoneInt = EI 1# +etwoInt = EI 2# +eminInt = EI (-2147483648#) -- GHC <= 2.09 had this at -2147483647 +emaxInt = EI 2147483647# +eeqInt (EI x) (EI y) = x ==# y +eneInt (EI x) (EI y) = x /=# y + +instance EEq EInt where + (===) x y = x `eeqInt` y + (/==) x y = x `eneInt` y + +main = putStr (if (ezeroInt === eoneInt) then "no!\n" else "yes!\n") + diff --git a/ghc/compiler/ilxGen/tests/test12.hs b/ghc/compiler/ilxGen/tests/test12.hs new file mode 100644 index 0000000..216c792 --- /dev/null +++ b/ghc/compiler/ilxGen/tests/test12.hs @@ -0,0 +1,44 @@ +class NewFunctor f where + new_fmap :: (a -> b) -> f a -> f b + +data N a = Z a | S (N a) + +nmap f (Z x) = Z (f x) +nmap f (S n) = S (nmap f n) + +tag (Z x) = x +tag (S n) = tag n + +instance NewFunctor N where + new_fmap = nmap + +--class Strange f where +-- zero :: a -> f a +-- suc :: f a -> f a +-- tag :: f a -> a + + +--class FMonad m where +-- (>>=) :: m a -> (a -> m b) -> m b +-- (>>) :: m a -> m b -> m b +-- return :: a -> m a +-- fail :: String -> m a +-- +-- m >> k = m >>= \_ -> k +-- fail s = error s + + + + +--instance Strange N +-- where +-- zero x = Z x +-- suc y = S y +-- tag n = gettag n + +twice :: NewFunctor f => (a -> a) -> f a -> f a +twice f x = new_fmap f (new_fmap f x) + +main = putStr (tag (nmap (\x -> x) (Z "hello world\n"))) +--main = putStr (tag (nmap (\x -> x) (Z "hello world\n"))) +-- main = putStr (tag {- (twice (\x -> x) -} (Z "hello world\n")) diff --git a/ghc/compiler/ilxGen/tests/test13.hs b/ghc/compiler/ilxGen/tests/test13.hs new file mode 100644 index 0000000..559c867 --- /dev/null +++ b/ghc/compiler/ilxGen/tests/test13.hs @@ -0,0 +1,20 @@ +class NewFunctor f where + inj :: a -> f a + surj :: f a -> a + +data N a = Z a + +ninj x = (Z x) +nsurj (Z x) = x + +instance NewFunctor N where + inj = ninj + surj = nsurj + +twice :: NewFunctor f => a -> f (f a) +twice x = inj(inj x) + +undo :: NewFunctor f => f (f a) -> a +undo x = surj(surj x) + +main = putStr (undo (Z (Z "hello world\n"))) diff --git a/ghc/compiler/ilxGen/tests/test14.hs b/ghc/compiler/ilxGen/tests/test14.hs new file mode 100644 index 0000000..86b5d1c --- /dev/null +++ b/ghc/compiler/ilxGen/tests/test14.hs @@ -0,0 +1,11 @@ +class EMonad m where + aaaaa :: m a -> (a -> m b) -> m b + bbbbb :: m a -> m b -> m b + + bbbbb m k = aaaaa m (\_ -> k) + -- = \M \A \B -> \m:(M A) -> \k:(M B) -> aaaaa M A B m (\_:A -> k: M B) + -- Free types must include "A"!!! + +main = putStr "hello world\n" + + diff --git a/ghc/compiler/ilxGen/tests/test15.hs b/ghc/compiler/ilxGen/tests/test15.hs new file mode 100644 index 0000000..2dc494c --- /dev/null +++ b/ghc/compiler/ilxGen/tests/test15.hs @@ -0,0 +1,20 @@ + +{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-} + + +module Foo where + +import PrelBase +import PrelList +import PrelEnum +import PrelShow +import PrelIO + + +bbuild :: forall a. (forall b. (a -> b -> b) -> b -> b) -> [a] +{-# INLINE 2 bbuild #-} +bbuild g = g (:) [] + +main = putStr "hello world\n" + + diff --git a/ghc/compiler/ilxGen/tests/test16.hs b/ghc/compiler/ilxGen/tests/test16.hs new file mode 100644 index 0000000..0e8b997 --- /dev/null +++ b/ghc/compiler/ilxGen/tests/test16.hs @@ -0,0 +1,5 @@ + + +data MMaybe a = No | Yes a + +main = putStr "hello world\n" \ No newline at end of file diff --git a/ghc/compiler/ilxGen/tests/test17.hs b/ghc/compiler/ilxGen/tests/test17.hs new file mode 100644 index 0000000..5e551b2 --- /dev/null +++ b/ghc/compiler/ilxGen/tests/test17.hs @@ -0,0 +1,44 @@ +{-# OPTIONS -fno-implicit-prelude #-} + +module Test17 where + +import PrelGHC +import PrelBase + +data Exception = IOException IOError | OtherExc + +data IOError + = IOError + String + +tthrow :: Exception -> a + +tthrow exception = raise# exception +ccatchException (IO m) k = IO (\s -> catch# m (\ex -> unIO (k ex)) s) + + +ccatch :: IO a -> (IOError -> IO a) -> IO a +ccatch m k = ccatchException m handler + where handler (IOException err) = k err + handler other = tthrow other + +ccatchNonIO :: IO a -> (Exception -> IO a) -> IO a +ccatchNonIO m k = ccatchException m handler + where handler (IOException err) = ioError err + handler other = k other + +newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #)) + +unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #)) +unIO (IO a) = a + +ioError :: IOError -> IO a +ioError err = IO (\s -> tthrow (IOException err) s) + + + +blockAsyncExceptions :: IO a -> IO a +blockAsyncExceptions (IO io) = IO (blockAsyncExceptions# io) + +unblockAsyncExceptions :: IO a -> IO a +unblockAsyncExceptions (IO io) = IO (unblockAsyncExceptions# io) diff --git a/ghc/compiler/ilxGen/tests/test18.hs b/ghc/compiler/ilxGen/tests/test18.hs new file mode 100644 index 0000000..12ca741 --- /dev/null +++ b/ghc/compiler/ilxGen/tests/test18.hs @@ -0,0 +1,129 @@ +{-# OPTIONS -fno-implicit-prelude #-} + +module Test18 where + +import PrelGHC +import PrelBase + +eftCharFB c n x y = go x + where + go x | x ># y = n + | otherwise = C# (chr# x) `c` go (x +# 1#) + + +eftIntFB c n x y | x ># y = n + | otherwise = go x + where + go x = I# x `c` if x ==# y then n else go (x +# 1#) + +eftIntList x y | x ># y = [] + | otherwise = go x + where + go x = I# x : if x ==# y then [] else go (x +# 1#) + + +efdCharFB c n x1 x2 + | delta >=# 0# = go_up_char_fb c n x1 delta 255# + | otherwise = go_dn_char_fb c n x1 delta 0# + where + delta = x2 -# x1 + +efdCharList x1 x2 + | delta >=# 0# = go_up_char_list x1 delta 255# + | otherwise = go_dn_char_list x1 delta 0# + where + delta = x2 -# x1 + +efdtCharFB c n x1 x2 lim + | delta >=# 0# = go_up_char_fb c n x1 delta lim + | otherwise = go_dn_char_fb c n x1 delta lim + where + delta = x2 -# x1 + +efdtCharList x1 x2 lim + | delta >=# 0# = go_up_char_list x1 delta lim + | otherwise = go_dn_char_list x1 delta lim + where + delta = x2 -# x1 + +go_up_char_fb c n x delta lim + = go_up x + where + go_up x | x ># lim = n + | otherwise = C# (chr# x) `c` go_up (x +# delta) + +go_dn_char_fb c n x delta lim + = go_dn x + where + go_dn x | x <# lim = n + | otherwise = C# (chr# x) `c` go_dn (x +# delta) + +go_up_char_list x delta lim + = go_up x + where + go_up x | x ># lim = [] + | otherwise = C# (chr# x) : go_up (x +# delta) + + +go_dn_char_list x delta lim + = go_dn x + where + go_dn x | x <# lim = [] + | otherwise = C# (chr# x) : go_dn (x +# delta) + +efdtIntFB c n x1 x2 y + | delta >=# 0# = if x1 ># y then n else go_up_int_fb c n x1 delta lim + | otherwise = if x1 <# y then n else go_dn_int_fb c n x1 delta lim + where + delta = x2 -# x1 + lim = y -# delta + +efdtIntList x1 x2 y + | delta >=# 0# = if x1 ># y then [] else go_up_int_list x1 delta lim + | otherwise = if x1 <# y then [] else go_dn_int_list x1 delta lim + where + delta = x2 -# x1 + lim = y -# delta + +efdIntFB c n x1 x2 + | delta >=# 0# = go_up_int_fb c n x1 delta ( 2147483647# -# delta) + | otherwise = go_dn_int_fb c n x1 delta ((-2147483648#) -# delta) + where + delta = x2 -# x1 + +efdIntList x1 x2 + | delta >=# 0# = go_up_int_list x1 delta ( 2147483647# -# delta) + | otherwise = go_dn_int_list x1 delta ((-2147483648#) -# delta) + where + delta = x2 -# x1 + +-- In all of these, the (x +# delta) is guaranteed not to overflow + +go_up_int_fb c n x delta lim + = go_up x + where + go_up x | x ># lim = I# x `c` n + | otherwise = I# x `c` go_up (x +# delta) + +go_dn_int_fb c n x delta lim + = go_dn x + where + go_dn x | x <# lim = I# x `c` n + | otherwise = I# x `c` go_dn (x +# delta) + +go_up_int_list x delta lim + = go_up x + where + go_up x | x ># lim = [I# x] + | otherwise = I# x : go_up (x +# delta) + +go_dn_int_list x delta lim + = go_dn x + where + go_dn x | x <# lim = [I# x] + | otherwise = I# x : go_dn (x +# delta) +eftInt = eftIntList +efdInt = efdIntList +efdtInt = efdtIntList + + diff --git a/ghc/compiler/ilxGen/tests/test19.hs b/ghc/compiler/ilxGen/tests/test19.hs new file mode 100644 index 0000000..a292599 --- /dev/null +++ b/ghc/compiler/ilxGen/tests/test19.hs @@ -0,0 +1,37 @@ + +{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-} + + +module Test19 where + +import PrelST +import PrelBase +import PrelErr + +newtype IIO a = IIO (State# RealWorld -> (# State# RealWorld, a #)) + +unIIO :: IIO a -> (State# RealWorld -> (# State# RealWorld, a #)) +unIIO (IIO a) = a + +instance Functor IIO where + fmap f x = x >>= (return . f) + +instance Monad IIO where + {-# INLINE return #-} + {-# INLINE (>>) #-} + {-# INLINE (>>=) #-} + m >> k = m >>= \ _ -> k + return x = returnIIO x + + m >>= k = bindIIO m k + fail s = error s -- not ioError? + + +bindIIO :: IIO a -> (a -> IIO b) -> IIO b +bindIIO (IIO m) k = IIO ( \ s -> + case m s of + (# new_s, a #) -> unIIO (k a) new_s + ) + +returnIIO :: a -> IIO a +returnIIO x = IIO (\ s -> (# s, x #)) diff --git a/ghc/compiler/ilxGen/tests/test1b.hs b/ghc/compiler/ilxGen/tests/test1b.hs new file mode 100644 index 0000000..c4b2336 --- /dev/null +++ b/ghc/compiler/ilxGen/tests/test1b.hs @@ -0,0 +1,104 @@ +-- To start: +-- source /bin/devghc + +-- To compile GHC +-- make ilxGen/IlxGen.o hsc + +-- To compile ILXASM +-- (cd /devel/fcom/src; make bin/ilxasm.exe) + +-- To compile to ILX +-- (cd ilxGen/tests; ../../../driver/ghc-inplace --ilx test.hs) + + + +-- To generate a complete ILX file, including preludes for GHC and ILX: +-- (cd ilxGen/tests/; cat prelude.ilx test.ilx /devel/fcom/src/ilxasm/stdlib-func.ilx > test.full.ilx) + +-- Run ILXASM to get a IL +-- ( cd ilxGen/tests/; /devel/fcom/src/bin/ilxasm.exe --no-ilasm --no-stdlib test.full.ilx > test.il) + +-- To compile IL to .EXE or .DLL: +-- With build of VS (e.g. Don & Andrew) +-- ( cd ilxGen/tests/; cmd /C "c:\\bin\\devvs.bat && ilasm test.il") +-- With Lightning SDK, where env. variables are on path (e.g. Reuben): +-- ( cd ilxGen/tests/; ilasm test.il) + +-- To validate .EXE: +-- (cd /devel/fcom/src; make bin/ilvalid.exe mscorlib.vlb) +-- (export ILVALID_HOME=/devel/fcom/src; cd ilxGen/tests/; /devel/fcom/src/bin/ilvalid.exe test.il) + +-- To run unverifiable code: +-- With build of VS (e.g. Don & Andrew) +-- (cd ilxGen/tests/; cmd /C "c:\\bin\\devvs.bat && .\test.exe") +-- With Lightning SDK, where env. variables are on path (e.g. Reuben): +-- (cd ilxGen/tests/; ./test.exe) + +-- To compile ILX to verifiable code and verify +-- (cd /devel/fcom/src; make bin/ilxasm.exe bin/ilverify.exe) && (cd ilxGen/tests/; export ILVALID_HOME=/devel/fcom/src; cat prelude.ilx test.ilx /devel/fcom/src/assem/stdlib-func.ilx > test.full.ilx && cd ilxGen/tests/; /devel/fcom/src/bin/ilxasm.exe --no-ilasm test.full.ilx > test.safe.il && /devel/fcom/src/bin/ilverify.exe test.safe.il) + +-- (cd ilxGen/tests/; cmd /C "c:\\bin\\devvs.bat && .\test.safe.exe") + +--append:: [Char] -> [Char] -> [Char] +--append [] l2 = l2 +--append (h:t) l2 = h:append t l2 + +data N = Z | S N + +chooseN n = + case n of + Z -> "even\n" + S Z -> "odd\n" + S (S m) -> chooseN m + +signN n = + case n of + Z -> Z + S Z -> S Z + S (S m) -> signN m +add n m = + case n of + Z -> m + S nn -> S (add nn m) + +mul n m = + case n of + Z -> Z + S nn -> add m (mul nn m) + +pow n m = + case m of + Z -> S Z + S mm -> mul n (pow n mm) + +sq n = mul n n + +n1 = S Z +n2 = add n1 n1 +n4 = add n2 n2 +n6 = add n2 n4 +n8 = add n2 n6 +n10 = add n2 n8 +n11 = add n1 n10 +n12 = add n1 n11 +n13 = add n1 n12 +n14 = add n1 n13 +n15 = add n1 n14 +n16 = add n1 n15 +n17 = add n1 n16 +n18 = add n1 n17 +n19 = add n1 n18 +n20 = add n1 n18 + +bign = pow n2 n19 +bign1 = add bign n1 + +foldn f n acc = + case n of + Z -> acc + S x -> foldn f x (f n acc) + +main = putStr (chooseN (foldn (\x y -> add (signN x) y) (pow n2 n4) n1)) + + + diff --git a/ghc/compiler/ilxGen/tests/test2.hs b/ghc/compiler/ilxGen/tests/test2.hs new file mode 100644 index 0000000..2c0c8fb --- /dev/null +++ b/ghc/compiler/ilxGen/tests/test2.hs @@ -0,0 +1 @@ +main = putStr "Hello world.\n" diff --git a/ghc/compiler/ilxGen/tests/test20.hs b/ghc/compiler/ilxGen/tests/test20.hs new file mode 100644 index 0000000..157a16d --- /dev/null +++ b/ghc/compiler/ilxGen/tests/test20.hs @@ -0,0 +1,9 @@ + +data N = Z | S N + +res Z x y = (# x, y #) +res (S n) x y = res n x y + +(# x, y #) = res (S Z) "no!" "hello world\n" + +main = putStr y diff --git a/ghc/compiler/ilxGen/tests/test21.hs b/ghc/compiler/ilxGen/tests/test21.hs new file mode 100644 index 0000000..1870f22 --- /dev/null +++ b/ghc/compiler/ilxGen/tests/test21.hs @@ -0,0 +1,13 @@ +{-# OPTIONS -fno-implicit-prelude #-} + +import PrelIOBase +import PrelIO +import PrelBase +import PrelAddr + +foreign import "libHS_cbits" "getErrStr__" unsafe ggetErrStr__ :: Int -> IO Addr + +main = putStr (uunsafePerformIO (ggetErrStr__ 4)) + +uunsafePerformIO :: IO Addr -> [Char] +uunsafePerformIO (IO m) = case m realWorld# of (# _, (A# r) #) -> (unpackCString# r) diff --git a/ghc/compiler/ilxGen/tests/test2b.hs b/ghc/compiler/ilxGen/tests/test2b.hs new file mode 100644 index 0000000..08a391f --- /dev/null +++ b/ghc/compiler/ilxGen/tests/test2b.hs @@ -0,0 +1,2 @@ +foreign import "ilxHello" unsafe ilxHello :: IO () +main = ilxHello diff --git a/ghc/compiler/ilxGen/tests/test2c.hs b/ghc/compiler/ilxGen/tests/test2c.hs new file mode 100644 index 0000000..d01df05 --- /dev/null +++ b/ghc/compiler/ilxGen/tests/test2c.hs @@ -0,0 +1,14 @@ +import PrelIOBase + + +bindIO2 :: IO () -> IO () -> IO () +bindIO2 m (IO k) = IO ( \ s -> k s ) + +foreign import "ilxHello" unsafe ilxHello :: IO () + +data N = S N | Z + +f Z = bindIO2 +f (S x) = f x + +main = f(S Z) ilxHello ilxHello diff --git a/ghc/compiler/ilxGen/tests/test2d.hs b/ghc/compiler/ilxGen/tests/test2d.hs new file mode 100644 index 0000000..8126127 --- /dev/null +++ b/ghc/compiler/ilxGen/tests/test2d.hs @@ -0,0 +1,7 @@ +foreign import ccall "libHS_cbits.so" "get_prog_argc" unsafe primArgc :: Int + +foreign import "ilxHello" unsafe ilxHello :: IO () +foreign import "ilxBad" unsafe ilxBad :: IO () + + +main = if (primArgc == 0) then ilxHello else ilxBad diff --git a/ghc/compiler/ilxGen/tests/test3.hs b/ghc/compiler/ilxGen/tests/test3.hs new file mode 100644 index 0000000..0254ee4 --- /dev/null +++ b/ghc/compiler/ilxGen/tests/test3.hs @@ -0,0 +1,24 @@ +foreign import "ilxHello" unsafe ilxHello :: IO () +foreign import "ilxBad" unsafe ilxBad :: IO () + +class Eqq a where + eqq :: a -> Bool + eqq2 :: a -> Bool + +-- x /= y = not (x == y) +-- x == y = not (x /= y) +-- x /= y = True + eqq x = False + eqq2 x = True + + +data Unit = Unit + +instance Eqq Unit +-- where +-- eqq Unit = True +-- eqq2 Unit = False + +choose x = if eqq x then ilxHello else if eqq2 x then ilxBad else ilxBad + +main = choose Unit diff --git a/ghc/compiler/ilxGen/tests/test4.hs b/ghc/compiler/ilxGen/tests/test4.hs new file mode 100644 index 0000000..080c652 --- /dev/null +++ b/ghc/compiler/ilxGen/tests/test4.hs @@ -0,0 +1,47 @@ +class Eqq a where + evenN :: a -> Bool + oddN :: a -> Bool + evenN x = False + oddN x = True + + +data N = Z | S N + +instance Eqq N + where + evenN Z = True + evenN (S x) = oddN x + oddN Z = False + oddN (S x) = evenN x + +choose x = if evenN x then "hello world (evenN)\n" else if oddN x then "hello world (oddN)\n" else "no!\n" + +add n m = + case n of + Z -> m + S nn -> S (add nn m) + +mul n m = + case n of + Z -> Z + S nn -> add m (mul nn m) + +pow n m = + case m of + Z -> S Z + S mm -> mul n (pow n mm) + +n1 = S Z +n2 = add n1 n1 +n4 = add n2 n2 +n6 = add n2 n4 +n8 = add n2 n6 +n10 = add n2 n8 +n16 = add n6 n10 +n18 = add n8 n10 +n20 = add n4 n16 + +bign = pow n2 n16 +bign1 = add bign n1 + +main = putStr (choose bign1) diff --git a/ghc/compiler/ilxGen/tests/test5.hs b/ghc/compiler/ilxGen/tests/test5.hs new file mode 100644 index 0000000..13d6028 --- /dev/null +++ b/ghc/compiler/ilxGen/tests/test5.hs @@ -0,0 +1,5 @@ +data One a = One a + +choose (One x) = x +main = putStr (choose (One "hello world\n")) + diff --git a/ghc/compiler/ilxGen/tests/test6.hs b/ghc/compiler/ilxGen/tests/test6.hs new file mode 100644 index 0000000..17e51ab --- /dev/null +++ b/ghc/compiler/ilxGen/tests/test6.hs @@ -0,0 +1,8 @@ +data List a = Cons a (List a) + +hdL (Cons x y) = x +tlL (Cons x y) = y + +test = Cons "hello world\n" test +main = putStr (hdL (tlL test)) + diff --git a/ghc/compiler/ilxGen/tests/test7.hs b/ghc/compiler/ilxGen/tests/test7.hs new file mode 100644 index 0000000..c146038 --- /dev/null +++ b/ghc/compiler/ilxGen/tests/test7.hs @@ -0,0 +1,8 @@ +data List a = Cons a (List a) + +hdL (Cons x y) = x +tlL (Cons x y) = y + +mk f x = f x (mk f x) +main = putStr (hdL (tlL (mk Cons "hello world!\n"))) + diff --git a/ghc/compiler/ilxGen/tests/test8.hs b/ghc/compiler/ilxGen/tests/test8.hs new file mode 100644 index 0000000..94a7e1f --- /dev/null +++ b/ghc/compiler/ilxGen/tests/test8.hs @@ -0,0 +1,8 @@ +data Inf a = A (Inf a) + +hd (A x) = x + +choose (A (A x)) = "hello world\n" +mk f = f (mk f) +main = putStr (choose (hd (mk A))) + diff --git a/ghc/compiler/ilxGen/tests/test9.hs b/ghc/compiler/ilxGen/tests/test9.hs new file mode 100644 index 0000000..311b65c --- /dev/null +++ b/ghc/compiler/ilxGen/tests/test9.hs @@ -0,0 +1,10 @@ +data Tree a = Node (Tree a) (Tree a) + +left (Node x y) = x +right (Node x y) = y + +choose (Node (Node _ _) (Node _ _)) = "hello world!\n" + +mk f = f (mk f) (mk f) +main = putStr (choose (mk Node)) + diff --git a/ghc/compiler/ilxGen/tests/yes.hs b/ghc/compiler/ilxGen/tests/yes.hs new file mode 100644 index 0000000..1dc4f08 --- /dev/null +++ b/ghc/compiler/ilxGen/tests/yes.hs @@ -0,0 +1,5 @@ + +foreign import "ilxHello" unsafe ilxHello :: IO () + +main :: IO () +main = ilxHello >> main \ No newline at end of file diff --git a/ghc/compiler/ilxGen/tests/yes2.hs b/ghc/compiler/ilxGen/tests/yes2.hs new file mode 100644 index 0000000..7fa20c5 --- /dev/null +++ b/ghc/compiler/ilxGen/tests/yes2.hs @@ -0,0 +1,18 @@ + +import PrelIOBase +foreign import "ilxHello" unsafe ilxHello :: IO () + + + +seqIO :: IO () -> IO () -> IO () +seqIO (IO m) (IO k) = IO ( \ s -> + case m s of + (# new_s, a #) -> k new_s + ) + + +yes () = seqIO ilxHello (yes ()) + +main :: IO () +main = yes () +