From: Ian Lynagh Date: Tue, 6 May 2008 10:44:56 +0000 (+0000) Subject: Remove ilxGen; part of trac #2243 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=f5edc6b0871a0debbc9a64f4cdb95c0dc35e5b16 Remove ilxGen; part of trac #2243 --- diff --git a/compiler/ilxGen/Entry.ilx b/compiler/ilxGen/Entry.ilx deleted file mode 100644 index 674c831..0000000 --- a/compiler/ilxGen/Entry.ilx +++ /dev/null @@ -1,53 +0,0 @@ -.assembly test { } -.assembly extern 'mscorlib' { } -.assembly extern ilx 'std' { } -// ENTRYPOINT -.class MainMain { - .method public static void Main(class [mscorlib]System.String[]) { - .entrypoint - ldstr "LOG: *** loading main value" call void [mscorlib]System.Console::WriteLine(class [mscorlib]System.String) - ldsfld thunk<(func ( /* unit skipped */ ) --> class [std]PrelBase_Z0T)> class Main::'Main_main' - - ldstr "LOG: *** evaluating main value" - call void [mscorlib]System.Console::WriteLine(class [mscorlib]System.String) - callfunc () --> (func ( /* unit skipped */ ) --> class [std]PrelBase_Z0T) - ldstr "LOG: *** calling main value" - call void [mscorlib]System.Console::WriteLine(class [mscorlib]System.String) - // ldunit - callfunc ( /* unit skipped */ ) --> class [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()" - call void [mscorlib]System.Console::WriteLine(class [mscorlib]System.String) - -ldsfld thunk<(func (thunk>) --> (func (/* unit skipped */) --> class [std]PrelBase_Z0T))> [std]'PrelHandle'::'PrelHandle_stdHandleFinalizzer' -ldsfld thunk> [std]'PrelHandle'::'PrelHandle_stdin' - callfunc () (thunk>) --> (func ( /* unit skipped */ ) --> class [std]PrelBase_Z0T) - callfunc ( /* unit skipped */ ) --> class [std]PrelBase_Z0T - pop - -ldsfld thunk<(func (thunk>) --> (func (/* unit skipped */) --> class [std]PrelBase_Z0T))> [std]'PrelHandle'::'PrelHandle_stdHandleFinalizzer' -ldsfld thunk> [std]'PrelHandle'::'PrelHandle_stdout' - callfunc () (thunk>) --> (func ( /* unit skipped */ ) --> class [std]PrelBase_Z0T) - callfunc ( /* unit skipped */ ) --> class [std]PrelBase_Z0T - pop - -ldsfld thunk<(func (thunk>) --> (func (/* unit skipped */) --> class [std]PrelBase_Z0T))> [std]'PrelHandle'::'PrelHandle_stdHandleFinalizzer' -ldsfld thunk> [std]'PrelHandle'::'PrelHandle_stderr' - callfunc () (thunk>) --> (func ( /* unit skipped */ ) --> class [std]PrelBase_Z0T) - callfunc ( /* unit skipped */ ) --> class [std]PrelBase_Z0T - pop - - ldstr "LOG: exit main()\n" - call void [mscorlib]System.Console::WriteLine(class [mscorlib]System.String) - ret - } -} - diff --git a/compiler/ilxGen/IlxGen.lhs b/compiler/ilxGen/IlxGen.lhs deleted file mode 100644 index 012782f..0000000 --- a/compiler/ilxGen/IlxGen.lhs +++ /dev/null @@ -1,2396 +0,0 @@ -% -\section{Generate .NET extended IL} - -\begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - -module IlxGen( ilxGen ) where - -#include "HsVersions.h" - -import Char ( ord, chr ) -import StgSyn -import Id ( idType, idName, isDeadBinder, idArity ) -import Var ( Var, Id, TyVar, isId, isTyVar, tyVarKind, tyVarName ) -import VarEnv -import VarSet ( isEmptyVarSet ) -import TyCon ( TyCon, tyConPrimRep, isUnboxedTupleTyCon, tyConDataCons, - tyConTyVars, isDataTyCon, isAlgTyCon, tyConArity - ) -import Type ( liftedTypeKind, openTypeKind, unliftedTypeKind, - isUnLiftedType, isTyVarTy, mkTyVarTy, predTypeRep, pprType, - splitForAllTys, splitFunTys, applyTy, applyTys, eqKind, tyVarsOfTypes - ) -import TypeRep ( Type(..) ) -import DataCon ( isUnboxedTupleCon, dataConTyCon, dataConRepType, dataConRepArgTys, DataCon(..) ) -import Literal ( Literal(..) ) -import PrelNames -- Lots of keys -import PrimOp ( PrimOp(..) ) -import ForeignCall ( CCallConv(..), ForeignCall(..), CCallSpec(..), CCallTarget(..), DNCallSpec(..) ) -import TysWiredIn ( mkTupleTy, tupleCon ) -import PrimRep ( PrimRep(..) ) -import Name ( nameModule, nameOccName, isExternalName, isInternalName, NamedThing(getName) ) -import Subst ( substTyWith ) - -import Module ( Module, PackageName, ModuleName, moduleName, - modulePackage, basePackage, - isHomeModule, isVanillaModule, - pprModuleName, mkHomeModule, mkModuleName - ) - -import UniqFM -import BasicTypes ( Boxity(..) ) -import CStrings ( CLabelString, pprCLabelString ) -import Outputable -import Char ( ord ) -import List ( partition, elem, insertBy,any ) -import UniqSet - -import TysPrim ( foreignObjPrimTyCon, weakPrimTyCon, byteArrayPrimTyCon, mutableByteArrayPrimTyCon ) - --- opt_SimplDoEtaReduction is used to help with assembly naming conventions for different --- versions of compiled Haskell code. We add a ".O" to all assembly and module --- names when this is set (because that's clue that -O was set). --- One day this will be configured by the command line. -import DynFlags ( opt_InPackage, opt_SimplDoEtaReduction ) - -import Util ( lengthIs, equalLength ) - -\end{code} - - - -%************************************************************************ -%* * -\subsection{Main driver} -%* * -%************************************************************************ - -\begin{code} -ilxGen :: Module -> [TyCon] -> [(StgBinding,[Id])] -> SDoc - -- The TyCons should include those arising from classes -ilxGen mod tycons binds_w_srts - = vcat [ text ".module '" <> (ppr (moduleName mod)) <> hscOptionQual <> text "o'", - text ".assembly extern 'mscorlib' {}", - vcat (map (ilxImportPackage topenv) (uniqSetToList import_packages)), - vcat (map (ilxImportModule topenv) (uniqSetToList import_modules)), - vcat (map (ilxImportTyCon topenv) (uniqSetToList import_tycons)), - vcat (map (ilxImportCCall topenv) (map snd (ufmToList import_ccalls))), - vcat (map (ilxTyCon topenv) data_tycons), - vcat (map (ilxBindClosures topenv) binds), - ilxTopBind mod topenv toppairs - ] - where - binds = map fst binds_w_srts - toppairs = ilxPairs binds - topenv = extendIlxEnvWithTops (emptyIlxEnv False mod) mod toppairs - -- Generate info from class decls as well - (import_packages,import_modules,import_tycons,import_ccalls) = importsBinds topenv binds (importsPrelude emptyImpInfo) - data_tycons = filter isDataTyCon tycons -\end{code} - -%************************************************************************ -%* * -\subsection{Find Imports} -%* * -%************************************************************************ - -\begin{code} - -importsBinds :: IlxEnv -> [StgBinding] -> ImportsInfo -> ImportsInfo -importsBinds env binds = foldR (importsBind env) binds - -importsNone :: ImportsInfo -> ImportsInfo -importsNone sofar = sofar - -importsBind :: IlxEnv -> StgBinding -> ImportsInfo -> ImportsInfo -importsBind env (StgNonRec _ b rhs) = importsRhs env rhs.importsVar env b -importsBind env (StgRec _ pairs) = foldR (\(b,rhs) -> importsRhs env rhs . importsVar env b) pairs - -importsRhs :: IlxEnv -> StgRhs -> ImportsInfo -> ImportsInfo -importsRhs env (StgRhsCon _ con args) = importsDataCon env con . importsStgArgs env args -importsRhs env (StgRhsClosure _ _ _ _ args body) = importsExpr env body. importsVars env args - -importsExpr :: IlxEnv -> StgExpr -> ImportsInfo -> ImportsInfo -importsExpr env (StgLit _) = importsNone -importsExpr env (StgApp f args) = importsVar env f.importsStgArgs env args -importsExpr env (StgConApp con args) = importsDataCon env con.importsStgArgs env args -importsExpr env (StgOpApp (StgFCallOp (CCall (CCallSpec (StaticTarget c) cc _)) _) args rty) - = addCCallInfo (c,cc, map stgArgType tm_args, rty) . importsStgArgs env args - where - (ty_args,tm_args) = splitTyArgs1 args - -importsExpr env (StgOpApp _ args res_ty) = importsType env res_ty. importsStgArgs env args - - -importsExpr env (StgSCC _ expr) = importsExpr env expr -importsExpr env (StgCase scrut _ _ bndr _ alts) - = importsExpr env scrut. imports_alts alts. importsVar env bndr - where - imports_alts (StgAlgAlts _ alg_alts deflt) -- The Maybe TyCon part is dealt with - -- by the case-binder's type - = foldR imports_alg_alt alg_alts . imports_deflt deflt - where - imports_alg_alt (con, bndrs, _, rhs) - = importsExpr env rhs . importsDataCon env con. importsVars env bndrs - - imports_alts (StgPrimAlts _ alg_alts deflt) - = foldR imports_prim_alt alg_alts . imports_deflt deflt - where - imports_prim_alt (_, rhs) = importsExpr env rhs - imports_deflt StgNoDefault = importsNone - imports_deflt (StgBindDefault rhs) = importsExpr env rhs - - -importsExpr env (StgLetNoEscape _ _ bind body) = importsExpr env (StgLet bind body) -importsExpr env (StgLet bind body) - = importsBind env bind . importsExpr env body - -importsApp env v args = importsVar env v. importsStgArgs env args -importsStgArgs env args = foldR (importsStgArg env) args - -importsStgArg :: IlxEnv -> StgArg -> ImportsInfo -> ImportsInfo -importsStgArg env (StgTypeArg ty) = importsType env ty -importsStgArg env (StgVarArg v) = importsVar env v -importsStgArg env _ = importsNone - -importsVars env vs = foldR (importsVar env) vs -importsVar env v = importsName env (idName v). importsType env (idType v) - -importsName env n - | isInternalName n = importsNone - | ilxEnvModule env == nameModule n = importsNone - | isHomeModule (nameModule n) = addModuleImpInfo (moduleName (nameModule n)) --- See HACK below - | isVanillaModule (nameModule n) && not inPrelude = importsPrelude - | isVanillaModule (nameModule n) && inPrelude = addModuleImpInfo (moduleName (nameModule n)) --- End HACK - | otherwise = addPackageImpInfo (modulePackage (nameModule n)) - - -importsPrelude | inPrelude = addModuleImpInfo (mkModuleName "PrelGHC") - | otherwise = addPackageImpInfo basePackage - - -importsType :: IlxEnv -> Type -> ImportsInfo -> ImportsInfo -importsType env ty = importsType2 env (deepIlxRepType ty) - -importsType2 :: IlxEnv -> Type -> ImportsInfo -> ImportsInfo -importsType2 env (AppTy f x) = importsType2 env f . importsType2 env x -importsType2 env (TyVarTy _) = importsNone -importsType2 env (TyConApp tc args) =importsTyCon env tc . importsTypeArgs2 env args -importsType2 env (FunTy arg res) = importsType env arg . importsType2 env res -importsType2 env (ForAllTy tv body_ty) = importsType2 env body_ty -importsType2 _ _ = panic "IlxGen.lhs: importsType2 ty" -importsTypeArgs2 env tys = foldR (importsType2 env) tys - -importsDataCon env dcon = importsTyCon env (dataConTyCon dcon) - -importsTyCon env tc | (not (isDataTyCon tc) || - isInternalName (getName tc) || - ilxEnvModule env == nameModule (getName tc)) = importsNone -importsTyCon env tc | otherwise = importsName env (getName tc) . addTyConImpInfo tc . - foldR (importsTyConDataCon env) (tyConDataCons tc) - - -importsTyConDataCon :: IlxEnv -> DataCon -> ImportsInfo -> ImportsInfo -importsTyConDataCon env dcon = foldR (importsTyConDataConType env) (filter (not . isVoidIlxRepType) (dataConRepArgTys dcon)) - -importsTyConDataConType :: IlxEnv -> Type -> ImportsInfo -> ImportsInfo -importsTyConDataConType env ty = importsTyConDataConType2 env (deepIlxRepType ty) - -importsTyConDataConType2 :: IlxEnv -> Type -> ImportsInfo -> ImportsInfo -importsTyConDataConType2 env (AppTy f x) = importsTyConDataConType2 env f . importsTyConDataConType2 env x -importsTyConDataConType2 env (TyVarTy _) = importsNone -importsTyConDataConType2 env (TyConApp tc args) = importsTyConDataConTypeTyCon env tc . importsTyConDataConTypeArgs2 env args -importsTyConDataConType2 env (FunTy arg res) = importsTyConDataConType env arg . importsTyConDataConType2 env res -importsTyConDataConType2 env (ForAllTy tv body_ty) = importsTyConDataConType2 env body_ty -importsTyConDataConType2 _ _ = panic "IlxGen.lhs: importsTyConDataConType2 ty" -importsTyConDataConTypeArgs2 env tys = foldR (importsTyConDataConType2 env) tys - -importsTyConDataConTypeTyCon env tc | (not (isDataTyCon tc) || - isInternalName (getName tc) || - ilxEnvModule env == nameModule (getName tc)) = importsNone -importsTyConDataConTypeTyCon env tc | otherwise = importsName env (getName tc) - - -type StaticCCallInfo = (CLabelString,CCallConv,[Type],Type) -type ImportsInfo = (UniqSet PackageName, UniqSet ModuleName, UniqSet TyCon, UniqFM StaticCCallInfo) - -- (Packages, Modules, Datatypes, Imported CCalls) - -emptyImpInfo :: ImportsInfo -emptyImpInfo = (emptyUniqSet, emptyUniqSet, emptyUniqSet, emptyUFM) -addPackageImpInfo p (w,x,y,z) = (addOneToUniqSet w p, x, y,z) -addModuleImpInfo m (w,x,y,z) = (w, addOneToUniqSet x m, y,z) -addTyConImpInfo tc (w,x,y,z) = (w, x, addOneToUniqSet y tc,z) -addCCallInfo info@(nm,a,b,c) (w,x,y,z) = (w, x, y,addToUFM z nm info) - -ilxImportTyCon :: IlxEnv -> TyCon -> SDoc -ilxImportTyCon env tycon | isDataTyCon tycon = ilxTyConDef True env tycon -ilxImportTyCon _ _ | otherwise = empty - -ilxImportPackage :: IlxEnv -> PackageName -> SDoc -ilxImportPackage _ p = text ".assembly extern" <+> singleQuotes (ppr p <> hscOptionQual) <+> text "{ }" - -ilxImportModule :: IlxEnv -> ModuleName -> SDoc -ilxImportModule _ m = text ".module extern" <+> singleQuotes (ppr m <> hscOptionQual <> text "o") - --- Emit a P/Invoke declaration for the imported C function --- TODO: emit the right DLL name -ilxImportCCall :: IlxEnv -> StaticCCallInfo -> SDoc -ilxImportCCall env (c,cc,args,ret) = - text ".method static assembly pinvokeimpl" <+> - parens (doubleQuotes (text "HSstd_cbits.dll") <+> text "cdecl") <+> retdoc <+> singleQuotes (pprCLabelString c) <+> - pprCValArgTys ilxTypeL env (map deepIlxRepType (filter (not. isVoidIlxRepType) args)) <+> - text "unmanaged preservesig { }" - where - retdoc = - if isVoidIlxRepType ret then text "void" - else ilxTypeR env (deepIlxRepType ret) - - -\end{code} - -%************************************************************************ -%* * -\subsection{Type declarations} -%* * -%************************************************************************ - -\begin{code} - - -ilxTyCon :: IlxEnv -> TyCon -> SDoc -ilxTyCon env tycon = ilxTyConDef False env tycon - --- filter to get only dataTyCons? -ilxTyConDef importing env tycon = - vcat [empty $$ line, - text ".classunion" <+> (if importing then text "import" else empty) <+> tycon_ref <+> tyvars_text <+> super_text <+> alts_text] - where - tycon_ref = nameReference env (getName tycon) <> (ppr tycon) - super_text = if importing then empty else text "extends thunk" <> angleBrackets (text "class" <+> tycon_ref) - tyvars = tyConTyVars tycon - (ilx_tvs, _) = categorizeTyVars tyvars - alts_env = extendIlxEnvWithFormalTyVars env ilx_tvs - tyvars_text = pprTyVarBinders alts_env ilx_tvs - alts = vcat (map (pprIlxDataCon alts_env) (tyConDataCons tycon)) - alts_text = nest 2 (braces alts) - -pprIlxDataCon env dcon = - text ".alternative" <+> pprId dcon <+> - parens (pprSepWithCommas (ilxTypeL env) (map deepIlxRepType (filter (not. isVoidIlxRepType) (dataConRepArgTys dcon)))) -\end{code} - - -%************************************************************************ -%* * -\subsection{Getting the .closures and literals out} * -%************************************************************************ - -\begin{code} - -ilxBindClosures :: IlxEnv -> StgBinding -> SDoc -ilxBindClosures env (StgNonRec _ b rhs) = ilxRhsClosures env (b,rhs) -ilxBindClosures env (StgRec _ pairs) - = vcat (map (ilxRhsClosures new_env) pairs) - where - new_env = extendIlxEnvWithBinds env pairs - ---------------- -ilxRhsClosures _ (_, StgRhsCon _ _ _) - = empty - -ilxRhsClosures env (bndr, StgRhsClosure _ _ fvs upd args rhs) - = vcat [ilxExprClosures next_env rhs, - - empty $$ line, - kind_text <+> singleQuotes cloname <+> free_vs_text, - nest 2 (braces ( - nest 2 (vcat [empty, - vcat [text ".apply" <+> closure_sig_text, - body_text - ], - empty - ]) - )) - ] - where - kind_of_thing = case upd of - Updatable -> ASSERT( null args ) ".thunk" - otherwise -> ".closure" - kind_text = text kind_of_thing - - cloname = ilxEnvQualifyByModule env (ppr bndr) - next_env = ilxPlaceStgRhsClosure env bndr - (free_vs_text,env_with_fvs) = pprFreeBinders next_env fvs - - - closure_sig_text = - vcat [ text "()", - (case args of - [] -> empty - otherwise -> args_text), - text "-->" <+> rty_text] - - (args_text,env_with_args) = pprArgBinders env_with_fvs args - - -- Find the type returned, from the no. of args and the type of "bndr" - rty_text = - case retType env_with_fvs (idIlxRepType bndr) args of - Just (env,ty) -> - if isVoidIlxRepType ty then (text "void") - else ilxTypeR env ty - Nothing -> trace "WARNING! IlxGen.trace could not find return type - see generated ILX for context where this occurs." (text "// Could not find return type:" <+> ilxTypeR env_with_fvs (idIlxRepType bndr)<+> text ", non representation: " <+> ilxTypeR env_with_fvs (idType bndr)) - - -- strip off leading ForAll and Fun type constructions - -- up to the given number of arguments, extending the environment as - -- we go. - retType env ty [] = Just (env, ty) - retType env (ForAllTy tv ty) (arg:args) = retType (extendIlxEnvWithTyArgs env [tv]) ty args - retType env (FunTy l r) (arg:args) = retType env r args - retType _ _ _ = Nothing - - -- Code for the local variables - locals = ilxExprLocals env_with_args rhs - - env_with_locals = extendIlxEnvWithLocals env_with_args locals - - -- Code for the body of the main apply method - body_code = vcat [empty, - pprIlxLocals env_with_args locals, - ilxExpr (IlxEEnv env_with_locals (mkUniqSet (filter (not.isTyVar) args))) rhs Return, - empty - ] - - body_text = nest 2 (braces (text ".maxstack 100" <+> nest 2 body_code)) - - -pprIlxLocals env [] = empty -pprIlxLocals env vs - = text ".locals" <+> parens (pprSepWithCommas (pprIlxLocal env) (filter nonVoidLocal vs)) - where - nonVoidLocal (LocalId v,_) = not (isVoidIlxRepId v) - nonVoidLocal _ = True - -pprIlxLocal env (LocalId v,_) = ilxTypeL env (idIlxRepType v) <+> pprId v -pprIlxLocal env (LocalSDoc (ty,doc,pin),_) = ilxTypeL env (deepIlxRepType ty) <+> (if pin then text "pinned" else empty) <+> doc - - -pprFreeBinders env fvs - = (ilx_tvs_text <+> vs_text, env2) - where - (free_ilx_tvs, _,free_vs) = categorizeVars fvs - real_free_vs = filter (not . isVoidIlxRepId) free_vs - -- ignore the higher order type parameters for the moment - env1 = extendIlxEnvWithFreeTyVars env free_ilx_tvs - ilx_tvs_text = pprTyVarBinders env1 free_ilx_tvs - vs_text = parens (pprSepWithCommas ppr_id real_free_vs) - ppr_id v = ilxTypeL env1 (idIlxRepType v) <+> pprId v - env2 = extendIlxEnvWithFreeVars env1 real_free_vs - -pprIdBinder env v = parens (ilxTypeL env (idIlxRepType v) <+> pprId v) - - -- Declarations for the arguments of the main apply method -pprArgBinders env [] = (empty,env) -pprArgBinders env (arg:args) - = (arg_text <+> rest_text, res_env) - where - (arg_text,env') = pprArgBinder env arg - (rest_text,res_env) = pprArgBinders env' args - --- We could probably omit some void argument binders, but --- don't... -pprArgBinder env arg - | isVoidIlxRepId arg = (text "()", extendIlxEnvWithArgs env [arg]) - | otherwise - = if isTyVar arg then - let env' = extendIlxEnvWithTyArgs env [arg] in - (pprTyVarBinder env' arg, env') - else (pprIdBinder env arg,extendIlxEnvWithArgs env [arg]) - --------------- --- Compute local variables used by generated method. --- The names of some generated locals are recorded as SDocs. - -data LocalSpec = LocalId Id | LocalSDoc (Type, SDoc, Bool) -- flag is for pinning - -ilxExprLocals :: IlxEnv -> StgExpr -> [(LocalSpec,Maybe (IlxEnv,StgRhs))] -ilxExprLocals env (StgLet bind body) = ilxBindLocals env bind ++ ilxExprLocals env body -ilxExprLocals env (StgLetNoEscape _ _ bind body) = ilxBindLocals env bind ++ ilxExprLocals env body -- TO DO???? -ilxExprLocals env (StgCase scrut _ _ bndr _ alts) - = ilxExprLocals (ilxPlaceStgCaseScrut env) scrut ++ - (if isDeadBinder bndr then [] else [(LocalId bndr,Nothing)]) ++ - ilxAltsLocals env alts -ilxExprLocals env (StgOpApp (StgFCallOp fcall _) args _) - = concat (ilxMapPlaceArgs 0 ilxCCallArgLocals env args) -ilxExprLocals _ _ = [] - --- Generate locals to use for pinning arguments as we cross the boundary --- to C. -ilxCCallArgLocals env (StgVarArg v) | pinCCallArg v = - [(LocalSDoc (idType v, ilxEnvQualifyByExact env (ppr v) <> text "pin", True), Nothing)] -ilxCCallArgLocals _ _ | otherwise = [] - -ilxBindLocals env (StgNonRec _ b rhs) = [(LocalId b,Just (env, rhs))] -ilxBindLocals env (StgRec _ pairs) = map (\(x,y) -> (LocalId x,Just (env, y))) pairs - -ilxAltsLocals env (StgAlgAlts _ alts deflt) = ilxDefltLocals env deflt ++ concat (ilxMapPlaceAlts ilxAlgAltLocals env alts) -ilxAltsLocals env (StgPrimAlts _ alts deflt) = ilxDefltLocals env deflt ++ concat (ilxMapPlaceAlts ilxPrimAltLocals env alts) - -ilxAlgAltLocals env (_, bndrs, _, rhs) = map (\x -> (LocalId x,Nothing)) (filter (\v -> isId v && not (isDeadBinder v)) bndrs) ++ ilxExprLocals env rhs -ilxPrimAltLocals env (_, rhs) = ilxExprLocals env rhs - -ilxDefltLocals _ StgNoDefault = [] -ilxDefltLocals env (StgBindDefault rhs) = ilxExprLocals (ilxPlaceStgBindDefault env) rhs - --------------- -ilxExprClosures :: IlxEnv -> StgExpr -> SDoc -ilxExprClosures env (StgApp _ args) - = vcat (ilxMapPlaceArgs 0 (ilxArgClosures) env args) -- get strings -ilxExprClosures env (StgConApp _ args) - = vcat (ilxMapPlaceArgs 0 (ilxArgClosures) env args) -- get strings -ilxExprClosures env (StgOpApp _ args _) - = vcat (ilxMapPlaceArgs 0 (ilxArgClosures) env args) -- get strings -ilxExprClosures env (StgLet bind body) - = ilxBindClosures env bind $$ ilxExprClosures (extendIlxEnvWithBinds env (ilxPairs1 bind)) body -ilxExprClosures env (StgLetNoEscape _ _ bind body) -- TO DO???? - = ilxBindClosures env bind $$ ilxExprClosures (extendIlxEnvWithBinds env (ilxPairs1 bind)) body -ilxExprClosures env (StgCase scrut _ _ _ _ alts) - = ilxExprClosures (ilxPlaceStgCaseScrut env) scrut $$ ilxAltsClosures env alts -ilxExprClosures env (StgLit lit) - = ilxGenLit env lit -ilxExprClosures _ _ - = empty - -ilxAltsClosures env (StgAlgAlts _ alts deflt) - = vcat [ilxExprClosures (ilxPlaceAlt env i) rhs | (i,(_, _, _, rhs)) <- [1..] `zip` alts] - $$ - ilxDefltClosures env deflt - -ilxAltsClosures env (StgPrimAlts _ alts deflt) - = vcat [ilxExprClosures (ilxPlaceAlt env i) rhs | (i,(_, rhs)) <- [1..] `zip` alts] - $$ - vcat [ ilxGenLit (ilxPlacePrimAltLit env i) lit | (i,(lit,_)) <- [1..] `zip` alts] - $$ - ilxDefltClosures env deflt - -ilxDefltClosures env (StgBindDefault rhs) = ilxExprClosures (ilxPlaceStgBindDefault env) rhs -ilxDefltClosures _ StgNoDefault = empty - -ilxArgClosures env (StgLitArg lit) = ilxGenLit env lit -ilxArgClosures _ _ = empty - - - -ilxGenLit env (MachStr fs) - = vcat [text ".field static assembly char " <+> singleQuotes nm <+> text "at" <+> nm <> text "L", - text ".data" <+> nm <> text "L" <+> text "= char *(" <> pprFSInILStyle fs <> text ")" - ] - where - nm = ilxEnvQualifyByExact env (text "string") - -ilxGenLit _ _ = empty - -\end{code} - - -%************************************************************************ -%* * -\subsection{Generating code} -%* * -%************************************************************************ - - -\begin{code} - --- Environment when generating expressions -data IlxEEnv = IlxEEnv IlxEnv (UniqSet Id) - -data Sequel = Return | Jump IlxLabel - -ilxSequel Return = text "ret" -ilxSequel (Jump lbl) = text "br" <+> pprIlxLabel lbl - -isReturn Return = True -isReturn (Jump _) = False - - -ilxExpr :: IlxEEnv -> StgExpr - -> Sequel -- What to do at the end - -> SDoc - -ilxExpr (IlxEEnv env _) (StgApp fun args) sequel - = ilxFunApp env fun args (isReturn sequel) $$ ilxSequel sequel - --- ilxExpr eenv (StgLit lit) sequel -ilxExpr (IlxEEnv env _) (StgLit lit) sequel - = pushLit env lit $$ ilxSequel sequel - --- ilxExpr eenv (StgConApp data_con args) sequel -ilxExpr (IlxEEnv env _) (StgConApp data_con args) sequel - = text " /* ilxExpr:StgConApp */ " <+> ilxConApp env data_con args $$ ilxSequel sequel - --- ilxExpr eenv (StgPrimApp primop args _) sequel -ilxExpr (IlxEEnv env _) (StgOpApp (StgFCallOp fcall _) args ret_ty) sequel - = ilxFCall env fcall args ret_ty $$ ilxSequel sequel - -ilxExpr (IlxEEnv env _) (StgOpApp (StgPrimOp primop) args ret_ty) sequel - = ilxPrimOpTable primop args env $$ ilxSequel sequel - ---BEGIN TEMPORARY --- The following are versions of a peephole optimizations for "let t = \[] t2[fvs] in t" --- I think would be subsumed by a general treatmenet of let-no-rec bindings?? -ilxExpr eenv@(IlxEEnv env _) (StgLet (StgNonRec _ bndr (StgRhsClosure _ _ _ _ [] rhs)) (StgApp fun [])) sequel - | (bndr == fun && null (ilxExprLocals env rhs)) -- TO DO??? - = ilxExpr eenv rhs sequel -ilxExpr eenv@(IlxEEnv env _) (StgLetNoEscape _ _ (StgNonRec _ bndr (StgRhsClosure _ _ _ _ [] rhs)) (StgApp fun [])) sequel - | (bndr == fun && null (ilxExprLocals env rhs)) -- TO DO??? - = ilxExpr eenv rhs sequel ---END TEMPORARY - -ilxExpr eenv (StgLet bind body) sequel - = ilxBind eenv bind $$ ilxExpr eenv body sequel - - -ilxExpr eenv (StgLetNoEscape _ _ bind body) sequel -- TO DO??? - = ilxBind eenv bind $$ ilxExpr eenv body sequel - --- StgCase: Special case 1 to avoid spurious branch. -ilxExpr eenv@(IlxEEnv env live) (StgCase (StgApp fun args) live_in_case _live_in_alts bndr _ alts) sequel - = vcat [ilxWipe env (uniqSetToList (live `minusUniqSet` live_in_case)), - ilxFunApp (ilxPlaceStgCaseScrut env) fun args False, - --ilxWipe env (uniqSetToList (live_in_case `minusUniqSet` _live_in_alts)), - --ilxAlts (IlxEEnv env _live_in_alts) bndr alts sequel - ilxAlts (IlxEEnv env live_in_case) bndr alts sequel - ] - --- StgCase: Special case 2 to avoid spurious branch. -ilxExpr eenv@(IlxEEnv env live) (StgCase (StgOpApp (StgPrimOp primop) args ret_ty) live_in_case _live_in_alts bndr _ alts) sequel - = vcat [ilxWipe env (uniqSetToList (live `minusUniqSet` live_in_case)), - ilxPrimOpTable primop args (ilxPlaceStgCaseScrut env), - --ilxWipe env (uniqSetToList (live_in_case `minusUniqSet` _live_in_alts)), - --ilxAlts (IlxEEnv env _live_in_alts) bndr alts sequel - ilxAlts (IlxEEnv env live_in_case) bndr alts sequel - ] - --- StgCase: Normal case. -ilxExpr eenv@(IlxEEnv env live) (StgCase scrut live_in_case _live_in_alts bndr _ alts) sequel - = vcat [ilxWipe env (uniqSetToList (live `minusUniqSet` live_in_case)), - ilxExpr (IlxEEnv (ilxPlaceStgCaseScrut env) live_in_case) scrut (Jump join_lbl), - ilxLabel join_lbl, - --ilxWipe env (uniqSetToList (live_in_case `minusUniqSet` _live_in_alts)), - --ilxAlts (IlxEEnv env _live_in_alts) bndr alts sequel - ilxAlts (IlxEEnv env live_in_case) bndr alts sequel - ] - where - join_lbl = mkJoinLabel bndr - -ilxExpr _ _ _ - = panic "ilxExpr: Patterns not matched:(IlxEEnv _ _) (StgSCC _ _) _ (IlxEEnv _ _) (StgLam _ _ _) _" - - --- Wipe out locals and arguments that are no longer in use, to --- prevent space leaks. If the VM is implemented 100% correctly then --- this should probably not be needed, as the live variable analysis --- in the JIT would tell the GC that these locals and arguments are --- no longer live. However I'm putting it in here so we can --- check out if it helps. --- --- Also, in any case this doesn't capture everything we need. e.g. --- when making a call: --- case f x of ... --- where x is not used in the alternatives, then the variable x --- is no longer live from the point it is transferred to the call --- onwards. We should expunge "live_in_case - live_in_alts" right --- before making the call, not after returning from the call.... --- --- Strictly speaking we also don't need to do this for primitive --- values such as integers and addresses, i.e. things not --- mapped down to GC'able objects. -ilxWipe env ids - = vcat (map (ilxWipeOne env) (filter (not.isVoidIlxRepId) ids)) - -ilxWipeOne env id - = case lookupIlxVarEnv env id of - Just Local -> text "ldloca " <+> pprId id <+> text "initobj.any" <+> (ilxTypeL env (idIlxRepType id)) - Just Arg -> text "deadarg " <+> pprId id <+> text "," <+> (ilxTypeL env (idIlxRepType id)) - Just (CloVar _) -> ilxComment (text "not yet wiping closure variable" <+> pprId id ) - _ -> ilxComment (text "cannot wipe non-local/non-argument" <+> pprId id ) - where - - ----------------------- - -ilxAlts :: IlxEEnv -> Id -> StgCaseAlts -> Sequel -> SDoc -ilxAlts (IlxEEnv env live) bndr alts sequel - -- At the join label, the result is on top - -- of the stack - = vcat [store_in_bndr, - do_case_analysis alts - ] - where - scrut_rep_ty = deepIlxRepType (idType bndr) - - store_in_bndr | isDeadBinder bndr = empty - | isVoidIlxRepId bndr - = ilxComment (text "ignoring store of zero-rep value to be analyzed") - | otherwise = text "dup" $$ (text "stloc" <+> pprId bndr) - - do_case_analysis (StgAlgAlts _ [] deflt) - = do_deflt deflt - - do_case_analysis (StgAlgAlts _ args deflt) - = do_alg_alts ([1..] `zip` args) deflt - - do_case_analysis (StgPrimAlts _ alts deflt) - = do_prim_alts ([1..] `zip` alts) $$ do_deflt deflt - - do_alg_alts [(i, alt@(data_con,bndrs,used_flags, rhs))] StgNoDefault | isUnboxedTupleCon data_con - -- Collapse the analysis of unboxed tuples where - -- some or all elements are zero-sized - -- - -- TO DO: add bndrs to set of live variables - = case bndrs' of - [h] -> bind_collapse bndrs used_flags <+> do_rhs_no_pop alt_env rhs - _ -> bind_components alt_env dcon' bndrs 0 used_flags <+> do_rhs alt_env rhs - where - bndrs' = filter (not. isVoidIlxRepId) bndrs - -- Replacement unboxed tuple type constructor, used if any of the - -- arguments have zero-size and more than one remains. - dcon' = tupleCon Unboxed (length bndrs') - - alt_env = IlxEEnv (ilxPlaceAlt env i) live - --alt_env = IlxEEnv (ilxPlaceAlt env i) - - bind_collapse [] _ = panic "bind_collapse: unary element not found" - bind_collapse (h:t) (is_used:used_flags) - | isVoidIlxRepId h = ilxComment (text "zero-rep binding eliminated") <+> (bind_collapse t used_flags) - | not is_used = ilxComment (text "not used") <+> text "pop" - | otherwise = text "stloc" <+> pprId h - - - do_alg_alts [(i, alt@(data_con,bndrs,used_flags, rhs))] StgNoDefault - = vcat [text "castdata" <+> sep [ilxTypeR env scrut_rep_ty <> comma, - ilxConRef env data_con], - do_alg_alt (IlxEEnv (ilxPlaceAlt env i) live) alt - ] - - do_alg_alts alts deflt - = vcat [text "datacase" <+> sep [ilxTypeR env scrut_rep_ty,text ",", - pprSepWithCommas pp_case labels_w_alts], - do_deflt deflt, - vcat (map do_labelled_alg_alt labels_w_alts) - ] - where - pp_case (i, (lbl, (data_con, _, _, _))) = parens (ilxConRef env data_con <> comma <> pprIlxLabel lbl) - labels_w_alts = [(i,(mkAltLabel bndr i, alt)) | (i, alt) <- alts] - - do_prim_alts [] = empty - do_prim_alts ((i, (lit,alt)) : alts) - = vcat [text "dup", pushLit (ilxPlacePrimAltLit env i) lit, text "bne.un" <+> pprIlxLabel lbl, - do_rhs (IlxEEnv (ilxPlaceAlt env i) live) alt, - ilxLabel lbl, do_prim_alts alts] - where - lbl = mkAltLabel bndr i - - do_labelled_alg_alt (i,(lbl, alt)) - = ilxLabel lbl $$ do_alg_alt (IlxEEnv (ilxPlaceAlt env i) live) alt - - do_alg_alt alt_eenv (data_con, bndrs, used_flags, rhs) - = vcat [bind_components alt_eenv data_con bndrs 0 used_flags, - do_rhs alt_eenv rhs - ] - - bind_components alt_eenv data_con [] n _ = empty - bind_components alt_eenv data_con (h:t) n (is_used:used_flags) - | isVoidIlxRepId h - -- don't increase the count in this case - = ilxComment (text "zero-rep binding eliminated") - <+> bind_components alt_eenv data_con t n used_flags - | otherwise - = bind_component alt_eenv data_con h is_used n - <+> bind_components alt_eenv data_con t (n + 1) used_flags - - bind_component alt_eenv@(IlxEEnv alt_env _) data_con bndr is_used reduced_fld_no - | not is_used - = ilxComment (text "not used") - | isVoidIlxRepId bndr - = ilxComment (text "ignoring bind of zero-rep variable") - | otherwise = vcat [text "dup", - ld_data alt_env data_con reduced_fld_no bndr, - text "stloc" <+> pprId bndr] - - do_deflt (StgBindDefault rhs) = do_rhs (IlxEEnv (ilxPlaceStgBindDefault env) live) rhs - do_deflt StgNoDefault = empty - - do_rhs alt_eenv rhs - | isVoidIlxRepId bndr = do_rhs_no_pop alt_eenv rhs -- void on the stack, nothing to pop - | otherwise = text "pop" $$ do_rhs_no_pop alt_eenv rhs -- drop the value - - do_rhs_no_pop alt_env rhs = ilxExpr alt_env rhs sequel - - ld_data alt_env data_con reduced_fld_no bndr - | isUnboxedTupleCon data_con - = text "ldfld" <+> sep [text "!" <> integer reduced_fld_no, - ilxTypeR alt_env scrut_rep_ty <> text "::fld" <> integer reduced_fld_no] - | otherwise - = text "lddata" <+> sep [ilxTypeR alt_env scrut_rep_ty <> comma, - ilxConRef env data_con <> comma, - integer reduced_fld_no] - - -------------------------- - -ilxBestTermArity = 3 -ilxBestTypeArity = 7 - - --- Constants of unlifted types are represented as --- applications to no arguments. -ilxFunApp env fun [] _ | isUnLiftedType (idType fun) - = pushId env fun - -ilxFunApp env fun args tail_call - = -- For example: - -- ldloc f function of type forall a. a->a - -- ldloc x arg of type Int - -- .tail callfunc (!0) --> !0 - -- - vcat [pushId env fun,ilxFunAppAfterPush env fun args tail_call] - -ilxFunAppAfterPush env fun args tail_call - = -- For example: - -- ldloc f function of type forall a. a->a - -- ldloc x arg of type Int - -- .tail callfunc (!0) --> !0 - -- - vcat [ilxFunAppArgs env 0 (idIlxRepType fun) args tail_call known_clo] - where - known_clo :: KnownClosure - known_clo = - case lookupIlxBindEnv env fun of - Just (_, StgRhsClosure _ _ _ Updatable _ _) -> Nothing - Just (place, StgRhsClosure _ _ fvs _ args _) -> Just (place,fun,args,fvs) - _ -> Nothing -- trace (show fun ++ " --> " ++ show (idArity fun)) - -type KnownClosure = Maybe ( IlxEnv -- Of the binding site of the function - , Id -- The function - , [Var] -- Binders - , [Var]) -- Free vars of the closure - --- Push as many arguments as ILX allows us to in one go, and call the function --- Recurse until we're done. --- The function is already on the stack -ilxFunAppArgs :: IlxEnv - -> Int -- Number of args already pushed (zero is a special case; - -- otherwise used only for place generation) - -> Type -- Type of the function - -> [StgArg] -- The arguments - -> Bool -- True <=> tail call please - -> KnownClosure -- Information about the function we're calling - -> SDoc - -ilxFunAppArgs env num_sofar funty args tail_call known_clo - = vcat [vcat (ilxMapPlaceArgs num_sofar pushArgWithVoids env now_args), - call_instr <+> (if num_sofar == 0 then text "() /* first step in every Haskell app. is to a thunk */ " else empty) - <+> now_args_text - <+> text "-->" - <+> later_ty_text, - later - ] - where - now_args_text = - case now_arg_tys of - [] -> empty - _ -> hsep (map (pprIlxArgInfo env_after_now_tyvs) now_arg_tys) - - later_ty_text - | isVoidIlxRepType later_ty = text "void" - | otherwise = ilxTypeR env_after_now_tyvs later_ty - - (now_args,now_arg_tys,env_after_now_tyvs,later_args,later_ty) = - case args of - (StgTypeArg v:rest) -> get_type_args ilxBestTypeArity args env funty - _ -> get_term_args 0 ilxBestTermArity args env funty - - -- Only apply up to maxArity real (non-type) arguments - -- at a time. ILX should, in principle, allow us to apply - -- arbitrary numbers, but you will get more succinct - -- (and perhaps more efficient) IL code - -- if you apply in clumps according to its maxArity setting. - -- This is because it has to unwind the stack and store it away - -- in local variables to do the partial applications. - -- - -- Similarly, ILX only allows one type application at a time, at - -- least until we implement unwinding the stack for this case. - -- - -- NB: In the future we may have to be more careful - -- all the way through - -- this file to bind type variables as we move through - -- type abstractions and "forall" types. This would apply - -- especially if the type variables were ever bound by expressions - -- involving the type variables. - - -- This part strips off at most "max" term applications or one type application - get_type_args 0 args env funty = ([],[],env,args,funty) - get_type_args max ((arg@(StgTypeArg v)):rest) env (ForAllTy tv rem_funty) - = if isIlxTyVar tv then - let env2 = extendIlxEnvWithFormalTyVars env [tv] in - let rest_ty = deepIlxRepType (substTyWith [tv] [v] rem_funty) in - let (now,now_tys,env3,later,later_ty) = get_type_args (max - 1) rest env rest_ty in - let arg_ty = mkTyVarTy tv in - (arg:now,(arg,arg_ty):now_tys,env2, later, later_ty) - else - get_type_args max rest env rem_funty -- ? subst?? - get_type_args _ (StgTypeArg _:_) _ _ = trace "IlxGen Internal Error: get_type_args could not get ForAllTy for corresponding arg" ([],[],env,[],funty) - get_type_args _ args env funty = ([],[],env,args,funty) - - get_term_args n 0 args env funty - -- Stop if we've hit the maximum number of ILX arguments to apply n one hit. - = ([],[],env,args,funty) - get_term_args n max args env funty - | (case known_clo of - Just (_,_,needed,_) -> needed `lengthIs` n - Nothing -> False) - -- Stop if we have the optimal number for a direct call - = ([],[],env,args,funty) - get_term_args _ _ (args@(StgTypeArg _:_)) env funty - -- Stop if we hit a type arg. - = ([],[],env,args,funty) - get_term_args n max (h:t) env (FunTy dom ran) - -- Take an argument. - = let (now,now_tys,env2,later,later_ty) = get_term_args (n+1) (max - 1) t env ran in - (h:now, (h,dom):now_tys,env2,later,later_ty) - get_term_args _ max (h:t) env funty = trace "IlxGen Internal Error: get_term_args could not get FunTy or ForAllTy for corresponding arg" ([],[],env,[],funty) - get_term_args _ max args env funty = ([],[],env,args,funty) - - -- Are there any remaining arguments? - done = case later_args of - [] -> True - _ -> False - - -- If so, generate the subsequent calls. - later = if done then text "// done" - else ilxFunAppArgs env (num_sofar + length now_args) later_ty later_args tail_call Nothing - - -- Work out whether to issue a direct call a known closure (callclo) or - -- an indirect call (callfunc). Basically, see if the identifier has - -- been let-bound, and then check we are applying exactly the right - -- number of arguments. Also check that it's not a thunk (actually, this - -- is done up above). - -- - -- The nasty "all" check makes sure that - -- the set of type variables in scope at the callsite is a superset - -- of the set of type variables needed for the direct call. This is - -- is needed because not all of the type variables captured by a - -- let-bound binding will get propogated down to the callsite, and - -- the ILX system of polymorphism demands that the free type variables - -- get reapplied when we issue the direct "callclo". The - -- type variables are in reality also "bound up" in the closure that is - -- passed as the first argument, so when we do an indirect call - -- to that closure we're fine, which is why we don't need them in - -- the "callfunc" case. - basic_call_instr = - case known_clo of - Just (known_env,fun,needed,fvs) | (equalLength needed now_args) && - all (\x -> elemIlxTyEnv x env) free_ilx_tvs -> - vcat [text "callclo class", - nameReference env (idName fun) <+> singleQuotes (ilxEnvQualifyByModule env (ppr fun)), - pprTypeArgs ilxTypeR env (map mkTyVarTy free_ilx_tvs)] - <> text "," - where - (free_ilx_tvs, free_non_ilx_tvs,free_vs) = categorizeVars fvs - otherwise -> text "callfunc" - call_instr = - if (tail_call && done) then text "tail." <+> basic_call_instr - else basic_call_instr - - --------------------------- --- Print the arg info at the call site --- For type args we are, at the moment, required to --- give both the actual and the formal (bound). The formal --- bound is always System.Object at the moment (bounds are --- not properly implemented in ILXASM in any case, and nor do --- we plan on making use og them) For --- non-type args the actuals are on the stack, and we just give the --- formal type. -pprIlxArgInfo env (StgTypeArg arg,ty) = - angleBrackets (ilxTypeR env (deepIlxRepType arg) <+> ilxComment (text "actual for tyvar")) <+> text "" -pprIlxArgInfo env (_,ty) = - parens (ilxTypeL env ty) - - ----------------------------- --- Code for a binding -ilxBind :: IlxEEnv -> StgBinding -> SDoc -ilxBind eenv@(IlxEEnv env _) bind = - vcat [vcat (map (ilxRhs env rec) pairs), - vcat (map (ilxFixupRec env rec) pairs)] - where - rec = ilxRecIds1 bind - pairs = ilxPairs1 bind - - ----------------------------- --- Allocate a closure or constructor. Fix up recursive definitions. -ilxRhs :: IlxEnv -> [Id] -> (Id, StgRhs) -> SDoc - -ilxRhs env rec (bndr, _) | isVoidIlxRepId bndr - = empty - -ilxRhs env rec (bndr, StgRhsCon _ con args) - = vcat [text " /* ilxRhs:StgRhsCon */ " <+> ilxConApp env con args, - text "stloc" <+> pprId bndr - ] - -ilxRhs env rec (bndr, StgRhsClosure _ _ fvs upd args rhs) - = -- Assume .closure v(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 = pprIlxNamedTyConApp env (ilxEnvQualifyByModule env (ppr bndr)) (map mkTyVarTy free_ilx_tvs) - -ilxFixupRec env rec (bndr, _) | isVoidIlxRepId bndr = ilxComment (text "no recursive fixup for void-rep-id") - -ilxFixupRec env rec (bndr, StgRhsCon _ con args) - = text "// no recursive fixup" - -ilxFixupRec env rec (bndr, StgRhsClosure _ _ fvs upd args rhs) - = vcat [vcat (map fixFv rec)] - where - fixFv recid = if elem recid fvs then - vcat [pushId env bndr, - pushId env recid, - text "stclofld" <+> clotext <> text "," <+> pprId recid] - else text "//no fixup needed for" <+> pprId recid - (free_ilx_tvs, free_non_ilx_tvs,free_vs) = categorizeVars fvs - clotext = pprIlxNamedTyConApp env (ilxEnvQualifyByModule env (ppr bndr)) (map mkTyVarTy free_ilx_tvs) - - - ---------------------------------------------- --- Code for a top-level binding in a module -ilxPairs binds = concat (map ilxPairs1 binds) - -ilxPairs1 (StgNonRec _ bndr rhs) = [(bndr,rhs)] -ilxPairs1 (StgRec _ pairs) = pairs - -ilxRecIds1 (StgNonRec _ bndr rhs) = [] -ilxRecIds1 (StgRec _ pairs) = map fst pairs - ---------------------------------------------- --- Code for a top-level binding in a module --- TODO: fix up recursions amongst CAF's --- e.g. --- x = S x --- for infinity... --- --- For the moment I've put in a completely spurious "reverse"... --- --- Consider: make fixing up of CAF's part of ILX? i.e. --- put static, constant, allocated datastructures into ILX. - -stableSortBy :: (a -> a -> Ordering) -> [a] -> [a] -stableSortBy f (h:t) = insertBy f h (stableSortBy f t) -stableSortBy f [] = [] - -usedBy :: (Id,StgRhs) -> (Id,StgRhs) -> Ordering -usedBy (m,_) (_,StgRhsCon _ data_con args) | any (isArg m) args = LT -usedBy (m,_) (n,_) | m == n = EQ -usedBy (m,_) (_,_) = GT - -isArg m (StgVarArg n) = (n == m) -isArg m _ = False - - -ilxTopBind :: Module -> IlxEnv -> [(Id,StgRhs)] -> SDoc ---ilxTopBind mod env (StgNonRec _ bndr rhs) = ---ilxTopRhs env (bndr,rhs) -ilxTopBind mod env pairs = - vcat [text ".class" <+> pprId mod, - nest 2 (braces (nest 2 (vcat [empty,cctor, flds, empty])))] - where - cctor = vcat [text ".method static rtspecialname specialname void .cctor()", - nest 2 (braces - (nest 2 (vcat [text ".maxstack 100", - text "ldstr \"LOG: initializing module" <+> pprId mod <+> text "\" call void ['mscorlib']System.Console::WriteLine(class [mscorlib]System.String)", - vcat (map (ilxTopRhs mod env) (stableSortBy usedBy pairs)), - text "ldstr \"LOG: initialized module" <+> pprId mod <+> text "\" call void ['mscorlib']System.Console::WriteLine(class [mscorlib]System.String)", - text "ret", - empty])))] - flds = vcat (map (ilxTopRhsStorage mod env) pairs) - ---ilxTopRhs mod env (bndr, _) | isVoidIlxRepId bndr --- = empty - -ilxTopRhs mod env (bndr, StgRhsClosure _ _ fvs upd args rhs) - = vcat [vcat (map (pushId env) free_vs), - (if null free_non_ilx_tvs then empty else (ilxComment (text "ignored some higher order type arguments in application - code will be non verifiable...."))), - text "newclo" <+> pprIlxNamedTyConApp env (ilxEnvQualifyByModule env (ppr bndr)) (map mkTyVarTy free_ilx_tvs), - text "stsfld" <+> pprFieldRef env (mod,bndTy,bndr) - ] - where - (free_ilx_tvs, free_non_ilx_tvs,free_vs) = categorizeVars fvs - bndTy = idIlxRepType bndr - -ilxTopRhs mod env (bndr, StgRhsCon _ data_con args) - = vcat [ text " /* ilxTopRhs: StgRhsCon */ " <+> ilxConApp env data_con args, - text "stsfld" <+> pprFieldRef env (mod,bndTy,bndr) - ] - where - bndTy = idIlxRepType bndr - -pprFieldRef env (mod,ty,id) - = ilxTypeL env ty <+> moduleReference env mod <+> pprId mod <> text "::" <> pprId id - -ilxTopRhsStorage mod env (bndr, StgRhsClosure _ _ _ _ _ _) - = text ".field public static " <+> ilxTypeL env bndTy <+> pprId bndr - where - bndTy = idIlxRepType bndr -ilxTopRhsStorage mod env (bndr, StgRhsCon _ _ _) - = text ".field public static " <+> ilxTypeL env bndTy <+> pprId bndr - where - bndTy = idIlxRepType bndr - --------------------------------------- --- Push an argument -pushArgWithVoids = pushArg_aux True -pushArg = pushArg_aux False - -pushArg_aux voids env (StgTypeArg ty) = empty -pushArg_aux voids env (StgVarArg var) = pushId_aux voids env var -pushArg_aux voids env (StgLitArg lit) = pushLit env lit - - -mapi f l = mapi_aux f l 0 - -mapi_aux f [] n = [] -mapi_aux f (h:t) n = f n h : mapi_aux f t (n+1) - --------------------------------------- --- Push an Id -pushId = pushId_aux False - -pushId_aux :: Bool -> IlxEnv -> Id -> SDoc -pushId_aux voids _ id | isVoidIlxRepId id = - /* if voids then text "ldunit" else */ ilxComment (text "pushId: void rep skipped") -pushId_aux _ env var - = case lookupIlxVarEnv env var of - Just Arg -> text "ldarg" <+> pprId var - Just (CloVar n) -> text "ldenv" <+> int n - Just Local -> text "ldloc" <+> pprId var - Just (Top m) -> - vcat [ilxComment (text "pushId (Top) " <+> pprId m), - text "ldsfld" <+> ilxTypeL env (idIlxRepType var) - <+> moduleReference env m <+> pprId (moduleName m) <> text "::" <> pprId var] - - Nothing -> - vcat [ilxComment (text "pushId (import) " <+> pprIlxTopVar env var), - text "ldsfld" <+> ilxTypeL env (idIlxRepType var) - <+> pprIlxTopVar env var] - --------------------------------------- --- Push a literal -pushLit env (MachChar c) = text "ldc.i4" <+> int c -pushLit env (MachStr s) = text "ldsflda char " <+> ilxEnvQualifyByExact env (text "string") -- pprFSInILStyle s -pushLit env (MachInt i) = text "ldc.i4" <+> integer i -pushLit env (MachInt64 i) = text "ldc.i8" <+> integer i -pushLit env (MachWord w) = text "ldc.i4" <+> integer w <+> text "conv.u4" -pushLit env (MachWord64 w) = text "ldc.i8" <+> integer w <+> text "conv.u8" -pushLit env (MachFloat f) = text "ldc.r4" <+> rational f -pushLit env (MachDouble f) = text "ldc.r8" <+> rational f -pushLit env (MachNullAddr) = text "ldc.i4 0" -pushLit env (MachLabel l _) = trace "WARNING: Cannot compile MachLabel to ILX in IlxGen.lhs" (text "// MachLabel!!! Not valid in ILX!!") - -pprIlxTopVar env v - | isExternalName n = (nameReference env n) <> pprId (nameModule n) <> text "::" <> singleQuotes (ppr (nameModule n) <> text "_" <> ppr (nameOccName n)) - | otherwise = pprId (nameOccName n) - where - n = idName v - -\end{code} - - -%************************************************************************ -%* * -\subsection{Printing types} -%* * -%************************************************************************ - - -\begin{code} - -isVoidIlxRepType (TyConApp tc _) | (tyConPrimRep tc == VoidRep) = True -isVoidIlxRepType (TyConApp tc tys) - = isUnboxedTupleTyCon tc && null (filter (not. isVoidIlxRepType) tys) -isVoidIlxRepType _ = False - -isVoidIlxRepId id = isVoidIlxRepType (idType id) - - - --- Get rid of all NewTy artifacts -deepIlxRepType :: Type -> Type -deepIlxRepType (FunTy l r) - = FunTy (deepIlxRepType l) (deepIlxRepType r) - -deepIlxRepType ty@(TyConApp tc tys) - = -- collapse UnboxedTupleTyCon down when it contains VoidRep types. - -- e.g. (# State#, Int#, Int# #) ===> (# Int#, Int# #) - if isUnboxedTupleTyCon tc then - let tys' = map deepIlxRepType (filter (not. isVoidIlxRepType) tys) in - case tys' of - [h] -> h - _ -> mkTupleTy Unboxed (length tys') tys' - else - TyConApp tc (map deepIlxRepType tys) -deepIlxRepType (AppTy f x) = AppTy (deepIlxRepType f) (deepIlxRepType x) -deepIlxRepType (ForAllTy b ty) = ForAllTy b (deepIlxRepType ty) -deepIlxRepType (PredTy p) = deepIlxRepType (predTypeRep p) -deepIlxRepType ty@(TyVarTy tv) = ty - -idIlxRepType id = deepIlxRepType (idType id) - --------------------------- --- Some primitive type constructors are not thunkable. --- Everything else needs to be marked thunkable. -ilxTypeL :: IlxEnv -> Type -> SDoc - -ilxTypeL env ty | isUnLiftedType ty || isVoidIlxRepType ty = ilxTypeR env ty -ilxTypeL env ty = text "thunk" <> angleBrackets (ilxTypeR env ty) - - --------------------------- --- Print non-thunkable version of type. --- - -ilxTypeR :: IlxEnv -> Type -> SDoc -ilxTypeR env ty | isVoidIlxRepType ty = text "/* unit skipped */" -ilxTypeR env ty@(AppTy f _) | isTyVarTy f = ilxComment (text "type app:" <+> pprType ty) <+> (text "class [mscorlib]System.Object") -ilxTypeR env ty@(AppTy f x) = trace "ilxTypeR: should I be beta reducing types?!" (ilxComment (text "ilxTypeR: should I be beta reducing types?!") <+> ilxTypeR env (applyTy f x)) -ilxTypeR env (TyVarTy tv) = ilxTyVar env tv - --- The following is a special rule for types constructed out of --- higher kinds, e.g. Monad f or Functor f. --- --- The code below is not as general as it should be, but as I --- have no idea if this approach will even work, I'm going to --- just try it out on some simple cases arising from the prelude. -ilxTypeR env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && null (tyConTyVars tc) - = ilxComment (text "what on earth? 2") <+> (ilxTypeR env (TyConApp tc t)) -ilxTypeR env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && not (isIlxTyVar (hd (tyConTyVars tc))) - = ilxTypeR env (TyConApp tc t) -ilxTypeR env (TyConApp tc args) = ilxTyConApp env tc args - - -- nb. the only legitimate place for VoidIlxRepTypes to occur in normalized IlxRepTypes - -- is on the left of an arrow - -- We could probably eliminate all but a final occurrence of these. -ilxTypeR env (FunTy arg res)| isVoidIlxRepType res - = pprIlxFunTy (ilxTypeL env arg) (text "void") -ilxTypeR env (FunTy arg res) - = pprIlxFunTy (ilxTypeL env arg) (ilxTypeR env res) - -ilxTypeR env ty@(ForAllTy tv body_ty) | isIlxTyVar tv - = parens (text "forall" <+> pprTyVarBinders env' [tv] <+> nest 2 (ilxTypeR env' body_ty)) - where - env' = extendIlxEnvWithFormalTyVars env [tv] - -ilxTypeR env ty@(ForAllTy tv body_ty) | otherwise - = ilxComment (text "higher order type var " <+> pprId tv) <+> - pprIlxFunTy (text "class [mscorlib]System.Object") (ilxTypeR env body_ty) - -pprIlxFunTy dom ran = parens (hsep [text "func",parens dom,text "-->", ran]) - -ilxTyConApp env tcon args = - case lookupUFM tyPrimConTable (getUnique tcon) of - Just f -> f args env - Nothing -> - (if isUnboxedTupleTyCon tcon then pprIlxUnboxedTupleTyConApp else pprIlxBoxedTyConApp) - env tcon args - -pprIlxTyCon env tcon = nameReference env (getName tcon) <> ppr tcon -pprIlxUnboxedTupleTyConApp env tcon args - = text "/* unboxed */ value class" <+> pprIlxTyCon env tcon' <> pprTypeArgs ilxTypeL env non_void - where - non_void = filter (not . isVoidIlxRepType) args - tcon' = dataConTyCon (tupleCon Unboxed (length non_void)) -pprIlxBoxedTyConApp env tcon args - = pprIlxNamedTyConApp env (pprIlxTyCon env tcon) args -pprIlxNamedTyConApp env tcon_text args - = text "class" <+> tcon_text <> pprTypeArgs ilxTypeR env args - --- Returns e.g: --- Void-sized type arguments are _always_ eliminated, everywhere. --- If the type constructor is an unboxed tuple type then it should already have --- been adjusted to be the correct constructor. -pprTypeArgs f env tys = pprTypeArgs_aux f env (filter (not . isVoidIlxRepType) tys) - -pprTypeArgs_aux f env [] = empty -pprTypeArgs_aux f env tys = angleBrackets (pprSepWithCommas (f env) tys) - - -pprTyVarBinders :: IlxEnv -> [TyVar] -> SDoc --- Returns e.g: --- plus a new environment with the type variables added. -pprTyVarBinders env [] = empty -pprTyVarBinders env tvs = angleBrackets (pprSepWithCommas (pprTyVarBinder_aux env) tvs) - -pprTyVarBinder :: IlxEnv -> TyVar -> SDoc -pprTyVarBinder env tv = - if isIlxTyVar tv then - angleBrackets (pprTyVarBinder_aux env tv) - else - ilxComment (text "higher order tyvar" <+> pprId tv <+> - text ":" <+> ilxTypeR env (tyVarKind tv)) <+> - ilxComment (text "omitted") - -- parens (text "class [mscorlib]System.Object" <+> pprId tv) - - -pprTyVarBinder_aux env tv = - ilxComment (text "tyvar" <+> pprId tv <+> text ":" <+> - ilxTypeR env (tyVarKind tv)) <+> - (text "class [mscorlib]System.Object") - --- Only a subset of Haskell types can be generalized using the type quantification --- of ILX -isIlxForAllKind h = - ( h `eqKind` liftedTypeKind) || - ( h `eqKind` unliftedTypeKind) || - ( h `eqKind` openTypeKind) - -isIlxTyVar v = isTyVar v && isIlxForAllKind (tyVarKind v) - -categorizeVars fvs = (ilx_tvs, non_ilx_tvs, vs) - where - (tvs, vs) = partition isTyVar fvs - (ilx_tvs, non_ilx_tvs) = categorizeTyVars tvs - -categorizeTyVars tyvs = partition isIlxTyVar tyvs - -pprValArgTys ppr_ty env tys = parens (pprSepWithCommas (ppr_ty env) tys) - -pprId id = singleQuotes (ppr id) - -\end{code} - -%************************************************************************ -%* * -\subsection{IlxEnv} -%* * -%************************************************************************ - -\begin{code} -type IlxTyEnv = [TyVar] -emptyIlxTyEnv = [] - --- Nb. There is currently no distinction between the kinds of type variables. --- We may need to add this to print out correct numbers, esp. for --- "forall" types -extendIlxTyEnvWithFreeTyVars env tyvars = env ++ mkIlxTyEnv tyvars -- bound by .closure x<...> in a closure declared with type parameters -extendIlxTyEnvWithFormalTyVars env tyvars = env ++ mkIlxTyEnv tyvars -- bound by "forall <...>" in a type -extendIlxTyEnvWithTyArgs env tyvars = env ++ mkIlxTyEnv tyvars -- bound by "<...>" in a closure implementing a universal type - -formalIlxTyEnv tyvars = mkIlxTyEnv tyvars -mkIlxTyEnv tyvars = [ v | v <- tyvars, isIlxTyVar v ] - -data HowBound = Top Module -- Bound in a modules - | Arg -- Arguments to the enclosing closure - | CloVar Int -- A free variable of the enclosing closure - -- The int is the index of the field in the - -- environment - | Local -- Local let binding - --- The SDoc prints a unique name for the syntactic block we're currently processing, --- e.g. Foo_bar_baz when inside closure baz inside closure bar inside module Foo. -data IlxEnv = IlxEnv (Module, IlxTyEnv, IdEnv HowBound,IdEnv (IlxEnv, StgRhs), Place,Bool) -type Place = (SDoc,SDoc) - -ilxTyVar env tv - = go 0 (ilxEnvTyEnv env) - where - go n [] - = pprTrace "ilxTyVar" (pprId tv <+> text "tv_env = { " - <+> pprSepWithCommas - (\x -> pprId x <+> text ":" <+> ilxTypeR env (tyVarKind x)) - (ilxEnvTyEnv env) <+> text "}") - (char '!' <> pprId tv) - go n (x:xs) - = {- pprTrace "go" (ppr (tyVarName tv) <+> ppr (tyVarName x)) -} - (if tyVarName x== tyVarName tv then char '!' <> int n <+> ilxComment (char '!' <> pprId tv) - else go (n+1) xs) - -emptyIlxEnv :: Bool -> Module -> IlxEnv -emptyIlxEnv trace mod = IlxEnv (mod, emptyIlxTyEnv, emptyVarEnv, emptyVarEnv, (ppr mod,empty),trace) - -nextPlace place sdoc = place <> sdoc -usePlace place sdoc = place <> sdoc - -ilxEnvModule (IlxEnv (m, _, _, _, _,_)) = m -ilxEnvSetPlace (IlxEnv (m, tv_env, id_env, bind_env, (mod,exact),tr)) sdoc - = IlxEnv (m, tv_env, id_env, bind_env, (mod, sdoc),tr) -ilxEnvNextPlace (IlxEnv (m, tv_env, id_env, bind_env, (mod,exact),tr)) sdoc - = IlxEnv (m, tv_env, id_env, bind_env, (mod, nextPlace exact sdoc),tr) -ilxEnvQualifyByModule (IlxEnv (_, _, _, _,(mod,_),_)) sdoc = usePlace mod sdoc -ilxEnvQualifyByExact (IlxEnv (_, _, _, _,(mod,exact),_)) sdoc = usePlace mod sdoc <> usePlace exact sdoc - -ilxPlaceStgBindDefault env = ilxEnvNextPlace env (text "D") -ilxPlaceStgRhsClosure env bndr = ilxEnvSetPlace env (ppr bndr) -- binders are already unique -ilxPlaceStgCaseScrut env = ilxEnvNextPlace env (text "S") - -ilxPlaceAlt :: IlxEnv -> Int -> IlxEnv -ilxPlaceAlt env i = ilxEnvNextPlace env (text "a" <> int i) -ilxPlacePrimAltLit env i = ilxEnvNextPlace env (text "P" <> int i) -ilxMapPlaceArgs start f env args = [ f (ilxEnvNextPlace env (text "A" <> int i)) a | (i,a) <- [start..] `zip` args ] -ilxMapPlaceAlts f env alts = [ f (ilxPlaceAlt env i) alt | (i,alt) <- [1..] `zip` alts ] - -extendIlxEnvWithFreeTyVars (IlxEnv (mod, tv_env, id_env, bind_env, place,tr)) tyvars - = IlxEnv (mod, extendIlxTyEnvWithFreeTyVars tv_env tyvars,id_env, bind_env, place,tr) - -extendIlxEnvWithFormalTyVars (IlxEnv (mod, tv_env, id_env, bind_env, place,tr)) tyvars - = IlxEnv (mod, extendIlxTyEnvWithFormalTyVars tv_env tyvars,id_env, bind_env, place,tr) - -extendIlxEnvWithTyArgs (IlxEnv (mod, tv_env, id_env, bind_env, place,tr)) tyvars - = IlxEnv (mod, extendIlxTyEnvWithTyArgs tv_env tyvars,id_env, bind_env, place,tr) - -extendIlxEnvWithArgs :: IlxEnv -> [Var] -> IlxEnv -extendIlxEnvWithArgs (IlxEnv (mod, tv_env, id_env, bind_env, place,tr)) args - = IlxEnv (mod, extendIlxTyEnvWithTyArgs tv_env [tv | tv <- args, isIlxTyVar tv], - extendVarEnvList id_env [(v,Arg) | v <- args, not (isIlxTyVar v)], - bind_env, place,tr) - -extendIlxEnvWithFreeVars (IlxEnv (mod, tv_env, id_env, bind_env, place,tr)) args - = IlxEnv (mod, - extendIlxTyEnvWithFreeTyVars tv_env [tv | tv <- args, isIlxTyVar tv], - extendVarEnvList id_env (clovs 0 args), - bind_env, - place,tr) - where - clovs _ [] = [] - clovs n (x:xs) = if not (isIlxTyVar x) then (x,CloVar n):clovs (n+1) xs else clovs n xs - -extendIlxEnvWithBinds env@(IlxEnv (mod, tv_env, id_env, bind_env, place,tr)) bnds - = IlxEnv (mod, tv_env, id_env, - extendVarEnvList bind_env [(v,(env,rhs)) | (v,rhs) <- bnds], - place,tr) - -extendIlxEnvWithLocals (IlxEnv (m, tv_env, id_env, bind_env, p,tr)) locals - = IlxEnv (m, tv_env, - extendVarEnvList id_env [(v,Local) | (LocalId v,_) <- locals], - extendVarEnvList bind_env [(v,(env,rhs)) | (LocalId v,Just (env,rhs)) <- locals], - p,tr) -extendIlxEnvWithTops env@(IlxEnv (m, tv_env, id_env, bind_env, place,tr)) mod binds - = IlxEnv (m, tv_env, - extendVarEnvList id_env [(bndr,Top mod) | (bndr,rhs) <- binds], - extendVarEnvList bind_env [(bndr,(env, rhs)) | (bndr,rhs) <- binds], - place,tr) - -formalIlxEnv (IlxEnv (m, tv_env, id_env, bind_env, place, tr)) tyvars - = IlxEnv (m, formalIlxTyEnv tyvars, id_env, bind_env, place, tr) - -ilxEnvTyEnv :: IlxEnv -> IlxTyEnv -ilxEnvTyEnv (IlxEnv (_, tv_env, _,_,_,_)) = tv_env -elemIlxTyEnv var env = elem var (ilxEnvTyEnv env ) -elemIlxVarEnv var (IlxEnv (_, _, id_env,_,_,_)) = elemVarEnv var id_env -lookupIlxVarEnv (IlxEnv (_, _, id_env,_,_,_)) var = lookupVarEnv id_env var -lookupIlxBindEnv (IlxEnv (_, _, _, bind_env,_,_)) var = lookupVarEnv bind_env var - -\end{code} - - -\begin{code} -type IlxLabel = SDoc - -pprIlxLabel lbl = lbl - -mkJoinLabel :: Id -> IlxLabel -mkJoinLabel v = text "J_" <> ppr v - -mkAltLabel :: Id -> Int -> IlxLabel -mkAltLabel v n = text "A" <> int n <> ppr v - -ilxLabel :: IlxLabel -> SDoc -ilxLabel lbl = line $$ (pprIlxLabel lbl <> colon) -\end{code} - - -%************************************************************************ -%* * -\subsection{Local pretty helper functions} -%* * -%************************************************************************ - -\begin{code} -pprSepWithCommas :: (a -> SDoc) -> [a] -> SDoc -pprSepWithCommas pp xs = sep (punctuate comma (map pp xs)) -ilxComment pp = text "/*" <+> pp <+> text "*/" -singleQuotes pp = char '\'' <> pp <> char '\'' - -line = text "// ----------------------------------" - -hscOptionQual = text ".i_" - -nameReference env n - | isInternalName n = empty - | ilxEnvModule env == nameModule n = text "" - | isHomeModule (nameModule n) = moduleNameReference (moduleName (nameModule n)) --- HACK: no Vanilla modules should be around, but they are!! This --- gets things working for the scenario "standard library linked as one --- assembly with multiple modules + a one module program running on top of this" --- Same applies to all other mentions of Vailla modules in this file - | isVanillaModule (nameModule n) && not inPrelude = basePackageReference - | isVanillaModule (nameModule n) && inPrelude = moduleNameReference (moduleName (nameModule n)) --- end hack - | otherwise = packageReference (modulePackage (nameModule n)) - -packageReference p = brackets (singleQuotes (ppr p <> hscOptionQual)) -moduleNameReference m = brackets ((text ".module") <+> (singleQuotes (pprModuleName m <> hscOptionQual <> text "o"))) - -moduleReference env m - | ilxEnvModule env == m = text "" - | isHomeModule m = moduleNameReference (moduleName m) - -- See hack above - | isVanillaModule m && not inPrelude = basePackageReference - | isVanillaModule m && inPrelude = moduleNameReference (moduleName m) - -- end hack - | otherwise = packageReference (modulePackage m) - -basePackageReference = packageReference basePackage -inPrelude = basePackage == opt_InPackage - ------------------------------------------------- --- This code is copied from absCSyn/CString.lhs, --- and modified to do the correct thing! It's --- still a mess though. Also, still have to do the --- right thing for embedded nulls. - -pprFSInILStyle :: FastString -> SDoc -pprFSInILStyle fs = doubleQuotes (text (stringToC (unpackFS fs))) - -stringToC :: String -> String --- Convert a string to the form required by C in a C literal string --- Tthe hassle is what to do w/ strings like "ESC 0"... -stringToC "" = "" -stringToC [c] = charToC c -stringToC (c:cs) - -- if we have something "octifiable" in "c", we'd better "octify" - -- the rest of the string, too. - = if (c < ' ' || c > '~') - then (charToC c) ++ (concat (map char_to_C cs)) - else (charToC c) ++ (stringToC cs) - where - char_to_C c | c == '\n' = "\\n" -- use C escapes when we can - | c == '\a' = "\\a" - | c == '\b' = "\\b" -- ToDo: chk some of these... - | c == '\r' = "\\r" - | c == '\t' = "\\t" - | c == '\f' = "\\f" - | c == '\v' = "\\v" - | otherwise = '\\' : (trigraph (ord c)) - -charToC :: Char -> String --- Convert a character to the form reqd in a C character literal -charToC c = if (c >= ' ' && c <= '~') -- non-portable... - then case c of - '\'' -> "\\'" - '\\' -> "\\\\" - '"' -> "\\\"" - '\n' -> "\\n" - '\a' -> "\\a" - '\b' -> "\\b" - '\r' -> "\\r" - '\t' -> "\\t" - '\f' -> "\\f" - '\v' -> "\\v" - _ -> [c] - else '\\' : (trigraph (ord c)) - -trigraph :: Int -> String -trigraph n - = [chr ((n `div` 100) `rem` 10 + ord '0'), - chr ((n `div` 10) `rem` 10 + ord '0'), - chr (n `rem` 10 + ord '0')] - - -\end{code} - -%************************************************************************ -%* * -\subsection{PrimOps and Constructors} -%* * -%************************************************************************ - -\begin{code} ----------------------------- --- Allocate a fresh constructor - -ilxConApp env data_con args - | isUnboxedTupleCon data_con - = let tm_args' = filter (not. isVoidIlxRepType . stgArgType) tm_args in - case tm_args' of - [h] -> - -- Collapse the construction of an unboxed tuple type where - -- every element is zero-sized - vcat (ilxMapPlaceArgs 0 pushArg env tm_args') - _ -> - -- Minimize the construction of an unboxed tuple type, which - -- may contain zero-sized elements. Recompute all the - -- bits and pieces from the simpler case below for the new data - -- type constructor.... - let data_con' = tupleCon Unboxed (length tm_args') in - let rep_ty_args' = filter (not . isVoidIlxRepType) rep_ty_args in - - let tycon' = dataConTyCon data_con' in - let (formal_tyvars', formal_tau_ty') = splitForAllTys (dataConRepType data_con') in - let (formal_arg_tys', _) = splitFunTys formal_tau_ty' in - let formal_env' = formalIlxEnv env formal_tyvars' in - - vcat [vcat (ilxMapPlaceArgs 0 pushArg env tm_args'), - sep [text "newobj void ", - ilxTyConApp env tycon' rep_ty_args', - text "::.ctor", - pprValArgTys ilxTypeR formal_env' (map deepIlxRepType formal_arg_tys') - ] - ] - | otherwise - -- Now all other constructions - = -- Assume C :: forall a. a -> T a -> T a - -- ldloc x arg of type Int - -- ldloc y arg of type T Int - -- newdata classunion T, 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 (ilxTyConApp env tycon rep_ty_args <> comma), - nest 2 (ilxConRef env data_con) - ] - ] - where - tycon = dataConTyCon data_con - rep_ty_args = map deepIlxRepType ty_args - (ty_args,tm_args) = if isAlgTyCon tycon then splitTyArgs (tyConTyVars tycon) args else splitTyArgs1 args - --- Split some type arguments off, throwing away the higher kinded ones for the moment. --- Base the higher-kinded checks off a corresponding list of formals. -splitTyArgs :: [Var] -- Formals - -> [StgArg] -- Actuals - -> ([Type], [StgArg]) -splitTyArgs (htv:ttv) (StgTypeArg h:t) - | isIlxTyVar htv = ((h:l), r) - | otherwise = trace "splitTyArgs: threw away higher kinded type arg" (l, r) - where (l,r) = splitTyArgs ttv t -splitTyArgs _ l = ([],l) - --- Split some type arguments off, where none should be higher kinded -splitTyArgs1 :: [StgArg] -> ([Type], [StgArg]) -splitTyArgs1 (StgTypeArg ty : args) = (ty:tys, args') - where - (tys, args') = splitTyArgs1 args -splitTyArgs1 args = ([], args) - -ilxConRef env data_con - | isUnboxedTupleCon data_con - = let data_con' = tupleCon Unboxed (length non_void_args)in - pprId data_con' <> arg_text - | otherwise - = pprId data_con <> arg_text - where - arg_text = pprValArgTys ilxTypeL env' (map deepIlxRepType non_void_args) - non_void_args = filter (not . isVoidIlxRepType) arg_tys - (tyvars, tau_ty) = splitForAllTys (dataConRepType data_con) - (arg_tys, _) = splitFunTys tau_ty - env' = formalIlxEnv env tyvars - - - - -\end{code} - - -%************************************************************************ -%* * -\subsection{PrimOps and Prim Representations} * -%************************************************************************ - -\begin{code} - -ilxPrimApp env op args ret_ty = ilxPrimOpTable op args env - - -type IlxTyFrag = IlxEnv -> SDoc -ilxType s env = text s - -ilxLift ty env = text "thunk" <> angleBrackets (ty env) - -ilxTypeSeq :: [IlxTyFrag] -> IlxTyFrag -ilxTypeSeq ops env = hsep (map (\x -> x env) ops) - -tyPrimConTable :: UniqFM ([Type] -> IlxTyFrag) -tyPrimConTable = - listToUFM [(addrPrimTyConKey, (\_ -> repAddr)), --- (fileStreamPrimTyConKey, (\_ -> repFileStream)), - (foreignObjPrimTyConKey, (\_ -> repForeign)), - (stablePtrPrimTyConKey, (\[ty] -> repStablePtr {- (ilxTypeL2 ty) -})), - (stableNamePrimTyConKey, (\[ty] -> repStableName {- (ilxTypeL2 ty) -} )), - (charPrimTyConKey, (\_ -> repChar)), - (wordPrimTyConKey, (\_ -> repWord)), - (byteArrayPrimTyConKey, (\_ -> repByteArray)), - (intPrimTyConKey, (\_ -> repInt)), - (int64PrimTyConKey, (\_ -> repInt64)), - (word64PrimTyConKey, (\_ -> repWord64)), - (floatPrimTyConKey, (\_ -> repFloat)), - (doublePrimTyConKey, (\_ -> repDouble)), - -- These can all also accept unlifted parameter types so we explicitly lift. - (arrayPrimTyConKey, (\[ty] -> repArray (ilxTypeL2 ty))), - (mutableArrayPrimTyConKey, (\[_, ty] -> repMutArray (ilxTypeL2 ty))), - (weakPrimTyConKey, (\[ty] -> repWeak (ilxTypeL2 ty))), - (mVarPrimTyConKey, (\[_, ty] -> repMVar (ilxTypeL2 ty))), - (mutVarPrimTyConKey, (\[ty1, ty2] -> repMutVar (ilxTypeL2 ty1) (ilxTypeL2 ty2))), - (mutableByteArrayPrimTyConKey, (\_ -> repByteArray)), - (threadIdPrimTyConKey, (\_ -> repThread)), - (bcoPrimTyConKey, (\_ -> repBCO)) - ] - -ilxTypeL2 :: Type -> IlxTyFrag -ilxTypeL2 ty env = ilxTypeL env ty -ilxTypeR2 :: Type -> IlxTyFrag -ilxTypeR2 ty env = ilxTypeR env ty - -ilxMethTyVarA = ilxType "!!0" -ilxMethTyVarB = ilxType "!!1" -prelGHCReference :: IlxTyFrag -prelGHCReference env = - if ilxEnvModule env == mkHomeModule (mkModuleName "PrelGHC") then empty - else if inPrelude then moduleNameReference (mkModuleName "PrelGHC") - else basePackageReference - -prelBaseReference :: IlxTyFrag -prelBaseReference env = - if ilxEnvModule env == mkHomeModule (mkModuleName "PrelBase") then empty - else if inPrelude then moduleNameReference (mkModuleName "PrelBase") - else basePackageReference - -repThread = ilxType "class [mscorlib]System.Threading.Thread /* ThreadId# */ " -repByteArray = ilxType "unsigned int8[] /* ByteArr# */ " ---repFileStream = text "void * /* FileStream# */ " -- text "class [mscorlib]System.IO.FileStream" -repInt = ilxType "int32" -repWord = ilxType "unsigned int32" -repAddr =ilxType "/* Addr */ void *" -repInt64 = ilxType "int64" -repWord64 = ilxType "unsigned int64" -repFloat = ilxType "float32" -repDouble = ilxType "float64" -repChar = ilxType "/* Char */ unsigned int8" -repForeign = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_Foreignzh"] -repInteger = ilxUnboxedPairRep repInt repByteArray -repIntegerPair = ilxUnboxedQuadRep repInt repByteArray repInt repByteArray -repArray ty = ilxTypeSeq [ty,ilxType "[]"] -repMutArray ty = ilxTypeSeq [ty,ilxType "[]"] -repMVar ty = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_MVarzh",ilxTyParams [ty]] -repMutVar _ ty2 = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_MutVarzh",ilxTyParams [ty2]] -repWeak ty1 = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_Weakzh",ilxTyParams [ty1]] -repStablePtr {- ty1 -} = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_StablePtrzh" {- ,ilxTyParams [ty1] -} ] -repStableName {- ty1 -} = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_StableNamezh" {- ,ilxTyParams [ty1] -} ] -classWeak = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_Weakzh"] -repBCO = ilxTypeSeq [ilxType "class ",prelGHCReference,ilxType "PrelGHC_BCOzh"] - -ilxTyPair l r = ilxTyParams [l,r] -ilxTyTriple l m r = ilxTyParams [l,m,r] -ilxTyQuad l m1 m2 r = ilxTyParams [l,m1,m2,r] -ilxUnboxedEmptyRep = ilxTypeSeq [ilxType "value class",prelGHCReference,ilxType "PrelGHC_Z1H"] -ilxUnboxedPairRep l r = ilxTypeSeq [ilxType "value class",prelGHCReference,ilxType "PrelGHC_Z2H",ilxTyPair l r] -ilxUnboxedTripleRep l m r = ilxTypeSeq [ilxType "value class",prelGHCReference,ilxType "PrelGHC_Z3H",ilxTyTriple l m r] -ilxUnboxedQuadRep l m1 m2 r = ilxTypeSeq [ilxType "value class",prelGHCReference,ilxType "PrelGHC_Z4H",ilxTyQuad l m1 m2 r] - -ilxTyIO b = ilxTypeSeq [ilxType "(func ( /* unit skipped */ ) --> ", b, ilxType ")"] - -ilxTyParams :: [IlxTyFrag] -> IlxTyFrag -ilxTyParams [] env = empty -ilxTyParams l env = angleBrackets (ilxTyParamsAux l env) - where - ilxTyParamsAux [] env = empty - ilxTyParamsAux [h] env = h env - ilxTyParamsAux (h:t) env = h env <> text "," <+> ilxTyParamsAux t env - ilxTyParams [] env = empty - - -type IlxOpFrag = IlxEnv -> SDoc -ilxOp :: String -> IlxOpFrag -ilxOp s env = text s -ilxOpSeq :: [IlxOpFrag] -> IlxOpFrag -ilxOpSeq ops env = hsep (map (\x -> x env) ops) - -ilxParams :: [IlxOpFrag] -> IlxOpFrag -ilxParams l env = parens (ilxParamsAux l env) - where - ilxParamsAux [] env = empty - ilxParamsAux [h] env = h env - ilxParamsAux (h:t) env = h env <> text "," <+> ilxParamsAux t env - - -ilxMethodRef rty cls nm tyargs args = - ilxOpSeq [rty,cls,ilxOp "::",ilxOp nm, - ilxTyParams tyargs,ilxParams args] - -ilxCall m = ilxOpSeq [ilxOp "call", m] - -ilxSupportClass = ilxOpSeq [prelGHCReference, ilxOp "'GHC.support'"] -ilxSuppMeth rty nm tyargs args = ilxMethodRef rty ilxSupportClass nm tyargs args - -ilxCallSuppMeth rty nm tyargs args = ilxCall (ilxSuppMeth rty nm tyargs args) - -ilxMkBool :: IlxOpFrag -ilxMkBool = ilxOpSeq [ilxOp "call class",prelBaseReference, - ilxOp "PrelBase_Bool", - prelGHCReference,ilxOp "GHC.support::mkBool(bool)"] -ilxCgt = ilxOpSeq [ilxOp "cgt",ilxMkBool] -ilxCge = ilxOpSeq [ilxOp "clt ldc.i4 0 ceq ",ilxMkBool] -ilxClt = ilxOpSeq [ilxOp "clt ",ilxMkBool] -ilxCle = ilxOpSeq [ilxOp "cgt ldc.i4 0 ceq ",ilxMkBool] -ilxCeq = ilxOpSeq [ilxOp "ceq ",ilxMkBool] -ilxCne = ilxOpSeq [ilxOp "ceq ldc.i4 0 ceq " ,ilxMkBool] -ilxCgtUn = ilxOpSeq [ilxOp "cgt.un ",ilxMkBool] -ilxCgeUn = ilxOpSeq [ilxOp "clt.un ldc.i4 0 ceq ",ilxMkBool] -ilxCltUn = ilxOpSeq [ilxOp "clt.un ",ilxMkBool] -ilxCleUn = ilxOpSeq [ilxOp "cgt.un ldc.i4 0 ceq ",ilxMkBool] - -ilxAddrOfForeignOp = ilxOpSeq [ilxOp "ldfld void *" , repForeign, ilxOp "::contents"] -ilxAddrOfByteArrOp = ilxOp "ldc.i4 0 ldelema unsigned int8" - -ilxPrimOpTable :: PrimOp -> [StgArg] -> IlxOpFrag -ilxPrimOpTable op - = case op of - CharGtOp -> simp_op ilxCgt - CharGeOp -> simp_op ilxCge - CharEqOp -> simp_op ilxCeq - CharNeOp -> simp_op ilxCne - CharLtOp -> simp_op ilxClt - CharLeOp -> simp_op ilxCle - - OrdOp -> simp_op (ilxOp "conv.i4") -- chars represented by UInt32 (u4) - ChrOp -> simp_op (ilxOp "conv.u4") - - IntGtOp -> simp_op ilxCgt - IntGeOp -> simp_op ilxCge - IntEqOp -> simp_op ilxCeq - IntNeOp -> simp_op ilxCne - IntLtOp -> simp_op ilxClt - IntLeOp -> simp_op ilxCle - - Narrow8IntOp -> simp_op (ilxOp"conv.i1") - Narrow16IntOp -> simp_op (ilxOp "conv.i2") - Narrow32IntOp -> simp_op (ilxOp "conv.i4") - Narrow8WordOp -> simp_op (ilxOp "conv.u1") - Narrow16WordOp -> simp_op (ilxOp "conv.u2") - Narrow32WordOp -> simp_op (ilxOp "conv.u4") - - WordGtOp -> simp_op ilxCgtUn - WordGeOp -> simp_op ilxCgeUn - WordEqOp -> simp_op ilxCeq - WordNeOp -> simp_op ilxCne - WordLtOp -> simp_op ilxCltUn - WordLeOp -> simp_op ilxCleUn - - AddrGtOp -> simp_op ilxCgt - AddrGeOp -> simp_op ilxCge - AddrEqOp -> simp_op ilxCeq - AddrNeOp -> simp_op ilxCne - AddrLtOp -> simp_op ilxClt - AddrLeOp -> simp_op ilxCle - - FloatGtOp -> simp_op ilxCgt - FloatGeOp -> simp_op ilxCge - FloatEqOp -> simp_op ilxCeq - FloatNeOp -> simp_op ilxCne - FloatLtOp -> simp_op ilxClt - FloatLeOp -> simp_op ilxCle - - DoubleGtOp -> simp_op ilxCgt - DoubleGeOp -> simp_op ilxCge - DoubleEqOp -> simp_op ilxCeq - DoubleNeOp -> simp_op ilxCne - DoubleLtOp -> simp_op ilxClt - DoubleLeOp -> simp_op ilxCle - - -- Int#-related ops: - IntAddOp -> simp_op (ilxOp "add") - IntSubOp -> simp_op (ilxOp "sub") - IntMulOp -> simp_op (ilxOp "mul") - IntQuotOp -> simp_op (ilxOp "div") - IntNegOp -> simp_op (ilxOp "neg") - IntRemOp -> simp_op (ilxOp "rem") - - -- Addr# ops: - AddrAddOp -> simp_op (ilxOp "add") - AddrSubOp -> simp_op (ilxOp "sub") - AddrRemOp -> simp_op (ilxOp "rem") - Int2AddrOp -> warn_op "int2Addr" (simp_op (ilxOp "/* PrimOp int2Addr */ ")) - Addr2IntOp -> warn_op "addr2Int" (simp_op (ilxOp "/* PrimOp addr2Int */ ")) - - -- Word#-related ops: - WordAddOp -> simp_op (ilxOp "add") - WordSubOp -> simp_op (ilxOp "sub") - WordMulOp -> simp_op (ilxOp "mul") - WordQuotOp -> simp_op (ilxOp "div") - WordRemOp -> simp_op (ilxOp "rem") - - ISllOp -> simp_op (ilxOp "shl") - ISraOp -> simp_op (ilxOp "shr") - ISrlOp -> simp_op (ilxOp "shr.un") - IntAddCOp -> simp_op (ilxCallSuppMeth (ilxUnboxedPairRep repInt repInt) "IntAddCOp" [] [repInt, repInt]) - IntSubCOp -> simp_op (ilxCallSuppMeth (ilxUnboxedPairRep repInt repInt) "IntSubCOp" [] [repInt, repInt]) - IntGcdOp -> simp_op (ilxCallSuppMeth repInt "IntGcdOp" [] [repInt, repInt]) - - - -- Word#-related ops: - AndOp -> simp_op (ilxOp "and") - OrOp -> simp_op (ilxOp "or") - NotOp -> simp_op (ilxOp "not") - XorOp -> simp_op (ilxOp "xor") - SllOp -> simp_op (ilxOp "shl") - SrlOp -> simp_op (ilxOp "shr") - Word2IntOp -> simp_op (ilxOp "conv.i4") - Int2WordOp -> simp_op (ilxOp "conv.u4") - - -- Float#-related ops: - FloatAddOp -> simp_op (ilxOp "add") - FloatSubOp -> simp_op (ilxOp "sub") - FloatMulOp -> simp_op (ilxOp "mul") - FloatDivOp -> simp_op (ilxOp "div") - FloatNegOp -> simp_op (ilxOp "neg") - Float2IntOp -> simp_op (ilxOp "conv.i4") - Int2FloatOp -> simp_op (ilxOp "conv.r4") - - DoubleAddOp -> simp_op (ilxOp "add") - DoubleSubOp -> simp_op (ilxOp "sub") - DoubleMulOp -> simp_op (ilxOp "mul") - DoubleDivOp -> simp_op (ilxOp "div") - DoubleNegOp -> simp_op (ilxOp "neg") - Double2IntOp -> simp_op (ilxOp "conv.i4") - Int2DoubleOp -> simp_op (ilxOp "conv.r4") - Double2FloatOp -> simp_op (ilxOp "conv.r4") - Float2DoubleOp -> simp_op (ilxOp "conv.r8") - DoubleDecodeOp -> simp_op (ilxCallSuppMeth (ilxUnboxedTripleRep repInt repInt repByteArray) "decodeDouble" [] [ilxType "float64"]) - FloatDecodeOp -> simp_op (ilxCallSuppMeth (ilxUnboxedTripleRep repInt repInt repByteArray) "decodeFloat" [] [ilxType "float32"]) - - FloatExpOp -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Exp(float64) conv.r4") - FloatLogOp -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Log(float64) conv.r4") - FloatSqrtOp -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Sqrt(float64) conv.r4") - FloatSinOp -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Sin(float64) conv.r4") - FloatCosOp -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Cos(float64) conv.r4") - FloatTanOp -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Tan(float64) conv.r4") - FloatAsinOp -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Asin(float64) conv.r4") - FloatAcosOp -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Acos(float64) conv.r4") - FloatAtanOp -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Atan(float64) conv.r4") - FloatSinhOp -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Sinh(float64) conv.r4") - FloatCoshOp -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Cosh(float64) conv.r4") - FloatTanhOp -> simp_op (ilxOp "conv.r8 call float64 [mscorlib]System.Math::Tanh(float64) conv.r4") - FloatPowerOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Pow(float64, float64) conv.r4") -- ** op, make use of implicit cast to r8... - - DoubleExpOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Exp(float64)") - DoubleLogOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Log(float64)") - DoubleSqrtOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Sqrt(float64)") - - DoubleSinOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Sin(float64)") - DoubleCosOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Cos(float64)") - DoubleTanOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Tan(float64)") - - DoubleAsinOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Asin(float64)") - DoubleAcosOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Acos(float64)") - DoubleAtanOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Atan(float64)") - - DoubleSinhOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Sinh(float64)") - DoubleCoshOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Cosh(float64)") - DoubleTanhOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Tanh(float64)") - - DoublePowerOp -> simp_op (ilxOp "call float64 [mscorlib]System.Math::Pow(float64, float64)") - - -- Integer (and related...) ops: bail out to support routines - IntegerAndOp -> simp_op (ilxCallSuppMeth repInteger "IntegerAndOp" [] [repInt, repByteArray, repInt, repByteArray]) - IntegerOrOp -> simp_op (ilxCallSuppMeth repInteger "IntegerOrOp" [] [repInt, repByteArray, repInt, repByteArray]) - IntegerXorOp -> simp_op (ilxCallSuppMeth repInteger "IntegerXorOp" [] [repInt, repByteArray, repInt, repByteArray]) - IntegerComplementOp -> simp_op (ilxCallSuppMeth repInteger "IntegerComplementOp" [] [repInt, repByteArray]) - IntegerAddOp -> simp_op (ilxCallSuppMeth repInteger "IntegerAddOp" [] [repInt, repByteArray, repInt, repByteArray]) - IntegerSubOp -> simp_op (ilxCallSuppMeth repInteger "IntegerSubOp" [] [repInt, repByteArray, repInt, repByteArray]) - IntegerMulOp -> simp_op (ilxCallSuppMeth repInteger "IntegerMulOp" [] [repInt, repByteArray, repInt, repByteArray]) - IntegerGcdOp -> simp_op (ilxCallSuppMeth repInteger "IntegerGcdOp" [] [repInt, repByteArray, repInt, repByteArray]) - IntegerQuotRemOp -> simp_op (ilxCallSuppMeth repIntegerPair "IntegerQuotRemOp" [] [repInt, repByteArray, repInt, repByteArray]) - IntegerDivModOp -> simp_op (ilxCallSuppMeth repIntegerPair "IntegerDivModOp" [] [repInt, repByteArray, repInt, repByteArray]) - IntegerIntGcdOp -> simp_op (ilxCallSuppMeth repInt "IntegerIntGcdOp" [] [repInt, repByteArray, repInt]) - IntegerDivExactOp -> simp_op (ilxCallSuppMeth repInteger "IntegerDivExactOp" [] [repInt, repByteArray, repInt, repByteArray]) - IntegerQuotOp -> simp_op (ilxCallSuppMeth repInteger "IntegerQuotOp" [] [repInt, repByteArray, repInt, repByteArray]) - IntegerRemOp -> simp_op (ilxCallSuppMeth repInteger "IntegerRemOp" [] [repInt, repByteArray, repInt, repByteArray]) - IntegerCmpOp -> simp_op (ilxCallSuppMeth repInt "IntegerCmpOp" [] [repInt, repByteArray, repInt, repByteArray]) - IntegerCmpIntOp -> simp_op (ilxCallSuppMeth repInt "IntegerCmpIntOp" [] [repInt, repByteArray, repInt]) - Integer2IntOp -> simp_op (ilxCallSuppMeth repInt "Integer2IntOp" [] [repInt, repByteArray]) - Integer2WordOp -> simp_op (ilxCallSuppMeth repWord "Integer2WordOp" [] [repInt, repByteArray]) - Int2IntegerOp -> simp_op (ilxCallSuppMeth repInteger "Int2IntegerOp" [] [repInt]) - Word2IntegerOp -> simp_op (ilxCallSuppMeth repInteger "Word2IntegerOp" [] [repWord]) --- IntegerToInt64Op -> simp_op (ilxCallSuppMeth repInt64 "IntegerToInt64Op" [] [repInt,repByteArray]) - Int64ToIntegerOp -> simp_op (ilxCallSuppMeth repInteger "Int64ToIntegerOp" [] [repInt64]) --- IntegerToWord64Op -> simp_op (ilxCallSuppMeth repWord64 "IntegerToWord64Op" [] [repInt,repByteArray]) - Word64ToIntegerOp -> simp_op (ilxCallSuppMeth repInteger "Word64ToIntegerOp" [] [repWord64]) - - - - IndexByteArrayOp_Char -> simp_op (ilxOp "ldelem.u1") - IndexByteArrayOp_WideChar -> simp_op (ilxOp "ldelem.u4") - IndexByteArrayOp_Int -> simp_op (ilxOp "ldelem.i4") - IndexByteArrayOp_Word -> simp_op (ilxOp "ldelem.u4") - IndexByteArrayOp_Addr -> simp_op (ilxOp "ldelem.u") - IndexByteArrayOp_Float -> simp_op (ilxOp "ldelem.r4") - IndexByteArrayOp_Double -> simp_op (ilxOp "ldelem.r8") - IndexByteArrayOp_StablePtr -> simp_op (ilxOp "ldelem.ref") - IndexByteArrayOp_Int8 -> simp_op (ilxOp "ldelem.i1") - IndexByteArrayOp_Int16 -> simp_op (ilxOp "ldelem.i2") - IndexByteArrayOp_Int32 -> simp_op (ilxOp "ldelem.i4") - IndexByteArrayOp_Int64 -> simp_op (ilxOp "ldelem.i8") - IndexByteArrayOp_Word8 -> simp_op (ilxOp "ldelem.u1") - IndexByteArrayOp_Word16 -> simp_op (ilxOp "ldelem.u2") - IndexByteArrayOp_Word32 -> simp_op (ilxOp "ldelem.u4") - IndexByteArrayOp_Word64 -> simp_op (ilxOp "ldelem.u8") - - {- should be monadic??? -} - ReadByteArrayOp_Char -> simp_op (ilxOp "ldelem.u1") - ReadByteArrayOp_WideChar -> simp_op (ilxOp "ldelem.u4") - ReadByteArrayOp_Int -> simp_op (ilxOp "ldelem.i4") - ReadByteArrayOp_Word -> simp_op (ilxOp "ldelem.u4") - ReadByteArrayOp_Addr -> simp_op (ilxOp "ldelem.u") - ReadByteArrayOp_Float -> simp_op (ilxOp "ldelem.r4") - ReadByteArrayOp_Double -> simp_op (ilxOp "ldelem.r8") - ReadByteArrayOp_StablePtr -> simp_op (ilxOp "ldelem.ref") - ReadByteArrayOp_Int8 -> simp_op (ilxOp "ldelem.i1") - ReadByteArrayOp_Int16 -> simp_op (ilxOp "ldelem.i2") - ReadByteArrayOp_Int32 -> simp_op (ilxOp "ldelem.i4") - ReadByteArrayOp_Int64 -> simp_op (ilxOp "ldelem.i8") - ReadByteArrayOp_Word8 -> simp_op (ilxOp "ldelem.u1") - ReadByteArrayOp_Word16 -> simp_op (ilxOp "ldelem.u2") - ReadByteArrayOp_Word32 -> simp_op (ilxOp "ldelem.u4") - ReadByteArrayOp_Word64 -> simp_op (ilxOp "ldelem.u8") - {- MutByteArr# s -> Int# -> State# s -> (# State# s, Char# #) -} - {- ByteArr# -> Int# -> Char# -} - - - WriteByteArrayOp_Char -> simp_op (ilxOp "stelem.u1") - WriteByteArrayOp_WideChar -> simp_op (ilxOp "stelem.u4") - WriteByteArrayOp_Int -> simp_op (ilxOp "stelem.i4") - WriteByteArrayOp_Word -> simp_op (ilxOp "stelem.u4") - WriteByteArrayOp_Addr -> simp_op (ilxOp "stelem.u") - WriteByteArrayOp_Float -> simp_op (ilxOp "stelem.r4") - WriteByteArrayOp_Double -> simp_op (ilxOp "stelem.r8") - WriteByteArrayOp_StablePtr -> simp_op (ilxOp "stelem.ref") - WriteByteArrayOp_Int8 -> simp_op (ilxOp "stelem.i1") - WriteByteArrayOp_Int16 -> simp_op (ilxOp "stelem.i2") - WriteByteArrayOp_Int32 -> simp_op (ilxOp "stelem.i4") - WriteByteArrayOp_Int64 -> simp_op (ilxOp "stelem.i8") - WriteByteArrayOp_Word8 -> simp_op (ilxOp "stelem.u1") - WriteByteArrayOp_Word16 -> simp_op (ilxOp "stelem.u2") - WriteByteArrayOp_Word32 -> simp_op (ilxOp "stelem.u4") - WriteByteArrayOp_Word64 -> simp_op (ilxOp "stelem.i8 /* nb. no stelem.u8 */") - {- MutByteArr# s -> Int# -> Char# -> State# s -> State# s -} - - IndexOffAddrOp_Char -> simp_op (ilxOp "sizeof unsigned int8 mul add ldind.u1") - IndexOffAddrOp_WideChar -> simp_op (ilxOp "sizeof int32 mul add ldind.u4") - IndexOffAddrOp_Int -> simp_op (ilxOp "sizeof int32 mul add ldind.i4") - IndexOffAddrOp_Word -> simp_op (ilxOp "sizeof int32 mul add ldind.u4") - IndexOffAddrOp_Addr -> simp_op (ilxOp "sizeof native unsigned int mul add ldind.i") - IndexOffAddrOp_StablePtr -> simp_op (ilxOp "sizeof native unsigned int mul add ldind.ref") - IndexOffAddrOp_Float -> simp_op (ilxOp "sizeof float32 mul add ldind.r4") - IndexOffAddrOp_Double -> simp_op (ilxOp "sizeof float64 mul add ldind.r8") - IndexOffAddrOp_Int8 -> simp_op (ilxOp "sizeof int8 mul add ldind.i1") - IndexOffAddrOp_Int16 -> simp_op (ilxOp "sizeof int16 mul add ldind.i2") - IndexOffAddrOp_Int32 -> simp_op (ilxOp "sizeof int32 mul add ldind.i4") - IndexOffAddrOp_Int64 -> simp_op (ilxOp "sizeof int64 mul add ldind.i8") - IndexOffAddrOp_Word8 -> simp_op (ilxOp "sizeof unsigned int8 mul add ldind.u1") - IndexOffAddrOp_Word16 -> simp_op (ilxOp "sizeof unsigned int16 mul add ldind.u2") - IndexOffAddrOp_Word32 -> simp_op (ilxOp "sizeof unsigned int32 mul add ldind.u4") - IndexOffAddrOp_Word64 -> simp_op (ilxOp "sizeof int64 mul add ldind.u8") - - -- ForeignObj: load the address inside the object first - -- TODO: is this remotely right? - EqForeignObj -> warn_op "eqForeignObj" (simp_op (ilxOp "pop /* PrimOp eqForeignObj */ ")) - IndexOffForeignObjOp_Char -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof unsigned int8 mul add ldind.u1"]) - IndexOffForeignObjOp_WideChar -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof int32 mul add ldind.u4"]) - IndexOffForeignObjOp_Int -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof int32 mul add ldind.i4"]) - IndexOffForeignObjOp_Word -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof unsigned int32 mul add ldind.u4"]) - IndexOffForeignObjOp_Addr -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof native unsigned int mul add ldind.i "]) - IndexOffForeignObjOp_StablePtr -> ty1_arg2_op (\ty fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof native unsigned int mul add ldind.ref "]) - IndexOffForeignObjOp_Float -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof float32 mul add ldind.r4"]) - IndexOffForeignObjOp_Double -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof float64 mul add ldind.r8"]) - IndexOffForeignObjOp_Int8 -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof int8 mul add ldind.i1"]) - IndexOffForeignObjOp_Int16 -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof int16 mul add ldind.i2"]) - IndexOffForeignObjOp_Int32 -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof int32 mul add ldind.i4"]) - IndexOffForeignObjOp_Int64 -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof int64 mul add ldind.i8"]) - IndexOffForeignObjOp_Word8 -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof unsigned int8 mul add ldind.u1"]) - IndexOffForeignObjOp_Word16 -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof unsigned int16 mul add ldind.u2"]) - IndexOffForeignObjOp_Word32 -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof unsigned int32 mul add ldind.u4"]) - IndexOffForeignObjOp_Word64 -> arg2_op (\fobj n -> ilxOpSeq [fobj, ilxAddrOfForeignOp, n, ilxOp "sizeof unsigned int64 mul add ldind.u8"]) - - ReadOffAddrOp_Char -> simp_op (ilxOp "sizeof unsigned int8 mul add ldind.u1") - ReadOffAddrOp_WideChar -> simp_op (ilxOp "sizeof int32 mul add ldind.u4") - ReadOffAddrOp_Int -> simp_op (ilxOp "sizeof int32 mul add ldind.i4") - ReadOffAddrOp_Word -> simp_op (ilxOp "sizeof unsigned int32 mul add ldind.u4") - ReadOffAddrOp_Addr -> simp_op (ilxOp "sizeof native unsigned int mul add ldind.i") - ReadOffAddrOp_Float -> simp_op (ilxOp "sizeof float32 mul add ldind.r4") - ReadOffAddrOp_Double -> simp_op (ilxOp "sizeof float64 mul add ldind.r8") - ReadOffAddrOp_StablePtr -> simp_op (ilxOp "sizeof native unsigned int mul add ldind.ref") - ReadOffAddrOp_Int8 -> simp_op (ilxOp "sizeof int8 mul add ldind.i1") - ReadOffAddrOp_Int16 -> simp_op (ilxOp "sizeof int16 mul add ldind.i2") - ReadOffAddrOp_Int32 -> simp_op (ilxOp "sizeof int32 mul add ldind.i4") - ReadOffAddrOp_Int64 -> simp_op (ilxOp "sizeof int64 mul add ldind.i8") - ReadOffAddrOp_Word8 -> simp_op (ilxOp "sizeof unsigned int8 mul add ldind.u1") - ReadOffAddrOp_Word16 -> simp_op (ilxOp "sizeof unsigned int16 mul add ldind.u2") - ReadOffAddrOp_Word32 -> simp_op (ilxOp "sizeof unsigned int32 mul add ldind.u4") - ReadOffAddrOp_Word64 -> simp_op (ilxOp "sizeof unsigned int64 mul add ldind.u8") - {- Addr# -> Int# -> Char# -> State# s -> State# s -} - - WriteOffAddrOp_Char -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr, n, ilxOp "add", v, ilxOp "stind.u1"]) - WriteOffAddrOp_WideChar -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr, n, ilxOp "sizeof int32 mul add", v, ilxOp "stind.u4"]) - WriteOffAddrOp_Int -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr, n, ilxOp "sizeof int32 mul add", v, ilxOp "stind.i4"]) - WriteOffAddrOp_Word -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr, n, ilxOp "sizeof int32 mul add", v, ilxOp "stind.u4"]) - WriteOffAddrOp_Addr -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr, n, ilxOp "sizeof native unsigned int mul add", v, ilxOp "stind.i"]) - WriteOffAddrOp_ForeignObj -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr, n, ilxOp "sizeof native unsigned int mul add", v, ilxOp "stind.ref"]) - WriteOffAddrOp_Float -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr, n, ilxOp "sizeof float32 mul add", v,ilxOp "stind.r4"]) - WriteOffAddrOp_StablePtr -> ty2_arg4_op (\ty1 sty addr n v s -> ilxOpSeq [addr, n, ilxOp "sizeof native unsigned int mul add", v, ilxOp "stind.ref"]) - WriteOffAddrOp_Double -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof float64 mul add",v,ilxOp "stind.r8"]) - WriteOffAddrOp_Int8 -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof int8 mul add",v,ilxOp "stind.i1"]) - WriteOffAddrOp_Int16 -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof int16 mul add",v,ilxOp "stind.i2"]) - WriteOffAddrOp_Int32 -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof int32 mul add",v,ilxOp "stind.i4"]) - WriteOffAddrOp_Int64 -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof int64 mul add",v,ilxOp "stind.i8"]) - WriteOffAddrOp_Word8 -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof unsigned int8 mul add",v,ilxOp "stind.u1"]) - WriteOffAddrOp_Word16 -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof unsigned int16 mul add",v,ilxOp "stind.u2"]) - WriteOffAddrOp_Word32 -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof unsigned int32 mul add",v,ilxOp "stind.u4"]) - WriteOffAddrOp_Word64 -> ty1_arg4_op (\sty addr n v s -> ilxOpSeq [addr,n,ilxOp "sizeof unsigned int64 mul add",v,ilxOp "stind.u8"]) - {- Addr# -> Int# -> Char# -> State# s -> State# s -} - - {- should be monadic??? -} - NewPinnedByteArrayOp_Char -> warn_op "newPinnedByteArray" (simp_op (ilxOp "newarr [mscorlib]System.Byte ")) - NewByteArrayOp_Char -> simp_op (ilxOp "newarr [mscorlib]System.Byte") --- NewByteArrayOp_Int -> simp_op (ilxOp "newarr [mscorlib]System.Int32") --- NewByteArrayOp_Word -> simp_op (ilxOp "newarr [mscorlib]System.UInt32") --- NewByteArrayOp_Addr -> simp_op (ilxOp "newarr [mscorlib]System.UInt64") --- NewByteArrayOp_Float -> simp_op (ilxOp "newarr [mscorlib]System.Single") --- NewByteArrayOp_Double -> simp_op (ilxOp "newarr [mscorlib]System.Double") --- NewByteArrayOp_StablePtr -> simp_op (ilxOp "newarr [mscorlib]System.UInt32") --- NewByteArrayOp_Int64 -> simp_op (ilxOp "newarr [mscorlib]System.Int64") TODO: there is no unique for this one -} --- NewByteArrayOp_Word64 -> simp_op (ilxOp "newarr [mscorlib]System.UInt64") -} - {- Int# -> State# s -> (# State# s, MutByteArr# s #) -} - ByteArrayContents_Char -> warn_op "byteArrayContents" (simp_op ilxAddrOfByteArrOp) - - UnsafeFreezeByteArrayOp -> ty1_op (\ty1 -> ilxOp "nop ") - {- MutByteArr# s -> State# s -> (# State# s, ByteArr# #) -} - SizeofByteArrayOp -> simp_op (ilxOp "ldlen") - {- ByteArr# -> Int# -} - - SameMutableByteArrayOp -> ty1_op (\ty1 -> ilxCeq) - {- MutByteArr# s -> MutByteArr# s -> Bool -} - SizeofMutableByteArrayOp -> ty1_op (\ty1 -> ilxOp "ldlen") - {- MutByteArr# s -> Int# -} - - SameMutVarOp -> ty2_op (\ty1 ty2 -> ilxCeq) - {- MutVar# s a -> MutVar# s a -> Bool -} - NewMutVarOp -> ty2_op (\ty1 ty2 -> ilxOpSeq [ilxOp "newobj void" , repMutVar ty1 ty2 , ilxOp "::.ctor(!0)"]) - {- a -> State# s -> (# State# s, MutVar# s a #) -} - ReadMutVarOp -> ty2_op (\ty1 ty2 -> ilxOpSeq [ilxOp "ldfld !0" , repMutVar ty1 ty2 , ilxOp "::contents"]) - {- MutVar# s a -> State# s -> (# State# s, a #) -} - WriteMutVarOp -> ty2_op (\ty1 ty2 -> ilxOpSeq [ilxOp "stfld !0" , repMutVar ty1 ty2 , ilxOp "::contents"]) - {- MutVar# s a -> a -> State# s -> State# s -} - - NewArrayOp -> ty2_op (\ty1 ty2 -> ilxCallSuppMeth (ilxType "!!0[]") "newArray" [ty1] [repInt,ilxMethTyVarA]) - {- Int# -> a -> State# s -> (# State# s, MutArr# s a #) -} - IndexArrayOp -> ty1_op (\ty1 -> ilxOp "ldelem.ref") - {- Array# a -> Int# -> (# a #) -} - WriteArrayOp -> ty2_op (\ty1 ty2 -> ilxOp "stelem.ref") - {- MutArr# s a -> Int# -> a -> State# s -> State# s -} - ReadArrayOp -> ty2_op (\ty1 ty2 -> ilxOp "ldelem.ref") - {- MutArr# s a -> Int# -> State# s -> (# State# s, a #) -} - UnsafeFreezeArrayOp -> ty2_op (\ty1 ty2 -> ilxOp "nop") - {- MutArr# s a -> State# s -> (# State# s, Array# a #) -} - UnsafeThawArrayOp -> ty2_op (\ty1 ty2 -> ilxOp "nop") - {- Array# a -> State# s -> (# State# s, MutArr# s a #) -} - - SameMutableArrayOp -> ty2_op (\ty1 ty2 -> ilxCeq) - {- MutArr# s a -> MutArr# s a -> Bool -} - - - RaiseOp -> ty2_op (\ty1 ty2 -> ilxOp "throw") - CatchOp -> ty2_op (\ty1 ty2 -> - ilxCallSuppMeth ilxMethTyVarA "'catch'" [ty1,ty2] [ilxLift (ilxTyIO (ilxType "!!0")), - ilxOp "thunk<(func (!!1) --> (func ( /* unit skipped */ ) --> !!0))>"]) - {- (State# RealWorld -> (# State# RealWorld, a #) ) - -> (b -> State# RealWorld -> (# State# RealWorld, a #) ) - -> State# RealWorld - -> (# State# RealWorld, a #) - -} - - BlockAsyncExceptionsOp -> ty1_op (\ty1 -> - ilxCallSuppMeth ilxMethTyVarA "blockAsyncExceptions" [ty1] [ilxLift (ilxTyIO (ilxType "!!0"))]) - - {- (State# RealWorld -> (# State# RealWorld, a #)) - -> (State# RealWorld -> (# State# RealWorld, a #)) - -} - - UnblockAsyncExceptionsOp -> ty1_op (\ty1 -> - ilxCallSuppMeth ilxMethTyVarA "unblockAsyncExceptions" [ty1] [ilxLift (ilxTyIO (ilxType "!!0"))]) - - {- - State# RealWorld -> (# State# RealWorld, a #)) - -> (State# RealWorld -> (# State# RealWorld, a #)) - -} - - NewMVarOp -> ty2_op (\sty ty -> - ilxOpSeq [ilxOp "newobj void " , repMVar ty , ilxOp "::.ctor()"]) - {- State# s -> (# State# s, MVar# s a #) -} - - TakeMVarOp -> ty2_op (\sty ty -> - ilxCallSuppMeth ilxMethTyVarA "takeMVar" [ty] [repMVar ilxMethTyVarA]) - {- MVar# s a -> State# s -> (# State# s, a #) -} - - -- These aren't yet right - TryTakeMVarOp -> ty2_op (\sty ty -> - ilxCallSuppMeth (ilxUnboxedPairRep repInt ilxMethTyVarA) "tryTakeMVar" [ty] [repMVar ilxMethTyVarA]) - {- MVar# s a -> State# s -> (# State# s, a #) -} - - TryPutMVarOp -> ty2_op (\sty ty -> - ilxCallSuppMeth repInt "tryPutMVar" [ty] [repMVar ilxMethTyVarA,ilxMethTyVarA]) - {- MVar# s a -> State# s -> (# State# s, a #) -} - - PutMVarOp -> ty2_op (\sty ty -> - ilxCallSuppMeth (ilxOp "void") "putMVar" [ty] [repMVar ilxMethTyVarA, ilxMethTyVarA]) - {- MVar# s a -> a -> State# s -> State# s -} - - SameMVarOp -> ty2_op (\sty ty -> ilxCeq) - {- MVar# s a -> MVar# s a -> Bool -} - --- TakeMaybeMVarOp -> ty2_op (\sty ty -> --- (ilxCallSuppMeth (ilxUnboxedPairRep repInt ilxMethTyVarA) "tryTakeMVar" [ty] [repMVar ilxMethTyVarA])) --- {- MVar# s a -> State# s -> (# State# s, Int#, a #) -} - - IsEmptyMVarOp -> ty2_op (\sty ty -> - ilxCallSuppMeth repInt "isEmptyMVar" [ty] [repMVar ilxMethTyVarA]) - {- MVar# s a -> State# s -> (# State# s, Int# #) -} - - TouchOp -> warn_op "touch" (ty1_op (\ty1 -> ilxOp "pop /* PrimOp touch */ ")) - - {- a -> Int# -} - DataToTagOp -> ty1_op (\ty1 -> - ilxCallSuppMeth repInt "dataToTag" [ty1] [ilxMethTyVarA]) - {- a -> Int# -} - - TagToEnumOp -> ty1_op (\ty1 -> - ilxCallSuppMeth ilxMethTyVarA "tagToEnum" [ty1] [repInt]) - {- Int# -> a -} - - MakeStablePtrOp -> ty1_op (\ty1 -> ilxOpSeq [ilxOp "box", ty1, ilxOp "newobj void", repStablePtr {- ty1 -}, ilxOp "::.ctor(class [mscorlib]System.Object)"]) - {- a -> State# RealWorld -> (# State# RealWorld, StablePtr# a #) -} - MakeStableNameOp -> ty1_op (\ty1 -> ilxOpSeq [ilxOp "pop newobj void", repStableName {- ty1 -}, ilxOp "::.ctor()"]) - -- primOpInfo MakeStableNameOp = mkGenPrimOp (sLit "makeStableName#") [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed 2 [mkStatePrimTy realWorldTy, mkStableNamePrimTy alphaTy])) - - EqStableNameOp -> ty1_op (\ty1 -> ilxOp "ceq") - -- [alphaTyVar] [mkStableNamePrimTy alphaTy, mkStableNamePrimTy alphaTy] (intPrimTy) - StableNameToIntOp -> warn_op "StableNameToIntOp" (ty1_op (\ty1 -> ilxOp "pop ldc.i4 0")) - -- [alphaTyVar] [mkStableNamePrimTy alphaTy] (intPrimTy) - - DeRefStablePtrOp -> ty1_op (\ty1 -> ilxOpSeq [ilxOp "ldfld class [mscorlib]System.Object", repStablePtr {- ty1 -}, ilxOp "::contents"]) - {- StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #) -} - - EqStablePtrOp -> ty1_op (\ty1 -> ilxOp "ceq") - {- StablePtr# a -> StablePtr# a -> Int# -} - - -- The 3rd argument to MkWeakOp is always a IO Monad action, i.e. passed as () --> () - MkWeakOp -> ty3_op (\ty1 ty2 ty3 -> ilxCall (ilxMethodRef (repWeak ilxMethTyVarB) classWeak "bake" [ilxLift ty1,ilxLift ty2] [ilxMethTyVarA, ilxMethTyVarB, ilxLift (ilxTyIO ilxUnboxedEmptyRep)])) - {- o -> b -> c -> State# RealWorld -> (# State# RealWorld, Weak# b #) -} - - DeRefWeakOp -> ty1_op (\ty1 -> ilxCall (ilxMethodRef (ilxUnboxedPairRep repInt ilxMethTyVarA) classWeak "deref" [ty1] [repWeak ilxMethTyVarA])) - FinalizeWeakOp -> ty1_op (\ty1 -> ilxCall (ilxMethodRef (ilxUnboxedPairRep repInt (ilxTyIO ilxUnboxedEmptyRep)) classWeak "finalizer" [ty1] [repWeak ilxMethTyVarA])) - {- Weak# a -> State# RealWorld -> (# State# RealWorld, Int#, - State# RealWorld -> (# State# RealWorld, Unit #)) #) -} - - MkForeignObjOp -> simp_op (ilxOpSeq [ilxOp "newobj void", repForeign, ilxOp "::.ctor(void *)"]) - WriteForeignObjOp -> ty1_op (\sty -> ilxOpSeq [ilxOp "stfld void *", repForeign, ilxOp "::contents"]) - ForeignObjToAddrOp -> simp_op ilxAddrOfForeignOp - YieldOp -> simp_op (ilxOpSeq [ilxOp "call class [mscorlib]System.Threading.Thread class [mscorlib]System.Threading.Thread::get_CurrentThread() - call instance void class [mscorlib]System.Threading.Thread::Suspend()"]) - MyThreadIdOp -> simp_op (ilxOpSeq [ilxOp "call default class [mscorlib]System.Threading.Thread class [mscorlib]System.Threading.Thread::get_CurrentThread() "]) - -- This pushes a THUNK across as the exception value. - -- This is the correct Haskell semantics... TODO: we should probably - -- push across an HaskellThreadAbortException object that wraps this - -- thunk, but which is still actually an exception of - -- an appropriate type. - KillThreadOp -> ty1_op (\ty -> ilxOpSeq [ilxOp "call instance void class [mscorlib]System.Threading.Thread::Abort(class [mscorlib]System.Object) "]) - {- ThreadId# -> a -> State# RealWorld -> State# RealWorld -} - - ForkOp -> warn_op "ForkOp" (simp_op (ilxOp "/* ForkOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw")) - ParOp -> warn_op "ParOp" (simp_op (ilxOp "/* ParOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw")) - DelayOp -> simp_op (ilxOp "call void class [mscorlib]System.Threading.Thread::Sleep(int32) ") - {- Int# -> State# s -> State# s -} - - WaitReadOp -> warn_op "WaitReadOp" (simp_op (ilxOp "/* WaitReadOp skipped... */ pop")) - WaitWriteOp -> warn_op "WaitWriteOp" (simp_op (ilxOp " /* WaitWriteOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw")) - ParAtForNowOp -> warn_op "ParAtForNowOp" (simp_op (ilxOp " /* ParAtForNowOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw")) - ParAtRelOp -> warn_op "ParAtRelOp" (simp_op (ilxOp " /* ParAtRelOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw")) - ParAtAbsOp -> warn_op "ParAtAbsOp" (simp_op (ilxOp " /* ParAtAbsOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw")) - ParAtOp -> warn_op "ParAtOp" (simp_op (ilxOp " /* ParAtOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw")) - ParLocalOp -> warn_op "ParLocalOp" (simp_op (ilxOp " /* ParLocalOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw")) - ParGlobalOp -> warn_op "ParGlobalOp" (simp_op (ilxOp " /* ParGlobalOp skipped... */ newobj void [mscorlib]System.Object::.ctor() throw")) - SeqOp -> warn_op "SeqOp" (simp_op (ilxOp " newobj void [mscorlib]System.Object::.ctor() throw ")) - AddrToHValueOp -> warn_op "AddrToHValueOp" (simp_op (ilxOp "newobj void [mscorlib]System.Object::.ctor() throw")) --- ReallyUnsafePtrEqualityOp -> simp_op (ilxOp "ceq") - - MkApUpd0_Op -> warn_op "MkApUpd0_Op" (simp_op (ilxOp " newobj void [mscorlib]System.Object::.ctor() throw")) - NewBCOOp -> warn_op "NewBCOOp" (simp_op (ilxOp " newobj void [mscorlib]System.Object::.ctor() throw")) - -- ("newBCO#") [alphaTyVar, deltaTyVar] [byteArrayPrimTy, byteArrayPrimTy, mkArrayPrimTy alphaTy, byteArrayPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed 2 [mkStatePrimTy deltaTy, bcoPrimTy])) - _ -> pprPanic "Unimplemented primop" (ppr op) - - -ty1_op :: (IlxTyFrag -> IlxOpFrag) -> [StgArg] -> IlxOpFrag -ty1_op op ((StgTypeArg ty1):rest) = - ilxOpSeq [getArgsStartingAt 1 rest, - op (ilxTypeR2 (deepIlxRepType ty1))] - -ty2_op :: (IlxTyFrag -> IlxTyFrag -> IlxOpFrag) -> [StgArg] -> IlxOpFrag -ty2_op op ((StgTypeArg ty1):(StgTypeArg ty2):rest) = - ilxOpSeq [getArgsStartingAt 2 rest, - op (ilxTypeR2 (deepIlxRepType ty1)) - (ilxTypeR2 (deepIlxRepType ty2))] - -ty3_op :: (IlxTyFrag -> IlxTyFrag -> IlxTyFrag -> IlxOpFrag) -> [StgArg] -> IlxOpFrag -ty3_op op ((StgTypeArg ty1):(StgTypeArg ty2):(StgTypeArg ty3):rest) = - ilxOpSeq [getArgsStartingAt 3 rest, - op (ilxTypeR2 (deepIlxRepType ty1)) - (ilxTypeR2 (deepIlxRepType ty2)) - (ilxTypeR2 (deepIlxRepType ty3))] - -arg2_op :: (IlxTyFrag -> IlxOpFrag -> IlxOpFrag) -> [StgArg] -> IlxOpFrag -arg2_op op [a1, a2] = - op (getAsArg 1 a1) - (getAsArg 2 a2) - -ty1_arg2_op :: (IlxTyFrag -> IlxOpFrag -> IlxOpFrag -> IlxOpFrag) -> [StgArg] -> IlxOpFrag -ty1_arg2_op op [(StgTypeArg ty1), a1, a2] = - op (ilxTypeR2 (deepIlxRepType ty1)) - (getAsArg 1 a1) - (getAsArg 2 a2) - -ty1_arg4_op :: (IlxTyFrag -> IlxOpFrag -> IlxOpFrag -> IlxOpFrag -> IlxOpFrag -> IlxOpFrag) -> [StgArg] -> IlxOpFrag -ty1_arg4_op op [(StgTypeArg ty1), a1, a2, a3, a4] = - op (ilxTypeR2 (deepIlxRepType ty1)) - (getAsArg 1 a1) - (getAsArg 2 a2) - (getAsArg 3 a3) - (getAsArg 4 a4) - -ty2_arg4_op :: (IlxTyFrag -> IlxTyFrag -> IlxOpFrag -> IlxOpFrag -> IlxOpFrag -> IlxOpFrag -> IlxOpFrag) -> [StgArg] -> IlxOpFrag -ty2_arg4_op op [(StgTypeArg ty1), (StgTypeArg ty2),a1, a2, a3, a4] = - op (ilxTypeR2 (deepIlxRepType ty1)) - (ilxTypeR2 (deepIlxRepType ty2)) - (getAsArg 2 a1) - (getAsArg 3 a2) - (getAsArg 4 a3) - (getAsArg 5 a4) - -hd (h:t) = h - -getAsArg n a env = hd (ilxMapPlaceArgs n pushArg env [a]) -getArgsStartingAt n a env = vcat (ilxMapPlaceArgs n pushArg env a) - -simp_op :: IlxOpFrag -> [StgArg] -> IlxOpFrag -simp_op op args env = vcat (ilxMapPlaceArgs 0 pushArg env args) $$ op env -warn_op warning f args = trace ("WARNING! IlxGen cannot translate primop " ++ warning) (f args) -\end{code} - -%************************************************************************ -%* * -\subsection{C Calls} -%* * -%************************************************************************ - -\begin{code} --- Call the P/Invoke stub wrapper generated in the import section. --- We eliminate voids in and around an IL C Call. --- We also do some type-directed translation for pinning Haskell-managed blobs --- of data as we throw them across the boundary. -ilxFCall env (CCall (CCallSpec (StaticTarget c) cconv gc)) args ret_ty - = ilxComment ((text "C call") <+> pprCLabelString c) <+> - vcat [vcat (ilxMapPlaceArgs 0 pushCArg env args), - text "call" <+> retdoc <+> pprCLabelString c <+> tyarg_doc - <+> pprCValArgTys ilxTypeL env (map deepIlxRepType (filter (not. isVoidIlxRepType) (map stgArgType tm_args))) ] - where - retdoc | isVoidIlxRepType ret_ty = text "void" - | otherwise = ilxTypeR env (deepIlxRepType ret_ty) - (ty_args,tm_args) = splitTyArgs1 args - tyarg_doc | not (isEmptyVarSet (tyVarsOfTypes ty_args)) = text "/* type variable found */" - | otherwise = pprTypeArgs ilxTypeR env ty_args - -ilxFCall env (DNCall (DNCallSpec call_instr)) args ret_ty - = ilxComment (text "IL call") <+> - vcat [vcat (ilxMapPlaceArgs 0 pushEvalArg env tm_args), - ptext call_instr - -- In due course we'll need to pass the type arguments - -- and to do that we'll need to have more than just a string - -- for call_instr - ] - where - (ty_args,tm_args) = splitTyArgs1 args - --- Push and argument and force its evaluation if necessary. -pushEvalArg _ (StgTypeArg _) = empty -pushEvalArg env (StgVarArg arg) = ilxFunApp env arg [] False -pushEvalArg env (StgLitArg lit) = pushLit env lit - - -hasTyCon (TyConApp tc _) tc2 = tc == tc2 -hasTyCon _ _ = False - -isByteArrayCArgTy ty = hasTyCon ty byteArrayPrimTyCon || hasTyCon ty mutableByteArrayPrimTyCon -isByteArrayCArg v = isByteArrayCArgTy (deepIlxRepType (idType v)) - -isForeignObjCArgTy ty = hasTyCon ty foreignObjPrimTyCon -isForeignObjCArg v = isForeignObjCArgTy (deepIlxRepType (idType v)) - -pinCCallArg v = isByteArrayCArg v || isForeignObjCArg v - -pinCArg env arg v = pushArg env arg <+> text "dup stloc" <+> singleQuotes (ilxEnvQualifyByExact env (ppr v) <> text "pin") -pushCArg env arg@(StgVarArg v) | isByteArrayCArg v = pinCArg env arg v <+> ilxAddrOfByteArrOp env -pushCArg env arg@(StgVarArg v) | isForeignObjCArg v = pinCArg env arg v <+> ilxAddrOfForeignOp env -pushCArg env arg | otherwise = pushArg env arg - -pprCValArgTys f env tys = parens (pprSepWithCommas (pprCValArgTy f env) tys) -pprCValArgTy f env ty | isByteArrayCArgTy ty = text "void *" <+> ilxComment (text "interior pointer into ByteArr#") -pprCValArgTy f env ty | isForeignObjCArgTy ty = text "void *" <+> ilxComment (text "foreign object") -pprCValArgTy f env ty | otherwise = f env ty - - -foldR :: (a -> b -> b) -> [a] -> b -> b --- foldR _ [] z = z --- foldR f (x:xs) z = f x (foldR f xs z) -{-# INLINE foldR #-} -foldR k xs z = go xs - where - go [] = z - go (y:ys) = y `k` go ys - -\end{code} - diff --git a/compiler/ilxGen/Makefile.stdlib b/compiler/ilxGen/Makefile.stdlib deleted file mode 100644 index bab9933..0000000 --- a/compiler/ilxGen/Makefile.stdlib +++ /dev/null @@ -1,82 +0,0 @@ -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/compiler/ilxGen/tests/Makefile b/compiler/ilxGen/tests/Makefile deleted file mode 100644 index 423839c..0000000 --- a/compiler/ilxGen/tests/Makefile +++ /dev/null @@ -1,130 +0,0 @@ - -TOP = ../../.. -include $(TOP)/mk/boilerplate.mk - -WAYS=$(GhcLibWays) - -#----------------------------------------------------------------------------- -# Setting the standard variables -# - -HC = $(GHC_INPLACE) -SRC_HC_OPTS+=-cpp -fglasgow-exts - -#----------------------------------------------------------------------------- -# -CORENV_DEBUG= -CORENV_RETAIL= -LOCALRUN=./ -ifeq ($(HOSTNAME),MSRC-HILDA) -CORENV_DEBUG="call devcorb2gen.bat checked" -CORENV_RETAIL="call devcorb2gen.bat free" -LOCALRUN=.\\ -endif - -ghc: - $(MAKE) -C ../.. - -ilx: - $(MAKE) -C $(ILX2IL_HOME) ilxdefault - -prel: ilx - $(MAKE) -C ../../../lib/std std.$(ilx_way).dll std.$(ilx_way).vlb - -#======================================================================== -# 1. From Haskell to ILX and then to IL - see build.mk - -#------------------------------------------------------------------------ -# 2. From IL to .EXE - -%.$(ilx_way).exe : %.$(ilx_way).il ../Entry.$(ilx_way).il - cat $*.$(ilx_way).il ../Entry.$(ilx_way).il > $@.tmp -# echo "call devcorb2gen free" > tmp.bat - echo "ilasm /DEBUG /QUIET /OUT=$@ $@.tmp" >> tmp.bat - cmd /c tmp.bat - -../Entry.$(hs2ilx_suffix)_o: ../Entry.ilx - sed -e "s|ilx std|ilx std.$(hs2ilx_suffix)|g" ../Entry.ilx > $@.tmp - mv $@.tmp $@ - - -%.$(ilx_way).mvl: %.$(ilx_way).il - (ILVALID_HOME=c:\\devel\\fcom\\src\\ ILVALID_MSCORLIB=mscorlib.vlb $(ILVALID) c:\\devel\\fcom\\src\\bin\\msilxlib$(ilx2il_suffix).vlb $(TOP)/lib/std/std.$(ilx_way).vlb $<) 2>&1 - - -#------------------------------------------------------------------------ -# From .HS to .EXE without using ILX -# Used to run performance comparisons against native code GHC - -%.Onot.exe: %.hs - $(GHC_INPLACE) -Onot -o $@ $< - -%.O.exe: %.hs - $(GHC_INPLACE) -O -o $@ $< - -WIN_TOP_ABS = $(subst /,\,$(FPTOOLS_TOP_ABS)) -WIN_ILX2IL_HOME = $(subst /,\,$(ILX2IL_HOME)) - -app.config: - echo "" > $@ - echo "" >> $@ - echo "" >> $@ - echo "" >> $@ - echo "" >> $@ - echo "" >> $@ - echo "" >> $@ - -%.run: %.exe app.config - time -p $< - -#------------------------------------------------------------------------ -# Running: - -HSstd_cbits.dll: $(DLL_PEN)/HSstd_cbits.dll - cp $< $@ - -%.cordbg.run: HSstd_cbits.dll %.exe - cp app.config $@.config -# echo "call devcorb2gen fastchecked" > $@.bat - echo "$(LOCALRUN)$(subst /,\\,$*).exe 2>&1" >> $@.bat - time -p cmd /c $(subst /,\\,$@).bat - rm $@.bat - -%.debug.run: HSstd_cbits.dll %.exe - cp app.config $@.config -# echo "call devcorb2gen fastchecked" > $@.bat - echo "$(LOCALRUN)$(subst /,\\,$*).exe 2>&1" >> $@.bat - time -p cmd /c $(subst /,\\,$@).bat - rm $@.bat - -%.retail.run: HSstd_cbits.dll %.exe - cp app.config $@.config -# echo "call devcorb2gen free" > $@.bat - echo "$(LOCALRUN)$(subst /,\\,$*).exe 2>&1" >> $@.bat - time -p cmd /c $(subst /,\\,$@).bat - rm $@.bat - - -%.run: %.exe - time -p $< - - -#-------------------- - -%.mvl: %.nolib.il - ILVALID_HOME=$(ILX2IL_HOME) $(ILVALID) $*.nolib.il - -ci: - (cd $(ILX2IL_HOME); $(CVS) ci -m "") - (cd ../..; cvs ci -m "") - (cd ../../../lib/std; $(CVS) ci -m "") - -upd: - (cd $(ILX2IL_HOME); $(CVS) up) - (cd ../..; $(CVS) up) - (cd ../../../lib/std; $(CVS) up) - - -.PHONY: %.run - -include $(TOP)/mk/target.mk diff --git a/compiler/ilxGen/tests/PrelNum.hs b/compiler/ilxGen/tests/PrelNum.hs deleted file mode 100644 index ca23e14..0000000 --- a/compiler/ilxGen/tests/PrelNum.hs +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - -{-# 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/compiler/ilxGen/tests/build.mk b/compiler/ilxGen/tests/build.mk deleted file mode 100644 index 285fd5d..0000000 --- a/compiler/ilxGen/tests/build.mk +++ /dev/null @@ -1,121 +0,0 @@ -# 1. To make standard library: -# -# e.g. from lib/std directory: -# $(MAKE) way=ilx-Onot-mono std.ilx-Onot.mono.dll std.ilx-Onot.mono.vlb -# $(MAKE) way=ilx-O-mono std.ilx-O.mono.dll std.ilx-O.mono.vlb -# $(MAKE) way=ilx-Onot-generic std.ilx-Onot.generic.dll -# -# 2. To make tests: -# -# e.g. from ilxGen/tests directory: -# -# $ make -n way=ilx-Onot-mono test1.ilx-Onot.mono.retail.run -# -# $ make -n way=ilx-Onot-mono test1-nostdlib.ilx-Onot.mono.retail.run HC_OPTS="-fno-implicit-prelude -fglasgow-exts" -# - - -# Add all the ILX ways so dependencies get made correctly. -# (n.b. Actually we only need to add "ilx-Onot" and "ilx-O" for the -# GHC --> ILX dependencies, as these are the portions of the ILX -# ways that are relevant in terms of GHC options, -# but we list some of the others anyway. Also note that -# there are no dependencies required for the ILX --> IL or -# IL --> CLR phases as these operate on the "standalone" -# ILX and IL files). -# -#GhcLibWays+= ilx-Onot-mono ilx-Onot ilx-O ilx-O-mono -GhcLibWays+=i -GhcWithIlx=YES - -ILXized=YES - -GhcHcOpts+=-DILX -DNO_BIG_TUPLES -GhcLibHcOpts+=-optI--mono -optI--add-suffix-to-assembly -optImsilxlib -optI--suffix-to-add -optI.mono - -# Each set of args below defines one ILX way. -#ALL_WAYS+=ilx-Onot-generic -#WAY_ilx-Onot-generic_NAME=ILX with Haskell Optimizer Off to run on Generic CLR -#WAY_ilx-Onot-generic_HC_OPTS=-buildtag ilx-Onot $(GHC_ILX_OPTS) -Onot -#WAY_ilx-Onot-generic_ILX2IL_OPTS=--generic -#WAY_ilx-Onot-generic_ILX=YES - -#ALL_WAYS+=ilx-Onot-fullgeneric-verifiable -#WAY_ilx-Onot-fullgeneric-verifiable_NAME=ILX with Haskell Optimizer Off to run on Generic CLR -#WAY_ilx-Onot-fullgeneric-verifiable_HC_OPTS=-buildtag ilx-Onot $(GHC_ILX_OPTS) -Onot -#WAY_ilx-Onot-fullgeneric-verifiable_ILX2IL_OPTS=--fullgeneric --verifiable -#WAY_ilx-Onot-fullgeneric-verifiable_ILX=YES - -#ALL_WAYS+=ilx-Onot-repgeneric-verifiable -#WAY_ilx-Onot-repgeneric-verifiable_NAME=ILX with Haskell Optimizer Off to run on Generic CLR -#WAY_ilx-Onot-repgeneric-verifiable_HC_OPTS=-buildtag ilx-Onot $(GHC_ILX_OPTS) -Onot -#WAY_ilx-Onot-repgeneric-verifiable_ILX2IL_OPTS=--repgeneric --verifiable -#WAY_ilx-Onot-repgeneric-verifiable_ILX=YES - -#ALL_WAYS+=ilx-O-generic -#WAY_ilx-O-generic_NAME=ILX with Haskell Optimizer On to run on Generic CLR -#WAY_ilx-O-generic_HC_OPTS=-buildtag ilx-O $(GHC_ILX_OPTS) -O -#WAY_ilx-O-generic_ILX2IL_OPTS=--generic -#WAY_ilx-O-generic_ILX=YES - -#ALL_WAYS+=ilx-Onot-mono -#WAY_ilx-Onot-mono_NAME=ILX with Haskell Optimizer Off to run on V1 CLR -#WAY_ilx-Onot-mono_HC_OPTS=-buildtag ilx-Onot $(GHC_ILX_OPTS) -Onot -#WAY_ilx-Onot-mono_ILX2IL_OPTS=--mono -#WAY_ilx-Onot-mono_ILX=YES - -#ALL_WAYS+=ilx-Onot-mono-verifiable -#WAY_ilx-Onot-mono-verifiable_NAME=ILX with Haskell Optimizer Off to run on V1 CLR, verifiable code (CURRENTLY WILL NOT RUN BECAUSE OF LACK OF HIGHER KINDED TYPE PARAMETERS BUT IS USEFUL TO FIND BUGS USING THE VERIFIER) -#WAY_ilx-Onot-mono-verifiable_HC_OPTS=-buildtag ilx-Onot $(GHC_ILX_OPTS) -Onot -#WAY_ilx-Onot-mono-verifiable_ILX2IL_OPTS=--mono --verifiable -#WAY_ilx-Onot-mono-verifiable_ILX=YES - -#ALL_WAYS+=ilx-O-mono -#WAY_ilx-O-mono_NAME=ILX with Haskell Optimizer On to run on V1 CLR -#WAY_ilx-O-mono_HC_OPTS=-buildtag ilx-O $(GHC_ILX_OPTS) -O -#WAY_ilx-O-mono_ILX2IL_OPTS=--mono -#WAY_ilx-O-mono_ILX=YES - -#ALL_WAYS+=ilx-Onot-generic-traced -#WAY_ilx-Onot-generic-traced_NAME=ILX with Haskell Optimizer Off to run on Generic CLR -#WAY_ilx-Onot-generic-traced_HC_OPTS=-buildtag ilx-Onot $(GHC_ILX_OPTS) -Onot -#WAY_ilx-Onot-generic-traced_ILX2IL_OPTS=--generic --traced -#WAY_ilx-Onot-generic-traced_ILX=YES - -#ALL_WAYS+=ilx-O-generic-traced -#WAY_ilx-O-generic-traced_NAME=ILX with Haskell Optimizer On to run on Generic CLR -#WAY_ilx-O-generic-traced_HC_OPTS=-buildtag ilx-O $(GHC_ILX_OPTS) -O -#WAY_ilx-O-generic-traced_ILX2IL_OPTS=--generic --traced -#WAY_ilx-O-generic-traced_ILX=YES - -#ALL_WAYS+=ilx-Onot-mono-traced -#WAY_ilx-Onot-mono-traced_NAME=ILX with Haskell Optimizer Off to run on V1 CLR -#WAY_ilx-Onot-mono-traced_HC_OPTS=-buildtag ilx-Onot $(GHC_ILX_OPTS) -Onot -#WAY_ilx-Onot-mono-traced_ILX2IL_OPTS=--mono --traced -#WAY_ilx-Onot-mono-traced_ILX=YES - -#ALL_WAYS+=ilx-O-mono-traced -#WAY_ilx-O-mono-traced_NAME=ILX with Haskell Optimizer On to run on V1 CLR -#WAY_ilx-O-mono-traced_HC_OPTS=-buildtag ilx-O $(GHC_ILX_OPTS) -O -#WAY_ilx-O-mono-traced_ILX2IL_OPTS=--mono --traced -#WAY_ilx-O-mono-traced_ILX=YES - -# Put a "." after the Haskell portion of the way. Way names can't contain -# dots for some reason elsewhere in the Make system. But we need to be able -# to split out the Haskell portion of the way from the ILX portion (e.g. --generic) -# and the runtime portion (e.g. --retail). -ilx_way=$(subst ilx-Onot-,ilx-Onot.,$(subst ilx-O-,ilx-O.,$(way))) -ilx2il_suffix=$(subst ilx-Onot.,.,$(subst ilx-O.,.,$(ilx_way))) -hs2ilx_suffix=$(subst $(ilx2il_suffix),,$(ilx_way)) -HS_ILX=$(subst $(way),$(hs2ilx_suffix),$(HS_OBJS)) -#HS_IL=$(subst $(hs2ilx_suffix)_o,$(ilx_way).il,$(HS_ILX)) -HS_IL=$(subst .o,.il,$(HS_ILX)) - -ILVALID=C:/devel/fcom/bin/ilvalid.exe -ILVERIFY=C:/devel/fcom/bin/ilverify.exe - -%.$(ilx_way).mvl : %.$(ilx_way).il $(HS_IL) - ((ILVALID_HOME=c:\\devel\\fcom\\src\\ ILVALID_MSCORLIB=mscorlib.vlb $(ILVALID) c:\\devel\\fcom\\src\\bin\\msilxlib$(ilx2il_suffix).vlb $(addprefix --other-il-module ,$(filter-out $*.$(ilx_way).il,$(HS_IL))) $<) 2>&1) | tee $@ - -%.$(ilx_way).mvr : %.$(ilx_way).il $(HS_IL) - ((ILVALID_HOME=c:\\devel\\fcom\\src\\ ILVALID_MSCORLIB=mscorlib.vlb $(ILVERIFY) c:\\devel\\fcom\\src\\bin\\msilxlib$(ilx2il_suffix).vlb $(addprefix --other-il-module ,$(filter-out $<,$(HS_IL))) $<) 2>&1) | tee $@ diff --git a/compiler/ilxGen/tests/foo.hs b/compiler/ilxGen/tests/foo.hs deleted file mode 100644 index d66608b..0000000 --- a/compiler/ilxGen/tests/foo.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# 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/compiler/ilxGen/tests/life.hs b/compiler/ilxGen/tests/life.hs deleted file mode 100644 index d6bcd16..0000000 --- a/compiler/ilxGen/tests/life.hs +++ /dev/null @@ -1,360 +0,0 @@ --------------------------------- --- 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/compiler/ilxGen/tests/reduce.ml b/compiler/ilxGen/tests/reduce.ml deleted file mode 100644 index cad379b..0000000 --- a/compiler/ilxGen/tests/reduce.ml +++ /dev/null @@ -1,101 +0,0 @@ - - -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/compiler/ilxGen/tests/test1-nostdlib.hs b/compiler/ilxGen/tests/test1-nostdlib.hs deleted file mode 100644 index 1e9053e..0000000 --- a/compiler/ilxGen/tests/test1-nostdlib.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Test1_nostdlib where -foreign import "ilxHello" unsafe ilxHello :: () - -ilx_main_no_stdlib = ilxHello diff --git a/compiler/ilxGen/tests/test1.hs b/compiler/ilxGen/tests/test1.hs deleted file mode 100644 index 10f307e..0000000 --- a/compiler/ilxGen/tests/test1.hs +++ /dev/null @@ -1 +0,0 @@ -main = putStr "HELLO HELLO Hello world WORLD WORLD.\n" diff --git a/compiler/ilxGen/tests/test10.hs b/compiler/ilxGen/tests/test10.hs deleted file mode 100644 index 46c384d..0000000 --- a/compiler/ilxGen/tests/test10.hs +++ /dev/null @@ -1,45 +0,0 @@ - -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/compiler/ilxGen/tests/test11.hs b/compiler/ilxGen/tests/test11.hs deleted file mode 100644 index ce53f71..0000000 --- a/compiler/ilxGen/tests/test11.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# 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/compiler/ilxGen/tests/test12.hs b/compiler/ilxGen/tests/test12.hs deleted file mode 100644 index 216c792..0000000 --- a/compiler/ilxGen/tests/test12.hs +++ /dev/null @@ -1,44 +0,0 @@ -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/compiler/ilxGen/tests/test13.hs b/compiler/ilxGen/tests/test13.hs deleted file mode 100644 index 559c867..0000000 --- a/compiler/ilxGen/tests/test13.hs +++ /dev/null @@ -1,20 +0,0 @@ -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/compiler/ilxGen/tests/test14.hs b/compiler/ilxGen/tests/test14.hs deleted file mode 100644 index 86b5d1c..0000000 --- a/compiler/ilxGen/tests/test14.hs +++ /dev/null @@ -1,11 +0,0 @@ -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/compiler/ilxGen/tests/test15.hs b/compiler/ilxGen/tests/test15.hs deleted file mode 100644 index 3e522d7..0000000 --- a/compiler/ilxGen/tests/test15.hs +++ /dev/null @@ -1,18 +0,0 @@ - -{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-} - - -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/compiler/ilxGen/tests/test16.hs b/compiler/ilxGen/tests/test16.hs deleted file mode 100644 index 0e8b997..0000000 --- a/compiler/ilxGen/tests/test16.hs +++ /dev/null @@ -1,5 +0,0 @@ - - -data MMaybe a = No | Yes a - -main = putStr "hello world\n" \ No newline at end of file diff --git a/compiler/ilxGen/tests/test17.hs b/compiler/ilxGen/tests/test17.hs deleted file mode 100644 index 5e551b2..0000000 --- a/compiler/ilxGen/tests/test17.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# 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/compiler/ilxGen/tests/test18.hs b/compiler/ilxGen/tests/test18.hs deleted file mode 100644 index 12ca741..0000000 --- a/compiler/ilxGen/tests/test18.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-# 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/compiler/ilxGen/tests/test19.hs b/compiler/ilxGen/tests/test19.hs deleted file mode 100644 index a292599..0000000 --- a/compiler/ilxGen/tests/test19.hs +++ /dev/null @@ -1,37 +0,0 @@ - -{-# 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/compiler/ilxGen/tests/test1b.hs b/compiler/ilxGen/tests/test1b.hs deleted file mode 100644 index c4b2336..0000000 --- a/compiler/ilxGen/tests/test1b.hs +++ /dev/null @@ -1,104 +0,0 @@ --- 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/compiler/ilxGen/tests/test2.hs b/compiler/ilxGen/tests/test2.hs deleted file mode 100644 index 8b1f5b5..0000000 --- a/compiler/ilxGen/tests/test2.hs +++ /dev/null @@ -1,88 +0,0 @@ --- 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 n10 -bign1 = add bign n1 - -main = putStr (chooseN bign1) - - diff --git a/compiler/ilxGen/tests/test20.hs b/compiler/ilxGen/tests/test20.hs deleted file mode 100644 index 157a16d..0000000 --- a/compiler/ilxGen/tests/test20.hs +++ /dev/null @@ -1,9 +0,0 @@ - -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/compiler/ilxGen/tests/test21.hs b/compiler/ilxGen/tests/test21.hs deleted file mode 100644 index 1870f22..0000000 --- a/compiler/ilxGen/tests/test21.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# 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/compiler/ilxGen/tests/test2b.hs b/compiler/ilxGen/tests/test2b.hs deleted file mode 100644 index 08a391f..0000000 --- a/compiler/ilxGen/tests/test2b.hs +++ /dev/null @@ -1,2 +0,0 @@ -foreign import "ilxHello" unsafe ilxHello :: IO () -main = ilxHello diff --git a/compiler/ilxGen/tests/test2c.hs b/compiler/ilxGen/tests/test2c.hs deleted file mode 100644 index d01df05..0000000 --- a/compiler/ilxGen/tests/test2c.hs +++ /dev/null @@ -1,14 +0,0 @@ -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/compiler/ilxGen/tests/test2d.hs b/compiler/ilxGen/tests/test2d.hs deleted file mode 100644 index 8126127..0000000 --- a/compiler/ilxGen/tests/test2d.hs +++ /dev/null @@ -1,7 +0,0 @@ -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/compiler/ilxGen/tests/test3.hs b/compiler/ilxGen/tests/test3.hs deleted file mode 100644 index 0254ee4..0000000 --- a/compiler/ilxGen/tests/test3.hs +++ /dev/null @@ -1,24 +0,0 @@ -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/compiler/ilxGen/tests/test4.hs b/compiler/ilxGen/tests/test4.hs deleted file mode 100644 index 080c652..0000000 --- a/compiler/ilxGen/tests/test4.hs +++ /dev/null @@ -1,47 +0,0 @@ -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/compiler/ilxGen/tests/test5.hs b/compiler/ilxGen/tests/test5.hs deleted file mode 100644 index 13d6028..0000000 --- a/compiler/ilxGen/tests/test5.hs +++ /dev/null @@ -1,5 +0,0 @@ -data One a = One a - -choose (One x) = x -main = putStr (choose (One "hello world\n")) - diff --git a/compiler/ilxGen/tests/test6.hs b/compiler/ilxGen/tests/test6.hs deleted file mode 100644 index 17e51ab..0000000 --- a/compiler/ilxGen/tests/test6.hs +++ /dev/null @@ -1,8 +0,0 @@ -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/compiler/ilxGen/tests/test7.hs b/compiler/ilxGen/tests/test7.hs deleted file mode 100644 index c146038..0000000 --- a/compiler/ilxGen/tests/test7.hs +++ /dev/null @@ -1,8 +0,0 @@ -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/compiler/ilxGen/tests/test8.hs b/compiler/ilxGen/tests/test8.hs deleted file mode 100644 index 94a7e1f..0000000 --- a/compiler/ilxGen/tests/test8.hs +++ /dev/null @@ -1,8 +0,0 @@ -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/compiler/ilxGen/tests/test9.hs b/compiler/ilxGen/tests/test9.hs deleted file mode 100644 index 311b65c..0000000 --- a/compiler/ilxGen/tests/test9.hs +++ /dev/null @@ -1,10 +0,0 @@ -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/compiler/ilxGen/tests/yes.hs b/compiler/ilxGen/tests/yes.hs deleted file mode 100644 index 1dc4f08..0000000 --- a/compiler/ilxGen/tests/yes.hs +++ /dev/null @@ -1,5 +0,0 @@ - -foreign import "ilxHello" unsafe ilxHello :: IO () - -main :: IO () -main = ilxHello >> main \ No newline at end of file diff --git a/compiler/ilxGen/tests/yes2.hs b/compiler/ilxGen/tests/yes2.hs deleted file mode 100644 index 7fa20c5..0000000 --- a/compiler/ilxGen/tests/yes2.hs +++ /dev/null @@ -1,18 +0,0 @@ - -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 () - diff --git a/compiler/package.conf.in b/compiler/package.conf.in index 3b2d265..ef2c8b4 100644 --- a/compiler/package.conf.in +++ b/compiler/package.conf.in @@ -119,7 +119,6 @@ exposed-modules: IfaceEnv IfaceSyn IfaceType - IlxGen Inst InstEnv InteractiveUI