From 9331c8ec2aa16ab5bf0554667fc44fc06facd06a Mon Sep 17 00:00:00 2001 From: dsyme Date: Wed, 4 Apr 2001 23:53:37 +0000 Subject: [PATCH] [project @ 2001-04-04 23:53:37 by dsyme] Some work on the ILX backend by Don Syme. Currently only being compiled by Don as it needs various makefile settings in order for this stuff to be compiled at all. --- ghc/compiler/ilxGen/Entry.ilx | 30 ++-- ghc/compiler/ilxGen/IlxGen.lhs | 337 +++++++++++++++++------------------ ghc/compiler/ilxGen/tests/Makefile | 243 ++++--------------------- ghc/compiler/ilxGen/tests/test1.hs | 90 +--------- ghc/compiler/ilxGen/tests/test15.hs | 2 - ghc/compiler/ilxGen/tests/test2.hs | 89 ++++++++- 6 files changed, 307 insertions(+), 484 deletions(-) diff --git a/ghc/compiler/ilxGen/Entry.ilx b/ghc/compiler/ilxGen/Entry.ilx index fe8b618..bb4c29d 100644 --- a/ghc/compiler/ilxGen/Entry.ilx +++ b/ghc/compiler/ilxGen/Entry.ilx @@ -4,14 +4,14 @@ .method public static void Main(class [mscorlib]System.String[]) { .entrypoint ldstr "LOG: loading main value\n" call void [mscorlib]System.Console::WriteLine(class [mscorlib]System.String) - ldsfld (func () --> class [ilx std]'()') class Main::'Main_main' + ldsfld (func (unit) --> class [ilx std]'()') class Main::'Main_main' ldstr "LOG: evaluating main value\n" call void [mscorlib]System.Console::WriteLine(class [mscorlib]System.String) - callfunc --> (func () --> class [ilx std]PrelBase_Z0T) + callfunc () --> (func (unit) --> class [ilx std]PrelBase_Z0T) ldstr "LOG: calling main value\n" call void [mscorlib]System.Console::WriteLine(class [mscorlib]System.String) - ldvoid + ldunit callfunc (void) --> class [ilx std]PrelBase_Z0T pop @@ -25,27 +25,27 @@ ldstr "LOG: calling critical finalizers manually in main()\n" call void [mscorlib]System.Console::WriteLine(class [mscorlib]System.String) -ldsfld (func (thunk>) --> (func () --> class [ilx std]PrelBase_Z0T)) [ilx std]'PrelHandle'::'PrelHandle_stdHandleFinalizzer' +ldsfld (func (thunk>) --> (func (unit) --> class [ilx std]PrelBase_Z0T)) [ilx std]'PrelHandle'::'PrelHandle_stdHandleFinalizzer' ldsfld thunk> [ilx std]'PrelHandle'::'PrelHandle_stdin' - callfunc (thunk>) --> (func () --> class [ilx std]PrelBase_Z0T) - callfunc --> (func () --> class [ilx std]PrelBase_Z0T) - ldvoid + callfunc (thunk>) --> (func (unit) --> class [ilx std]PrelBase_Z0T) + callfunc () --> (func (unit) --> class [ilx std]PrelBase_Z0T) + ldunit callfunc (void) --> class [ilx std]PrelBase_Z0T pop -ldsfld (func (thunk>) --> (func () --> class [ilx std]PrelBase_Z0T)) [ilx std]'PrelHandle'::'PrelHandle_stdHandleFinalizzer' +ldsfld (func (thunk>) --> (func (unit) --> class [ilx std]PrelBase_Z0T)) [ilx std]'PrelHandle'::'PrelHandle_stdHandleFinalizzer' ldsfld thunk> [ilx std]'PrelHandle'::'PrelHandle_stdout' - callfunc (thunk>) --> (func () --> class [ilx std]PrelBase_Z0T) - callfunc --> (func () --> class [ilx std]PrelBase_Z0T) - ldvoid + callfunc (thunk>) --> (func (unit) --> class [ilx std]PrelBase_Z0T) + callfunc () --> (func (unit) --> class [ilx std]PrelBase_Z0T) + ldunit callfunc (void) --> class [ilx std]PrelBase_Z0T pop -ldsfld (func (thunk>) --> (func () --> class [ilx std]PrelBase_Z0T)) [ilx std]'PrelHandle'::'PrelHandle_stdHandleFinalizzer' +ldsfld (func (thunk>) --> (func (unit) --> class [ilx std]PrelBase_Z0T)) [ilx std]'PrelHandle'::'PrelHandle_stdHandleFinalizzer' ldsfld thunk> [ilx std]'PrelHandle'::'PrelHandle_stderr' - callfunc (thunk>) --> (func () --> class [ilx std]PrelBase_Z0T) - callfunc --> (func () --> class [ilx std]PrelBase_Z0T) - ldvoid + callfunc (thunk>) --> (func (unit) --> class [ilx std]PrelBase_Z0T) + callfunc () --> (func (unit) --> class [ilx std]PrelBase_Z0T) + ldunit callfunc (void) --> class [ilx std]PrelBase_Z0T pop diff --git a/ghc/compiler/ilxGen/IlxGen.lhs b/ghc/compiler/ilxGen/IlxGen.lhs index babd35c..9deb431 100644 --- a/ghc/compiler/ilxGen/IlxGen.lhs +++ b/ghc/compiler/ilxGen/IlxGen.lhs @@ -30,8 +30,10 @@ import PrimRep ( PrimRep(..) ) import Name ( nameModule, nameOccName, isGlobalName, isLocalName, isDllName, NamedThing(getName) ) import Subst ( substTy, mkTyVarSubst ) -import Module ( Module, PackageName, ModuleName, moduleName, modulePackage, preludePackage, - isHomeModule, pprModuleName, mkHomeModule, mkModuleName +import Module ( Module, PackageName, ModuleName, moduleName, + modulePackage, preludePackage, + isPrelModule, isHomeModule, isVanillaModule, + pprModuleName, mkHomeModule, mkModuleName ) import UniqFM @@ -73,7 +75,7 @@ ilxGen mod tycons binds_w_srts ] where binds = map fst binds_w_srts - (import_packages,import_modules,import_tycons) = importsBinds binds `unionImpInfo` importsPrelude + (import_packages,import_modules,import_tycons) = importsBinds binds (importsPrelude emptyImpInfo) toppairs = ilxPairs binds topenv = extendIlxEnvWithTops (emptyIlxEnv False mod) mod toppairs -- Generate info from class decls as well @@ -88,102 +90,105 @@ ilxGen mod tycons binds_w_srts \begin{code} -importsBinds :: [StgBinding] -> ImportsInfo -importsBinds binds = unionImpInfos (map importsBind binds) +importsBinds :: [StgBinding] -> ImportsInfo-> ImportsInfo +importsBinds binds = foldR importsBind binds -importsBind :: StgBinding -> ImportsInfo -importsBind (StgNonRec _ b rhs) = importsRhs rhs `unionImpInfo` importsVar b -importsBind (StgRec _ pairs) = unionImpInfos (map (\(b,rhs) -> importsRhs rhs `unionImpInfo` importsVar b) pairs) +importsNone :: ImportsInfo -> ImportsInfo +importsNone sofar = sofar -importsRhs (StgRhsCon _ con args) = importsDataCon con `unionImpInfo` importsStgArgs args -importsRhs (StgRhsClosure _ _ _ upd args body) = importsExpr body `unionImpInfo` importsVars args +importsBind :: StgBinding -> ImportsInfo -> ImportsInfo +importsBind (StgNonRec _ b rhs) = importsRhs rhs.importsVar b +importsBind (StgRec _ pairs) = foldR (\(b,rhs) -> importsRhs rhs . importsVar b) pairs -importsExpr :: StgExpr -> ImportsInfo -importsExpr (StgLit l) = emptyImpInfo -importsExpr (StgApp f args) = importsVar f `unionImpInfo` importsStgArgs args -importsExpr (StgConApp con args) = importsDataCon con `unionImpInfo` importsStgArgs args -importsExpr (StgPrimApp op args res_ty) = importsType res_ty `unionImpInfo` importsStgArgs args +importsRhs (StgRhsCon _ con args) = importsDataCon con . importsStgArgs args +importsRhs (StgRhsClosure _ _ _ upd args body) = importsExpr body. importsVars args + +importsExpr :: StgExpr -> ImportsInfo -> ImportsInfo +importsExpr (StgLit l) = importsNone +importsExpr (StgApp f args) = importsVar f.importsStgArgs args +importsExpr (StgConApp con args) = importsDataCon con.importsStgArgs args +importsExpr (StgPrimApp op args res_ty) = importsType res_ty. importsStgArgs args importsExpr (StgSCC cc expr) = importsExpr expr importsExpr (StgCase scrut _ _ bndr srt alts) - = importsExpr scrut `unionImpInfo` imports_alts alts `unionImpInfo` importsVar bndr + = importsExpr scrut. imports_alts alts. importsVar bndr where imports_alts (StgAlgAlts _ alts deflt) -- The Maybe TyCon part is dealt with -- by the case-binder's type - = unionImpInfos (map imports_alg_alt alts) `unionImpInfo` imports_deflt deflt + = foldR imports_alg_alt alts . imports_deflt deflt where imports_alg_alt (con, bndrs, _, rhs) - = importsExpr rhs `unionImpInfo` importsDataCon con `unionImpInfo` importsVars bndrs + = importsExpr rhs . importsDataCon con. importsVars bndrs imports_alts (StgPrimAlts _ alts deflt) - = unionImpInfos (map imports_prim_alt alts) `unionImpInfo` imports_deflt deflt + = foldR imports_prim_alt alts . imports_deflt deflt where imports_prim_alt (lit, rhs) = importsExpr rhs - imports_deflt StgNoDefault = emptyImpInfo + imports_deflt StgNoDefault = importsNone imports_deflt (StgBindDefault rhs) = importsExpr rhs + importsExpr (StgLetNoEscape _ _ bind body) = importsExpr (StgLet bind body) importsExpr (StgLet bind body) - = importsBind bind `unionImpInfo` importsExpr body + = importsBind bind . importsExpr body -importsApp v args = importsVar v `unionImpInfo` importsStgArgs args -importsStgArgs args = unionImpInfos (map importsStgArg args) +importsApp v args = importsVar v. importsStgArgs args +importsStgArgs args = foldR importsStgArg args -importsStgArg :: StgArg -> ImportsInfo +importsStgArg :: StgArg -> ImportsInfo -> ImportsInfo importsStgArg (StgTypeArg ty) = importsType ty importsStgArg (StgVarArg v) = importsVar v -importsStgArg _ = emptyImpInfo +importsStgArg _ = importsNone -importsVars vs = unionImpInfos (map importsVar vs) -importsVar v = importsName (idName v) `unionImpInfo` importsType (idType v) +importsVars vs = foldR importsVar vs +importsVar v = importsName (idName v). importsType (idType v) importsName n - | isLocalName n = emptyImpInfo - | thisModule == nameModule n = emptyImpInfo - | isDllName n = singlePackageImpInfo (modulePackage (nameModule n)) - | otherwise = singleModuleImpInfo (moduleName (nameModule n)) + | isLocalName n = importsNone + | thisModule == nameModule n = importsNone + | isHomeModule (nameModule n) = addModuleImpInfo (moduleName (nameModule n)) + | isVanillaModule (nameModule n) = addPackageImpInfo preludePackage + | otherwise = addPackageImpInfo (modulePackage (nameModule n)) + importsModule m - | thisModule == m = emptyImpInfo - | isHomeModule m = singleModuleImpInfo (moduleName m) - | otherwise = singlePackageImpInfo (modulePackage m) + | thisModule == m = importsNone + | isHomeModule m = trace "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA\n" (addModuleImpInfo (moduleName m)) + | isVanillaModule m = addPackageImpInfo preludePackage + | otherwise = addPackageImpInfo (modulePackage m) -importsType :: Type -> ImportsInfo +importsType :: Type -> ImportsInfo -> ImportsInfo importsType ty = importsType2 (deepIlxRepType ty) -importsType2 :: Type -> ImportsInfo -importsType2 (AppTy f x) = importsType2 f `unionImpInfo` importsType2 x -importsType2 (TyVarTy _) = emptyImpInfo -importsType2 (TyConApp tc args) =importsTyCon tc `unionImpInfo` importsTypeArgs2 args -importsType2 (FunTy arg res) = importsType arg `unionImpInfo` importsType2 res +importsType2 :: Type -> ImportsInfo -> ImportsInfo +importsType2 (AppTy f x) = importsType2 f . importsType2 x +importsType2 (TyVarTy _) = importsNone +importsType2 (TyConApp tc args) =importsTyCon tc . importsTypeArgs2 args +importsType2 (FunTy arg res) = importsType arg . importsType2 res importsType2 (ForAllTy tv body_ty) = importsType2 body_ty importsType2 (NoteTy _ ty) = importsType2 ty -importsTypeArgs2 tys =unionImpInfos (map importsType2 tys) +importsTypeArgs2 tys = foldR importsType2 tys importsDataCon dcon = importsTyCon (dataConTyCon dcon) -importsMaybeTyCon Nothing = emptyImpInfo +importsMaybeTyCon Nothing = importsNone importsMaybeTyCon (Just tc) = importsName (getName tc) importsTyCon tc | (not (isDataTyCon tc) || isLocalName (getName tc) || - thisModule == nameModule (getName tc)) = emptyImpInfo -importsTyCon tc | otherwise = importsName (getName tc) `unionImpInfo` (emptyUniqSet, emptyUniqSet,unitUniqSet tc) + thisModule == nameModule (getName tc)) = importsNone +importsTyCon tc | otherwise = importsName (getName tc) . addTyConImpInfo tc -importsPrelude | preludePackage == opt_InPackage = singleModuleImpInfo (mkModuleName "PrelGHC") - | otherwise = singlePackageImpInfo preludePackage +importsPrelude | preludePackage == opt_InPackage = addModuleImpInfo (mkModuleName "PrelGHC") + | otherwise = addPackageImpInfo preludePackage -type ImportsInfo = (UniqSet PackageName, UniqSet ModuleName, UniqSet TyCon) -- (Packages, Modules, Datatypes) +type ImportsInfo = (UniqSet PackageName, UniqSet ModuleName, UniqSet TyCon) + -- (Packages, Modules, Datatypes) emptyImpInfo :: ImportsInfo emptyImpInfo = (emptyUniqSet, emptyUniqSet, emptyUniqSet) -singlePackageImpInfo p = (unitUniqSet p, emptyUniqSet, emptyUniqSet) -singleModuleImpInfo m = (emptyUniqSet, unitUniqSet m, emptyUniqSet) - -unionImpInfo :: ImportsInfo -> ImportsInfo -> ImportsInfo -unionImpInfo (w1,x1,y1) (w2,x2,y2) = (unionUniqSets w1 w2, unionUniqSets x1 x2, unionUniqSets y1 y2) - -unionImpInfos :: [ImportsInfo] -> ImportsInfo -unionImpInfos fvs = foldr unionImpInfo emptyImpInfo fvs +addPackageImpInfo p (w,x,y) = (addOneToUniqSet w p, x, y) +addModuleImpInfo m (w,x,y) = (w, addOneToUniqSet x m, y) +addTyConImpInfo tc (w,x,y) = (w, x, addOneToUniqSet y tc) ilxImportTyCon :: IlxEnv -> TyCon -> SDoc ilxImportTyCon env tycon | isDataTyCon tycon = pprIlxTyConDef True env tycon @@ -273,8 +278,9 @@ ilxRhsClosures env (bndr, StgRhsClosure _ _ fvs upd args rhs) closure_sig_text = - vcat [(case args of - [] -> empty + vcat [ text "()", + (case args of + [] -> empty other -> args_text), text "-->" <+> rty_text] @@ -345,7 +351,7 @@ pprArgBinders env (arg:args) -- We could probably omit some void argument binders, but -- don't... pprArgBinder env arg - | isVoidIlxRepId arg = (text "()", extendIlxEnvWithArgs env [arg]) + | isVoidIlxRepId arg = (text "(unit)", extendIlxEnvWithArgs env [arg]) | otherwise = if isTyVar arg then let env' = extendIlxEnvWithTyArgs env [arg] in @@ -705,13 +711,16 @@ ilxFunApp env fun args tail_call -- Recurse until we're done. ilxFunAppArgs env num_sofar funty args tail_call known_clo = vcat [vcat (ilxMapPlaceArgs num_sofar pushArgWithVoids env now_args), - call_instr <+> now_args_text + call_instr <+> text "()" <+> now_args_text <+> text "-->" <+> (pprIlxTypeR env_after_now_tyvs later_ty), later ] where - now_args_text = hsep (map (pprIlxArgInfo env_after_now_tyvs) now_arg_tys) + now_args_text = + case now_arg_tys of + [] -> empty + _ -> hsep (map (pprIlxArgInfo env_after_now_tyvs) now_arg_tys) (now_args,now_arg_tys,env_after_now_tyvs,later_args,later_ty) = case args of @@ -990,7 +999,7 @@ pushId = pushId_aux False pushId_aux :: Bool -> IlxEnv -> Id -> SDoc pushId_aux voids _ id | isVoidIlxRepId id = - if voids then text "ldvoid" else ilxComment (text "pushId: void rep skipped") + if voids then text "ldunit" else ilxComment (text "pushId: void rep skipped") pushId_aux _ env var = case lookupIlxVarEnv env var of Just Arg -> text "ldarg" <+> pprId var @@ -1054,22 +1063,6 @@ isVoidIlxRepId id = isVoidIlxRepType (idType id) -- Get rid of all NoteTy and NewTy artifacts deepIlxRepType :: Type -> Type - --- Eliminate state variables on left of arrow types... --- We have to be careful not to erase too much information here - --- the type may not accurately describe --- the "functionness" of the result. For example, --- State# -> Int# --- reduces to --- Int# --- which looks like an unboxed type. It isn't - it's --- just a function taking no arguments. As such, we --- have to rely on the context in which a function type is being --- used to know what to do. --- --- deepIlxRepType (FunTy l r) | isVoidIlxRepType l --- = deepIlxRepType r - deepIlxRepType (FunTy l r) = FunTy (deepIlxRepType l) (deepIlxRepType r) @@ -1097,42 +1090,22 @@ deepIlxRepType ty@(TyVarTy tv) = ty idIlxRepType id = deepIlxRepType (idType id) -------------------------- --- Function types and type functions are implicitly thunkable. -- Some primitive type constructors are not thunkable. -- Everything else needs to be marked thunkable. pprIlxTypeL :: IlxEnv -> Type -> SDoc -pprIlxTypeL env ty | isVoidIlxRepType ty - = trace "pprIlxTypeL: VoidRep" pprIlxTypeR env ty - -pprIlxTypeL env ty@(FunTy arg res) - = pprIlxTypeR env ty - -pprIlxTypeL env ty@(ForAllTy arg res) - = pprIlxTypeR env ty - -pprIlxTypeL env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && null (tyConTyVars tc) - = ilxComment (text "what the fuck?") <+> (pprIlxTypeR env ty) -pprIlxTypeL env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && not (isIlxTyVar (hd (tyConTyVars tc))) - = pprIlxTypeR env ty - -pprIlxTypeL env ty | isUnLiftedType ty -- must come after cases above because isUnLiftedType strips Forall's - = pprIlxTypeR env ty - -pprIlxTypeL env ty - = text "thunk" <> angleBrackets (pprIlxTypeR env ty) +pprIlxTypeL env ty | isUnLiftedType ty || isVoidIlxRepType ty = pprIlxTypeR env ty +pprIlxTypeL env ty = text "thunk" <> angleBrackets (pprIlxTypeR env ty) -------------------------- -- Print non-thunkable version of type. -- pprIlxTypeR :: IlxEnv -> Type -> SDoc -pprIlxTypeR env ty | isVoidIlxRepType ty = text "void" -pprIlxTypeR env ty = pprIlxTypeR2 env ty - -pprIlxTypeR2 env ty@(AppTy f _) | isTyVarTy f = ilxComment (text "type app:" <+> pprId ty) <+> (text "class [mscorlib]System.Object") -pprIlxTypeR2 env ty@(AppTy f x) = trace "pprIlxTypeR: should I be beta reducing types?!" (ilxComment (text "pprIlxTypeR: should I be beta reducing types...") <+> pprIlxTypeR env (applyTy f x)) -pprIlxTypeR2 env (TyVarTy tv) = pprIlxTyVar env tv +pprIlxTypeR env ty | isVoidIlxRepType ty = text "unit" +pprIlxTypeR env ty@(AppTy f _) | isTyVarTy f = ilxComment (text "type app:" <+> pprId ty) <+> (text "class [mscorlib]System.Object") +pprIlxTypeR env ty@(AppTy f x) = trace "pprIlxTypeR: should I be beta reducing types?!" (ilxComment (text "pprIlxTypeR: should I be beta reducing types...") <+> pprIlxTypeR env (applyTy f x)) +pprIlxTypeR env (TyVarTy tv) = pprIlxTyVar env tv -- The following is a special rule for types constructed out of -- higher kinds, e.g. Monad f or Functor f. @@ -1140,37 +1113,32 @@ pprIlxTypeR2 env (TyVarTy tv) = pprIlxTyVar env tv -- The code below is not as general as it should be, but as I -- have no idea if this approach will even work, I'm going to -- just try it out on some simple cases arising from the prelude. -pprIlxTypeR2 env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && null (tyConTyVars tc) +pprIlxTypeR env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && null (tyConTyVars tc) = ilxComment (text "what the fuck? 2") <+> (pprIlxTypeR env (TyConApp tc t)) -pprIlxTypeR2 env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && not (isIlxTyVar (hd (tyConTyVars tc))) +pprIlxTypeR env ty@(TyConApp tc (h:t)) | isAlgTyCon tc && not (isIlxTyVar (hd (tyConTyVars tc))) = pprIlxTypeR env (TyConApp tc t) -pprIlxTypeR2 env (TyConApp tc args) = pprIlxTyConApp env tc args +pprIlxTypeR env (TyConApp tc args) = pprIlxTyConApp env tc args -- nb. the only legitimate place for VoidIlxRepTypes to occur in normalized IlxRepTypes -- is on the left of an arrow -- We could probably eliminate all but a final occurrence of these. - --pprIlxTypeR2 env (FunTy arg res@(FunTy _ _)) | isVoidIlxRepType arg - -- = pprIlxTypeR env res -pprIlxTypeR2 env (FunTy arg res) | isVoidIlxRepType arg - = parens (text "func () -->" <+> pprIlxTypeR env res) -pprIlxTypeR2 env (FunTy arg res) +pprIlxTypeR env (FunTy arg res) = pprIlxFunTy (pprIlxTypeL env arg) (pprIlxTypeR env res) -pprIlxTypeR2 env ty@(ForAllTy tv body_ty) | isIlxTyVar tv +pprIlxTypeR env ty@(ForAllTy tv body_ty) | isIlxTyVar tv = parens (text "forall" <+> pprTyVarBinders env' [tv] <+> nest 2 (pprIlxTypeR env' body_ty)) where env' = extendIlxEnvWithFormalTyVars env [tv] -pprIlxTypeR2 env ty@(ForAllTy tv body_ty) | otherwise +pprIlxTypeR env ty@(ForAllTy tv body_ty) | otherwise = ilxComment (text "higher order type var " <+> pprId tv) <+> pprIlxFunTy (text "class [mscorlib]System.Object") (pprIlxTypeR env body_ty) -pprIlxTypeR2 env (NoteTy _ ty) +pprIlxTypeR env (NoteTy _ ty) = trace "WARNING! non-representation type given to pprIlxTypeR: see generated ILX for context where this occurs" (vcat [text "/* WARNING! non-representation type given to pprIlxTypeR! */", pprIlxTypeR env ty ]) - pprIlxFunTy dom ran = parens (hsep [text "func",parens dom,text "-->", ran]) pprIlxTyConApp env tc args = @@ -1393,23 +1361,20 @@ line = text "// ----------------------------------" hscOptionQual = if opt_SimplDoEtaReduction then text ".O" else text ".Onot" nameReference (IlxEnv (thisMod, _, _, _, _, _)) n - | isLocalName n = text "/* local */" + | isLocalName n = empty | thisMod == nameModule n = text "" - | isDllName n = brackets ((text "ilx") <+> singleQuotes (ppr (modulePackage (nameModule n)) <> hscOptionQual)) - | otherwise = brackets ((text ".module") <+> (text "ilx") <+> singleQuotes (pprModuleName (moduleName (nameModule n)) <> hscOptionQual)) + | isHomeModule (nameModule n) = moduleNameReference (moduleName (nameModule n)) + | isVanillaModule (nameModule n) = packageReference preludePackage + | otherwise = packageReference (modulePackage (nameModule n)) + +packageReference p = brackets ((text "ilx") <+> singleQuotes (ppr p <> hscOptionQual)) +moduleNameReference m = brackets ((text ".module") <+> (text "ilx") <+> singleQuotes (pprModuleName m <> hscOptionQual)) moduleReference (IlxEnv (thisMod, _, _, _, _, _)) m | thisMod == m = text "" - | isHomeModule m = brackets ((text ".module") <+> (text "ilx") <+> singleQuotes (pprModuleName (moduleName m) <> hscOptionQual)) - | otherwise = brackets ((text "ilx") <+> singleQuotes (ppr (modulePackage m) <> hscOptionQual)) - -prelGHCReference = - if preludePackage == opt_InPackage then brackets (text ".module ilx PrelGHC" <> hscOptionQual) - else brackets (text "ilx" <+> text (_UNPK_ preludePackage) <> hscOptionQual) - -prelBaseReference = - if preludePackage == opt_InPackage then brackets (text ".module ilx PrelBase" <> hscOptionQual) - else brackets (text "ilx" <+> text (_UNPK_ preludePackage) <> hscOptionQual) + | isHomeModule m = moduleNameReference (moduleName m) + | isVanillaModule m = packageReference preludePackage + | otherwise = packageReference (modulePackage m) ------------------------------------------------ -- This code is copied from absCSyn/CString.lhs, @@ -1574,55 +1539,28 @@ tyPrimConTable = listToUFM [(addrPrimTyConKey, (\_ _ -> repAddr)), \end{code} + %************************************************************************ %* * -\subsection{C Calls} +\subsection{PrimOps} %* * %************************************************************************ \begin{code} --- We eliminate voids in and around an IL C Call. We don't yet emit PInvoke stubs. --- We also do some type-directed translation for pinning Haskell-managed blobs --- of data as we throw them across the boundary. -ilxCCall env (CCall (StaticTarget c) casm gc cconv) args ret_ty = - ilxComment (text "C call <+> pprCLabelString c") <+> - vcat [vcat (ilxMapPlaceArgs 0 pushCArg env args), - text "call" <+> retdoc <+> text "class " <+> prelGHCReference <+> text "PrelGHC::" <+> pprCLabelString c <+> pprTypeArgs pprIlxTypeR env ty_args - <+> pprCValArgTys pprIlxTypeL env (map deepIlxRepType (filter (not. isVoidIlxRepType) (map stgArgType tm_args))) ] - where - retdoc = - if isVoidIlxRepType ret_ty then text "void" - else pprIlxTypeR env (deepIlxRepType ret_ty) - (ty_args,tm_args) = splitTyArgs1 args - - -hasTyCon (TyConApp tc _) tc2 = tc == tc2 -hasTyCon _ _ = False - -isByteArrayCArgTy ty = hasTyCon ty byteArrayPrimTyCon || hasTyCon ty mutableByteArrayPrimTyCon -isByteArrayCArg v = isByteArrayCArgTy (deepIlxRepType (idType v)) -pinCCallArg v = isByteArrayCArg v - -ilxAddrOfPinnedByteArr = text "ldc.i4 0 ldelema unsigned int8" - -pushCArg env arg@(StgVarArg v) | isByteArrayCArg v = pushArg env arg <+> text "dup stloc" <+> squotes (ilxEnvQualifyByExact env (ppr v) <> text "pin") <+> ilxAddrOfPinnedByteArr -pushCArg env arg | otherwise = pushArg env arg -pprCValArgTys f env tys = parens (pprSepWithCommas (pprCValArgTy f env) tys) -pprCValArgTy f env ty | isByteArrayCArgTy ty = text "void *" <+> ilxComment (text "interior pointer into ByteArr#") -pprCValArgTy f env ty | otherwise = f env ty +prelGHCReference = + if preludePackage == opt_InPackage then + brackets (text ".module ilx PrelGHC" <> hscOptionQual) + else brackets (text "ilx" <+> text (_UNPK_ preludePackage) <> hscOptionQual) -\end{code} -%************************************************************************ -%* * -\subsection{PrimOps} -%* * -%************************************************************************ +prelBaseReference = + if preludePackage == opt_InPackage then + brackets (text ".module ilx PrelBase" <> hscOptionQual) + else brackets (text "ilx" <+> text (_UNPK_ preludePackage) <> hscOptionQual) -\begin{code} ilxPrimApp env (CCallOp ccall) args ret_ty = ilxCCall env ccall args ret_ty ilxPrimApp env op args ret_ty = ilxPrimOpTable op env args @@ -1962,7 +1900,7 @@ ilxPrimOpTable op RaiseOp -> ty2_op (\ty1 ty2 -> text "throw") CatchOp -> ty2_op (\ty1 ty2 -> - text "call" <+> ilxSuppMeth ilxMethA "catch" [ty1,ty2] [text "(func () --> !!0)", text "(func (!!1) --> (func () --> !!0))"]) + text "call" <+> ilxSuppMeth ilxMethA "catch" [ty1,ty2] [text "(func (unit) --> !!0)", text "(func (!!1) --> (func (unit) --> !!0))"]) {- (State# RealWorld -> (# State# RealWorld, a #) ) -> (b -> State# RealWorld -> (# State# RealWorld, a #) ) -> State# RealWorld @@ -1970,14 +1908,14 @@ ilxPrimOpTable op -} BlockAsyncExceptionsOp -> ty1_op (\ty1 -> - text "call" <+> ilxSuppMeth ilxMethA "blockAsyncExceptions" [ty1] [text "(func () --> !!0)"]) + text "call" <+> ilxSuppMeth ilxMethA "blockAsyncExceptions" [ty1] [text "(func (unit) --> !!0)"]) {- (State# RealWorld -> (# State# RealWorld, a #)) -> (State# RealWorld -> (# State# RealWorld, a #)) -} UnblockAsyncExceptionsOp -> ty1_op (\ty1 -> - text "call" <+> ilxSuppMeth ilxMethA "unblockAsyncExceptions" [ty1] [text "(func () --> !!0)"]) + text "call" <+> ilxSuppMeth ilxMethA "unblockAsyncExceptions" [ty1] [text "(func (unit) --> !!0)"]) {- State# RealWorld -> (# State# RealWorld, a #)) @@ -1992,6 +1930,15 @@ ilxPrimOpTable op text "call" <+> ilxSuppMeth ilxMethA "takeMVar" [ty] [repMVar ilxMethA]) {- MVar# s a -> State# s -> (# State# s, a #) -} + -- These aren't yet right + TryTakeMVarOp -> ty2_op (\sty ty -> + text "call" <+> ilxSuppMeth ilxMethA "tryTakeMVar" [ty] [repMVar ilxMethA]) + {- MVar# s a -> State# s -> (# State# s, a #) -} + + TryPutMVarOp -> ty2_op (\sty ty -> + text "call" <+> ilxSuppMeth ilxMethA "tryPutMVar" [ty] [repMVar ilxMethA]) + {- MVar# s a -> State# s -> (# State# s, a #) -} + PutMVarOp -> ty2_op (\sty ty -> text "call" <+> ilxSuppMeth (text "void") "putMVar" [ty] [repMVar ilxMethA, ilxMethA]) {- MVar# s a -> a -> State# s -> State# s -} @@ -2028,7 +1975,7 @@ ilxPrimOpTable op {- o -> b -> c -> State# RealWorld -> (# State# RealWorld, Weak# b #) -} DeRefWeakOp -> ty1_op (\ty1 -> text "call" <+> ilxMethodRef (ilxUnboxedPairRep repInt (text "!0")) (repWeak ty1) "deref" [] []) - FinalizeWeakOp -> ty1_op (\ty1 -> text "call" <+> ilxMethodRef (ilxUnboxedPairRep repInt (text "(func () --> class '()')")) (repWeak ty1) "finalizer" [] []) + FinalizeWeakOp -> ty1_op (\ty1 -> text "call" <+> ilxMethodRef (ilxUnboxedPairRep repInt (text "(func (unit) --> class '()')")) (repWeak ty1) "finalizer" [] []) {- Weak# a -> State# RealWorld -> (# State# RealWorld, Int#, State# RealWorld -> (# State# RealWorld, Unit #)) #) -} @@ -2082,3 +2029,55 @@ hd2 (h:t) = h simp_op op env args = vcat (ilxMapPlaceArgs 0 pushArg env args) $$ op warn_op warning f args = trace ("WARNING! IlxGen cannot translate primop " ++ warning) (f args) \end{code} + +%************************************************************************ +%* * +\subsection{C Calls} +%* * +%************************************************************************ + +\begin{code} + +-- We eliminate voids in and around an IL C Call. We don't yet emit PInvoke stubs. +-- We also do some type-directed translation for pinning Haskell-managed blobs +-- of data as we throw them across the boundary. +ilxCCall env (CCall (StaticTarget c) casm gc cconv) args ret_ty = + ilxComment (text "C call <+> pprCLabelString c") <+> + vcat [vcat (ilxMapPlaceArgs 0 pushCArg env args), + text "call" <+> retdoc <+> text "class " <+> prelGHCReference <+> text "PrelGHC::" <+> pprCLabelString c <+> pprTypeArgs pprIlxTypeR env ty_args + <+> pprCValArgTys pprIlxTypeL env (map deepIlxRepType (filter (not. isVoidIlxRepType) (map stgArgType tm_args))) ] + where + retdoc = + if isVoidIlxRepType ret_ty then text "void" + else pprIlxTypeR env (deepIlxRepType ret_ty) + (ty_args,tm_args) = splitTyArgs1 args + + +hasTyCon (TyConApp tc _) tc2 = tc == tc2 +hasTyCon _ _ = False + +isByteArrayCArgTy ty = hasTyCon ty byteArrayPrimTyCon || hasTyCon ty mutableByteArrayPrimTyCon +isByteArrayCArg v = isByteArrayCArgTy (deepIlxRepType (idType v)) +pinCCallArg v = isByteArrayCArg v + +ilxAddrOfPinnedByteArr = text "ldc.i4 0 ldelema unsigned int8" + +pushCArg env arg@(StgVarArg v) | isByteArrayCArg v = pushArg env arg <+> text "dup stloc" <+> squotes (ilxEnvQualifyByExact env (ppr v) <> text "pin") <+> ilxAddrOfPinnedByteArr +pushCArg env arg | otherwise = pushArg env arg + +pprCValArgTys f env tys = parens (pprSepWithCommas (pprCValArgTy f env) tys) +pprCValArgTy f env ty | isByteArrayCArgTy ty = text "void *" <+> ilxComment (text "interior pointer into ByteArr#") +pprCValArgTy f env ty | otherwise = f env ty + + +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/ghc/compiler/ilxGen/tests/Makefile b/ghc/compiler/ilxGen/tests/Makefile index 115c0f4..03765c8 100644 --- a/ghc/compiler/ilxGen/tests/Makefile +++ b/ghc/compiler/ilxGen/tests/Makefile @@ -1,4 +1,3 @@ -include ../../../lib/std/Makefile.src # These settings are if you use a visual studio build CVS=cvs @@ -6,236 +5,75 @@ CORENV_DEBUG= CORENV_RETAIL= LOCALRUN=./ ILX_FAST=x -ifeq ($(HOSTNAME),msrc-hilda) -CORENV_DEBUG="call devvsnearerb1gen.bat" -CORENV_RETAIL="call devvsnearerb1gen.bat retail" +ifeq ($(HOSTNAME),MSRC-HILDA) +CORENV_DEBUG="call devcorb2gen.bat fastchecked" +CORENV_RETAIL="call devcorb2gen.bat free" LOCALRUN=.\\ ILX_FAST= endif -ILXASM_HOME=C:/devel/fcom/src -ILXASM=$(ILXASM_HOME)/bin/ilxasm$(ILX_FAST).exe -ILVALID=$(ILXASM_HOME)/bin/ilvalid$(ILX_FAST).exe -ILXASM_FLAGS=-l $(ILXASM_HOME)/ilxasm --no-ilasm --tailcall-indirect +ILX2IL_HOME=C:/devel/fcom/src +ILX2IL=$(ILX2IL_HOME)/bin/ilx2il.opt.exe +ILVALID=$(ILX2IL_HOME)/bin/ilvalid.opt.exe ghc: - $(MAKE) -C ../.. ghc + $(MAKE) -C ../.. -ilxasm: - $(MAKE) -C $(ILXASM_HOME) bin/ilxasm.exe +ilx: + $(MAKE) -C $(ILX2IL_HOME) ilxdefault -ilxasmx: - $(MAKE) -C $(ILXASM_HOME) bin/ilxasmx.exe - -ilvalid: - $(MAKE) -C $(ILXASM_HOME) bin/ilvalid.exe - -ilvalidx: - $(MAKE) -C $(ILXASM_HOME) bin/ilvalidx.exe - -prel: - $(MAKE) -C ../../../lib/std ilxasm std.Onot.nongeneric.boxed.dll - $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.nongeneric.boxed.dll - -prelq: - $(MAKE) -C ../../../lib/std ilxasm std.Onot.nongeneric.boxed.trial.dll - $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.nongeneric.boxed.trial.dll - -oprel: - $(MAKE) -C ../../../lib/std ilxasm std.O.nongeneric.boxed.dll - $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.nongeneric.boxed.dll - -oprelq: - $(MAKE) -C ../../../lib/std ilxasm std.O.nongeneric.boxed.trial.dll - $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.nongeneric.boxed.trial.dll - -tprel: - $(MAKE) -C ../../../lib/std ilxasm std.Onot.nongeneric.boxed.traced.dll - $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.nongeneric.boxed.traced.dll - -otprel: - $(MAKE) -C ../../../lib/std ilxasm std.O.nongeneric.boxed.traced.dll - $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.nongeneric.boxed.traced.dll - -#gprel: -# $(MAKE) -C ../../../lib/std ilxasm std.Onot.generic.dll -# $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.generic.dll -# -#ogprel: -# $(MAKE) -C ../../../lib/std ilxasm std.O.generic.dll -# $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.generic.dll -# -#gtprel: -# $(MAKE) -C ../../../lib/std ilxasm std.Onot.generic.traced.dll -# $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.generic.traced.dll - -vgprel: - $(MAKE) -C ../../../lib/std ilxasm std.Onot.vmeth-erased.generic.dll - $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.vmeth-erased.generic.dll - -ovgprel: - $(MAKE) -C ../../../lib/std ilxasm std.O.vmeth-erased.generic.dll - $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.vmeth-erased.generic.dll - -ovgprelq: - $(MAKE) -C ../../../lib/std ilxasm std.O.vmeth-erased.generic.trial.dll - $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.vmeth-erased.generic.trial.dll - -vgtprel: - $(MAKE) -C ../../../lib/std ilxasm std.Onot.vmeth-erased.generic.traced.dll - $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.vmeth-erased.generic.traced.dll - -ovgtprel: - $(MAKE) -C ../../../lib/std ilxasm std.O.vmeth-erased.generic.traced.dll - $(MAKE) -C $(ILXASM_HOME) bin/msilxlib.vmeth-erased.generic.traced.dll +prel: ilx + $(MAKE) -C ../../../lib/std std.Onot.mono-b2.dll %.o: %.hs ../../ghc-4.11 ../../ghc-inplace -o $@ -c $*.hs -std_NONGENERIC_STATIC_IL=$(patsubst %.lhs,../../../lib/std/%.nongeneric.boxed.static.il,$(std_SRC)) ../../../lib/std/PrelGHC.nongeneric.boxed.static.il -std_GENERIC_STATIC_IL=$(patsubst %.lhs,../../../lib/std/%.generic.static.il,$(std_SRC)) ../../../lib/std/PrelGHC.generic.static.il - #======================================================================== # 1. From Haskell to ILX %.Onot.ilx: %.hs ../../ghc-4.11 - ../../ghc-inplace -c -fglasgow-exts -o $@ -i../../../lib/std/.Onot -Onot -filx $*.hs -osuf Onot.ilx + ../../ghc-inplace -c -fglasgow-exts -o $@ -i../../../lib/std/.Onot -Onot -filx -fkeep-stg-types $*.hs -osuf Onot.ilx %.O.ilx: %.hs ../../ghc-4.11 - ../../ghc-inplace -c -fglasgow-exts -o $@ -i../../../lib/std/.O -O -filx $*.hs -osuf O.ilx + ../../ghc-inplace -c -fglasgow-exts -o $@ -i../../../lib/std/.O -O -filx -fkeep-stg-types $*.hs -osuf O.ilx ../Entry.Onot.ilx: ../Entry.ilx sed -e "s|ilx std|ilx std.Onot|g" ../Entry.ilx > $@.tmp mv $@.tmp $@ -%.Onot.dlllib.ilx: %.Onot.ilx ../Entry.Onot.ilx - cat ../Entry.Onot.ilx $*.Onot.ilx > $@.tmp - mv $@.tmp $@ - ../Entry.O.ilx: ../Entry.ilx sed -e "s|ilx std|ilx std.O|g" ../Entry.ilx > $@.tmp mv $@.tmp $@ -%.O.dlllib.ilx: %.O.ilx ../Entry.O.ilx - cat ../Entry.O.ilx $*.O.ilx > $@.tmp - mv $@.tmp $@ - -HSstd_cbits.dll: ../../../lib/std/cbits/HSstd_cbits.dll - cp $< $@ - #======================================================================== # 2. From ILX to IL -#------------------------------------------------------------------------ -# Compile for a vanilla VM against a vanilla library organised as a -# seperate assembly/DLL. - -%.nongeneric.boxed.dlllib.il: $(ILXASM) %.dlllib.ilx - $(ILXASM) --box-everything --no-stdlib $(ILXASM_FLAGS) -o $@.tmp $*.dlllib.ilx - mv $@.tmp $@ - -#------------------------------------------------------------------------ -# Same -# - running a trial optimization -# - for traced code on a vanilla VM -%.nongeneric.boxed.trial.dlllib.il: $(ILXASM) %.dlllib.ilx - $(ILXASM) --trial-opt --box-everything --no-stdlib $(ILXASM_FLAGS) -o $@.tmp $*.dlllib.ilx +%.generic.il: $(ILX2IL) %.ilx + $(ILX2IL) --generic $(ILX2IL_FLAGS) -o $@.tmp $*.ilx mv $@.tmp $@ -%.nongeneric.boxed.traced.dlllib.il: $(ILXASM) %.dlllib.ilx - $(ILXASM) --box-everything --trace-il --no-stdlib $(ILXASM_FLAGS) -o $@.tmp $*.dlllib.ilx +%.mono.il: $(ILX2IL) %.ilx + $(ILX2IL) --mono $(ILX2IL_FLAGS) -o $@.tmp $*.ilx mv $@.tmp $@ #------------------------------------------------------------------------ -# Same, for a generic library and generic VM - -%.generic.dlllib.il: $(ILXASM) %.dlllib.ilx - $(ILXASM) --no-pp --no-stdlib $(ILXASM_FLAGS) -o $@.tmp $*.dlllib.ilx - mv $@.tmp $@ - -%.generic.trial.dlllib.il: $(ILXASM) %.dlllib.ilx - $(ILXASM) --trial-opt --no-pp --no-stdlib $(ILXASM_FLAGS) -o $@.tmp $*.dlllib.ilx - mv $@.tmp $@ - -%.generic.traced.dlllib.il: $(ILXASM) %.dlllib.ilx - $(ILXASM) --trace-il --no-pp --no-stdlib $(ILXASM_FLAGS) -o $@.tmp $*.dlllib.ilx - mv $@.tmp $@ - -%.vmeth-erased.generic.dlllib.il: $(ILXASM) %.dlllib.ilx - $(ILXASM) --poly-virtual-method-erase --no-pp --no-stdlib $(ILXASM_FLAGS) -o $@.tmp $*.dlllib.ilx - mv $@.tmp $@ - -%.vmeth-erased.generic.trial.dlllib.il: $(ILXASM) %.dlllib.ilx - $(ILXASM) --trial-opt --poly-virtual-method-erase --no-pp --no-stdlib $(ILXASM_FLAGS) -o $@.tmp $*.dlllib.ilx - mv $@.tmp $@ - -%.vmeth-erased.generic.traced.dlllib.il: $(ILXASM) %.dlllib.ilx - $(ILXASM) --poly-virtual-method-erase --trace-il --no-pp --no-stdlib $(ILXASM_FLAGS) -o $@.tmp $*.dlllib.ilx - mv $@.tmp $@ - - -#------------------------------------------------------------------------ -# Compile for a vanilla VM against a vanilla library compiled to IL code -# to be statically linked as one big module. We hack this up by textually -# stripping out all the assembly qualifications (apart from mscorlib) -# from the ILX forward files and IL code itself. We then just -# concatenate all the IL code together and compile it as a single .EXE. - -%.staticlib.ilx: %.ilx ../Entry.ilx - cat ../Entry.ilx $*.ilx | \ - sed -e "sQ\[std\]QQg" | \ - sed -e "sQ\['std'\]QQg" > $@.tmp - cat $@.tmp > $@.tmp2 - mv $@.tmp2 $@ - rm $@.tmp - - -%.generic.staticlib.il: $(ILXASM) %.staticlib.ilx - $(ILXASM) --static --no-pp $(ILXASM_FLAGS) -o $@.tmp $*.staticlib.ilx - cat $(std_GENERIC_STATIC_IL) $@.tmp > $@.tmp2 - mv $@.tmp2 $@ - rm $@.tmp - - -%.nongeneric.boxed.staticlib.il: $(ILXASM) %.staticlib.ilx - $(ILXASM) --box-everything --static $(ILXASM_FLAGS) -o $@.tmp $*.staticlib.ilx - cat $(std_NONGENERIC_STATIC_IL) $@.tmp > $@.tmp2 - mv $@.tmp2 $@ - rm $@.tmp - - -#------------------------------------------------------------------------ -# For compiling test cases that don't use the standard library at all. - -%.nolib.ilx: %.ilx PrelBase.test.ilx ../PrelGHC.ilx ../Entry.ilx - cat ../PrelGHC.ilx PrelBase.test.ilx ../Entry.ilx $*.ilx > $@.tmp - mv $@.tmp $@ - -%.nolib.il: $(ILXASM) $(ILXASM_HOME)/ilxasm/stdlib-func-by-mcalli.ilx %.nolib.ilx - $(ILXASM) $(ILXASM_FLAGS) -o $@.tmp $*.nolib.ilx - mv $@.tmp $@ - -%.nolib.traced.il: $(ILXASM) $(ILXASM_HOME)/ilxasm/stdlib-func-by-mcalli.ilx %.nolib.ilx - $(ILXASM) --trace-il $(ILXASM_FLAGS) $*.nolib.ilx > $@.tmp - mv $@.tmp $@ - - -#------------------------------------------------------------------------ # From IL to .EXE -%.retail.exe: %.il ../Entry.Onot.mono.il - cat %.il ../Entry.Onot.mono.il > $@.tmp +%.generic.exe: %.generic.il ../Entry.Onot.generic.il + cat $*.generic.il ../Entry.Onot.generic.il > $@.tmp echo "$(CORENV_RETAIL)" > $@.bat - echo "ilasm -exe -quiet -out=$(subst /,\\,$@.tmp) $(subst /,\\,$<)" >> $@.bat + echo "ilasm /exe /quiet /out=$(subst /,\\,$@.tmp) $(subst /,\\,$@.tmp)" >> $@.bat time -p cmd /c $(subst /,\\,$@).bat rm $@.bat -%.debug.exe: %.il +%.mono.exe: %.mono.il ../Entry.Onot.mono.il + cat $*.mono.il ../Entry.Onot.mono.il > $@.tmp echo "$(CORENV_RETAIL)" > $@.bat - echo "ilasm -exe -quiet -debug -out=$(subst /,\\,$@) $(subst /,\\,$<)" >> $@.bat + echo "ilasm /exe /quiet /out=$(subst /,\\,$@.tmp) $(subst /,\\,$@.tmp)" >> $@.bat time -p cmd /c $(subst /,\\,$@).bat rm $@.bat + #------------------------------------------------------------------------ # From .HS to .EXE without using ILX # Used to run performance comparisons against native code GHC @@ -246,25 +84,25 @@ HSstd_cbits.dll: ../../../lib/std/cbits/HSstd_cbits.dll %.O.exe: %.hs ghc -O -o $@ $< -%.o: %.hs ../../hsc.exe - ../../../driver/ghc-inplace -o $@ -c $*.hs - %.run: %.exe time -p $< #------------------------------------------------------------------------ # Running: -%.debug.run: HSstd_cbits.dll %.debug.exe +HSstd_cbits.dll: ../../../lib/std/cbits/HSstd_cbits.dll + cp $< $@ + +%.debug.run: HSstd_cbits.dll %.exe echo "$(CORENV_DEBUG)" > $@.bat - echo "set CORPATH=$(subst /,\\,$(ILXASM_HOME))\\bin;\\GHC\\fptools\\ghc\\lib\\std;%CORPATH%" >> $@.bat + echo "set CORPATH=$(subst /,\\,$(ILX2IL_HOME))\\bin;\\GHC\\fptools\\ghc\\lib\\std;%CORPATH%" >> $@.bat echo "$(LOCALRUN)$(subst /,\\,$*).debug.exe 2>&1" >> $@.bat time -p cmd /c $(subst /,\\,$@).bat rm $@.bat -%.retail.run: HSstd_cbits.dll %.retail.exe +%.retail.run: HSstd_cbits.dll %.exe echo "$(CORENV_RETAIL)" > $@.bat - echo "set CORPATH=$(subst /,\\,$(ILXASM_HOME))\\bin;\\GHC\\fptools\\ghc\\lib\\std;%CORPATH%" >> $@.bat + echo "set CORPATH=$(subst /,\\,$(ILX2IL_HOME))\\bin;\\GHC\\fptools\\ghc\\lib\\std;%CORPATH%" >> $@.bat echo "$(LOCALRUN)$(subst /,\\,$*).retail.exe 2>&1" >> $@.bat time -p cmd /c $(subst /,\\,$@).bat rm $@.bat @@ -274,32 +112,21 @@ HSstd_cbits.dll: ../../../lib/std/cbits/HSstd_cbits.dll time -p $< - #-------------------- -%.debug.exe: %.nolib.il - echo "$(CORENV_RETAIL)" > $@.bat - echo "$(CORENV_RETAIL)ilasm /DEBUG /OUT=$(subst /,\\,$@) $(subst /,\\,$<)" >> $@.bat - time -p cmd /c $(subst /,\\,$@).bat - rm $@.bat - -%.trace-il.nolib.il: $(ILXASM) $(ILXASM_HOME)/ilxasm/stdlib-func-by-mcalli.ilx %.nolib.ilx - $(ILXASM) $(ILXASM_FLAGS) --trace-il $*.nolib.ilx > $@.tmp - mv $@.tmp $@ - %.mvl: %.nolib.il - ILVALID_HOME=$(ILXASM_HOME) $(ILVALID) $*.nolib.il + ILVALID_HOME=$(ILX2IL_HOME) $(ILVALID) $*.nolib.il ci: - (cd $(ILXASM_HOME); $(CVS) ci -m "") + (cd $(ILX2IL_HOME); $(CVS) ci -m "") (cd ../..; cvs ci -m "") (cd ../../../lib/std; $(CVS) ci -m "") upd: - (cd $(ILXASM_HOME); $(CVS) up) + (cd $(ILX2IL_HOME); $(CVS) up) (cd ../..; $(CVS) up) (cd ../../../lib/std; $(CVS) up) -.PRECIOUS: %.nongeneric.boxed.dlllib.il %.generic.dlllib.il %.generic.il %.nolib.il %.Onot.ilx %.O.ilx %.nolib.ilx %.dlllib.ilx %.exe %.debug.exe %.dll %.O.exe +.PRECIOUS: %.mono-nonstatic.il %.fullgeneric-nonstatic.il %.fullgeneric.il %.nolib.il %.Onot.ilx %.O.ilx %.nolib.ilx %-nonstatic.ilx %.exe %.debug.exe %.dll %.O.exe .PHONY: %.run diff --git a/ghc/compiler/ilxGen/tests/test1.hs b/ghc/compiler/ilxGen/tests/test1.hs index 158c2a7..2c0c8fb 100644 --- a/ghc/compiler/ilxGen/tests/test1.hs +++ b/ghc/compiler/ilxGen/tests/test1.hs @@ -1,89 +1 @@ --- To start: --- source /bin/devghc - --- To compile GHC --- make ilxGen/IlxGen.o hsc - --- To compile ILXASM --- (cd /devel/fcom/src; make bin/ilxasm.exe) - --- To compile to ILX --- (cd ilxGen/tests; ../../../driver/ghc-inplace --ilx test.hs) - - - --- To generate a complete ILX file, including preludes for GHC and ILX: --- (cd ilxGen/tests/; cat prelude.ilx test.ilx /devel/fcom/src/ilxasm/stdlib-func.ilx > test.full.ilx) - --- Run ILXASM to get a IL --- ( cd ilxGen/tests/; /devel/fcom/src/bin/ilxasm.exe --no-ilasm --no-stdlib test.full.ilx > test.il) - --- To compile IL to .EXE or .DLL: --- With build of VS (e.g. Don & Andrew) --- ( cd ilxGen/tests/; cmd /C "c:\\bin\\devvs.bat && ilasm test.il") --- With Lightning SDK, where env. variables are on path (e.g. Reuben): --- ( cd ilxGen/tests/; ilasm test.il) - --- To validate .EXE: --- (cd /devel/fcom/src; make bin/ilvalid.exe mscorlib.vlb) --- (export ILVALID_HOME=/devel/fcom/src; cd ilxGen/tests/; /devel/fcom/src/bin/ilvalid.exe test.il) - --- To run unverifiable code: --- With build of VS (e.g. Don & Andrew) --- (cd ilxGen/tests/; cmd /C "c:\\bin\\devvs.bat && .\test.exe") --- With Lightning SDK, where env. variables are on path (e.g. Reuben): --- (cd ilxGen/tests/; ./test.exe) - --- To compile ILX to verifiable code and verify --- (cd /devel/fcom/src; make bin/ilxasm.exe bin/ilverify.exe) && (cd ilxGen/tests/; export ILVALID_HOME=/devel/fcom/src; cat prelude.ilx test.ilx /devel/fcom/src/assem/stdlib-func.ilx > test.full.ilx && cd ilxGen/tests/; /devel/fcom/src/bin/ilxasm.exe --no-ilasm test.full.ilx > test.safe.il && /devel/fcom/src/bin/ilverify.exe test.safe.il) - --- (cd ilxGen/tests/; cmd /C "c:\\bin\\devvs.bat && .\test.safe.exe") - ---append:: [Char] -> [Char] -> [Char] ---append [] l2 = l2 ---append (h:t) l2 = h:append t l2 - -data N = Z | S N - -chooseN n = - case n of - Z -> "even\n" - S Z -> "odd\n" - S (S m) -> chooseN m - -add n m = - case n of - Z -> m - S nn -> S (add nn m) - -mul n m = - case n of - Z -> Z - S nn -> add m (mul nn m) - -pow n m = - case m of - Z -> S Z - S mm -> mul n (pow n mm) - -sq n = mul n n - -n1 = S Z -n2 = add n1 n1 -n4 = add n2 n2 -n6 = add n2 n4 -n8 = add n2 n6 -n10 = add n2 n8 -n16 = add n6 n10 -n17 = add n1 n16 -n18 = add n8 n10 -n19 = add n1 n18 -n20 = add n4 n16 - -bign = pow n2 n20 -bign1 = add bign n1 - -main = putStr (chooseN bign1) - - - +main = putStr "Hello world.\n" diff --git a/ghc/compiler/ilxGen/tests/test15.hs b/ghc/compiler/ilxGen/tests/test15.hs index 2dc494c..3e522d7 100644 --- a/ghc/compiler/ilxGen/tests/test15.hs +++ b/ghc/compiler/ilxGen/tests/test15.hs @@ -2,8 +2,6 @@ {-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-} -module Foo where - import PrelBase import PrelList import PrelEnum diff --git a/ghc/compiler/ilxGen/tests/test2.hs b/ghc/compiler/ilxGen/tests/test2.hs index 2c0c8fb..7b86e6f 100644 --- a/ghc/compiler/ilxGen/tests/test2.hs +++ b/ghc/compiler/ilxGen/tests/test2.hs @@ -1 +1,88 @@ -main = putStr "Hello world.\n" +-- To start: +-- source /bin/devghc + +-- To compile GHC +-- make ilxGen/IlxGen.o hsc + +-- To compile ILXASM +-- (cd /devel/fcom/src; make bin/ilxasm.exe) + +-- To compile to ILX +-- (cd ilxGen/tests; ../../../driver/ghc-inplace --ilx test.hs) + + + +-- To generate a complete ILX file, including preludes for GHC and ILX: +-- (cd ilxGen/tests/; cat prelude.ilx test.ilx /devel/fcom/src/ilxasm/stdlib-func.ilx > test.full.ilx) + +-- Run ILXASM to get a IL +-- ( cd ilxGen/tests/; /devel/fcom/src/bin/ilxasm.exe --no-ilasm --no-stdlib test.full.ilx > test.il) + +-- To compile IL to .EXE or .DLL: +-- With build of VS (e.g. Don & Andrew) +-- ( cd ilxGen/tests/; cmd /C "c:\\bin\\devvs.bat && ilasm test.il") +-- With Lightning SDK, where env. variables are on path (e.g. Reuben): +-- ( cd ilxGen/tests/; ilasm test.il) + +-- To validate .EXE: +-- (cd /devel/fcom/src; make bin/ilvalid.exe mscorlib.vlb) +-- (export ILVALID_HOME=/devel/fcom/src; cd ilxGen/tests/; /devel/fcom/src/bin/ilvalid.exe test.il) + +-- To run unverifiable code: +-- With build of VS (e.g. Don & Andrew) +-- (cd ilxGen/tests/; cmd /C "c:\\bin\\devvs.bat && .\test.exe") +-- With Lightning SDK, where env. variables are on path (e.g. Reuben): +-- (cd ilxGen/tests/; ./test.exe) + +-- To compile ILX to verifiable code and verify +-- (cd /devel/fcom/src; make bin/ilxasm.exe bin/ilverify.exe) && (cd ilxGen/tests/; export ILVALID_HOME=/devel/fcom/src; cat prelude.ilx test.ilx /devel/fcom/src/assem/stdlib-func.ilx > test.full.ilx && cd ilxGen/tests/; /devel/fcom/src/bin/ilxasm.exe --no-ilasm test.full.ilx > test.safe.il && /devel/fcom/src/bin/ilverify.exe test.safe.il) + +-- (cd ilxGen/tests/; cmd /C "c:\\bin\\devvs.bat && .\test.safe.exe") + +--append:: [Char] -> [Char] -> [Char] +--append [] l2 = l2 +--append (h:t) l2 = h:append t l2 + +data N = Z | S N + +chooseN n = + case n of + Z -> "even\n" + S Z -> "odd\n" + S (S m) -> chooseN m + +add n m = + case n of + Z -> m + S nn -> S (add nn m) + +mul n m = + case n of + Z -> Z + S nn -> add m (mul nn m) + +pow n m = + case m of + Z -> S Z + S mm -> mul n (pow n mm) + +sq n = mul n n + +n1 = S Z +n2 = add n1 n1 +n4 = add n2 n2 +n6 = add n2 n4 +n8 = add n2 n6 +n10 = add n2 n8 +n16 = add n6 n10 +n17 = add n1 n16 +n18 = add n8 n10 +n19 = add n1 n18 +n20 = add n4 n16 + +bign = pow n2 n20 +bign1 = add bign n1 + +main = putStr (chooseN bign1) + + -- 1.7.10.4