From e5e652c0c97a7a83b2b15c19cdf33c19949dcc1f Mon Sep 17 00:00:00 2001 From: paende Date: Wed, 20 Oct 2010 12:29:09 +0000 Subject: [PATCH] merged with trunk --- EHC/Makefile | 6 +- EHC/SVNREVISION | 2 +- EHC/VERSION | 2 +- EHC/configure | 109 +- EHC/configure.ac | 27 +- EHC/ehclib/base/Prelude.hs | 6 +- EHC/ehclib/base/System/CPUTime.hsc | 2 + EHC/ehclib/base/System/Console/GetOpt.hs | 2 + EHC/ehclib/base/System/Environment.hs | 1 + EHC/ehclib/filepath/System/FilePath.hs | 1 + EHC/ehclib/filepath/System/FilePath/Posix.hs | 1 + EHC/ehclib/files2.mk | 13 +- EHC/ehclib/haskell98/CError.hs | 1 + EHC/ehclib/haskell98/CForeign.hs | 1 + EHC/ehclib/haskell98/CPUTime.hs | 1 + EHC/ehclib/haskell98/CString.hs | 1 + EHC/ehclib/haskell98/CTypes.hs | 1 + EHC/ehclib/haskell98/Directory.hs | 1 + EHC/ehclib/haskell98/ForeignPtr.hs | 1 + EHC/ehclib/haskell98/IO.hs | 49 +- EHC/ehclib/haskell98/Int.hs | 1 + EHC/ehclib/haskell98/Locale.hs | 1 + EHC/ehclib/haskell98/MarshalAlloc.hs | 1 + EHC/ehclib/haskell98/MarshalArray.hs | 1 + EHC/ehclib/haskell98/MarshalError.hs | 1 + EHC/ehclib/haskell98/MarshalUtils.hs | 1 + EHC/ehclib/haskell98/Ptr.hs | 2 + EHC/ehclib/haskell98/Random.hs | 1 + EHC/ehclib/haskell98/StablePtr.hs | 1 + EHC/ehclib/haskell98/Storable.hs | 1 + EHC/ehclib/haskell98/System.hs | 1 + EHC/ehclib/haskell98/Time.hs | 1 + EHC/ehclib/haskell98/Word.hs | 1 + EHC/ehclib/uhcbase/Data/Int.hs | 1 + EHC/ehclib/uhcbase/Data/Typeable.hs | 4 + EHC/ehclib/uhcbase/Data/Word.hs | 1 + EHC/ehclib/uhcbase/Foreign.hs | 1 + EHC/ehclib/uhcbase/Foreign/C.hs | 1 + EHC/ehclib/uhcbase/Foreign/C/Error.hs | 1 + EHC/ehclib/uhcbase/Foreign/C/String.hs | 1 + EHC/ehclib/uhcbase/Foreign/C/Types.hs | 1 + EHC/ehclib/uhcbase/Foreign/ForeignPtr.hs | 1 + EHC/ehclib/uhcbase/Foreign/Marshal.hs | 1 + EHC/ehclib/uhcbase/Foreign/Marshal/Alloc.hs | 1 + EHC/ehclib/uhcbase/Foreign/Marshal/Array.hs | 1 + EHC/ehclib/uhcbase/Foreign/Marshal/Error.hs | 1 + EHC/ehclib/uhcbase/Foreign/Marshal/Pool.hs | 1 + EHC/ehclib/uhcbase/Foreign/Marshal/Utils.hs | 1 + EHC/ehclib/uhcbase/Foreign/Ptr.hs | 1 + EHC/ehclib/uhcbase/Foreign/StablePtr.hs | 1 + EHC/ehclib/uhcbase/Foreign/Storable.hs | 1 + EHC/ehclib/uhcbase/System/IO.hs | 1 + EHC/ehclib/uhcbase/System/Posix/Internals.hs | 1 + EHC/ehclib/uhcbase/System/Posix/Types.hs | 1 + EHC/ehclib/uhcbase/UHC/Base.chs | 233 ++-- EHC/ehclib/uhcbase/UHC/ByteArray.chs | 23 +- EHC/ehclib/uhcbase/UHC/Conc.chs | 1 + EHC/ehclib/uhcbase/UHC/ForeignPtr.chs | 1 + EHC/ehclib/uhcbase/UHC/Handle.chs | 1 + EHC/ehclib/uhcbase/UHC/IO.chs | 1 + EHC/ehclib/uhcbase/UHC/IOBase.chs | 21 +- EHC/ehclib/uhcbase/UHC/Int.chs | 1 + EHC/ehclib/uhcbase/UHC/OldIO.chs | 51 +- EHC/ehclib/uhcbase/UHC/Run.chs | 9 +- EHC/ehclib/uhcbase/UHC/StablePtr.chs | 1 + EHC/ehclib/uhcbase/UHC/Storable.chs | 1 + EHC/ehclib/uhcbase/UHC/Word.chs | 1 + EHC/mk/config.mk.in | 10 +- EHC/mk/shared.mk.in | 10 +- EHC/src/ehc/AbstractCore.chs | 6 + EHC/src/ehc/AbstractCore/Utils.chs | 7 +- EHC/src/ehc/AnaDomain/Utils.chs | 15 +- EHC/src/ehc/Base/Common.chs | 83 +- EHC/src/ehc/Base/GenJavaLike.chs | 248 ++++ EHC/src/ehc/Base/HsName.chs | 138 ++- EHC/src/ehc/Base/Optimize.chs | 8 +- EHC/src/ehc/Base/Pragma.chs | 43 +- EHC/src/ehc/BuiltinPrims.chs | 8 +- EHC/src/ehc/Config.chs.in | 35 +- EHC/src/ehc/Core.cag | 82 +- EHC/src/ehc/Core/AbsSyn.cag | 22 +- EHC/src/ehc/Core/CommonCtxtPred.cag | 8 +- EHC/src/ehc/Core/CommonJavaLike.cag | 193 +++ EHC/src/ehc/Core/FFI.chs | 6 +- EHC/src/ehc/Core/ModAsMap.cag | 78 ++ EHC/src/ehc/Core/Parser.chs | 2 +- EHC/src/ehc/Core/Pretty.cag | 25 +- EHC/src/ehc/Core/ToJScript.cag | 1052 +++++++++++++++++ EHC/src/ehc/Core/ToJazy.cag | 502 ++------ EHC/src/ehc/Core/Trf.chs | 13 +- EHC/src/ehc/Core/Trf/AnaRelevance.cag | 97 +- EHC/src/ehc/Core/Trf/RenUniq.cag | 187 ++- EHC/src/ehc/Core/Utils.chs | 112 +- EHC/src/ehc/EH/InferClass.cag | 3 +- EHC/src/ehc/EH/ToCore.cag | 2 +- EHC/src/ehc/EHC.chs | 15 +- EHC/src/ehc/EHC/Common.chs | 58 +- EHC/src/ehc/EHC/CompilePhase/Cleanup.chs | 35 +- EHC/src/ehc/EHC/CompilePhase/CompileC.chs | 40 +- .../ehc/EHC/CompilePhase/CompileJScript.chs | 87 ++ EHC/src/ehc/EHC/CompilePhase/CompileLLVM.chs | 2 +- EHC/src/ehc/EHC/CompilePhase/Link.chs | 2 + EHC/src/ehc/EHC/CompilePhase/Output.chs | 32 +- .../ehc/EHC/CompilePhase/TopLevelPhases.chs | 165 ++- .../ehc/EHC/CompilePhase/TransformGrin.chs | 5 +- EHC/src/ehc/EHC/CompilePhase/Translations.chs | 35 +- EHC/src/ehc/EHC/CompileRun.chs | 2 +- EHC/src/ehc/EHC/CompileUnit.chs | 30 +- EHC/src/ehc/EHC/GrinCompilerDriver.chs | 4 +- EHC/src/ehc/Foreign.cag | 13 +- EHC/src/ehc/Foreign/AbsSyn.cag | 13 +- EHC/src/ehc/Foreign/Extract.cag | 15 +- EHC/src/ehc/Foreign/Parser.chs | 9 +- EHC/src/ehc/Foreign/Pretty.cag | 3 + EHC/src/ehc/GrinByteCode/ToC.cag | 2 +- EHC/src/ehc/GrinCode/Trf/EvalElim.cag | 4 +- EHC/src/ehc/HS/AbsSyn.cag | 3 + EHC/src/ehc/HS/ModImpExp.cag | 2 + EHC/src/ehc/HS/Parser.chs | 3 +- EHC/src/ehc/HS/Pragmas.cag | 3 + EHC/src/ehc/HS/Pretty.cag | 2 + EHC/src/ehc/JScript.cag | 54 + EHC/src/ehc/JScript/AbsSyn.cag | 113 ++ EHC/src/ehc/JScript/Pretty.cag | 112 ++ EHC/src/ehc/Opts.chs | 89 +- EHC/src/ehc/Opts/Base.chs | 4 +- EHC/src/ehc/Scanner/Common.chs | 4 +- EHC/src/ehc/TyCore/Base.chs | 10 - EHC/src/ehc/TyCore/ToCore.cag | 2 +- EHC/src/ehc/files-ag-d.dep | 1 + EHC/src/ehc/files-ag-s.dep | 3 + EHC/src/ehc/files1.mk | 9 +- EHC/src/ehc/files2.mk | 2 + EHC/src/ehc/variant.mk | 38 +- EHC/src/jscript/core/interpreter.cjs | 458 +++++++ EHC/src/jscript/files.mk | 75 ++ EHC/src/jscript/rts/prim.cjs | 140 +++ EHC/src/libutil/EH/Util/CompileRun.hs | 60 +- EHC/src/shuffle/files.mk | 1 + EHC/src/text2text/Common.hs | 60 +- EHC/src/text2text/Text/To/Common.ag | 7 + .../Text/To/CommonHeaderNumbering.ag | 47 + EHC/src/text2text/Text/To/DocLaTeX.ag | 6 - EHC/src/text2text/Text/To/Html.ag | 280 +++++ EHC/src/text2text/Text/To/TWiki.ag | 86 +- EHC/src/text2text/Text2Text.hs | 6 + EHC/src/text2text/files.mk | 9 +- EHC/src/text2text/text2text.cabal.in | 1 + EHC/test/benchmark/runbenchmark.pl.in | 6 +- EHC/text/SlidesIntro.cltex | 2 +- EHC/text/SlidesStatus.cltex | 159 ++- EHC/text/ToolDocEHC.cltex | 22 +- EHC/text/files-targets.mk | 6 + EHC/text/files-variants.mk | 5 +- EHC/text/files2.mk | 18 +- EHC/text/main.cltex | 27 +- EHC/www/files.mk | 2 +- 157 files changed, 5111 insertions(+), 1003 deletions(-) create mode 100644 EHC/src/ehc/Base/GenJavaLike.chs create mode 100644 EHC/src/ehc/Core/CommonJavaLike.cag create mode 100644 EHC/src/ehc/Core/ModAsMap.cag create mode 100644 EHC/src/ehc/Core/ToJScript.cag create mode 100644 EHC/src/ehc/EHC/CompilePhase/CompileJScript.chs create mode 100644 EHC/src/ehc/JScript.cag create mode 100644 EHC/src/ehc/JScript/AbsSyn.cag create mode 100644 EHC/src/ehc/JScript/Pretty.cag create mode 100644 EHC/src/jscript/core/interpreter.cjs create mode 100644 EHC/src/jscript/files.mk create mode 100644 EHC/src/jscript/rts/prim.cjs create mode 100644 EHC/src/text2text/Text/To/CommonHeaderNumbering.ag create mode 100644 EHC/src/text2text/Text/To/Html.ag diff --git a/EHC/Makefile b/EHC/Makefile index 4ca701bf4..f725d247a 100755 --- a/EHC/Makefile +++ b/EHC/Makefile @@ -77,6 +77,9 @@ include $(SRC_PREFIX)rts/files.mk ifeq ($(ENABLE_JAVA),yes) -include $(SRC_PREFIX)jazy/files.mk endif +ifeq ($(ENABLE_JSCRIPT),yes) +-include $(SRC_PREFIX)jscript/files.mk +endif include $(SRC_PREFIX)ehc/files2.mk -include $(SRC_PREFIX)agprimer/files.mk -include $(SRC_PREFIX)infer2pass/variant.mk @@ -383,7 +386,8 @@ release-prepare: FUN_PREFIX2DIR = $(patsubst %/,%,$(1)) tst: - @echo $(EHCLIB_SH_MAP_PKG2VERSIONED) + @echo $(EHC_VARIANT_TARGET) + @echo $(EHC_CFG_USE_UNIX_AND_C) tstv: $(MAKE) EHC_VARIANT=100 tst diff --git a/EHC/SVNREVISION b/EHC/SVNREVISION index 947fe5dc3..72ef916a5 100644 --- a/EHC/SVNREVISION +++ b/EHC/SVNREVISION @@ -1 +1 @@ -2169M +2177M diff --git a/EHC/VERSION b/EHC/VERSION index 524cb5524..45a1b3f44 100644 --- a/EHC/VERSION +++ b/EHC/VERSION @@ -1 +1 @@ -1.1.1 +1.1.2 diff --git a/EHC/configure b/EHC/configure index bde1261f1..13ab631fb 100755 --- a/EHC/configure +++ b/EHC/configure @@ -681,6 +681,7 @@ javacCmd jarCmd JAVAC_CMD JAR_CMD +ENABLE_JSCRIPT ENABLE_LLVM ENABLE_CLR ENABLE_TYCORE @@ -689,6 +690,8 @@ ranlibCmd RANLIB_CMD arCmd AR_CMD +catCmd +CAT_CMD libtoolStaticCmd EHC_BUILD_SUFFIX GCC_EHC_OPTIONS @@ -749,7 +752,8 @@ GMP_LIB_ARCHIVE GCC_EHC_EXTRA_EXTERN_LIBS SUFFIX_SHELL SUFFIX_EXEC -SUFFIX_LIB +SUFFIX_LIBC +SUFFIX_LIBJSCRIPT PREFIX_LIB PATHS_SEP SLASH @@ -1363,6 +1367,7 @@ Optional Features: --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] --enable-java include java code generation + --enable-jscript include JavaScript code generation --enable-llvm include llvm code generation --enable-clr include clr code generation --enable-tycore include TyCore typed intermediate language @@ -2361,6 +2366,17 @@ echo "$as_me: error: fi +### enable options: jscript (JavaScript) +# Check whether --enable-jscript was given. +if test "${enable_jscript+set}" = set; then + enableval=$enable_jscript; enableJScript=yes +else + enableJScript=no +fi + +ENABLE_JSCRIPT=$enableJScript + + ### enable options: llvm # Check whether --enable-llvm was given. if test "${enable_llvm+set}" = set; then @@ -2541,6 +2557,74 @@ esac AR_CMD=$arCmd +### cat + + # Extract the first word of "cat", so it can be a program name with args. +set dummy cat; ac_word=$2 +{ echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6; } +if test "${ac_cv_path_catCmd+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + case $catCmd in + [\\/]* | ?:[\\/]*) + ac_cv_path_catCmd="$catCmd" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + ac_cv_path_catCmd="$as_dir/$ac_word$ac_exec_ext" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done +done +IFS=$as_save_IFS + + ;; +esac +fi +catCmd=$ac_cv_path_catCmd +if test -n "$catCmd"; then + { echo "$as_me:$LINENO: result: $catCmd" >&5 +echo "${ECHO_T}$catCmd" >&6; } +else + { echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6; } +fi + + + if test -z "$catCmd"; then + + { { echo "$as_me:$LINENO: error: + You must install cat before you can continue + Perhaps it is already installed, but not in your PATH?" >&5 +echo "$as_me: error: + You must install cat before you can continue + Perhaps it is already installed, but not in your PATH?" >&2;} + { (exit 1); exit 1; }; } + + fi + +# See remarks about cpp +case $HostPlatform in + i*86-*-mingw* | i*86-*-cygwin* ) + if test ! -x "$toplevelSystemAbsolutePathPrefix/$catCmd" + then + catCmd="`echo $catCmd | sed -e 's+/usr++'`" + fi + ;; + *) + ;; +esac +CAT_CMD=$catCmd + + ### libtool # Extract the first word of "libtool", so it can be a program name with args. @@ -30891,7 +30975,8 @@ GCC_EHC_EXTRA_EXTERN_LIBS="$gcc_ehc_extra_extern_libs" # file suffixes suffix_shell="" suffix_exec="" -suffix_lib=".a" +suffix_libC=".a" +suffix_libJScript=".mjs" prefix_lib="" # development platform development_platform="UNIX" @@ -30911,7 +30996,7 @@ case $HostPlatform in # file suffixes suffix_shell=".bat" suffix_exec=".exe" - #suffix_lib=".lib" + #suffix_libC=".lib" #prefix_lib="lib" development_platform="CYGWIN" # path separator @@ -30948,7 +31033,9 @@ SUFFIX_SHELL="$suffix_shell" SUFFIX_EXEC="$suffix_exec" -SUFFIX_LIB="$suffix_lib" +SUFFIX_LIBC="$suffix_libC" + +SUFFIX_LIBJSCRIPT="$suffix_libJScript" PREFIX_LIB="$prefix_lib" @@ -31762,6 +31849,7 @@ javacCmd!$javacCmd$ac_delim jarCmd!$jarCmd$ac_delim JAVAC_CMD!$JAVAC_CMD$ac_delim JAR_CMD!$JAR_CMD$ac_delim +ENABLE_JSCRIPT!$ENABLE_JSCRIPT$ac_delim ENABLE_LLVM!$ENABLE_LLVM$ac_delim ENABLE_CLR!$ENABLE_CLR$ac_delim ENABLE_TYCORE!$ENABLE_TYCORE$ac_delim @@ -31770,6 +31858,8 @@ ranlibCmd!$ranlibCmd$ac_delim RANLIB_CMD!$RANLIB_CMD$ac_delim arCmd!$arCmd$ac_delim AR_CMD!$AR_CMD$ac_delim +catCmd!$catCmd$ac_delim +CAT_CMD!$CAT_CMD$ac_delim libtoolStaticCmd!$libtoolStaticCmd$ac_delim EHC_BUILD_SUFFIX!$EHC_BUILD_SUFFIX$ac_delim GCC_EHC_OPTIONS!$GCC_EHC_OPTIONS$ac_delim @@ -31790,9 +31880,6 @@ hsc2hsCmd!$hsc2hsCmd$ac_delim HSC2HS_CMD!$HSC2HS_CMD$ac_delim haddockCmd!$haddockCmd$ac_delim HADDOCK_CMD!$HADDOCK_CMD$ac_delim -HADDOCK_VERSION!$HADDOCK_VERSION$ac_delim -OPT_GHC_STANDARD_PACKAGES!$OPT_GHC_STANDARD_PACKAGES$ac_delim -CABAL_BASE_LIB_DEPENDS!$CABAL_BASE_LIB_DEPENDS$ac_delim _ACEOF if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 97; then @@ -31834,6 +31921,9 @@ _ACEOF ac_delim='%!_!# ' for ac_last_try in false false false false false :; do cat >conf$$subs.sed <<_ACEOF +HADDOCK_VERSION!$HADDOCK_VERSION$ac_delim +OPT_GHC_STANDARD_PACKAGES!$OPT_GHC_STANDARD_PACKAGES$ac_delim +CABAL_BASE_LIB_DEPENDS!$CABAL_BASE_LIB_DEPENDS$ac_delim CABAL_EXTRA_LIB_DEPENDS!$CABAL_EXTRA_LIB_DEPENDS$ac_delim CABAL_OPT_ALLOW_UNDECIDABLE_INSTANCES!$CABAL_OPT_ALLOW_UNDECIDABLE_INSTANCES$ac_delim uuagcCmd!$uuagcCmd$ac_delim @@ -31871,7 +31961,8 @@ GMP_LIB_ARCHIVE!$GMP_LIB_ARCHIVE$ac_delim GCC_EHC_EXTRA_EXTERN_LIBS!$GCC_EHC_EXTRA_EXTERN_LIBS$ac_delim SUFFIX_SHELL!$SUFFIX_SHELL$ac_delim SUFFIX_EXEC!$SUFFIX_EXEC$ac_delim -SUFFIX_LIB!$SUFFIX_LIB$ac_delim +SUFFIX_LIBC!$SUFFIX_LIBC$ac_delim +SUFFIX_LIBJSCRIPT!$SUFFIX_LIBJSCRIPT$ac_delim PREFIX_LIB!$PREFIX_LIB$ac_delim PATHS_SEP!$PATHS_SEP$ac_delim SLASH!$SLASH$ac_delim @@ -31902,7 +31993,7 @@ LIBOBJS!$LIBOBJS$ac_delim LTLIBOBJS!$LTLIBOBJS$ac_delim _ACEOF - if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 66; then + if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 70; then break elif $ac_last_try; then { { echo "$as_me:$LINENO: error: could not make $CONFIG_STATUS" >&5 diff --git a/EHC/configure.ac b/EHC/configure.ac index 614c44ba6..16ed81968 100644 --- a/EHC/configure.ac +++ b/EHC/configure.ac @@ -128,6 +128,10 @@ then AC_SUBST(JAR_CMD,$jarCmd) fi +### enable options: jscript (JavaScript) +AC_ARG_ENABLE(jscript, AS_HELP_STRING([--enable-jscript],[include JavaScript code generation]), [enableJScript=yes], [enableJScript=no]) +AC_SUBST(ENABLE_JSCRIPT,$enableJScript) + ### enable options: llvm AC_ARG_ENABLE(llvm, AS_HELP_STRING([--enable-llvm],[include llvm code generation]), [enableLlvm=yes], [enableLlvm=no]) AC_SUBST(ENABLE_LLVM,$enableLlvm) @@ -174,6 +178,21 @@ case $HostPlatform in esac AC_SUBST(AR_CMD,$arCmd) +### cat +REQUIRED_PROG_FOR_EH(catCmd,cat) +# See remarks about cpp +case $HostPlatform in + i*86-*-mingw* | i*86-*-cygwin* ) + if test ! -x "$toplevelSystemAbsolutePathPrefix/$catCmd" + then + catCmd="`echo $catCmd | sed -e 's+/usr++'`" + fi + ;; + *) + ;; +esac +AC_SUBST(CAT_CMD,$catCmd) + ### libtool REQUIRED_OPTIONAL_PROG_FOR_EH(libtoolStaticCmd,libtool) @@ -946,7 +965,8 @@ AC_SUBST(GCC_EHC_EXTRA_EXTERN_LIBS,"$gcc_ehc_extra_extern_libs") # file suffixes suffix_shell="" suffix_exec="" -suffix_lib=".a" +suffix_libC=".a" +suffix_libJScript=".mjs" prefix_lib="" # development platform development_platform="UNIX" @@ -966,7 +986,7 @@ case $HostPlatform in # file suffixes suffix_shell=".bat" suffix_exec=".exe" - #suffix_lib=".lib" + #suffix_libC=".lib" #prefix_lib="lib" development_platform="CYGWIN" # path separator @@ -1001,7 +1021,8 @@ esac # suffixes, path separator, ... AC_SUBST(SUFFIX_SHELL,"$suffix_shell") AC_SUBST(SUFFIX_EXEC,"$suffix_exec") -AC_SUBST(SUFFIX_LIB,"$suffix_lib") +AC_SUBST(SUFFIX_LIBC,"$suffix_libC") +AC_SUBST(SUFFIX_LIBJSCRIPT,"$suffix_libJScript") AC_SUBST(PREFIX_LIB,"$prefix_lib") AC_SUBST(PATHS_SEP,"$paths_sep") AC_SUBST(SLASH,"$slash") diff --git a/EHC/ehclib/base/Prelude.hs b/EHC/ehclib/base/Prelude.hs index 603dd0f59..81de08e18 100644 --- a/EHC/ehclib/base/Prelude.hs +++ b/EHC/ehclib/base/Prelude.hs @@ -26,7 +26,7 @@ module Prelude , module UHC.Show , module UHC.Read , module UHC.Run -#if defined (__UHC_TARGET_C__) || defined (__UHC_TARGET_LLVM__) +#if ( defined(__UHC_TARGET_C__) || defined(__UHC_TARGET_JSCRIPT__) || defined (__UHC_TARGET_LLVM__) ) , module UHC.OldIO #else , module System.IO @@ -69,13 +69,13 @@ import UHC.Show import UHC.Read import UHC.IOBase ( IOError, ioError, userError, catch, unsafePerformIO -#if defined (__UHC_TARGET_C__) || defined (__UHC_TARGET_LLVM__) +#if (defined(__UHC_TARGET_C__) || defined (__UHC_TARGET_LLVM__)) && !defined(__UHC_TARGET_JSCRIPT__) , FilePath #endif ) import UHC.Run -#if defined (__UHC_TARGET_C__) || defined (__UHC_TARGET_LLVM__) +#if ( defined(__UHC_TARGET_C__) || defined(__UHC_TARGET_JSCRIPT__) || defined (__UHC_TARGET_LLVM__) ) import UHC.OldIO #else import System.IO diff --git a/EHC/ehclib/base/System/CPUTime.hsc b/EHC/ehclib/base/System/CPUTime.hsc index 355db567b..acb3c5dd7 100644 --- a/EHC/ehclib/base/System/CPUTime.hsc +++ b/EHC/ehclib/base/System/CPUTime.hsc @@ -1,3 +1,5 @@ +{-# EXCLUDE_IF_TARGET jscript #-} + ----------------------------------------------------------------------------- -- | -- Module : System.CPUTime diff --git a/EHC/ehclib/base/System/Console/GetOpt.hs b/EHC/ehclib/base/System/Console/GetOpt.hs index 92ebd5205..e58310156 100644 --- a/EHC/ehclib/base/System/Console/GetOpt.hs +++ b/EHC/ehclib/base/System/Console/GetOpt.hs @@ -1,3 +1,5 @@ +{-# EXCLUDE_IF_TARGET jscript #-} + ----------------------------------------------------------------------------- -- | -- Module : System.Console.GetOpt diff --git a/EHC/ehclib/base/System/Environment.hs b/EHC/ehclib/base/System/Environment.hs index bb889e0b2..8d938b88a 100644 --- a/EHC/ehclib/base/System/Environment.hs +++ b/EHC/ehclib/base/System/Environment.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# EXCLUDE_IF_TARGET jscript #-} ----------------------------------------------------------------------------- -- | diff --git a/EHC/ehclib/filepath/System/FilePath.hs b/EHC/ehclib/filepath/System/FilePath.hs index a8d3ead78..0db2345fa 100644 --- a/EHC/ehclib/filepath/System/FilePath.hs +++ b/EHC/ehclib/filepath/System/FilePath.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} + {- | Module : System.FilePath Copyright : (c) Neil Mitchell 2005-2007 diff --git a/EHC/ehclib/filepath/System/FilePath/Posix.hs b/EHC/ehclib/filepath/System/FilePath/Posix.hs index 831e7991f..61cdd761a 100644 --- a/EHC/ehclib/filepath/System/FilePath/Posix.hs +++ b/EHC/ehclib/filepath/System/FilePath/Posix.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} + #define MODULE_NAME Posix #ifndef IS_WINDOWS diff --git a/EHC/ehclib/files2.mk b/EHC/ehclib/files2.mk index 46768dfe3..d915e7903 100644 --- a/EHC/ehclib/files2.mk +++ b/EHC/ehclib/files2.mk @@ -10,8 +10,6 @@ FUN_PKG_VERSIONED = $(1)-$(EHCLIB_PKG_$(call FUN_STRIP_DASH,$(1))_VERSION) # $1: versioned pkg name #FUN_PKG_UNVERSIONED = $(patsubst %-%,,$(1)) -# not yet used - EHCLIB_PKG_uhcbase_VERSION := $(EH_VERSION_FULL) EHCLIB_PKG_base_VERSION := 3.0.0.0 EHCLIB_PKG_array_VERSION := 1.0.0.0 @@ -149,7 +147,9 @@ EHCLIB_ALL_SPECIALS := $(EHCLIB_GEN_HS) $(GEN_GENERTUPINST_BLD_EXEC) # all EHCLIB_ALL_SRC := $(EHCLIB_HS_ALL_SRC_HS) $(EHCLIB_CHS_ALL_SRC_CHS) $(EHCLIB_ASIS_ALL_SRC_ASIS) -EHCLIB_ALL_DRV_HS := $(EHCLIB_HS_ALL_DRV_HS) $(EHCLIB_CHS_ALL_DRV_HS) $(EHCLIB_FROZEN_ALL_DRV_HS) $(EHCLIB_HSC_ALL_DRV_HS) $(EHCLIB_GEN_HS) +EHCLIB_ALL_DRV_HS := $(EHCLIB_HS_ALL_DRV_HS) $(EHCLIB_CHS_ALL_DRV_HS) $(EHCLIB_FROZEN_ALL_DRV_HS) \ + $(if $(EHC_CFG_USE_UNIX_AND_C),$(EHCLIB_HSC_ALL_DRV_HS),) \ + $(EHCLIB_GEN_HS) EHCLIB_ALL_DRV_C := $(EHCLIB_C_ALL_DRV_C) $(EHCLIB_CC_ALL_DRV_C) $(EHCLIB_FROZEN_ALL_DRV_C) EHCLIB_ALL_DRV_ASIS := $(EHCLIB_FROZEN_ALL_DRV_ASIS) $(EHCLIB_ASIS_ALL_DRV_ASIS) EHCLIB_ALL_DRV := $(EHCLIB_ALL_DRV_HS) $(EHCLIB_ALL_DRV_ASIS) $(EHCLIB_ALL_DRV_C) @@ -178,11 +178,12 @@ EHCLIB_DIST_FILES := $(EHCLIB_ALL_SRC) $(EHCLIB_MKF) EHCLIB_BASE_OPTS = -O2 EHCLIB_DEBUG_OPTS = +#EHCLIB_DEBUG_OPTS = --gen-trace=1 --dump-core-stages=1 #EHCLIB_DEBUG_OPTS = --dump-core-stages=1 -OStrictnessAnalysis #EHCLIB_DEBUG_OPTS = --priv=1 #EHCLIB_DEBUG_OPTS = -peh -v3 #EHCLIB_DEBUG_OPTS = --no-hi-check -#EHCLIB_DEBUG_OPTS = --dump-core-stages=1 --dump-grin-stages=1 --gen-trace=1 --gen-cmt=1 +#EHCLIB_DEBUG_OPTS = --dump-core-stages=1 --dump-grin-stages=1 --gen-cmt=1 #EHCLIB_DEBUG_OPTS = --dump-core-stages=1 --dump-grin-stages=1 -v4 #EHCLIB_DEBUG_OPTS = --target-flavor=debug --dump-core-stages=1 --dump-grin-stages=1 --gen-trace=1 --gen-cmt=1 #EHCLIB_DEBUG_OPTS = -O0 @@ -222,7 +223,7 @@ ehclib-variant-dflt: \ --import-path=$(call FUN_MK_PKG_INC_DIR,$(call FUN_INSTALL_PKG_PREFIX,$${pkgv})) \ $${pkgs} \ $${hsFiles} \ - `find $(EHCLIB_BLD_VARIANT_ASPECTS_PREFIX)$${pkg} -name '*.c'` \ + $(if $(EHC_CFG_USE_UNIX_AND_C),`find $(EHCLIB_BLD_VARIANT_ASPECTS_PREFIX)$${pkg} -name '*.c'`,) \ +RTS -K30m ; \ err=$$? ; \ if test $${err} -ne 0 ; then exit $${err} ; fi ; \ @@ -251,6 +252,8 @@ ehclib-codegentargetspecific-C: $(if $(EHC_CFG_USE_GRIN),$(INSTALL_LIB_RTS),) ehclib-codegentargetspecific-jazy: $(if $(ENABLE_JAVA),$(INSTALL_LIB_JAZY),) +ehclib-codegentargetspecific-jscript: $(if $(ENABLE_JSCRIPT),$(INSTALL_LIB_JSCRIPT),) + ehclib-codegentargetspecific-core: ehclib-codegentargetspecific-clr: diff --git a/EHC/ehclib/haskell98/CError.hs b/EHC/ehclib/haskell98/CError.hs index 635e3f4ca..b00e6ce84 100644 --- a/EHC/ehclib/haskell98/CError.hs +++ b/EHC/ehclib/haskell98/CError.hs @@ -1,2 +1,3 @@ +{-# EXCLUDE_IF_TARGET jscript #-} module CError (module Foreign.C.Error) where import Foreign.C.Error diff --git a/EHC/ehclib/haskell98/CForeign.hs b/EHC/ehclib/haskell98/CForeign.hs index 90e08d9ed..732178902 100644 --- a/EHC/ehclib/haskell98/CForeign.hs +++ b/EHC/ehclib/haskell98/CForeign.hs @@ -1,2 +1,3 @@ +{-# EXCLUDE_IF_TARGET jscript #-} module CForeign ( module Foreign.C ) where import Foreign.C diff --git a/EHC/ehclib/haskell98/CPUTime.hs b/EHC/ehclib/haskell98/CPUTime.hs index 9b5ab6fb3..a12875be8 100644 --- a/EHC/ehclib/haskell98/CPUTime.hs +++ b/EHC/ehclib/haskell98/CPUTime.hs @@ -1,3 +1,4 @@ +{-# EXCLUDE_IF_TARGET jscript #-} module CPUTime ( getCPUTime, cpuTimePrecision ) where diff --git a/EHC/ehclib/haskell98/CString.hs b/EHC/ehclib/haskell98/CString.hs index 433dabc45..61fc60700 100644 --- a/EHC/ehclib/haskell98/CString.hs +++ b/EHC/ehclib/haskell98/CString.hs @@ -1,2 +1,3 @@ +{-# EXCLUDE_IF_TARGET jscript #-} module CString (module Foreign.C.String) where import Foreign.C.String diff --git a/EHC/ehclib/haskell98/CTypes.hs b/EHC/ehclib/haskell98/CTypes.hs index b7e3f5545..a6b834bf3 100644 --- a/EHC/ehclib/haskell98/CTypes.hs +++ b/EHC/ehclib/haskell98/CTypes.hs @@ -1,2 +1,3 @@ +{-# EXCLUDE_IF_TARGET jscript #-} module CTypes (module Foreign.C.Types) where import Foreign.C.Types diff --git a/EHC/ehclib/haskell98/Directory.hs b/EHC/ehclib/haskell98/Directory.hs index aa488a0e4..7fcff316f 100644 --- a/EHC/ehclib/haskell98/Directory.hs +++ b/EHC/ehclib/haskell98/Directory.hs @@ -1,3 +1,4 @@ +{-# EXCLUDE_IF_TARGET jscript #-} module Directory ( Permissions( Permissions, readable, writable, executable, searchable ), createDirectory, removeDirectory, removeFile, diff --git a/EHC/ehclib/haskell98/ForeignPtr.hs b/EHC/ehclib/haskell98/ForeignPtr.hs index d0e70d991..bc493514f 100644 --- a/EHC/ehclib/haskell98/ForeignPtr.hs +++ b/EHC/ehclib/haskell98/ForeignPtr.hs @@ -1,2 +1,3 @@ +{-# EXCLUDE_IF_TARGET jscript #-} module ForeignPtr (module Foreign.ForeignPtr) where import Foreign.ForeignPtr diff --git a/EHC/ehclib/haskell98/IO.hs b/EHC/ehclib/haskell98/IO.hs index b9f4a2d57..d489ebaa4 100644 --- a/EHC/ehclib/haskell98/IO.hs +++ b/EHC/ehclib/haskell98/IO.hs @@ -2,52 +2,75 @@ module IO ( Handle, -#ifndef __UHC_TARGET_C__ +#if !( defined(__UHC_TARGET_C__) || defined(__UHC_TARGET_JSCRIPT__) ) HandlePosn, #endif IOMode(ReadMode,WriteMode,AppendMode,ReadWriteMode), -#ifndef __UHC_TARGET_C__ +#if !( defined(__UHC_TARGET_C__) || defined(__UHC_TARGET_JSCRIPT__) ) BufferMode(NoBuffering,LineBuffering,BlockBuffering), SeekMode(AbsoluteSeek,RelativeSeek,SeekFromEnd), #endif - stdin, stdout, stderr, - openFile, hClose, -#ifndef __UHC_TARGET_C__ +#if !defined(__UHC_TARGET_JSCRIPT__) + stdin, +#endif + stdout, stderr, +#if !defined(__UHC_TARGET_JSCRIPT__) + openFile, +#endif + hClose, +#if !( defined(__UHC_TARGET_C__) || defined(__UHC_TARGET_JSCRIPT__) ) hFileSize, hIsEOF, isEOF, hSetBuffering, hGetBuffering, #endif hFlush, -#ifndef __UHC_TARGET_C__ +#if !( defined(__UHC_TARGET_C__) || defined(__UHC_TARGET_JSCRIPT__) ) hGetPosn, hSetPosn, hSeek, hWaitForInput, hReady, hGetChar, hGetLine, hLookAhead, #endif +#if !defined(__UHC_TARGET_JSCRIPT__) hGetContents, +#endif hPutChar, hPutStr, hPutStrLn, -#ifndef __UHC_TARGET_C__ +#if !( defined(__UHC_TARGET_C__) || defined(__UHC_TARGET_JSCRIPT__) ) hPrint, hIsOpen, hIsClosed, hIsReadable, hIsWritable, hIsSeekable, #endif +#if !( defined(__UHC_TARGET_JSCRIPT__) ) isAlreadyExistsError, isDoesNotExistError, isAlreadyInUseError, isFullError, isEOFError, isIllegalOperation, isPermissionError, isUserError, ioeGetErrorString, ioeGetHandle, ioeGetFileName, - try, bracket, bracket_, + try, + bracket, bracket_, +#endif -- ...and what the Prelude exports - IO, FilePath, IOError, ioError, userError, catch, interact, - putChar, putStr, putStrLn, print, getChar, getLine, getContents, + IO, +#if !( defined(__UHC_TARGET_JSCRIPT__) ) + FilePath, +#endif + IOError, ioError, userError, catch, +#if !defined(__UHC_TARGET_JSCRIPT__) + interact, +#endif + putChar, putStr, putStrLn, print, +#if !defined(__UHC_TARGET_JSCRIPT__) + getChar, getLine, getContents, readFile, writeFile, appendFile, -#ifndef __UHC_TARGET_C__ +#endif +#if !( defined(__UHC_TARGET_C__) || defined(__UHC_TARGET_JSCRIPT__) ) readIO, readLn #endif ) where -#ifdef __UHC_TARGET_C__ +#if ( defined(__UHC_TARGET_C__) || defined(__UHC_TARGET_JSCRIPT__) ) import UHC.OldIO #else import System.IO #endif +#if !( defined(__UHC_TARGET_JSCRIPT__) ) import System.IO.Error +#endif -- | The 'bracket' function captures a common allocate, compute, deallocate -- idiom in which the deallocation step must occur even in the case of an @@ -57,6 +80,7 @@ import System.IO.Error -- The version of @bracket@ in "Control.Exception" handles all exceptions, -- and should be used instead. +#if !( defined(__UHC_TARGET_JSCRIPT__) ) bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c bracket before after m = do x <- before @@ -80,3 +104,4 @@ bracket_ before after m = do case rs of Right r -> return r Left e -> ioError e +#endif diff --git a/EHC/ehclib/haskell98/Int.hs b/EHC/ehclib/haskell98/Int.hs index c27580ad1..ad27cf7c6 100644 --- a/EHC/ehclib/haskell98/Int.hs +++ b/EHC/ehclib/haskell98/Int.hs @@ -1,2 +1,3 @@ +{-# EXCLUDE_IF_TARGET jscript #-} module Int ( module Data.Int ) where import Data.Int diff --git a/EHC/ehclib/haskell98/Locale.hs b/EHC/ehclib/haskell98/Locale.hs index d71c355ad..7a28a9033 100644 --- a/EHC/ehclib/haskell98/Locale.hs +++ b/EHC/ehclib/haskell98/Locale.hs @@ -1,3 +1,4 @@ +{-# EXCLUDE_IF_TARGET jscript #-} module Locale ( TimeLocale(..), defaultTimeLocale ) where diff --git a/EHC/ehclib/haskell98/MarshalAlloc.hs b/EHC/ehclib/haskell98/MarshalAlloc.hs index 7e3873b2a..ced4afa23 100644 --- a/EHC/ehclib/haskell98/MarshalAlloc.hs +++ b/EHC/ehclib/haskell98/MarshalAlloc.hs @@ -1,2 +1,3 @@ +{-# EXCLUDE_IF_TARGET jscript #-} module MarshalAlloc (module Foreign.Marshal.Alloc) where import Foreign.Marshal.Alloc diff --git a/EHC/ehclib/haskell98/MarshalArray.hs b/EHC/ehclib/haskell98/MarshalArray.hs index e5043c1f2..e8b1027b3 100644 --- a/EHC/ehclib/haskell98/MarshalArray.hs +++ b/EHC/ehclib/haskell98/MarshalArray.hs @@ -1,2 +1,3 @@ +{-# EXCLUDE_IF_TARGET jscript #-} module MarshalArray (module Foreign.Marshal.Array) where import Foreign.Marshal.Array diff --git a/EHC/ehclib/haskell98/MarshalError.hs b/EHC/ehclib/haskell98/MarshalError.hs index c690fe224..e2b5d63f8 100644 --- a/EHC/ehclib/haskell98/MarshalError.hs +++ b/EHC/ehclib/haskell98/MarshalError.hs @@ -1,3 +1,4 @@ +{-# EXCLUDE_IF_TARGET jscript #-} module MarshalError ( module Foreign.Marshal.Error, IOErrorType, diff --git a/EHC/ehclib/haskell98/MarshalUtils.hs b/EHC/ehclib/haskell98/MarshalUtils.hs index eb93bfff9..2e7078f61 100644 --- a/EHC/ehclib/haskell98/MarshalUtils.hs +++ b/EHC/ehclib/haskell98/MarshalUtils.hs @@ -1,2 +1,3 @@ +{-# EXCLUDE_IF_TARGET jscript #-} module MarshalUtils (module Foreign.Marshal.Utils) where import Foreign.Marshal.Utils diff --git a/EHC/ehclib/haskell98/Ptr.hs b/EHC/ehclib/haskell98/Ptr.hs index 88eff0e59..0a13b56c7 100644 --- a/EHC/ehclib/haskell98/Ptr.hs +++ b/EHC/ehclib/haskell98/Ptr.hs @@ -1,2 +1,4 @@ +{-# EXCLUDE_IF_TARGET jscript #-} + module Ptr (module Foreign.Ptr) where import Foreign.Ptr diff --git a/EHC/ehclib/haskell98/Random.hs b/EHC/ehclib/haskell98/Random.hs index f857f0860..feeeef201 100644 --- a/EHC/ehclib/haskell98/Random.hs +++ b/EHC/ehclib/haskell98/Random.hs @@ -1,3 +1,4 @@ +{-# EXCLUDE_IF_TARGET jscript #-} module Random ( RandomGen(next, split, genRange), StdGen, mkStdGen, diff --git a/EHC/ehclib/haskell98/StablePtr.hs b/EHC/ehclib/haskell98/StablePtr.hs index 64cf49a33..260244a27 100644 --- a/EHC/ehclib/haskell98/StablePtr.hs +++ b/EHC/ehclib/haskell98/StablePtr.hs @@ -1,2 +1,3 @@ +{-# EXCLUDE_IF_TARGET jscript #-} module StablePtr (module Foreign.StablePtr) where import Foreign.StablePtr diff --git a/EHC/ehclib/haskell98/Storable.hs b/EHC/ehclib/haskell98/Storable.hs index 86fdc8824..a58228e1e 100644 --- a/EHC/ehclib/haskell98/Storable.hs +++ b/EHC/ehclib/haskell98/Storable.hs @@ -1,2 +1,3 @@ +{-# EXCLUDE_IF_TARGET jscript #-} module Storable (module Foreign.Storable) where import Foreign.Storable diff --git a/EHC/ehclib/haskell98/System.hs b/EHC/ehclib/haskell98/System.hs index 0c48514b5..bcdf97f13 100644 --- a/EHC/ehclib/haskell98/System.hs +++ b/EHC/ehclib/haskell98/System.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# EXCLUDE_IF_TARGET jscript #-} module System ( ExitCode(ExitSuccess,ExitFailure), diff --git a/EHC/ehclib/haskell98/Time.hs b/EHC/ehclib/haskell98/Time.hs index 569626dbd..6645fe15d 100644 --- a/EHC/ehclib/haskell98/Time.hs +++ b/EHC/ehclib/haskell98/Time.hs @@ -1,3 +1,4 @@ +{-# EXCLUDE_IF_TARGET jscript #-} module Time ( ClockTime, Month(January,February,March,April,May,June, diff --git a/EHC/ehclib/haskell98/Word.hs b/EHC/ehclib/haskell98/Word.hs index e823f88e2..48b37a30d 100644 --- a/EHC/ehclib/haskell98/Word.hs +++ b/EHC/ehclib/haskell98/Word.hs @@ -1,2 +1,3 @@ +{-# EXCLUDE_IF_TARGET jscript #-} module Word ( module Data.Word ) where import Data.Word diff --git a/EHC/ehclib/uhcbase/Data/Int.hs b/EHC/ehclib/uhcbase/Data/Int.hs index 098808481..175d3349b 100644 --- a/EHC/ehclib/uhcbase/Data/Int.hs +++ b/EHC/ehclib/uhcbase/Data/Int.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude, CPP #-} {-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# EXCLUDE_IF_TARGET jscript #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Int diff --git a/EHC/ehclib/uhcbase/Data/Typeable.hs b/EHC/ehclib/uhcbase/Data/Typeable.hs index 4caec5a78..d78a868ca 100644 --- a/EHC/ehclib/uhcbase/Data/Typeable.hs +++ b/EHC/ehclib/uhcbase/Data/Typeable.hs @@ -86,8 +86,10 @@ module Data.Typeable import qualified Data.HashTable as HT #endif import Data.Maybe +#if !defined(__UHC_TARGET_JSCRIPT__) import Data.Int import Data.Word +#endif import Data.List( foldl, intersperse ) import Unsafe.Coerce @@ -633,6 +635,7 @@ INSTANCE_TYPEABLE0(Handle,handleTc,"Handle") #endif INSTANCE_TYPEABLE0(Integer,integerTc,"Integer") +#if !defined(__UHC_TARGET_JSCRIPT__) INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8") INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16") INSTANCE_TYPEABLE0(Int32,int32Tc,"Int32") @@ -642,6 +645,7 @@ INSTANCE_TYPEABLE0(Word8,word8Tc,"Word8" ) INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16") INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32") INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64") +#endif #ifdef __UHC__ deriving instance Typeable TyCon diff --git a/EHC/ehclib/uhcbase/Data/Word.hs b/EHC/ehclib/uhcbase/Data/Word.hs index de1657985..70f5d9a49 100644 --- a/EHC/ehclib/uhcbase/Data/Word.hs +++ b/EHC/ehclib/uhcbase/Data/Word.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude, CPP #-} {-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# EXCLUDE_IF_TARGET jscript #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Word diff --git a/EHC/ehclib/uhcbase/Foreign.hs b/EHC/ehclib/uhcbase/Foreign.hs index a3848a6ea..7e4675d9b 100644 --- a/EHC/ehclib/uhcbase/Foreign.hs +++ b/EHC/ehclib/uhcbase/Foreign.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# EXCLUDE_IF_TARGET jscript #-} ----------------------------------------------------------------------------- -- | -- Module : Foreign diff --git a/EHC/ehclib/uhcbase/Foreign/C.hs b/EHC/ehclib/uhcbase/Foreign/C.hs index 3f86c4f97..36ac517f1 100644 --- a/EHC/ehclib/uhcbase/Foreign/C.hs +++ b/EHC/ehclib/uhcbase/Foreign/C.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# EXCLUDE_IF_TARGET jscript #-} ----------------------------------------------------------------------------- -- | -- Module : Foreign.C diff --git a/EHC/ehclib/uhcbase/Foreign/C/Error.hs b/EHC/ehclib/uhcbase/Foreign/C/Error.hs index 3840e9697..0d87f3cbb 100644 --- a/EHC/ehclib/uhcbase/Foreign/C/Error.hs +++ b/EHC/ehclib/uhcbase/Foreign/C/Error.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude, CPP #-} {-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-} +{-# EXCLUDE_IF_TARGET jscript #-} ----------------------------------------------------------------------------- -- | -- Module : Foreign.C.Error diff --git a/EHC/ehclib/uhcbase/Foreign/C/String.hs b/EHC/ehclib/uhcbase/Foreign/C/String.hs index 7ae1fad69..3d0419fc2 100644 --- a/EHC/ehclib/uhcbase/Foreign/C/String.hs +++ b/EHC/ehclib/uhcbase/Foreign/C/String.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude, CPP #-} {-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# EXCLUDE_IF_TARGET jscript #-} ----------------------------------------------------------------------------- -- | -- Module : Foreign.C.String diff --git a/EHC/ehclib/uhcbase/Foreign/C/Types.hs b/EHC/ehclib/uhcbase/Foreign/C/Types.hs index d3eb3f62c..be15ffdd8 100644 --- a/EHC/ehclib/uhcbase/Foreign/C/Types.hs +++ b/EHC/ehclib/uhcbase/Foreign/C/Types.hs @@ -1,6 +1,7 @@ {-# LANGUAGE NoImplicitPrelude, CPP #-} {-# OPTIONS_GHC -XNoImplicitPrelude #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# EXCLUDE_IF_TARGET jscript #-} -- XXX -fno-warn-unused-binds stops us warning about unused constructors, -- but really we should just remove them if we don't want them ----------------------------------------------------------------------------- diff --git a/EHC/ehclib/uhcbase/Foreign/ForeignPtr.hs b/EHC/ehclib/uhcbase/Foreign/ForeignPtr.hs index af21c9629..90e4e927d 100644 --- a/EHC/ehclib/uhcbase/Foreign/ForeignPtr.hs +++ b/EHC/ehclib/uhcbase/Foreign/ForeignPtr.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude, CPP #-} {-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# EXCLUDE_IF_TARGET jscript #-} ----------------------------------------------------------------------------- -- | -- Module : Foreign.ForeignPtr diff --git a/EHC/ehclib/uhcbase/Foreign/Marshal.hs b/EHC/ehclib/uhcbase/Foreign/Marshal.hs index e732d9994..76ffb6ef7 100644 --- a/EHC/ehclib/uhcbase/Foreign/Marshal.hs +++ b/EHC/ehclib/uhcbase/Foreign/Marshal.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# EXCLUDE_IF_TARGET jscript #-} ----------------------------------------------------------------------------- -- | -- Module : Foreign.Marshal diff --git a/EHC/ehclib/uhcbase/Foreign/Marshal/Alloc.hs b/EHC/ehclib/uhcbase/Foreign/Marshal/Alloc.hs index 38a36baa9..2f0a6f56c 100644 --- a/EHC/ehclib/uhcbase/Foreign/Marshal/Alloc.hs +++ b/EHC/ehclib/uhcbase/Foreign/Marshal/Alloc.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude, CPP #-} {-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# EXCLUDE_IF_TARGET jscript #-} ----------------------------------------------------------------------------- -- | -- Module : Foreign.Marshal.Alloc diff --git a/EHC/ehclib/uhcbase/Foreign/Marshal/Array.hs b/EHC/ehclib/uhcbase/Foreign/Marshal/Array.hs index ff0345838..d28f0d86f 100644 --- a/EHC/ehclib/uhcbase/Foreign/Marshal/Array.hs +++ b/EHC/ehclib/uhcbase/Foreign/Marshal/Array.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude, CPP #-} {-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# EXCLUDE_IF_TARGET jscript #-} ----------------------------------------------------------------------------- -- | -- Module : Foreign.Marshal.Array diff --git a/EHC/ehclib/uhcbase/Foreign/Marshal/Error.hs b/EHC/ehclib/uhcbase/Foreign/Marshal/Error.hs index cf705ac38..02d246a7d 100644 --- a/EHC/ehclib/uhcbase/Foreign/Marshal/Error.hs +++ b/EHC/ehclib/uhcbase/Foreign/Marshal/Error.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude, CPP #-} {-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# EXCLUDE_IF_TARGET jscript #-} ----------------------------------------------------------------------------- -- | -- Module : Foreign.Marshal.Error diff --git a/EHC/ehclib/uhcbase/Foreign/Marshal/Pool.hs b/EHC/ehclib/uhcbase/Foreign/Marshal/Pool.hs index b9bb11ac9..11ad4282f 100644 --- a/EHC/ehclib/uhcbase/Foreign/Marshal/Pool.hs +++ b/EHC/ehclib/uhcbase/Foreign/Marshal/Pool.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude, CPP #-} {-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# EXCLUDE_IF_TARGET jscript #-} -------------------------------------------------------------------------------- -- | -- Module : Foreign.Marshal.Pool diff --git a/EHC/ehclib/uhcbase/Foreign/Marshal/Utils.hs b/EHC/ehclib/uhcbase/Foreign/Marshal/Utils.hs index 5746e075b..d810e0987 100644 --- a/EHC/ehclib/uhcbase/Foreign/Marshal/Utils.hs +++ b/EHC/ehclib/uhcbase/Foreign/Marshal/Utils.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude, CPP #-} {-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# EXCLUDE_IF_TARGET jscript #-} ----------------------------------------------------------------------------- -- | -- Module : Foreign.Marshal.Utils diff --git a/EHC/ehclib/uhcbase/Foreign/Ptr.hs b/EHC/ehclib/uhcbase/Foreign/Ptr.hs index 6a04e7035..6642cc4af 100644 --- a/EHC/ehclib/uhcbase/Foreign/Ptr.hs +++ b/EHC/ehclib/uhcbase/Foreign/Ptr.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude, CPP #-} {-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# EXCLUDE_IF_TARGET jscript #-} ----------------------------------------------------------------------------- -- | -- Module : Foreign.Ptr diff --git a/EHC/ehclib/uhcbase/Foreign/StablePtr.hs b/EHC/ehclib/uhcbase/Foreign/StablePtr.hs index 2ca5197fc..e4ffbd540 100644 --- a/EHC/ehclib/uhcbase/Foreign/StablePtr.hs +++ b/EHC/ehclib/uhcbase/Foreign/StablePtr.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude, CPP #-} {-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# EXCLUDE_IF_TARGET jscript #-} ----------------------------------------------------------------------------- -- | -- Module : Foreign.StablePtr diff --git a/EHC/ehclib/uhcbase/Foreign/Storable.hs b/EHC/ehclib/uhcbase/Foreign/Storable.hs index e26d0369b..6cba1e890 100644 --- a/EHC/ehclib/uhcbase/Foreign/Storable.hs +++ b/EHC/ehclib/uhcbase/Foreign/Storable.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude, CPP #-} {-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# EXCLUDE_IF_TARGET jscript #-} ----------------------------------------------------------------------------- -- | -- Module : Foreign.Storable diff --git a/EHC/ehclib/uhcbase/System/IO.hs b/EHC/ehclib/uhcbase/System/IO.hs index adcbac5c3..49deb3b58 100644 --- a/EHC/ehclib/uhcbase/System/IO.hs +++ b/EHC/ehclib/uhcbase/System/IO.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude, CPP #-} {-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-} +{-# EXCLUDE_IF_TARGET jscript #-} ----------------------------------------------------------------------------- -- | -- Module : System.IO diff --git a/EHC/ehclib/uhcbase/System/Posix/Internals.hs b/EHC/ehclib/uhcbase/System/Posix/Internals.hs index ee3abfc3a..9aaceb066 100644 --- a/EHC/ehclib/uhcbase/System/Posix/Internals.hs +++ b/EHC/ehclib/uhcbase/System/Posix/Internals.hs @@ -2,6 +2,7 @@ {-# OPTIONS_GHC -XNoImplicitPrelude #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-} {-# OPTIONS_HADDOCK hide #-} +{-# EXCLUDE_IF_TARGET jscript #-} ----------------------------------------------------------------------------- -- | diff --git a/EHC/ehclib/uhcbase/System/Posix/Types.hs b/EHC/ehclib/uhcbase/System/Posix/Types.hs index edf780318..fd36dc68b 100644 --- a/EHC/ehclib/uhcbase/System/Posix/Types.hs +++ b/EHC/ehclib/uhcbase/System/Posix/Types.hs @@ -1,6 +1,7 @@ {-# LANGUAGE NoImplicitPrelude, CPP #-} {-# OPTIONS_GHC -XNoImplicitPrelude #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# EXCLUDE_IF_TARGET jscript #-} ----------------------------------------------------------------------------- -- | -- Module : System.Posix.Types diff --git a/EHC/ehclib/uhcbase/UHC/Base.chs b/EHC/ehclib/uhcbase/UHC/Base.chs index c5b630940..2d2202886 100644 --- a/EHC/ehclib/uhcbase/UHC/Base.chs +++ b/EHC/ehclib/uhcbase/UHC/Base.chs @@ -248,11 +248,19 @@ packedStringToString p = if packedStringNull p data ByteArray foreign import prim primByteArrayLength :: ByteArray -> Int +#if defined(__UHC_TARGET_JSCRIPT__) +foreign import prim primByteArrayToPackedString :: ByteArray -> PackedString +primByteArrayToString = packedStringToString . primByteArrayToPackedString +#else foreign import prim primByteArrayToString :: ByteArray -> String +#endif -#if defined (__UHC_TARGET_C__) || defined (__UHC_TARGET_LLVM__) +#if defined(__UHC_TARGET_C__) || defined (__UHC_TARGET_LLVM__) + foreign import prim packedStringToInteger :: PackedString -> Integer +#elif defined(__UHC_TARGET_JSCRIPT__) +foreign import prim "primPackedStringToInteger" packedStringToInteger :: PackedString -> Integer #else foreign import prim "primCStringToInteger" packedStringToInteger :: PackedString -> Integer #endif @@ -928,8 +936,36 @@ instance Show Int where -- Integer type -------------------------------------------------------------- -foreign import prim primEqInteger :: Integer -> Integer -> Bool -foreign import prim primCmpInteger :: Integer -> Integer -> Ordering +#if defined(__UHC_TARGET_JSCRIPT__) +-- Integers are (for now) represented by Int +foreign import prim "primEqInt" primEqInteger :: Integer -> Integer -> Bool +foreign import prim "primCmpInt" primCmpInteger :: Integer -> Integer -> Ordering +foreign import prim "primAddInt" primAddInteger :: Integer -> Integer -> Integer +foreign import prim "primSubInt" primSubInteger :: Integer -> Integer -> Integer +foreign import prim "primMulInt" primMulInteger :: Integer -> Integer -> Integer +foreign import prim "primNegInt" primNegInteger :: Integer -> Integer +foreign import prim "primQuotInt" primQuotInteger :: Integer -> Integer -> Integer +foreign import prim "primRemInt" primRemInteger :: Integer -> Integer -> Integer +foreign import prim "primDivInt" primDivInteger :: Integer -> Integer -> Integer +foreign import prim "primModInt" primModInteger :: Integer -> Integer -> Integer +foreign import prim "primQuotRemInt" primQuotRemInteger :: Integer -> Integer -> (Integer,Integer) +foreign import prim "primDivModInt" primDivModInteger :: Integer -> Integer -> (Integer,Integer) +#else +foreign import prim primEqInteger :: Integer -> Integer -> Bool +foreign import prim primCmpInteger :: Integer -> Integer -> Ordering +foreign import prim primAddInteger :: Integer -> Integer -> Integer +foreign import prim primSubInteger :: Integer -> Integer -> Integer +foreign import prim primMulInteger :: Integer -> Integer -> Integer +foreign import prim primNegInteger :: Integer -> Integer +foreign import prim primQuotInteger :: Integer -> Integer -> Integer +foreign import prim primRemInteger :: Integer -> Integer -> Integer +foreign import prim primDivInteger :: Integer -> Integer -> Integer +foreign import prim primModInteger :: Integer -> Integer -> Integer +#ifdef __UHC_TARGET_BC__ +foreign import prim primQuotRemInteger :: Integer -> Integer -> (Integer,Integer) +foreign import prim primDivModInteger :: Integer -> Integer -> (Integer,Integer) +#endif +#endif instance Eq Integer where (==) = primEqInteger @@ -937,11 +973,6 @@ instance Eq Integer where instance Ord Integer where compare = primCmpInteger -foreign import prim primAddInteger :: Integer -> Integer -> Integer -foreign import prim primSubInteger :: Integer -> Integer -> Integer -foreign import prim primMulInteger :: Integer -> Integer -> Integer -foreign import prim primNegInteger :: Integer -> Integer - instance Num Integer where (+) = primAddInteger (-) = primSubInteger @@ -952,18 +983,11 @@ instance Num Integer where fromInteger x = x fromInt = primIntToInteger - instance Real Integer where toRational x = x % 1 -foreign import prim primQuotInteger :: Integer -> Integer -> Integer -foreign import prim primRemInteger :: Integer -> Integer -> Integer -foreign import prim primDivInteger :: Integer -> Integer -> Integer -foreign import prim primModInteger :: Integer -> Integer -> Integer - - -#if defined (__UHC_TARGET_C__) || defined (__UHC_TARGET_LLVM__) +#if defined( __UHC_TARGET_C__) || defined(__UHC_TARGET_JAZY__) || defined (__UHC_TARGET_LLVM__) instance Integral Integer where divMod x y = (primDivInteger x y, primModInteger x y) @@ -977,9 +1001,6 @@ instance Integral Integer where #else -foreign import prim primQuotRemInteger :: Integer -> Integer -> (Integer,Integer) -foreign import prim primDivModInteger :: Integer -> Integer -> (Integer,Integer) - instance Integral Integer where divMod = primDivModInteger quotRem = primQuotRemInteger @@ -992,7 +1013,6 @@ instance Integral Integer where #endif - instance Enum Integer where succ x = x + 1 pred x = x - 1 @@ -1006,8 +1026,6 @@ instance Enum Integer where where p | n2 >= n = (<= m) | otherwise = (>= m) - - #if defined (__UHC_TARGET_C__) || defined (__UHC_TARGET_LLVM__) {- This implementation fails for showInt minBound because in 2's complement arithmetic @@ -1052,10 +1070,63 @@ instance Read Integer where data Float -- opaque datatype of 32bit IEEE floating point numbers data Double -- opaque datatype of 64bit IEEE floating point numbers -foreign import prim primEqFloat :: Float -> Float -> Bool -foreign import prim primCmpFloat :: Float -> Float -> Ordering -foreign import prim primEqDouble :: Double -> Double -> Bool -foreign import prim primCmpDouble :: Double -> Double -> Ordering +#if defined(__UHC_TARGET_JSCRIPT__) +foreign import prim "primEqInt" primEqFloat :: Float -> Float -> Bool +foreign import prim "primCmpInt" primCmpFloat :: Float -> Float -> Ordering + +foreign import prim "primEqDouble" primEqDouble :: Double -> Double -> Bool +foreign import prim "primCmpDouble" primCmpDouble :: Double -> Double -> Ordering + +foreign import prim "primAddInt" primAddFloat :: Float -> Float -> Float +foreign import prim "primSubInt" primSubFloat :: Float -> Float -> Float +foreign import prim "primMulInt" primMulFloat :: Float -> Float -> Float +foreign import prim "primNegInt" primNegFloat :: Float -> Float +foreign import prim "primUnsafeId" primIntToFloat :: Int -> Float +foreign import prim "primUnsafeId" primIntegerToFloat :: Integer -> Float + +foreign import prim "primAddDouble" primAddDouble :: Double -> Double -> Double +foreign import prim "primSubDouble" primSubDouble :: Double -> Double -> Double +foreign import prim "primMulDouble" primMulDouble :: Double -> Double -> Double +foreign import prim "primNegDouble" primNegDouble :: Double -> Double +foreign import prim "primUnsafeId" primIntToDouble :: Int -> Double +foreign import prim "primUnsafeId" primIntegerToDouble :: Integer -> Double + +foreign import prim "primQuotInt" primDivideFloat :: Float -> Float -> Float +foreign import prim "primRecipDouble" primRecipFloat :: Float -> Float +foreign import prim "primUnsafeId" primDoubleToFloat :: Double -> Float + +foreign import prim "primUnsafeId" primFloatToDouble :: Float -> Double +foreign import prim "primRationalToDouble" primRationalToFloat :: Rational -> Float +foreign import prim "primRationalToDouble" primRationalToDouble :: Rational -> Double +#else +foreign import prim primEqFloat :: Float -> Float -> Bool +foreign import prim primCmpFloat :: Float -> Float -> Ordering + +foreign import prim primEqDouble :: Double -> Double -> Bool +foreign import prim primCmpDouble :: Double -> Double -> Ordering + +foreign import prim primAddFloat :: Float -> Float -> Float +foreign import prim primSubFloat :: Float -> Float -> Float +foreign import prim primMulFloat :: Float -> Float -> Float +foreign import prim primNegFloat :: Float -> Float +foreign import prim primIntToFloat :: Int -> Float +foreign import prim primIntegerToFloat :: Integer -> Float + +foreign import prim primAddDouble :: Double -> Double -> Double +foreign import prim primSubDouble :: Double -> Double -> Double +foreign import prim primMulDouble :: Double -> Double -> Double +foreign import prim primNegDouble :: Double -> Double +foreign import prim primIntToDouble :: Int -> Double +foreign import prim primIntegerToDouble :: Integer -> Double + +foreign import prim primDivideFloat :: Float -> Float -> Float +foreign import prim primRecipFloat :: Float -> Float +foreign import prim primDoubleToFloat :: Double -> Float + +foreign import prim primFloatToDouble :: Float -> Double +foreign import prim primRationalToFloat :: Rational -> Float +foreign import prim primRationalToDouble :: Rational -> Double +#endif instance Eq Float where (==) = primEqFloat instance Eq Double where (==) = primEqDouble @@ -1063,12 +1134,6 @@ instance Eq Double where (==) = primEqDouble instance Ord Float where compare = primCmpFloat instance Ord Double where compare = primCmpDouble -foreign import prim primAddFloat :: Float -> Float -> Float -foreign import prim primSubFloat :: Float -> Float -> Float -foreign import prim primMulFloat :: Float -> Float -> Float -foreign import prim primNegFloat :: Float -> Float -foreign import prim primIntToFloat :: Int -> Float -foreign import prim primIntegerToFloat :: Integer -> Float instance Num Float where (+) = primAddFloat @@ -1080,12 +1145,6 @@ instance Num Float where fromInteger = primIntegerToFloat fromInt = primIntToFloat -foreign import prim primAddDouble :: Double -> Double -> Double -foreign import prim primSubDouble :: Double -> Double -> Double -foreign import prim primMulDouble :: Double -> Double -> Double -foreign import prim primNegDouble :: Double -> Double -foreign import prim primIntToDouble :: Int -> Double -foreign import prim primIntegerToDouble :: Integer -> Double instance Num Double where (+) = primAddDouble @@ -1114,10 +1173,6 @@ fromRat x = (m%1)*(b%1)^^n where (m,n) = decodeFloat x b = floatRadix x -foreign import prim primDivideFloat :: Float -> Float -> Float -foreign import prim primRecipFloat :: Float -> Float -foreign import prim primDoubleToFloat :: Double -> Float -foreign import prim primFloatToDouble :: Float -> Double instance Fractional Float where (/) = primDivideFloat @@ -1142,8 +1197,6 @@ instance Fractional Double where primitive primRationalToFloat :: Rational -> Float primitive primRationalToDouble :: Rational -> Double -----------------------------} -foreign import prim primRationalToFloat :: Rational -> Float -foreign import prim primRationalToDouble :: Rational -> Double {----------------------------- -- These functions are used by Hugs - don't change their types. @@ -1174,7 +1227,22 @@ foreign import prim primAtanFloat :: Float -> Float foreign import prim primExpFloat :: Float -> Float foreign import prim primLogFloat :: Float -> Float foreign import prim primSqrtFloat :: Float -> Float -#else +foreign import prim primAtan2Float :: Float -> Float -> Float +#elif defined(__UHC_TARGET_JSCRIPT__) +foreign import prim "primSinDouble" primSinFloat :: Float -> Float +foreign import prim "primCosDouble" primCosFloat :: Float -> Float +foreign import prim "primTanDouble" primTanFloat :: Float -> Float +foreign import prim "primAsinDouble" primAsinFloat :: Float -> Float +foreign import prim "primAcosDouble" primAcosFloat :: Float -> Float +foreign import prim "primAtanDouble" primAtanFloat :: Float -> Float +foreign import prim "primExpDouble" primExpFloat :: Float -> Float +foreign import prim "primLogDouble" primLogFloat :: Float -> Float +foreign import prim "primSqrtDouble" primSqrtFloat :: Float -> Float +foreign import prim "primSinhDouble" primSinhFloat :: Float -> Float +foreign import prim "primCoshDouble" primCoshFloat :: Float -> Float +foreign import prim "primTanhDouble" primTanhFloat :: Float -> Float +foreign import prim "primAtan2Double" primAtan2Float :: Float -> Float -> Float +#else foreign import ccall "sinf" primSinFloat :: Float -> Float foreign import ccall "cosf" primCosFloat :: Float -> Float foreign import ccall "tanf" primTanFloat :: Float -> Float @@ -1188,6 +1256,7 @@ foreign import ccall "sqrtf" primSqrtFloat :: Float -> Float foreign import ccall "sinhf" primSinhFloat :: Float -> Float foreign import ccall "coshf" primCoshFloat :: Float -> Float foreign import ccall "tanhf" primTanhFloat :: Float -> Float +foreign import ccall "atan2f" primAtan2Float :: Float -> Float -> Float #endif instance Floating Float where @@ -1216,6 +1285,21 @@ foreign import prim primAtanDouble :: Double -> Double foreign import prim primExpDouble :: Double -> Double foreign import prim primLogDouble :: Double -> Double foreign import prim primSqrtDouble :: Double -> Double +foreign import prim primAtan2Double :: Double -> Double -> Double +#elif defined(__UHC_TARGET_JSCRIPT__) +foreign import prim primSinDouble :: Double -> Double +foreign import prim primCosDouble :: Double -> Double +foreign import prim primTanDouble :: Double -> Double +foreign import prim primAsinDouble :: Double -> Double +foreign import prim primAcosDouble :: Double -> Double +foreign import prim primAtanDouble :: Double -> Double +foreign import prim primExpDouble :: Double -> Double +foreign import prim primLogDouble :: Double -> Double +foreign import prim primSqrtDouble :: Double -> Double +foreign import prim primSinhDouble :: Double -> Double +foreign import prim primCoshDouble :: Double -> Double +foreign import prim primTanhDouble :: Double -> Double +foreign import prim primAtan2Double :: Double -> Double -> Double #else foreign import ccall "sin" primSinDouble :: Double -> Double foreign import ccall "cos" primCosDouble :: Double -> Double @@ -1229,6 +1313,7 @@ foreign import ccall "sqrt" primSqrtDouble :: Double -> Double foreign import ccall "sinh" primSinhDouble :: Double -> Double foreign import ccall "cosh" primCoshDouble :: Double -> Double foreign import ccall "tanh" primTanhDouble :: Double -> Double +foreign import ccall "atan2" primAtan2Double :: Double -> Double -> Double #endif instance Floating Double where @@ -1264,20 +1349,15 @@ floatProperFraction x foreign import prim primIsIEEE :: Bool foreign import prim primRadixDoubleFloat :: Int -foreign import prim primIsNaNFloat :: Float -> Bool -foreign import prim primIsNegativeZeroFloat :: Float -> Bool -foreign import prim primIsDenormalizedFloat :: Float -> Bool -foreign import prim primIsInfiniteFloat :: Float -> Bool -foreign import prim primDigitsFloat :: Int -foreign import prim primMaxExpFloat :: Int -foreign import prim primMinExpFloat :: Int -foreign import prim primDecodeFloat :: Float -> (Integer, Int) -foreign import prim primEncodeFloat :: Integer -> Int -> Float -#ifdef __UHC_TARGET_JAZY__ -foreign import prim primAtan2Float :: Float -> Float -> Float -#else -foreign import ccall "atan2f" primAtan2Float :: Float -> Float -> Float -#endif +foreign import prim primIsNaNFloat :: Float -> Bool +foreign import prim primIsNegativeZeroFloat :: Float -> Bool +foreign import prim primIsDenormalizedFloat :: Float -> Bool +foreign import prim primIsInfiniteFloat :: Float -> Bool +foreign import prim primDigitsFloat :: Int +foreign import prim primMaxExpFloat :: Int +foreign import prim primMinExpFloat :: Int +foreign import prim primDecodeFloat :: Float -> (Integer, Int) +foreign import prim primEncodeFloat :: Integer -> Int -> Float instance RealFloat Float where floatRadix _ = toInteger primRadixDoubleFloat @@ -1292,20 +1372,15 @@ instance RealFloat Float where isIEEE _ = primIsIEEE atan2 = primAtan2Float -foreign import prim primIsNaNDouble :: Double -> Bool -foreign import prim primIsNegativeZeroDouble :: Double -> Bool -foreign import prim primIsDenormalizedDouble :: Double -> Bool -foreign import prim primIsInfiniteDouble :: Double -> Bool -foreign import prim primDigitsDouble :: Int -foreign import prim primMaxExpDouble :: Int -foreign import prim primMinExpDouble :: Int -foreign import prim primDecodeDouble :: Double -> (Integer, Int) -foreign import prim primEncodeDouble :: Integer -> Int -> Double -#ifdef __UHC_TARGET_JAZY__ -foreign import prim primAtan2Double :: Double -> Double -> Double -#else -foreign import ccall "atan2" primAtan2Double :: Double -> Double -> Double -#endif +foreign import prim primIsNaNDouble :: Double -> Bool +foreign import prim primIsNegativeZeroDouble :: Double -> Bool +foreign import prim primIsDenormalizedDouble :: Double -> Bool +foreign import prim primIsInfiniteDouble :: Double -> Bool +foreign import prim primDigitsDouble :: Int +foreign import prim primMaxExpDouble :: Int +foreign import prim primMinExpDouble :: Int +foreign import prim primDecodeDouble :: Double -> (Integer, Int) +foreign import prim primEncodeDouble :: Integer -> Int -> Double instance RealFloat Double where floatRadix _ = toInteger primRadixDoubleFloat @@ -2039,15 +2114,23 @@ primbindIO (IO io) f ioFromPrim :: (IOWorld -> a) -> IO a ioFromPrim f = IO (\w -> let x = f w - in letstrict x2 = x -- as a side effect, this will update x - in (w, x) -- do not use x2 here, because the code generated by letstrict violates the Grin-invariant if the result is used directly + in letstrict x' = x -- as a side effect, this will update x +#ifdef __UHC_TARGET_C__ + in (w, x) -- do not use x' here, because the code generated by letstrict violates the Grin-invariant if the result is used directly +#else + in (w, x') +#endif ) primbindIO :: IO a -> (a -> IO b) -> IO b primbindIO (IO io) f = IO (\w -> case io w of (w', x) -> letstrict x' = x -- as a side effect, this will update x +#ifdef __UHC_TARGET_C__ in case f x of -- do not use x' here, because the code generated by letstrict violates the Grin-invariant if the result is used directly +#else + in case f x' of +#endif IO fx -> fx w' ) diff --git a/EHC/ehclib/uhcbase/UHC/ByteArray.chs b/EHC/ehclib/uhcbase/UHC/ByteArray.chs index b9ff58a58..da7bb5cc4 100644 --- a/EHC/ehclib/uhcbase/UHC/ByteArray.chs +++ b/EHC/ehclib/uhcbase/UHC/ByteArray.chs @@ -19,19 +19,28 @@ module UHC.ByteArray , unsafeFreezeByteArray , indexCharArray, indexWideCharArray - , indexIntArray, indexWordArray, indexAddrArray, indexStablePtrArray + , indexIntArray, indexWordArray, indexAddrArray +#if !defined( __UHC_TARGET_JSCRIPT__ ) + , indexStablePtrArray +#endif , indexFloatArray, indexDoubleArray , indexInt8Array, indexInt16Array, indexInt32Array, indexInt64Array , indexWord8Array, indexWord16Array, indexWord32Array, indexWord64Array , readCharArray, readWideCharArray - , readIntArray, readWordArray, readAddrArray, readStablePtrArray + , readIntArray, readWordArray, readAddrArray +#if !defined( __UHC_TARGET_JSCRIPT__ ) + , readStablePtrArray +#endif , readFloatArray, readDoubleArray , readInt8Array, readInt16Array, readInt32Array, readInt64Array , readWord8Array, readWord16Array, readWord32Array, readWord64Array , writeCharArray, writeWideCharArray - , writeIntArray, writeWordArray, writeAddrArray, writeStablePtrArray + , writeIntArray, writeWordArray, writeAddrArray +#if !defined( __UHC_TARGET_JSCRIPT__ ) + , writeStablePtrArray +#endif , writeFloatArray, writeDoubleArray , writeInt8Array, writeInt16Array, writeInt32Array, writeInt64Array , writeWord8Array, writeWord16Array, writeWord32Array, writeWord64Array @@ -41,7 +50,9 @@ module UHC.ByteArray import UHC.Base import UHC.Ptr +#if !defined( __UHC_TARGET_JSCRIPT__ ) import UHC.StablePtr +#endif import UHC.Types #include "MachDeps.h" @@ -137,8 +148,10 @@ foreign import prim "primIndexWord64Array" indexWord64Array :: ByteArray -> In %%] %%[99 +#if !defined( __UHC_TARGET_JSCRIPT__ ) indexStablePtrArray :: forall s . ByteArray -> Int -> StablePtr s indexStablePtrArray a i = letstrict x = indexAddrArray a i in StablePtr x +#endif %%] %%[99 @@ -167,8 +180,10 @@ readFloatArray (MutableByteArray a) i s = letstrict x = indexFloatArray a i in ( readDoubleArray :: MutableByteArray s -> Int -> State s -> ( State s,Double ) readDoubleArray (MutableByteArray a) i s = letstrict x = indexDoubleArray a i in (s, x) +#if !defined( __UHC_TARGET_JSCRIPT__ ) readStablePtrArray :: MutableByteArray s -> Int -> State s -> ( State s,StablePtr s ) readStablePtrArray (MutableByteArray a) i s = letstrict x = indexStablePtrArray a i in (s, x) +#endif readInt8Array :: MutableByteArray s -> Int -> State s -> ( State s,Int8 ) readInt8Array (MutableByteArray a) i s = letstrict x = indexInt8Array a i in (s, x) @@ -252,8 +267,10 @@ writeFloatArray (MutableByteArray a) i x s = letstrict _ = primWriteFloatArray a writeDoubleArray :: MutableByteArray s -> Int -> Double -> State s -> State s writeDoubleArray (MutableByteArray a) i x s = letstrict _ = primWriteDoubleArray a i x in s +#if !defined( __UHC_TARGET_JSCRIPT__ ) writeStablePtrArray :: MutableByteArray s -> Int -> StablePtr s -> State s -> State s writeStablePtrArray (MutableByteArray a) i (StablePtr x) s = letstrict _ = primWriteAddrArray a i x in s +#endif writeInt8Array :: MutableByteArray s -> Int -> Int8 -> State s -> State s writeInt8Array (MutableByteArray a) i x s = letstrict _ = primWriteInt8Array a i x in s diff --git a/EHC/ehclib/uhcbase/UHC/Conc.chs b/EHC/ehclib/uhcbase/UHC/Conc.chs index 3e6da532f..c8162e63b 100644 --- a/EHC/ehclib/uhcbase/UHC/Conc.chs +++ b/EHC/ehclib/uhcbase/UHC/Conc.chs @@ -11,6 +11,7 @@ In particular, System.IO requires this. %%[99 {-# LANGUAGE NoImplicitPrelude #-} +{-# EXCLUDE_IF_TARGET jscript #-} module UHC.Conc ( threadWaitRead, threadWaitWrite diff --git a/EHC/ehclib/uhcbase/UHC/ForeignPtr.chs b/EHC/ehclib/uhcbase/UHC/ForeignPtr.chs index 5a8d36bd6..f97ab74c0 100644 --- a/EHC/ehclib/uhcbase/UHC/ForeignPtr.chs +++ b/EHC/ehclib/uhcbase/UHC/ForeignPtr.chs @@ -2,6 +2,7 @@ {-# LANGUAGE NoImplicitPrelude, CPP #-} {-# OPTIONS_GHC -XNoImplicitPrelude #-} {-# OPTIONS_HADDOCK hide #-} +{-# EXCLUDE_IF_TARGET jscript #-} ----------------------------------------------------------------------------- -- | -- Module : GHC.ForeignPtr diff --git a/EHC/ehclib/uhcbase/UHC/Handle.chs b/EHC/ehclib/uhcbase/UHC/Handle.chs index f2f26c9b1..6d93d592b 100644 --- a/EHC/ehclib/uhcbase/UHC/Handle.chs +++ b/EHC/ehclib/uhcbase/UHC/Handle.chs @@ -1,5 +1,6 @@ %%[99 {-# LANGUAGE NoImplicitPrelude, CPP #-} +{-# EXCLUDE_IF_TARGET jscript #-} ----------------------------------------------------------------------------- -- | diff --git a/EHC/ehclib/uhcbase/UHC/IO.chs b/EHC/ehclib/uhcbase/UHC/IO.chs index 4ab608701..8e48a7b0c 100644 --- a/EHC/ehclib/uhcbase/UHC/IO.chs +++ b/EHC/ehclib/uhcbase/UHC/IO.chs @@ -1,6 +1,7 @@ %%[99 {-# LANGUAGE NoImplicitPrelude, CPP #-} {-# OPTIONS_HADDOCK hide #-} +{-# EXCLUDE_IF_TARGET jscript #-} #undef DEBUG_DUMP diff --git a/EHC/ehclib/uhcbase/UHC/IOBase.chs b/EHC/ehclib/uhcbase/UHC/IOBase.chs index 7e1bee194..315ff2df3 100644 --- a/EHC/ehclib/uhcbase/UHC/IOBase.chs +++ b/EHC/ehclib/uhcbase/UHC/IOBase.chs @@ -55,8 +55,10 @@ module UHC.IOBase #endif catch, catchException, -#if defined (__UHC_TARGET_C__) || defined (__UHC_TARGET_LLVM__) +#if defined( __UHC_TARGET_C__ ) || defined (__UHC_TARGET_LLVM__) FHandle, +#elif defined( __UHC_TARGET_JSCRIPT__ ) + JSHandle(..), #endif ) where @@ -372,8 +374,11 @@ data IOMode -- alphabetical order of constructors required, assumed %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%[99 -#if defined (__UHC_TARGET_C__) || defined (__UHC_TARGET_LLVM__) +#if defined( __UHC_TARGET_C__ ) || defined (__UHC_TARGET_LLVM__) + data FHandle -- opaque, contains FILE* +#elif defined( __UHC_TARGET_JSCRIPT__ ) +data JSHandle = JSHandle String #else data GBHandle -- opaque, contains GB_Chan #endif @@ -386,6 +391,14 @@ instance Eq FHandle where instance Show FHandle where showsPrec _ h = showString "" +#elif defined( __UHC_TARGET_JSCRIPT__ ) + +instance Eq JSHandle where + _ == _ = False + +instance Show JSHandle where + showsPrec _ h = showString "" + #else foreign import prim primEqGBHandleFileno :: GBHandle -> Int -> Bool @@ -418,8 +431,10 @@ data Handle !(MVar Handle__) -- The write side | OldHandle -#if defined (__UHC_TARGET_C__) || defined (__UHC_TARGET_LLVM__) +#if defined( __UHC_TARGET_C__ ) || defined (__UHC_TARGET_LLVM__) FHandle +#elif defined( __UHC_TARGET_JSCRIPT__ ) + JSHandle #else GBHandle #endif diff --git a/EHC/ehclib/uhcbase/UHC/Int.chs b/EHC/ehclib/uhcbase/UHC/Int.chs index 25bb1024b..855564a33 100644 --- a/EHC/ehclib/uhcbase/UHC/Int.chs +++ b/EHC/ehclib/uhcbase/UHC/Int.chs @@ -1,5 +1,6 @@ %%[99 {-# LANGUAGE NoImplicitPrelude, CPP #-} +{-# EXCLUDE_IF_TARGET jscript #-} -- Compiler knows the Int types of this module are defined here diff --git a/EHC/ehclib/uhcbase/UHC/OldIO.chs b/EHC/ehclib/uhcbase/UHC/OldIO.chs index 9cc8551a0..0327a3e2d 100644 --- a/EHC/ehclib/uhcbase/UHC/OldIO.chs +++ b/EHC/ehclib/uhcbase/UHC/OldIO.chs @@ -10,10 +10,16 @@ module UHC.OldIO , IOMode(..) -- IO functions - , hClose, hGetContents, hGetChar, hGetLine, hPutChar, hPutStr, hPutStrLn, hFlush - , stdin, stdout, stderr, openFile - , putChar, putStr, putStrLn, print, {- hPrint, -} getChar, getLine, getContents, interact + , hClose, hPutChar, hPutStr, hPutStrLn, hFlush + , putChar, putStr, putStrLn, print{- hPrint, -} + , stdout, stderr +#if !defined(__UHC_TARGET_JSCRIPT__) + , stdin + , openFile + , hGetContents, hGetChar, hGetLine + , getChar, getLine, getContents, interact , readFile, writeFile, appendFile +#endif ) where @@ -91,8 +97,10 @@ hPutChar h c = ioFromPrim (\_ -> primHPutChar h c) #endif + #if defined (__UHC_TARGET_C__) || defined (__UHC_TARGET_LLVM__) + openFile :: FilePath -> IOMode -> IO Handle openFile f m = ioFromPrim (\_ -> OldHandle (primOpenFile (forceString f) m)) @@ -104,20 +112,29 @@ stderr = OldHandle primStderr hIsEOF :: Handle -> IO Bool hIsEOF (OldHandle h) = ioFromPrim (\_ -> primHIsEOF h) +#elif defined(__UHC_TARGET_JSCRIPT__) +stdout, stderr :: Handle +stdout = OldHandle (JSHandle "stdout") +stderr = OldHandle (JSHandle "stderr") #else openFile :: FilePath -> IOMode -> IO Handle openFile f m = ioFromPrim (\_ -> primOpenFileOrStd f m Nothing) -stdin, stdout, stderr :: Handle #ifdef __UHC_TARGET_JAZY__ + +stdin, stdout, stderr :: Handle stdin = primStdin stdout = primStdout stderr = primStderr + #else + +stdin, stdout, stderr :: Handle stdin = primOpenFileOrStd "" ReadMode (Just 0) stdout = primOpenFileOrStd "" WriteMode (Just 1) stderr = primOpenFileOrStd "" WriteMode (Just 2) + #endif #endif @@ -132,6 +149,7 @@ stderr = primOpenFileOrStd "" WriteMode (Just 2) -- specializations for stdin, stdout +#if !defined(__UHC_TARGET_JSCRIPT__) getChar :: IO Char getChar = hGetChar stdin @@ -140,6 +158,7 @@ getLine = hGetLine stdin getContents :: IO String getContents = hGetContents stdin +#endif putChar :: Char -> IO () putChar = hPutChar stdout @@ -153,8 +172,10 @@ putStr = hPutStr stdout putStrLn :: String -> IO () putStrLn = hPutStrLn stdout +#if !defined(__UHC_TARGET_JSCRIPT__) interact :: (String -> String) -> IO () interact f = getContents >>= (putStr . f) +#endif -- combinations with newline and show @@ -167,6 +188,7 @@ hPutStrLn h s = do { hPutStr h s hPrint :: Show a => Handle -> a -> IO () hPrint h = hPutStrLn h . show +#if !defined(__UHC_TARGET_JSCRIPT__) hGetLine :: Handle -> IO String hGetLine h = do { c <- hGetChar h ; hGetLine2 c @@ -187,8 +209,9 @@ hGetLine h = do { c <- hGetChar h hGetLine2 c isEOFError ex = ioe_type ex == EOF #endif +#endif - +#if !defined(__UHC_TARGET_JSCRIPT__) -- combinations with Read -- raises an exception instead of an error readIO :: Read a => String -> IO a @@ -202,11 +225,12 @@ readLn :: Read a => IO a readLn = do l <- getLine r <- readIO l return r - +#endif -- file open&process&close wrapped in one function +#if !defined(__UHC_TARGET_JSCRIPT__) readFile :: FilePath -> IO String readFile name = openFile name ReadMode >>= hGetContents @@ -225,7 +249,7 @@ writeFile2 mode name s catchException (hPutStr h s) (\e -> hClose h >> throw e) #endif hClose h - +#endif %%] @@ -248,7 +272,9 @@ foreign import prim primHGetContents :: Handle -> String -- or for efficiency using additional primitives ---------------------------------------------------------------- +#if !defined(__UHC_TARGET_JSCRIPT__) hGetContents :: Handle -> IO String +#endif hPutStr :: Handle -> String -> IO () @@ -262,6 +288,15 @@ hGetContents h = do b <- hIsEOF h ; return (c:cs) } +#else + +hGetContents h = ioFromPrim (\_ -> primHGetContents h) + +#endif + + +#if defined(__UHC_TARGET_C__) || defined(__UHC_TARGET_JSCRIPT__) + hPutStr h s = do if null s then return () else do { hPutChar h (head s) @@ -272,8 +307,6 @@ hPutStr h s = do if null s foreign import prim primStringToByteArray :: String -> Int -> ByteArray -hGetContents h = ioFromPrim (\_ -> primHGetContents h) - hPutStr h s = do let (shd,stl) = splitAt 1000 s ioFromPrim (\_ -> primHPutByteArray h (primStringToByteArray shd 1000)) if null stl then return () else hPutStr h stl diff --git a/EHC/ehclib/uhcbase/UHC/Run.chs b/EHC/ehclib/uhcbase/UHC/Run.chs index 96c6c1645..75c54fd22 100644 --- a/EHC/ehclib/uhcbase/UHC/Run.chs +++ b/EHC/ehclib/uhcbase/UHC/Run.chs @@ -13,16 +13,18 @@ module UHC.Run import UHC.Base import UHC.IOBase import UHC.OldException +#ifndef __UHC_TARGET_JSCRIPT__ import UHC.Handle +#endif import UHC.StackTrace -#ifndef __UHC_TARGET_C__ +#if !( defined(__UHC_TARGET_C__) || defined(__UHC_TARGET_JSCRIPT__) ) import System.IO (hPutStrLn) #endif %%] %%[99 -#if defined (__UHC_TARGET_C__) || defined (__UHC_TARGET_LLVM__) +#if defined(__UHC_TARGET_C__) || defined(__UHC_TARGET_JSCRIPT__) || defined (__UHC_TARGET_LLVM__) -- Wrapper around 'main', invoked as 'ehcRunMain main' ehcRunMain :: IO a -> IO a @@ -57,7 +59,6 @@ ehcRunMain m = } ) -#endif -- try to flush stdout/stderr, but don't worry if we fail -- (these handles might have errors, and we don't want to go into @@ -71,4 +72,6 @@ wrapCleanUp :: IO a -> IO a wrapCleanUp m = do x <- m cleanUp return x + +#endif %%] diff --git a/EHC/ehclib/uhcbase/UHC/StablePtr.chs b/EHC/ehclib/uhcbase/UHC/StablePtr.chs index a119f373d..2d04dd7cf 100644 --- a/EHC/ehclib/uhcbase/UHC/StablePtr.chs +++ b/EHC/ehclib/uhcbase/UHC/StablePtr.chs @@ -3,6 +3,7 @@ {-# OPTIONS_GHC -XNoImplicitPrelude #-} {-# OPTIONS_HADDOCK hide #-} +{-# EXCLUDE_IF_TARGET jscript #-} ----------------------------------------------------------------------------- -- | -- Module : GHC.Stable diff --git a/EHC/ehclib/uhcbase/UHC/Storable.chs b/EHC/ehclib/uhcbase/UHC/Storable.chs index 765d2c515..4ae36c951 100644 --- a/EHC/ehclib/uhcbase/UHC/Storable.chs +++ b/EHC/ehclib/uhcbase/UHC/Storable.chs @@ -3,6 +3,7 @@ {-# OPTIONS_GHC -XNoImplicitPrelude #-} {-# OPTIONS_HADDOCK hide #-} +{-# EXCLUDE_IF_TARGET jscript #-} ----------------------------------------------------------------------------- -- | -- Module : GHC.Storable diff --git a/EHC/ehclib/uhcbase/UHC/Word.chs b/EHC/ehclib/uhcbase/UHC/Word.chs index 31bfc08ab..35c43b019 100644 --- a/EHC/ehclib/uhcbase/UHC/Word.chs +++ b/EHC/ehclib/uhcbase/UHC/Word.chs @@ -1,5 +1,6 @@ %%[99 {-# LANGUAGE NoImplicitPrelude, CPP #-} +{-# EXCLUDE_IF_TARGET jscript #-} -- Compiler knows the Word types of this module are defined here diff --git a/EHC/mk/config.mk.in b/EHC/mk/config.mk.in index 2d54b0fe0..2989b8797 100644 --- a/EHC/mk/config.mk.in +++ b/EHC/mk/config.mk.in @@ -29,7 +29,8 @@ EH_VERSION_ASNUMBER := @EH_VERSION_ASNUMBER@ # TOPABS_PREFIX : absolute prefix/pathname to top dir EXEC_SUFFIX := @SUFFIX_EXEC@ -LIB_SUFFIX := @SUFFIX_LIB@ +LIBC_SUFFIX := @SUFFIX_LIBC@ +LIBJSCRIPT_SUFFIX := @SUFFIX_LIBJSCRIPT@ PATH_SEP := / PATHS_SEP := @PATHS_SEP@ PATHS_SEP_COL := : @@ -64,11 +65,16 @@ ifeq (@ENABLE_JAVA@,yes) ENABLE_JAVA := yes endif -# include java code generation +# include clr code generation ifeq (@ENABLE_CLR@,yes) ENABLE_CLR := yes endif +# include javascript code generation +ifeq (@ENABLE_JSCRIPT@,yes) +ENABLE_JSCRIPT := yes +endif + # include llvm code generation ifeq (@ENABLE_LLVM@,yes) ENABLE_LLVM := yes diff --git a/EHC/mk/shared.mk.in b/EHC/mk/shared.mk.in index cefc0bd7c..0efc3092c 100644 --- a/EHC/mk/shared.mk.in +++ b/EHC/mk/shared.mk.in @@ -180,7 +180,7 @@ INSTALLABS_INC_PREFIX := $(INSTALLABS_PREFIX)include/ # location for uhc installs, as specified by configure INSTALL_UHC_ROOT := @prefix@/lib -INSTALL_UHC_DIR := @prefix@/@INSTALL_LIB_SUFFIX@ +INSTALL_UHC_DIR := @prefix@/@INSTALL_LIBC_SUFFIX@ INSTALL_UHC_PREFIX := $(INSTALL_UHC_DIR)/ INSTALL_UHC_BIN_PREFIX := @prefix@/bin/ INSTALL_UHC_LIB_PREFIX := $(INSTALL_UHC_PREFIX)lib/ @@ -228,6 +228,7 @@ OPEN_FOR_EDIT := bbedit STRIP := $(STRIP_CMD) JAVAC := @JAVAC_CMD@ JAR := @JAR_CMD@ +CAT := @CAT_CMD@ SHELL_FILTER_NONEMP_FILES := $(BINABS_PREFIX)filterOutEmptyFiles SHELL_AGDEPEND := $(BINABS_PREFIX)agdepend TAR := @TAR_CMD@ @@ -320,13 +321,18 @@ FUN_MK_PKG_INC_DIR = $(1)include # for a C library # $1: directory/location prefix # $2: package name -FUN_MK_CLIB_FILENAME = $(1)lib$(2)$(LIB_SUFFIX) +FUN_MK_CLIB_FILENAME = $(1)lib$(2)$(LIBC_SUFFIX) # for a java library # $1: directory/location prefix # $2: package name FUN_MK_JAVALIB_FILENAME = $(1)lib$(2).jar +# for a jscript library +# $1: directory/location prefix +# $2: package name +FUN_MK_JSLIB_FILENAME = $(1)lib$(2)$(LIBJSCRIPT_SUFFIX) + ########################################################################################### # Regular options to commands, as functions still depending on variant + target ########################################################################################### diff --git a/EHC/src/ehc/AbstractCore.chs b/EHC/src/ehc/AbstractCore.chs index 52aa8fb3a..3ebfa5c8e 100644 --- a/EHC/src/ehc/AbstractCore.chs +++ b/EHC/src/ehc/AbstractCore.chs @@ -494,6 +494,11 @@ acoreLetRec bs e = acoreLet (acoreBindcategRec) bs e {-# INLINE acoreLetRec #-} %%] +%%[(8 codegen) export(acoreLetN) +acoreLetN :: (Eq bcat, AbstractCore e m b basp bcat mbind t p pr pf a) => [(bcat,[b])] -> e -> e +acoreLetN cbs e = foldr (\(c,bs) e -> acoreLet c bs e) e cbs +%%] + %%[(8 codegen) export(acoreLet1PlainTy,acoreLet1Plain) acoreLet1PlainTy :: (Eq bcat, AbstractCore e m b basp bcat mbind t p pr pf a) => HsName -> t -> e -> e -> e acoreLet1PlainTy nm t e @@ -1110,6 +1115,7 @@ data WhatExpr | ExprIsVar HsName | ExprIsInt Int | ExprIsOther + | ExprIsBind deriving Eq %%] diff --git a/EHC/src/ehc/AbstractCore/Utils.chs b/EHC/src/ehc/AbstractCore/Utils.chs index aeae7cb85..99a940b28 100644 --- a/EHC/src/ehc/AbstractCore/Utils.chs +++ b/EHC/src/ehc/AbstractCore/Utils.chs @@ -177,7 +177,7 @@ type MbPatRest' pr = Maybe (pr,Int) -- (pat rest, arity) acoreStrictSatCaseMetaTy :: (Eq bcat, AbstractCore e m b basp bcat mbind t p pr pf a) => RCEEnv' e m b ba t -> Maybe (HsName,t) -> m -> e -> [a] -> e acoreStrictSatCaseMetaTy env mbNm meta e [] = rceCaseCont env -- TBD: should be error message "scrutinizing datatype without constructors" -acoreStrictSatCaseMetaTy env mbNm meta e [alt] -- [CAlt_Alt (CPat_Con (CTag tyNm _ _ _ _) CPatRest_Empty [CPatFld_Fld _ _ pnm]) ae] +acoreStrictSatCaseMetaTy env mbNm meta e [alt] -- [CAlt_Alt (CPat_Con (CTag tyNm _ _ _ _) CPatRest_Empty [CPatFld_Fld _ _ pnm _]) ae] | isJust mbPatCon && length flds == 1 && dgiIsNewtype dgi = acoreLet cat ( [ acoreBind1CatMetaTy cat pnm meta (acoreTyErr "TBD: mkExprStrictSatCaseMeta.1") e ] @@ -193,10 +193,11 @@ acoreStrictSatCaseMetaTy env mbNm meta e alts Just (n,ty) -> acoreLet1StrictInMetaTy n meta ty e $ mk alts Nothing -> mk alts e where mk (alt:alts) n - = acoreLet (acoreBindcategStrict) altOffBL (acoreCaseDflt n (acoreAltLSaturate env (alt':alts)) (Just $ rceCaseCont env)) + = acoreLet (acoreBindcategStrict) altOffBL (acoreCaseDflt n (acoreAltLSaturate env (alt':alts)) (Just undef)) where (alt',altOffBL) = acoreAltOffsetL alt mk [] n - = acoreCaseDflt n [] (Just $ rceCaseCont env) -- dummy case + = acoreCaseDflt n [] (Just undef) -- dummy case + undef = acoreBuiltinUndefined (rceEHCOpts env) acoreStrictSatCaseMeta :: (Eq bcat, AbstractCore e m b basp bcat mbind t p pr pf a) => RCEEnv' e m b ba t -> Maybe (HsName) -> m -> e -> [a] -> e acoreStrictSatCaseMeta env eNm m e alts = acoreStrictSatCaseMetaTy env (acoreTyLift "acoreStrictSatCaseMeta" eNm) m e alts diff --git a/EHC/src/ehc/AnaDomain/Utils.chs b/EHC/src/ehc/AnaDomain/Utils.chs index 96692c006..e016a1ff8 100644 --- a/EHC/src/ehc/AnaDomain/Utils.chs +++ b/EHC/src/ehc/AnaDomain/Utils.chs @@ -37,8 +37,9 @@ -- | configuring quantification, for debugging data RelevTyQuantHow = RelevTyQuantHow_Solve -- solve - | RelevTyQuantHow_RemoveAmbig -- vars not in type are removed - | RelevTyQuantHow_VarDefaultToTop -- vars left over, and in type, are default to top + | RelevTyQuantHow_RemoveAmbig -- constraints over vars not in type are removed + | RelevTyQuantHow_VarDefaultToTop -- vars left over, and in type, are defaulted to top + | RelevTyQuantHow_Quant -- quant deriving Eq %%] @@ -71,7 +72,9 @@ relevtyQuant how m qs t where qsm = Set.map (solveVarMp |=>) qs2 qs4 = Set.toList qs3 ftvTQ = ftvT' `Set.union` ftvSet qs4 - quantOver = Set.toList ftvTQ + quantOver + | RelevTyQuantHow_Quant `elem` how = Set.toList ftvTQ + | otherwise = [] t' -> ( t' , emptyVarMp , Set.empty @@ -364,9 +367,9 @@ assSolve bound qualS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%[(8 codegen) hs export(relevTyArgsFromCTag) --- | relev ty for tuple/constructor. isJust mbResTy <=> not whenInPat +-- | relev ty for tuple/constructor. isJust mbResTy <=> not isInPat relevTyArgsFromCTag :: Bool -> CTag -> Maybe RelevTy -> Int -> DataGam -> UID -> Maybe ([RelevTy],RelevQualS) -relevTyArgsFromCTag whenInPat ct mbResTy arity dataGam u +relevTyArgsFromCTag isInPat ct mbResTy arity dataGam u = case ct of CTagRec -> Just (map fresh $ mkNewLevUIDL arity u, Set.empty) @@ -381,7 +384,7 @@ relevTyArgsFromCTag whenInPat ct mbResTy arity dataGam u where fr _ = fresh _ -> (top, fr, \_ _ -> [] ) where fr e | e = freshStrict - | otherwise = fresh + | otherwise = freshLazy _ -> Nothing %%] diff --git a/EHC/src/ehc/Base/Common.chs b/EHC/src/ehc/Base/Common.chs index 25eddcb60..dd4dff04c 100644 --- a/EHC/src/ehc/Base/Common.chs +++ b/EHC/src/ehc/Base/Common.chs @@ -85,9 +85,6 @@ %%[8 hs export(ctag,ppCTag,ppCTagInt) %%] -%%[8 export(CTagsMp) -%%] - %%[9 export(ppListV) %%] @@ -493,8 +490,11 @@ data Unbox %%% Misc info passed to backend %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%[8 hs +%%[8 hs export(CTagsMp, emptyCTagsMp) type CTagsMp = AssocL HsName (AssocL HsName CTag) + +emptyCTagsMp :: CTagsMp +emptyCTagsMp = [] %%] %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -1314,7 +1314,7 @@ deriving instance Data Pos %%[7 uidHNm :: UID -> HsName -uidHNm = hsnFromString . show +uidHNm = mkHNm -- hsnFromString . show %%] %%[7 @@ -1328,7 +1328,7 @@ uidQualHNm modnm uid = %%[1 instance HSNM UID where - mkHNm = mkHNm . show + mkHNm x = hsnFromString ('_' : show x) %%] %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -1354,6 +1354,14 @@ instance Serialize Fixity where sput = sputPlain sget = sgetPlain +instance Binary KnownPrim where + put = putEnum8 + get = getEnum8 + +instance Serialize KnownPrim where + sput = sputPlain + sget = sgetPlain + instance Binary x => Binary (AlwaysEq x) where put (AlwaysEq x) = put x get = liftM AlwaysEq get @@ -1447,3 +1455,66 @@ genNmMap mk xs m | otherwise = let (q,r) = x `quotRem` 26 in ch q ++ ch r %%] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Known primitives, encoding semantics of particular primitives in a FFI decl, propagated to backend +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 codegen) export(KnownPrim(..)) +data KnownPrim + = + -- platform Int + KnownPrim_AddI + | KnownPrim_SubI + | KnownPrim_MulI + +%%[[97 + -- platform Float + | KnownPrim_AddF + | KnownPrim_SubF + | KnownPrim_MulF + + -- platform Double + | KnownPrim_AddD + | KnownPrim_SubD + | KnownPrim_MulD + + -- 8 bit + | KnownPrim_Add8 -- add: 1 byte / 8 bit, etc etc + | KnownPrim_Sub8 + | KnownPrim_Mul8 + + -- 16 bit + | KnownPrim_Add16 + | KnownPrim_Sub16 + | KnownPrim_Mul16 + + -- 32 bit + | KnownPrim_Add32 + | KnownPrim_Sub32 + | KnownPrim_Mul32 + + -- 64 bit + | KnownPrim_Add64 + | KnownPrim_Sub64 + | KnownPrim_Mul64 +%%]] + deriving (Show,Eq,Enum,Bounded) +%%] + +%%[(20 codegen) +deriving instance Data KnownPrim +deriving instance Typeable KnownPrim +%%] + +%%[(8 codegen) +instance PP KnownPrim where + pp = pp . show +%%] + +%%[(8 codegen) export(allKnownPrimMp) +allKnownPrimMp :: Map.Map String KnownPrim +allKnownPrimMp + = Map.fromList [ (drop prefixLen $ show t, t) | t <- [ minBound .. maxBound ] ] + where prefixLen = length "KnownPrim_" +%%] + diff --git a/EHC/src/ehc/Base/GenJavaLike.chs b/EHC/src/ehc/Base/GenJavaLike.chs new file mode 100644 index 000000000..862d8917c --- /dev/null +++ b/EHC/src/ehc/Base/GenJavaLike.chs @@ -0,0 +1,248 @@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Utils aiding generation of Java like backends +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[doesWhat doclatex +Various Java like code generation utility snippets. +%%] + +%%[(8 jazy || jscript) hs module {%{EH}Base.GenJavaLike} +%%] + +%%[(8 jazy || jscript) hs import(qualified Data.Map as Map,Data.Bits, Data.List) +%%] + +%%[(8 jazy || jscript) hs import({%{EH}Base.Builtin},{%{EH}Base.Builtin2},{%{EH}BuiltinPrims}) +%%] + +%%[(8 jazy || jscript) hs import(EH.Util.Pretty, EH.Util.Utils, qualified EH.Util.FastSeq as Seq) +%%] + +%%[(8 jazy || jscript) hs import({%{EH}Opts.Base},{%{EH}Base.HsName},{%{EH}Base.Common},{%{EH}Base.BasicAnnot}) +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Environment info for code variables (CVar) +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jazy || jscript) hs export(CVarInfo'(..), CVarMp'(..)) +data CVarInfo' ty varref tupfldref + = CVarInfo_This -- this object + { cvarType :: ty + } + | CVarInfo_Local -- a local on the stack + { cvarType :: ty + , cvarOffset :: varref + } + | CVarInfo_DataFld -- a field of a datatype alternative + { cvarType :: ty + , cvarData :: CVarInfo' ty varref tupfldref + , cvarClassLocNm :: HsName + , cvarFldNm :: String + } + | CVarInfo_TupFld -- a field of a tuple + { cvarType :: ty + , cvarTuple :: CVarInfo' ty varref tupfldref + , cvarInx :: Either tupfldref HsName + } + | CVarInfo_Global -- a global + { cvarType :: ty + , cvarClassLocNm :: HsName + , cvarFldNm :: String + } + | CVarInfo_None + +type CVarMp' ty varref tupfldref = Map.Map HsName (CVarInfo' ty varref tupfldref) +%%] + +%%[(8 jazy || jscript) hs export(cvarGlob) +-- | global reference +cvarGlob :: ty -> HsName -> HsName -> HsName -> CVarInfo' ty varref tupfldref +cvarGlob ty clNm nm safeVarNm + = CVarInfo_Global ty clNm' (show safeVarNm) +%%[[8 + where clNm' = clNm +%%][20 + where clNm' = maybe clNm (\m -> hsnSetQual m $ hsnQualified m) $ hsnQualifier nm +%%]] +%%] + + +%%[(8 jazy || jscript) hs export(cvarToRef) +-- | generate ref +cvarToRef + :: ( ty -> e -- make for 'this', + , ty -> varref -> e -- local, + , ty -> HsName -> String -> e -- global, + , ty -> e -> HsName -> String -> e -- data field, + , e -> e -> e -- tuple field + , tupfldref -> e -- offset + ) + -> CVarMp' ty varref tupfldref -> CVarInfo' ty varref tupfldref -> e +cvarToRef + (mkThis,mkLocal,mkGlobal,mkDataFld,mkTupFld,mkOffset) + cvarMp vi + = ref vi + where ref vi + = case vi of + CVarInfo_This t + -> mkThis t + CVarInfo_Local t o + -> mkLocal t o + CVarInfo_Global t cl f + -> mkGlobal t cl f + CVarInfo_DataFld t cvid cl f + -> mkDataFld t (ref cvid) cl f + CVarInfo_TupFld t cvit f + -> mkTupFld (ref cvit) o + where o = case f of + Left o -> mkOffset o + Right n -> ref $ panicJust "GenJavaLike.cvarToRef.CVarInfo_TupFld" $ Map.lookup n cvarMp + CVarInfo_None + -> panic "GenJavaLike.cvarToRef.CVarInfo_None" +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Dealing with >5 args +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jazy || jscript) hs export(javalikeArgsPack) +-- pack > 5 args into tuple, otherwise normal +javalikeArgsPack + :: Int -- limit after which arguments are passed via array + -> (ty,ty,[e]->e,Int->String) + -> [e] + -> (String,ty,[e]) +javalikeArgsPack limit (tyTup,tyObj,mkTup,mkAppNm) args + | nArgs > limit = (nm,tyTup,[mkTup args]) + | otherwise = (nm,tyObj,args) + where nArgs = length args + nm = mkAppNm nArgs +%%] + +%%[(8 jazy || jscript) hs export(javalikeArgsUnpack) +-- unpack > 5 args from tuple, otherwise normal +javalikeArgsUnpack + :: Enum fldref + => Int -- limit after which arguments are passed via array + -> ( ty -- tuple type + , ty -- object/default type + , ty -- int type + , [HsName] -> [ref] -- + , Int -> e -- make int + , Int -> [ref] -> [ref] -- make <= 5 argument references + , Int -> [ref] -- make > 5 argument reference + ) + -> [HsName] + -> ( [(ref,ty)] + , [(e,ty)] + , [(HsName,CVarInfo' ty ref fldref)] + ) +javalikeArgsUnpack limit (tyTup,tyObj,tyInt,toRef,mkInt,mkArgRefs,mkArgRefs5) args + | overLimit = ([(off0,tyTup)] , [(mkInt nArgs,tyInt)], mkMp [ CVarInfo_TupFld tyObj tup (Left o) | o <- [toEnum 0..] ]) + | otherwise = (zip offs (repeat tyObj), [] , mkMp [ CVarInfo_Local tyObj o | o <- offs ]) + where nArgs = length args + overLimit = nArgs > limit + offs@(off0:_) + | overLimit = mkArgRefs5 nArgs + | otherwise = mkArgRefs nArgs $ toRef args + tup = CVarInfo_Local tyTup off0 + mkMp = zip args +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Case: scrutinee type (i.e. tag) +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jazy || jscript) hs export(Scrutinee(..)) +data Scrutinee + = Scrutinee_Tag CTag + | Scrutinee_Int Int + | Scrutinee_Var HsName + | Scrutinee_Other String +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% FFI +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jazy || jscript) hs export(javalikeMkFFICall) +-- | construct the ffi call +javalikeMkFFICall + :: ( BuiltinInfo -> basicinfo -- extract machine specific info of builtin info + , Bool -> basicinfo -> (e->e, ty) -- unbox + , basicinfo -> (e->e, ty) -- box + , [ty] -> ty -> String -> e -> [e] -> e -- make prim call + , e->e -- evaluate + , ty -- default ty + ) + -> EHCOpts + -> Bool -- do eval of args + -> String -- name of ffi entity + -> [Maybe HsName] -- list of (possibly) type constructor names of arguments + -> Maybe HsName -- and result + -> ( [e -> e] -- additional unwrapping for each argument + , e -> e -- and result + , e -> [e] -> e -- and primitive call constructor + ) +javalikeMkFFICall + (getInfo,unbox,box,mkPrim,jiEvl,jtyObj) + opts doArgEval + impEntNm argMbConL resMbCon + = (mkArgsE,mkResE,primE) + where lkupBuiltin = \n -> Map.lookup n m + where m = builtinKnownBoxedTyMp opts + mkxxbox how mbCon + = case mbCon of + Just c -> case lkupBuiltin c of + Just bi -> how (getInfo bi) + _ -> dflt + _ -> dflt + where dflt = (jiEvl,jtyObj) + mkunbox = mkxxbox (unbox doArgEval) + mkbox = mkxxbox box + (mkArgsE,argsTy) + = unzip $ map mkunbox argMbConL + (mkResE,resTy) + = mkbox resMbCon + primE = mkPrim argsTy resTy impEntNm +%%] + +ffiJazyMkCall + = javalikeMkFFICall + ( biJazyBasicTy,basicTyJUnbox,basicTyJBox + , \argsTy resTy impEntNm f as -> (j $ J.Instr_Invoke J.InvokeMode_Static (J.Const_Method nmPrim impEntNm argsTy (Just resTy))) + , jiEvl, jtyObj + ) + +basicTyJUnbox :: Bool -> BasicJazy -> (J.JInstr -> J.JInstr,J.Type) +basicTyJBox :: BasicJazy -> (J.JInstr -> J.JInstr,J.Type) + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Binding +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jazy || jscript) hs export(JBind'(..),JBinds') +data JBind' ty e fld + = JBind + { jbindOrigNm :: HsName + , jbindNm :: HsName + , jbindTy :: ty + , jbindJI :: e + , jbindFld :: fld + } +type JBinds' ty e fld = Seq.Seq (JBind' ty e fld) +%%] + +%%[(8 jazy || jscript) hs export(jBind') +jBind' :: (ty,HsName->HsName,HsName -> fld) -> HsName -> HsName -> e -> JBinds' ty e fld +jBind' (tyDefault,mkFldNm,mkFld) nmOrig nm e + = Seq.singleton + $ JBind nmOrig + nm' + tyDefault {- @expr.jty -} + e + (mkFld nm') + where nm' = mkFldNm nm -- hsnJavaLikeVarToFld nm +%%] + diff --git a/EHC/src/ehc/Base/HsName.chs b/EHC/src/ehc/Base/HsName.chs index 1317b9940..dc4801f25 100644 --- a/EHC/src/ehc/Base/HsName.chs +++ b/EHC/src/ehc/Base/HsName.chs @@ -28,7 +28,7 @@ HsNameUniqifier to guarantee such an invariant. %%[3 import(qualified Data.Set as Set,Data.Maybe) %%] -%%[8 export(hsnShowAlphanumeric, hsnShowAlphanumericShort) +%%[8 import(qualified Data.Set as Set,Data.Maybe, Data.Char, Numeric) %%] %%[8 import(EH.Util.FPath,Char,qualified Data.Map as Map) @@ -50,7 +50,8 @@ HsNameUniqifier to guarantee such an invariant. %%[7 export(HsNameUniqifier(..)) -- | A HsNameUniqifier represents the 'type' of unification data HsNameUniqifier - = HsNameUniqifier_New -- just a new identifier + = HsNameUniqifier_Blank -- just a new identifier, with an empty show + | HsNameUniqifier_New -- just a new identifier | HsNameUniqifier_GloballyUnique -- globally unique | HsNameUniqifier_Evaluated -- evaluated | HsNameUniqifier_Field -- extracted field @@ -69,11 +70,15 @@ data HsNameUniqifier | HsNameUniqifier_LacksLabel -- label used in lacking predicates %%[[92 | HsNameUniqifier_GenericClass -- a name introduced by generics +%%]] +%%[[(8 jscript) + | HsNameUniqifier_JSSwitchResult -- var for result of switch %%]] deriving (Eq,Ord,Enum) -- | The show of a HsNameUniqifier is found back in the pretty printed code, current convention is 3 uppercase letters, as a balance between size and clarity of meaning instance Show HsNameUniqifier where + show HsNameUniqifier_Blank = "" show HsNameUniqifier_New = "NEW" show HsNameUniqifier_GloballyUnique = "UNQ" show HsNameUniqifier_Evaluated = "EVL" @@ -94,6 +99,9 @@ instance Show HsNameUniqifier where %%[[91 show HsNameUniqifier_GenericClass = "GEN" %%]] +%%[[(8 jscript) + show HsNameUniqifier_JSSwitchResult = "JSW" +%%]] %%] %%[7 export(HsNameUnique(..)) @@ -115,6 +123,9 @@ instance Show HsNameUnique where %%[7 type HsNameUniqifierMp = Map.Map HsNameUniqifier [HsNameUnique] +emptyHsNameUniqifierMp :: HsNameUniqifierMp +emptyHsNameUniqifierMp = Map.empty + showHsNameUniqifierMp :: String -> HsNameUniqifierMp -> [String] showHsNameUniqifierMp usep us = [ usep ++ show (length u) ++ show uqf ++ concat [ usep ++ show uu | uu <- u, uu /= HsNameUnique_None ] | (uqf,u) <- Map.toList us ] %%] @@ -168,7 +179,7 @@ instance Eq HsName where instance Ord HsName where n1 `compare` n2 = hsnCanonicSplit n1 `compare` hsnCanonicSplit n2 -%%[1 export(mkHNmBase,hsnMbBaseString,hsnBaseUnpack,hsnBaseString) +%%[1 export(mkHNmBase) -- | Just lift a string to the base HsName variant mkHNmBase :: String -> HsName %%[[1 @@ -176,16 +187,27 @@ mkHNmBase = HsName_Base %%][7 mkHNmBase s = HsName_Modf [] (HsName_Base s) Map.empty %%]] +%%] + +%%[1 export(hsnBaseUnpack',hsnBaseUnpack) +-- | unpack a HsName into qualifiers + base string + repack function +hsnBaseUnpack' :: HsName -> Maybe ([String],String,[String] -> String -> HsName) +hsnBaseUnpack' (HsName_Base s ) = Just ([],s,\_ s -> HsName_Base s) +%%[[7 +hsnBaseUnpack' (HsName_Modf q b u) = fmap (\(bs,mk) -> (q, bs, \q s -> HsName_Modf q (mk s) u)) (hsnBaseUnpack b) +hsnBaseUnpack' _ = Nothing +%%]] -- | unpack a HsName into base string + repack function hsnBaseUnpack :: HsName -> Maybe (String,String -> HsName) hsnBaseUnpack (HsName_Base s ) = Just (s,HsName_Base) %%[[7 hsnBaseUnpack (HsName_Modf q b u) = fmap (\(bs,mk) -> (bs, \s -> HsName_Modf q (mk s) u)) (hsnBaseUnpack b) --- hsnBaseUnpack (HNmQ ns ) = do { (i,l) <- initlast ns ; (bs,mk) <- hsnBaseUnpack l ; return (bs, \s -> (HNmQ $ i ++ [mk s])) } hsnBaseUnpack _ = Nothing %%]] +%%] +%%[1 export(hsnMbBaseString,hsnBaseString) -- | If name is a HsName_Base after some unpacking, return the base string, without qualifiers, without uniqifiers hsnMbBaseString :: HsName -> Maybe String hsnMbBaseString = fmap fst . hsnBaseUnpack @@ -349,7 +371,7 @@ charAlphanumeric c = [c] charAlphanumeric c | isDigit c = [c] | otherwise = error ("no alphanumeric representation for " ++ show c) -%%[8 +%%[8 export(hsnShowAlphanumeric, hsnShowAlphanumericShort) dontStartWithDigit :: String -> String dontStartWithDigit xs@(a:_) | isDigit a || a=='_' = "y"++xs | otherwise = xs @@ -490,9 +512,22 @@ hsnSetLevQual _ _ n = n %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%[8 export(hsnFixUniqifiers) +hsnFixUniqifiers' :: String -> HsName -> HsName +hsnFixUniqifiers' sep (HsName_Modf qs n us) = HsName_Modf qs (hsnSuffix n (concat $ showHsNameUniqifierMp sep us)) Map.empty +hsnFixUniqifiers' _ n = n + hsnFixUniqifiers :: HsName -> HsName -hsnFixUniqifiers (HsName_Modf qs n us) = HsName_Modf qs (hsnSuffix n (concat $ showHsNameUniqifierMp "_@" us)) Map.empty -hsnFixUniqifiers n = n +hsnFixUniqifiers = hsnFixUniqifiers' "_@" +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Strip the uniqifier part +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[8 export(hsnStripUniqifiers) +hsnStripUniqifiers :: HsName -> HsName +hsnStripUniqifiers (HsName_Modf qs n us) = HsName_Modf qs n emptyHsNameUniqifierMp +hsnStripUniqifiers n = n %%] %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -725,6 +760,95 @@ data IdOcc type HsNameS = Set.Set HsName %%] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Safe names for Java like backends +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jazy || jscript) hs export(hsnSafeJavaLike) +-- ensure a name valid for JVM like backends +hsnSafeJavaLike :: HsName -> HsName +hsnSafeJavaLike + = hsnMapQualified (concatMap safe) . hsnFixUniqifiers' "" + where safe '_' = "__" + safe c | isDigit c || isLetter c || c == '_' = [c] + | otherwise = "_" ++ showHex (ord c) "" +%%] + safe '.' = "_dot" + safe ':' = "_colon" + safe '/' = "_fslash" + -- safe '<' = "_lt" + -- safe '>' = "_gt" + safe '\\' = "_bslash" + safe '[' = "_lbrack" + safe ']' = "_rbrack" + safe '@' = "_at" + safe c = [c] + +%%[(8 jazy || jscript) hs export(hsnJavaLikeVar) +-- safe name of a variable +hsnJavaLikeVar + :: ( HsName -> HsName -- adapt for particular platform, before mangling here + , HsName -> HsName -- post prefix + , String -> String -- adapt module qualifiers + ) + -> HsName -> HsName -> HsName -> HsName +hsnJavaLikeVar (preadapt, postprefix, updqual) pkg mod v +%%[[8 + = hsnSafeJavaLike v +%%][20 + = postprefix $ hsnSafeJavaLike $ handleUpper $ qual $ preadapt v + where handleUpper v + = case hsnBaseUnpack v of + Just (s@(c:vs), mk) | isUpper c -> mk (s ++ "_") + _ -> v + qual v + = case hsnBaseUnpack' v of + Just (q, s, mk) -> mk (map updqual q) s + _ -> v +%%]] +%%] + +%%[(8 jazy || jscript) hs export(hsnJavaLikeVarCls) +-- name of the class of a variable +hsnJavaLikeVarCls :: HsName -> HsName -> HsName -> HsName +hsnJavaLikeVarCls pkg mod v +%%[[8 + = hsnSuffix mod ("-" ++ show v) +%%][20 + = hsnSetQual pkg v +%%]] +%%] + +%%[(8 jazy || jscript) hs export(hsnJavaLikeVarToFld) +-- field name of var name +hsnJavaLikeVarToFld :: HsName -> HsName +hsnJavaLikeVarToFld v +%%[[8 + = v +%%][20 + = hsnQualified v +%%]] +%%] + +%%[(8 jazy || jscript) hs export(hsnJavaLikeDataTy, hsnJavaLikeDataCon, hsnJavaLikeDataFldAt, hsnJavaLikeDataFlds) +-- name of class of data type +hsnJavaLikeDataTy :: HsName -> HsName -> HsName -> HsName +hsnJavaLikeDataTy pkg mod d = hsnSafeJavaLike d `hsnSuffix` "_Ty" + +-- name of class of data constructor +hsnJavaLikeDataCon :: HsName -> HsName -> HsName -> HsName +hsnJavaLikeDataCon pkg mod d = hsnSafeJavaLike d `hsnSuffix` "_Con" + +-- name of field of data +hsnJavaLikeDataFldAt :: Int -> String +hsnJavaLikeDataFldAt i = show i + +-- all names of fields of data +hsnJavaLikeDataFlds :: Int -> [String] +hsnJavaLikeDataFlds arity = map hsnJavaLikeDataFldAt [0..arity-1] +%%] + + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Support for transformations %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% diff --git a/EHC/src/ehc/Base/Optimize.chs b/EHC/src/ehc/Base/Optimize.chs index 7cf6b29ec..9db50158c 100644 --- a/EHC/src/ehc/Base/Optimize.chs +++ b/EHC/src/ehc/Base/Optimize.chs @@ -53,9 +53,13 @@ data OptimizationLevel %%] %%[(8 codegen) export(OptimizationScope(..)) +-- | Scope of optimizations, increasingly more global data OptimizationScope - = OptimizationScope_PerModule - | OptimizationScope_WholeProgram + = OptimizationScope_PerModule -- per module +%%[[20 + | OptimizationScope_WholeGrin -- whole program, starting with GRIN + | OptimizationScope_WholeCore -- whole program, starting with Core +%%]] deriving (Eq,Ord,Show,Enum,Bounded) %%] diff --git a/EHC/src/ehc/Base/Pragma.chs b/EHC/src/ehc/Base/Pragma.chs index b9ba8e02e..cbf7cb2ae 100644 --- a/EHC/src/ehc/Base/Pragma.chs +++ b/EHC/src/ehc/Base/Pragma.chs @@ -9,7 +9,7 @@ %%] %%[99 import(EH.Util.Pretty,EH.Util.Utils) %%] -%%[99 import({%{EH}Base.HsName}) +%%[99 import({%{EH}Base.HsName},{%{EH}Base.Target}) %%] %%[99 import({%{EH}Base.Binary}, {%{EH}Base.Serialize}) %%] @@ -33,9 +33,14 @@ data Pragma , pragmaDerivFieldName :: HsName -- this field is derivable , pragmaDerivDefaultName :: HsName -- using this default value } - | Pragma_NoGenericDeriving -- turn off generic deriving - | Pragma_GenericDeriving -- turn on generic deriving (default) - | Pragma_ExtensibleRecords -- turn on extensible records + | Pragma_NoGenericDeriving -- turn off generic deriving + | Pragma_GenericDeriving -- turn on generic deriving (default) + | Pragma_ExtensibleRecords -- turn on extensible records +%%[[(99 codegen) + | Pragma_ExcludeIfTarget + { pragmaExcludeTargets :: [Target] + } +%%]] deriving (Eq,Ord,Show,Typeable,Data) %%] @@ -65,24 +70,42 @@ showAllSimplePragmas = showAllSimplePragmas' " " %%] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Querying pragmas +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(99 codegen) export(pragmaIsExcludeTarget) +pragmaIsExcludeTarget :: Target -> Pragma -> Bool +pragmaIsExcludeTarget t (Pragma_ExcludeIfTarget ts) = t `elem` ts +pragmaIsExcludeTarget _ _ = False +%%] + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Instances: Binary, Serialize %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%[99 instance Serialize Pragma where - sput (Pragma_NoImplicitPrelude ) = sputWord8 0 - sput (Pragma_CPP ) = sputWord8 1 - sput (Pragma_Derivable a b c ) = sputWord8 2 >> sput a >> sput b >> sput c - sput (Pragma_NoGenericDeriving ) = sputWord8 3 - sput (Pragma_GenericDeriving ) = sputWord8 4 + sput (Pragma_NoImplicitPrelude ) = sputWord8 0 + sput (Pragma_CPP ) = sputWord8 1 + sput (Pragma_Derivable a b c ) = sputWord8 2 >> sput a >> sput b >> sput c + sput (Pragma_NoGenericDeriving ) = sputWord8 3 + sput (Pragma_GenericDeriving ) = sputWord8 4 + sput (Pragma_ExtensibleRecords ) = sputWord8 5 +%%[[(99 codegen) + sput (Pragma_ExcludeIfTarget a ) = sputWord8 6 >> sput a +%%]] sget = do t <- sgetWord8 case t of 0 -> return Pragma_NoImplicitPrelude 1 -> return Pragma_CPP - 2 -> liftM3 Pragma_Derivable sget sget sget + 2 -> liftM3 Pragma_Derivable sget sget sget 3 -> return Pragma_NoGenericDeriving 4 -> return Pragma_GenericDeriving + 5 -> return Pragma_ExtensibleRecords +%%[[(99 codegen) + 6 -> liftM Pragma_ExcludeIfTarget sget +%%]] %%] diff --git a/EHC/src/ehc/BuiltinPrims.chs b/EHC/src/ehc/BuiltinPrims.chs index c831302b5..8203a27d0 100644 --- a/EHC/src/ehc/BuiltinPrims.chs +++ b/EHC/src/ehc/BuiltinPrims.chs @@ -2,17 +2,19 @@ %%% Implementation of primitives %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%[doesWhat doclatex The prims table describes special handling for some primitives, independent of the backend (for now). Module {%{EH}BuiltinPrims} describes similar information required in the frontend. Ideally, these tables should be merged. +%%] -%%[(8 codegen grin).moduleHeader module {%{EH}BuiltinPrims} +%%[(8 codegen).moduleHeader module {%{EH}BuiltinPrims} %%] -%%[(8 codegen grin) import({%{EH}Base.HsName},{%{EH}Base.Common},{%{EH}Opts},{%{EH}Base.BasicAnnot},{%{EH}Base.Builtin},{%{EH}GrinByteCode}) +%%[(8 codegen) import({%{EH}Base.HsName},{%{EH}Base.Common},{%{EH}Opts},{%{EH}Base.BasicAnnot},{%{EH}Base.Builtin},{%{EH}GrinByteCode}) %%] -%%[(8 codegen grin) import(qualified Data.Map as Map, qualified EH.Util.FastSeq as Seq, EH.Util.Pretty, EH.Util.Utils) +%%[(8 codegen) import(qualified Data.Map as Map, qualified EH.Util.FastSeq as Seq, EH.Util.Pretty, EH.Util.Utils) %%] %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% diff --git a/EHC/src/ehc/Config.chs.in b/EHC/src/ehc/Config.chs.in index 6bc0d3ac5..d44add9ce 100644 --- a/EHC/src/ehc/Config.chs.in +++ b/EHC/src/ehc/Config.chs.in @@ -122,6 +122,12 @@ mkInstallPkgdirUser opts = filePathCoalesceSeparator $ filePathUnPrefix $ mkDirbasedInstallPrefix (ehcOptUserDir opts) INST_LIB_PKG2 "" (show $ ehcOptTarget opts) "" %%] +%%[(8 codegen) export(mkInstalledRts) +-- | construct path for RTS +mkInstalledRts :: EHCOpts -> (String -> String -> String) -> WhatInstallFile -> String -> String -> String +mkInstalledRts opts mkLib how variant rts = mkLib (mkInstallFilePrefix opts how variant rts) rts +%%] + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Cmds %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -146,6 +152,11 @@ shellCmdJar :: String shellCmdJar = "@TOPLEVEL_SYSTEM_ABSPATH_PREFIX@@JAR_CMD@@SUFFIX_EXEC@" %%] +%%[(8 jscript) export(shellCmdCat) +shellCmdCat :: String +shellCmdCat = "@TOPLEVEL_SYSTEM_ABSPATH_PREFIX@@CAT_CMD@@SUFFIX_EXEC@" +%%] + %%[99 export(shellCmdCpp) shellCmdCpp :: String shellCmdCpp = "@TOPLEVEL_SYSTEM_ABSPATH_PREFIX@@CPP_CMD@@SUFFIX_EXEC@" @@ -186,11 +197,6 @@ mkShellCmdLibtool archive files %%% Libraries %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%[8 -prefixLib :: String -prefixLib = "@PREFIX_LIB@" -%%] - %%[8 export(libnamesGcc) libnamesGcc :: EHCOpts -> [String] libnamesGcc opts @@ -207,9 +213,9 @@ libnamesGcc opts %%]] %%] -%%[8 export(libnamesGccPerVariant) -libnamesGccPerVariant :: [String] -libnamesGccPerVariant +%%[8 export(libnamesRts) +libnamesRts :: [String] +libnamesRts = [ prefixLib ++ "@RTS_PKG_NAME@"] %%] @@ -243,9 +249,14 @@ libnamesGccEhcExtraExternalLibs %%] %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%% File suffixes +%%% File suffixes, prefixes %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%[8 +prefixLib :: String +prefixLib = "@PREFIX_LIB@" +%%] + %%[8 export(mbSuffixExec,linkerSymbolPrefix) suffixExec :: String suffixExec = "@SUFFIX_EXEC@" @@ -261,3 +272,9 @@ linkerSymbolPrefix :: String linkerSymbolPrefix = "@LINKER_SYMBOL_PREFIX@" %%] + +%%[(8 jscript) export(suffixJScriptLib) +suffixJScriptLib :: String +suffixJScriptLib = filter (/= '.') "@SUFFIX_LIBJSCRIPT@" +%%] + diff --git a/EHC/src/ehc/Core.cag b/EHC/src/ehc/Core.cag index ed7a57c89..aa20688f6 100644 --- a/EHC/src/ehc/Core.cag +++ b/EHC/src/ehc/Core.cag @@ -28,7 +28,10 @@ Datatype LamInfo holds the implementation info to be exported from a module. %%[(8 codegen) hs import(Data.Maybe,Data.Char,Data.List,EH.Util.Pretty,EH.Util.Utils) %%] -%%[(8 codegen) hs export(CodeAGItf(..), CModule(..), CExpr(..), MbCExpr, CBind(..), CBindAspect(..), CMetaVal(..), CExprAnn(..), CMetaBind(..), CMetas, CBindL, CBindAspectL, CPatRest(..), CAlt(..), CAltL, CPat(..), CPatL, CPatFld(..), CPatFldL) +%%[(8 codegen) hs export(CodeAGItf(..), CModule(..), CExpr(..), MbCExpr, CBind(..), CBindAspect(..), CMetaVal(..), CMetaBind(..), CMetas, CBindL, CBindAspectL, CPatRest(..), CAlt(..), CAltL, CPat(..), CPatFld(..), CPatFldL) +%%] + +%%[(8 codegen) hs export(CBindAnn(..), CBindAnnL, CExprAnn(..)) %%] %%[(8 codegen) hs import(qualified Data.Map as Map,qualified Data.Set as Set) @@ -37,9 +40,11 @@ Datatype LamInfo holds the implementation info to be exported from a module. %%[(8 codegen) hs import({%{EH}LamInfo},{%{EH}Ty}) %%] -%%[(20 codegen grin) hs import(Control.Monad, {%{EH}Base.Binary}, {%{EH}Base.Serialize}) +%%[(20 codegen) hs import(Data.Array) %%] -%%[(20 codegen grin) hs import(Data.Typeable(Typeable), Data.Generics(Data)) +%%[(20 codegen) hs import(Control.Monad, {%{EH}Base.Binary}, {%{EH}Base.Serialize}) +%%] +%%[(20 codegen) hs import(Data.Typeable(Typeable), Data.Generics(Data)) %%] %%[(90 codegen) hs import({%{EH}Foreign}) export(module {%{EH}Foreign}) @@ -180,6 +185,18 @@ cbindNm (CBind_Bind n _) = n -- cbindNm (CBind_FFI _ _ _ n _ ) = n %%] +%%[(20 codegen) hs export(cbindAspectMbExpr,cbindExprs) +-- | extract expr for aspect, relevant for later use/analysis/... +cbindAspectMbExpr :: CBindAspect -> Maybe CExpr +cbindAspectMbExpr (CBindAspect_Bind _ e) = Just e +cbindAspectMbExpr (CBindAspect_Val _ e) = Just e +cbindAspectMbExpr _ = Nothing + +-- | extract exprs of a binding which are relevant for use/analysis/... +cbindExprs :: CBind -> [CExpr] +cbindExprs (CBind_Bind _ a) = catMaybes $ map cbindAspectMbExpr a +%%] + %%[(9797 codegen) hs export(cexprMbConst) cexprMbConst :: CExpr -> Maybe Integer cexprMbConst e@(CExpr_Int i) = Just $ toInteger i @@ -415,6 +432,7 @@ offMpMpKeysSet m = Set.unions [ Map.keysSet m' | (_,m') <- Map.elems m ] %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%[(20 codegen) hs export(cModMerge) +-- | merge by concatenation cModMerge :: [CModule] -> CModule cModMerge mL = foldr1 cmb mL @@ -424,6 +442,49 @@ cModMerge mL = CModule_Mod m2 (get e1 e2) (t1++t2) %%] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Map/Database representation of a module +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(20 codegen) hs export(CDbBindLetInfo, CDbBindLetInfo'2) +-- | the binding info required for let bind +type CDbBindLetInfo'' f cat bind = (cat,f bind) +type CDbBindLetInfo' f = CDbBindLetInfo'' f CBindingsCateg CBind +type CDbBindLetInfo'2 cat bind = CDbBindLetInfo'' [] cat bind +type CDbBindLetInfo = CDbBindLetInfo' [] +%%] + +%%[(20 codegen) hs export(CDbBindArray, CDbBindRef, CDbModuleBindMp) +-- | actual bindings stored in separate array to allow for sharing +type CDbBindArray = Array Int (CDbBindLetInfo' (Array Int)) + +-- | reference into database of bindings, agnostic of name given to it +type CDbBindRef = (Int,Int) + +-- | binding map of global names to individual bindings +type CDbModuleBindMp = Map.Map HsName CDbBindRef +%%] + +%%[(20 codegen) hs export(CModuleDatabase(..), emptyCModuleDatabase) +-- | the full module represented in a map/database like format (20101004 AD: to be made into persistent db soon) +data CModuleDatabase + = CModuleDatabase + { cmoddbModNm :: !HsName -- module name + , cmoddbBindArr :: !CDbBindArray -- bindings + , cmoddbBindMp :: !CDbModuleBindMp -- map of name to bindings + , cmoddbMainExpr :: !CExpr -- the final expr of the module's let expr + , cmoddbTagsMp :: !CTagsMp -- datatype info + } + +emptyCModuleDatabase :: CModuleDatabase +emptyCModuleDatabase = CModuleDatabase hsnUnknown (array (1,0) []) Map.empty (acoreInt 0) emptyCTagsMp +%%] + +%%[(20 codegen) hs export(cmoddbLookup) +cmoddbLookup :: HsName -> CModuleDatabase -> Maybe CDbBindRef +cmoddbLookup n db = Map.lookup n $ cmoddbBindMp db +%%] + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Instances: Binary, Serialize, ForceEval %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -531,6 +592,13 @@ instance Serialize CExprAnn where 1 -> liftM CExprAnn_Coe sget 2 -> return (CExprAnn_Debug "") +instance Serialize CBindAnn where + sput (CBindAnn_Coe a) = sputWord8 0 >> sput a + sget + = do t <- sgetWord8 + case t of + 0 -> liftM CBindAnn_Coe sget + instance Serialize CBindAspect where sput (CBindAspect_Bind a b ) = sputWord8 0 >> sput a >> sput b -- sput (CBindAspect_FFI a b c d ) = sputWord8 1 >> sput a >> sput b >> sput c >> sput d @@ -595,11 +663,11 @@ instance Serialize CPatRest where 1 -> return CPatRest_Empty instance Serialize CPatFld where - sput (CPatFld_Fld a b c ) = sputWord8 0 >> sput a >> sput b >> sput c + sput (CPatFld_Fld a b c d ) = sputWord8 0 >> sput a >> sput b >> sput c >> sput d sget = do t <- sgetWord8 case t of - 0 -> liftM3 CPatFld_Fld sget sget sget + 0 -> liftM4 CPatFld_Fld sget sget sget sget instance Serialize CBindingsCateg where sput = sputEnum8 @@ -652,7 +720,7 @@ instance AbstractCore CExpr CMetaVal CBind CBindAspect CBindingsCateg CMetaBind %%]] -- patfld - acorePatFldTy _ (lbl,off) n = CPatFld_Fld lbl off n + acorePatFldTy _ (lbl,off) n = CPatFld_Fld lbl off n [] -- patrest acorePatRestEmpty = CPatRest_Empty @@ -706,7 +774,7 @@ instance AbstractCore CExpr CMetaVal CBind CBindAspect CBindingsCateg CMetaBind acorePatMbChar _ = Nothing acoreUnAlt (CAlt_Alt p e) = (p,e) - acoreUnPatFld (CPatFld_Fld l o n) = (Ty_Any,(l,o),n) + acoreUnPatFld (CPatFld_Fld l o n _) = (Ty_Any,(l,o),n) -- coercion %%[[8 diff --git a/EHC/src/ehc/Core/AbsSyn.cag b/EHC/src/ehc/Core/AbsSyn.cag index f71dc3c11..e9a647ede 100644 --- a/EHC/src/ehc/Core/AbsSyn.cag +++ b/EHC/src/ehc/Core/AbsSyn.cag @@ -159,20 +159,31 @@ SET AllMeta = CMetaVal CMetaBind CMetas %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%[(8 codegen) +-- | on CExpr DATA CExpr | Ann ann : CExprAnn expr : CExpr %%] %%[(8 codegen) +-- | ann for CExpr DATA CExprAnn | Ty ty : {Ty} | Coe coe : {RelevCoe} | Debug info : {String} + +-- | ann for name intro +DATA CBindAnn + | Coe coe : {RelevCoe} +%%] + +%%[(8 codegen) +TYPE CBindAnnL = [CBindAnn] %%] %%[(8 codegen) -SET AllAnn = CExprAnn +SET AllExprAnn = CExprAnn +SET AllBindAnn = CBindAnn CBindAnnL %%] %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -305,8 +316,6 @@ DATA CPat binds : CPatFldL | Int int : {Int} | Char char : {Char} - -TYPE CPatL = [CPat] %%] %%[(8 codegen) @@ -318,6 +327,7 @@ DATA CPatFld | Fld lbl : {HsName} offset : CExpr fldNm : {HsName} + fldAnns : CBindAnnL TYPE CPatFldL = [CPatFld] %%] @@ -336,8 +346,8 @@ DATA CPat %%[(8 codegen) SET AllAlt = CAlt CAltL -SET AllPat = CPatRest CPat CPatL AllPatFld -SET AllPatFld = CPatFld CPatFldL +SET AllPat = CPatRest CPat AllPatFld +SET AllPatFld = CPatFld CPatFldL AllBindAnn %%] %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -351,7 +361,7 @@ SET AllExprOnly = CExpr MbCExpr SET AllExprBase - = AllExprOnly AllAnn AllBind AllAlt AllPat + = AllExprOnly AllExprAnn AllBind AllAlt AllPat SET AllExpr = AllExprBase diff --git a/EHC/src/ehc/Core/CommonCtxtPred.cag b/EHC/src/ehc/Core/CommonCtxtPred.cag index c90161288..4343e13f4 100644 --- a/EHC/src/ehc/Core/CommonCtxtPred.cag +++ b/EHC/src/ehc/Core/CommonCtxtPred.cag @@ -83,6 +83,9 @@ SEM CExpr | App loc . whatBelow = maybe (ExprIsApp 1) (\a -> ExprIsApp $ a + 1) $ whatExprMbApp @func.whatBelow | * - Lam App Var Int Ann CaseAltFail loc . whatBelow = ExprIsOther + +SEM CExpr + | App loc . isTopApp' = isNothing $ whatExprMbApp @lhs.whatAbove %%] %%[(8 codegen) @@ -94,8 +97,11 @@ SEM CExpr | * - Lam App Ann loc . whatAbove = ExprIsOther +SEM CExpr + | Let loc . isTopLet = @lhs.whatAbove == ExprIsBind + SEM CBindAspect - | Bind Val loc . whatAbove = ExprIsOther + | Bind Val loc . whatAbove = ExprIsBind SEM CPatFld | Fld loc . whatAbove = ExprIsOther diff --git a/EHC/src/ehc/Core/CommonJavaLike.cag b/EHC/src/ehc/Core/CommonJavaLike.cag new file mode 100644 index 000000000..c5709f8ee --- /dev/null +++ b/EHC/src/ehc/Core/CommonJavaLike.cag @@ -0,0 +1,193 @@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Common stuff for Java like backends +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Level, Let's also one level higher +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jazy || jscript) +SEM CExpr + | Let binds . lev = @lhs.lev + 1 +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Global name info +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jazy || jscript) +ATTR AllNT [ topClassNm: HsName pkgNm: HsName | | ] +%%[[8 +ATTR AllNT [ moduleClassNm: HsName | | ] +%%][99 +ATTR AllNT - CodeAGItf CModule [ moduleClassNm: HsName | | ] +ATTR CodeAGItf CModule [ | | moduleClassNm: HsName ] +%%]] +%%] + +%%[(8 jazy || jscript) +SEM CModule + | Mod loc . topClassNm = @moduleNm + . pkgNm = @moduleNm +%%[[8 + . moduleClassNm = @moduleNm +%%][20 + . moduleClassNm = hsnSetQual @moduleNm $ hsnQualified @moduleNm +%%]] + +SEM CodeAGItf + | AGItf loc . topClassNm = hsnUnknown + . pkgNm = hsnUnknown +%%[[8 + . moduleClassNm = hsnUnknown +%%][99 +%%]] +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Various contextual info +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jazy || jscript) +ATTR AllExprOnly [ mbLamNm: {Maybe (HsName,HsName)} | | ] + +SEM CExpr + | App Lam loc . mbLamNm = Nothing + +SEM CAlt + | Alt loc . mbLamNm = Nothing + +SEM CBindAspect + | Bind Val expr . mbLamNm = Just (@varnm,@lhs.nm) + +SEM CPatFld + | Fld offset . mbLamNm = Nothing + +SEM CModule + | Mod expr . mbLamNm = Nothing +%%] + +%%[(8 jazy || jscript) +SEM CExpr + | Lam loc . (hasFunHere,(lamNm,origLamNm)) + = if @lhs.whatAbove /= ExprIsLam + then (True,fromJust @lhs.mbLamNm) + else (False,(hsnUnknown,hsnUnknown)) + +SEM CBindAspect + | Bind Val loc . isCAF = @expr.whatBelow /= ExprIsLam +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Variable bindings for other than global +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +assuming def for + hs + : CVarMp + , tyDefault + ag + : CExpr.Let : @loc.nmToRefAssocL + , CExpr.Lam : @loc.lamBindings + , CPatFld.Fld: @loc.cviField + +%%[(8 jazy || jscript) +ATTR AllBind [ | | bindNmL USE {++} {[]} : {[HsName]} ] + +SEM CBind + | Bind loc . bindNmL = [@nm] +%%] + +%%[(8 jazy || jscript) +ATTR AllNT [ cvarMp: CVarMp | | ] + +SEM CodeAGItf + | AGItf loc . cvarMp = Map.empty + +%%] + +%%[(8 jazy || jscript) +ATTR AllPat [ | | patCVarMp USE {`Map.union`} {Map.empty} : CVarMp ] + +SEM CPatFld + | Fld loc . patCVarMp = Map.singleton @fldNm @cviField +%%] + +%%[(8 jazy || jscript) +SEM CExpr + | Lam loc . cvarMp = Map.fromList @lamBindings `Map.union` @lhs.cvarMp + | Let loc . (nLocals,cvarMpNew) + = if @isGlobal + then (0,Map.empty) + else let nLocals = length @binds.bindNmL + in ( nLocals + , Map.fromList + [ (n,CVarInfo_Local tyDefault o) + | (n,o) <- @nmToRefAssocL + ] + ) + . cvarMp = @cvarMpNew `Map.union` @lhs.cvarMp + +SEM CAlt + | Alt loc . cvarMpOffsets = Map.fromList [ (n,cvi) | (n,cvi,_) <- @pat.offsetBinds ] + expr . cvarMp = Map.unions [@cvarMpOffsets, @pat.patCVarMp, @lhs.cvarMp] +%%] + +%%[(8 jazy || jscript) +SEM CExpr + | Var loc . cvi = Map.findWithDefault (cvarGlob tyDefault @lhs.moduleClassNm @nm @varnm) @nm @lhs.cvarMp +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Lam args +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jazy || jscript) +ATTR CExpr [ | | nmArgL: {[HsName]} ] + +SEM CExpr + | Lam loc . nmArgL = @arg : @body.nmArgL + loc . nmArgL : {[HsName]} + | * - Lam Ann lhs . nmArgL = [] +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Case: scrutinee +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jazy || jscript) +ATTR AllAlt AllPat [ scrutineeCVarInfo: CVarInfo | | ] +%%] + +%%[(8 jazy || jscript) +ATTR AllPatFld [ ctag: CTag | | ] + +SEM CPat + | Con binds . ctag = @tag +%%] + +%%[(8 jazy || jscript) +ATTR AllAlt CPat [ | | scrutinees USE {++} {[]} : {[Scrutinee]} ] + +SEM CPat + | Con lhs . scrutinees = [Scrutinee_Tag @tag] + | Var lhs . scrutinees = [Scrutinee_Var @pnm] + | Int lhs . scrutinees = [Scrutinee_Int @int] + | Char lhs . scrutinees = [Scrutinee_Other "char"] + | * - Con Var Int Char Ann + lhs . scrutinees = [Scrutinee_Other "other"] +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Bind gathering +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jazy || jscript) +ATTR AllBind CExpr [ | | jbinds USE {`Seq.union`} {Seq.empty}: JBinds] +%%] + +%%[(8 jazy || jscript) +SEM CExpr + | Let lhs . jbinds = @jbindsLet `Seq.union` @body.jbinds +%%] + diff --git a/EHC/src/ehc/Core/FFI.chs b/EHC/src/ehc/Core/FFI.chs index f878bde42..627326d99 100644 --- a/EHC/src/ehc/Core/FFI.chs +++ b/EHC/src/ehc/Core/FFI.chs @@ -7,7 +7,7 @@ %%% Utilities for dealing with FFI, for now part of Core, meant for Grin gen %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%[(8 codegen) module {%{EH}Core.FFI} import({%{EH}Base.Builtin},{%{EH}Base.Builtin2},{%{EH}Opts},{%{EH}Base.Common}) +%%[(8 codegen) module {%{EH}Core.FFI} import({%{EH}Base.Builtin},{%{EH}Base.Builtin2},{%{EH}Opts},{%{EH}Base.Target},{%{EH}Base.Common}) %%] %%[(8 codegen) hs import(qualified Data.Map as Map,Data.Maybe) @@ -62,8 +62,8 @@ tyNmFFIBoxBasicAnnot opts -- | is ty living as a tagged pointer? tyNmGBMayLiveAsTaggedPtr :: EHCOpts -> HsName -> Maybe BuiltinInfo tyNmGBMayLiveAsTaggedPtr opts - | ehcOptFullProgAnalysis opts = const Nothing - | otherwise = builtinGrinInfo opts + | targetIsGrinBytecode (ehcOptTarget opts) = builtinGrinInfo opts + | otherwise = const Nothing -- | BasicAnnot when unboxing also means living as tagged pointer tyNmGBTagPtrBasicAnnot :: EHCOpts -> Bool -> HsName -> BasicAnnot -> BasicAnnot diff --git a/EHC/src/ehc/Core/ModAsMap.cag b/EHC/src/ehc/Core/ModAsMap.cag new file mode 100644 index 000000000..22cbc273f --- /dev/null +++ b/EHC/src/ehc/Core/ModAsMap.cag @@ -0,0 +1,78 @@ +%%[0 +%include lhs2TeX.fmt +%include afp.fmt +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Free variables +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(20 codegen) hs module {%{EH}Core.ModAsMap} +%%] + +%%[(20 codegen) hs import(qualified Data.Set as Set,qualified Data.Map as Map, Data.Array) +%%] + +%%[(20 codegen) hs import(qualified EH.Util.FastSeq as Seq) +%%] + +%%[(20 codegen) hs import({%{EH}Base.Common},{%{EH}Core},{%{EH}Ty}) +%%] + +%%[(20 codegen).WRAPPER ag import({Core/AbsSyn}) +WRAPPER CodeAGItf +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Haskell itf +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(20 codegen) hs export(cexprModAsDatabase) +cexprModAsDatabase :: CModule -> CModuleDatabase +cexprModAsDatabase m + = db_Syn_CodeAGItf t + where t = wrap_CodeAGItf (sem_CodeAGItf (CodeAGItf_AGItf m)) Inh_CodeAGItf +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Database/Map +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(20 codegen) +ATTR CodeAGItf CModule [ | | db: CModuleDatabase ] + +SEM CModule + | Mod lhs . db = let binds = Seq.toList @expr.bindSq + nrBinds = length binds + (refs,arrs) + = unzip + [ (Map.unions refs, (cat, listArray (0, nrSubBinds-1) bs)) + | (bi,(cat,bs)) <- zip [0 .. nrBinds-1] binds + , let nrSubBinds = length bs + , let refs = zipWith (\b i -> Map.singleton (cbindNm b) (bi,i)) bs [0 .. nrSubBinds-1] + ] + in emptyCModuleDatabase + { cmoddbModNm = @moduleNm + , cmoddbBindMp = Map.unions refs + , cmoddbBindArr = listArray (0, nrBinds-1) arrs + , cmoddbMainExpr = @expr.expr + , cmoddbTagsMp = @ctagsMp + } +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Bindings, Expr, and other pieces of info +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(20 codegen) +ATTR AllNT [ | | copy: SELF ] +ATTR CExpr [ | | bindSq: {Seq.Seq CDbBindLetInfo} + expr : CExpr + ] + +SEM CExpr + | Let lhs . bindSq = Seq.singleton (@categ,@binds.copy) `Seq.union` @body.bindSq + . expr = @body.expr + | * - Let lhs . bindSq = Seq.empty + . expr = @copy +%%] diff --git a/EHC/src/ehc/Core/Parser.chs b/EHC/src/ehc/Core/Parser.chs index 942c926ce..41382b477 100644 --- a/EHC/src/ehc/Core/Parser.chs +++ b/EHC/src/ehc/Core/Parser.chs @@ -192,5 +192,5 @@ pCPat pCPatFld :: CParser CPatFld pCPatFld - = CPatFld_Fld <$ pOCURLY <*> pDollNm <* pCOMMA <*> pCExpr <* pCCURLY <* pEQUAL <*> pDollNm -- pCPat + = (\l o n -> CPatFld_Fld l o n []) <$ pOCURLY <*> pDollNm <* pCOMMA <*> pCExpr <* pCCURLY <* pEQUAL <*> pDollNm -- pCPat %%] diff --git a/EHC/src/ehc/Core/Pretty.cag b/EHC/src/ehc/Core/Pretty.cag index 422ae7d23..ce8c40f55 100644 --- a/EHC/src/ehc/Core/Pretty.cag +++ b/EHC/src/ehc/Core/Pretty.cag @@ -127,7 +127,7 @@ ppCurlyList pL xs = ppListSep "{ " " }" ", " $ map pL xs %%[(8 codegen) ATTR CodeAGItf AllCodeNT [ | | pp USE {>-<} {empty} : PP_Doc ] -ATTR CPatFldL CPatL CBindL CAltL CBindAspectL [ | | ppL: {[PP_Doc]} ] +ATTR CPatFldL CBindL CAltL CBindAspectL CBindAnnL [ | | ppL: {[PP_Doc]} ] ATTR CExpr [ | | lamBodyPP: PP_Doc lamArgPPL: {[PP_Doc]} ] ATTR CExpr [ | | appFunPP : PP_Doc appArgPPL: {[PP_Doc]} ] @@ -195,21 +195,13 @@ SEM CBindAspect | FFE lhs . pp = "=" >#< ("foreignexport" >#< ppCurlysCommasBlock [pp (show @callconv),"\"" >|< @expEnt >|< "\"",ppCNm @expNm,ppTyWithCfg' CfgPP_Plain @ty]) %%]] -SEM CBindAspectL - | Nil lhs . ppL = [] - | Cons lhs . ppL = @hd.pp : @tl.ppL - -SEM CBindL +SEM CBindAspectL CBindL CPatFldL CAltL CBindAnnL | Nil lhs . ppL = [] | Cons lhs . ppL = @hd.pp : @tl.ppL SEM CAlt | Alt lhs . pp = ppDef (@pat.pp >#< "->") (@expr.pp) -SEM CAltL - | Nil lhs . ppL = [] - | Cons lhs . ppL = @hd.pp : @tl.ppL - SEM CPat | Int lhs . pp = ppLit "Int" (show @int) | Char lhs . pp = ppLit "Char" [@char] @@ -217,19 +209,13 @@ SEM CPat | Con lhs . pp = ppDef ("#Tag" >#< ppTag @tag) (ppCurly (@rest.pp >#< "|" >#< ppCommas' @binds.ppL)) -SEM CPatL - | Nil lhs . ppL = [] - | Cons lhs . ppL = @hd.pp : @tl.ppL - SEM CPatFld - | Fld lhs . pp = ppCurlysCommas' [ppCNm @lbl,@offset.pp {- ,ppCNm @nm -}] >|< "=" >|< ppCNm @fldNm -- @pat.pp + | Fld lhs . pp = ppCurlysCommas' [ppCNm @lbl,@offset.pp {- ,ppCNm @nm -}] >|< "=" >|< ppCNm @fldNm + >|< (if null @fldAnns.ppL then empty else ppParensCommas' @fldAnns.ppL) SEM CPatRest | Var lhs . pp = ppCNm @nm -SEM CPatFldL - | Nil lhs . ppL = [] - | Cons lhs . ppL = @hd.pp : @tl.ppL %%] | Undef lhs . pp = pp hsnUnknown @@ -271,6 +257,9 @@ SEM CExprAnn | Ty loc . pp = "::" >#< ppTyWithCfg' CfgPP_Plain @ty | Coe loc . pp = "~" >#< ppRelevCoe @lhs.varPPMp @coe | Debug loc . pp = ppCmt $ pp @info + +SEM CBindAnn + | Coe loc . pp = "~" >#< ppRelevCoe @lhs.varPPMp @coe %%] %%[(9 codegen) diff --git a/EHC/src/ehc/Core/ToJScript.cag b/EHC/src/ehc/Core/ToJScript.cag new file mode 100644 index 000000000..c63c51f67 --- /dev/null +++ b/EHC/src/ehc/Core/ToJScript.cag @@ -0,0 +1,1052 @@ +%%[0 +%include lhs2TeX.fmt +%include afp.fmt +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Code generation for Javascript +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jscript) hs module {%{EH}Core.ToJScript} import({%{EH}Base.Common},{%{EH}Opts},{%{EH}Ty},{%{EH}Core}) +%%] + +%%[(8 jscript) hs import(Data.Maybe, qualified Data.Map as Map, qualified Data.Set as Set, Data.Char, Data.Maybe, Data.List) +%%] +%%[(8 jscript) hs import(EH.Util.Utils, qualified EH.Util.FastSeq as Seq) +%%] + +%%[(8 jscript) hs import({%{EH}Base.Builtin},{%{EH}Base.Builtin2},{%{EH}BuiltinPrims},{%{EH}Base.BasicAnnot},{%{EH}Base.GenJavaLike}) +%%] + +%%[(8 jscript) hs import({%{EH}Gam.DataGam}) +%%] + +%%[(8 jscript) hs import(qualified {%{EH}JScript} as J) +%%] + +%%[(90 jscript) hs import({%{EH}Foreign.Extract}) +%%] + +-- debug +%%[(8 jscript) hs import({%{EH}Base.Debug},EH.Util.Pretty) +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Interface +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jscript).WRAPPER ag import({Core/AbsSyn},{Core/CommonLev},{Core/CommonBindNm},{Core/CommonJavaLike},{Core/CommonPred},{Core/CommonCtxtPred},{Core/CommonFFI}) +WRAPPER CodeAGItf +%%] + +%%[(8 jscript) hs export(cmod2JScriptModule) +cmod2JScriptModule :: EHCOpts -> DataGam -> CModule -> J.JScriptModule +cmod2JScriptModule opts dataGam cmod + = js_Syn_CodeAGItf t + where t = wrap_CodeAGItf (sem_CodeAGItf (CodeAGItf_AGItf cmod)) + (Inh_CodeAGItf { opts_Inh_CodeAGItf = opts + , dataGam_Inh_CodeAGItf = dataGam + }) +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Global info +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jscript) +ATTR CodeAGItf AllNT [ opts: EHCOpts | | ] +%%] + +%%[(8 jscript) +ATTR CodeAGItf AllNT [ dataGam: DataGam | | ] +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Unique +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jscript) +ATTR AllNT [ | gUniq: UID | ] + +SEM CodeAGItf + | AGItf loc . gUniq = uidStart +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Names +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jscript) hs +nmFunSuff :: Int -> String +nmFunSuff n | n > 5 = "N" + | n >= 0 = show n + | otherwise = "" +-- nmApplyN n = "_a" ++ nmFunSuff n ++ "_" +nmEvalN n = "_e" ++ nmFunSuff n ++ "_" +nmEval = nmEvalN (-1) +nmFunN n = mkHNm ("_F" {- ++ nmFunSuff n -} ++ "_") +nmAppN n = "_A" {- ++ nmFunSuff n -} ++ "_" +nmTag = mkHNm "_tag_" +nmInd = mkHNm "_i_" +nmIndSet = mkHNm "_i_set_" +nmSwitchRes = mkHNm "_sw" +%%] + +%%[(8 jscript) hs +hsnJScriptVar :: Bool -> HsName -> HsName -> HsName -> HsName +%%[[8 +hsnJScriptVar isGlobal = hsnJavaLikeVar (id, id, id) +%%][20 +hsnJScriptVar isGlobal = hsnJavaLikeVar (if isGlobal then id else hsnQualified, hsnPrefix "$", ('$':)) +%%]] +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Safe name +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jscript) +SEM CBindAspect + | * loc . varnm = hsnJScriptVar @lhs.isGlobal @lhs.pkgNm @lhs.topClassNm @lhs.nm + loc . varnm : HsName + +SEM CExpr + | Var loc . varnm = hsnJScriptVar True @lhs.pkgNm @lhs.topClassNm @nm + +SEM CPatFld + | Fld loc . varnm = hsnJScriptVar False @lhs.pkgNm @lhs.topClassNm @fldNm +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Extract all module names of globally introduced identifers +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(20 jscript) +ATTR CExpr AllBind [ | | usedModNmS USE {`Set.union`} {Set.empty} : {FvS} ] + +SEM CBindAspect + | * lhs . usedModNmS = maybe Set.empty Set.singleton $ hsnQualifier @varnm + +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Known types +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8888 jscript) hs +jtyInt = J.Type_Class nmInt +jtyChar = J.Type_Class nmChar +jtyStr = J.Type_Class nmStr +jtyObj = J.Type_Class nmObj +jtyTup = J.Type_Array jtyObj +jtyData = J.Type_Class nmData +jtyFun = J.Type_Class nmFun +jtyApp = J.Type_Class nmApp +jtyEvl = J.Type_Class nmEvl +jtyInd = J.Type_Class nmInd +%%] + +%%[(9797 jscript) hs +jtyByte = J.Type_Class nmByte +jtyShort = J.Type_Class nmShort +jtyLong = J.Type_Class nmLong +jtyFloat = J.Type_Class nmFloat +jtyDouble = J.Type_Class nmDouble +%%] + +%%[(9898 jscript) hs +jtyHandle = J.Type_Class nmHandle +jtyByteArray = J.Type_Array J.Type_Byte +jtyInteger = J.Type_Class (mkHNm "java.math.BigInteger") +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Known offsets: arguments to a non static method +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8888 jscript) hs +methArgOffset0 :: Int +methArgOffset0 = 1 + +methArgOffsets :: Int -> [Int] +methArgOffsets arity = [methArgOffset0 .. arity - methArgOffset0 + 1] +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Labels +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8888 jscript) hs +lblTake1 :: J.Label -> (J.Label,J.Label) +lblTake1 l = (l,l+1) +%%] + +%%[(8888 jscript) +ATTR AllNT [ | lblSeed: {J.Label} | ] + +SEM CodeAGItf + | AGItf loc . lblSeed = 0 + +SEM CExpr + | Case (loc.lblDefault,loc.lblSeed2) = lblTake1 @lhs.lblSeed + (loc.lblAftCase,alts.lblSeed) = lblTake1 @lblSeed2 + +SEM CAlt + | Alt (loc.lblAlt,pat.lblSeed) = lblTake1 @lhs.lblSeed +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Variable bindings for other than global +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jscript) hs +type CVarInfo = CVarInfo' () HsName Int +type CVarMp = CVarMp' () HsName Int +%%] + +%%[(8 jscript) hs +tyDefault = () +%%] + +%%[(8 jscript) hs +jvRef :: CVarMp -> CVarInfo -> J.Expr +jvRef + = cvarToRef + ( \_ -> J.Expr_This + , \_ o -> jsVar o + , \_ _ f -> jsVar f + , \_ e _ f -> J.Expr_ObjFld e (mkHNm f) + , \ e o -> J.Expr_ArrInx e o + , jsIntConst + ) +%%] + +%%[(8 jscript) +SEM CExpr + | Let loc . nmToRefAssocL = map (\x -> (x, hsnJScriptVar @isGlobal @lhs.pkgNm @lhs.topClassNm x)) @binds.bindNmL +%%] + +%%[(8 jscript) +SEM CExpr + | Lam loc . (jsArgTyL,_,lamBindings) + = if @hasFunHere + then jsArgsUnpack (map (hsnJScriptVar False @lhs.pkgNm @lhs.topClassNm)) @nmArgL + else ([],[],[]) +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Case: scrutinee +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jscript) +%%] +-- dummy +SEM CExpr + | Case loc . scrutineeCVarInfo = CVarInfo_None + +%%[(8 jscript) +SEM CExpr + | Case loc . (scrutineeTagJS,scrutineeCVarInfo) + = case @alts.scrutinees of + (Scrutinee_Var nm : _) + -> panic ("Core.ToJScript.CExpr.Case.Scrutinee_Var: " ++ show nm ++ " : not yet implemented") + (Scrutinee_Int _ : _) + -> ( @expr.js + , CVarInfo_None + ) + (Scrutinee_Tag tag : _) + -> ( gettag + , CVarInfo_Local () $ panicJust "ToJScript.CExpr.Case scrutinee" $ J.exprMbVar @expr.js + ) + where (gettag) + = case tag of + CTagRec -> ( J.Expr_Str "*** ERR GETTAG ***" ) + CTag _ _ _ _ _ -> ( J.Expr_Sel @expr.js nmTag + ) + (Scrutinee_Other x : _) + -> panic ("Core.ToJScript.CExpr.Case.Scrutinee_Other: " ++ x ++ " : not yet implemented") + [] + -> panic ("Core.ToJScript.CExpr.Case.-") +%%] + +%%[(8888 jscript) +SEM CExpr + | Case loc . altsLocalOffset = @lhs.localOffset + 1 + . (scrutineeJI,scrutineeTagJI,scrutineeCVarInfo) + = case @alts.scrutinees of + (Scrutinee_Var nm : _) + -> panic ("Core.ToJScript.CExpr.Case.Scrutinee_Var: " ++ show nm ++ " : not yet implemented") + (Scrutinee_Int _ : _) + -> ( emptyJI + , unbox @expr.ji + , CVarInfo_None + ) + where (unbox,ty) = basicTyJUnbox False BasicJazy_Int + (Scrutinee_Tag tag : _) + -> ( jiCast ty @expr.ji ## J.Instr_Store ty @lhs.localOffset + , gettag + , cvi + ) + where (ty,gettag,cvi) + = case tag of + CTagRec -> (jtyTup,emptyJI,mkcvi jtyTup) + CTag tn _ _ _ _ -> ( J.Type_Class tn' + , jvRef @lhs.cvarMp cvi + ## J.Instr_Get False (J.Const_Field tn' nmTag J.Type_Int) + , cvi + ) + where cvi = mkcvi (J.Type_Class tn') + tn' = hsnJavaLikeDataTy @lhs.pkgNm @lhs.topClassNm tn + mkcvi ty = CVarInfo_Local ty @lhs.localOffset + (Scrutinee_Other x : _) + -> panic ("Core.ToJScript.CExpr.Case.Scrutinee_Other: " ++ x ++ " : not yet implemented") + [] + -> panic ("Core.ToJScript.CExpr.Case.-") +%%] + +%%[(8 jscript) +SEM CAlt + | Alt loc . (scrutineeTag) + = case @pat.scrutinees of + (Scrutinee_Tag (CTag _ cn tag _ _) : _) + -> ( tag + ) + (Scrutinee_Int i : _) + -> ( i + ) + _ -> (0) +%%] + +%%[(8888 jscript) +SEM CAlt + | Alt loc . (scrutineeAltJI,scrutineeCVarInfo,scrutineeTag) + = case @pat.scrutinees of + (Scrutinee_Tag (CTag _ cn tag _ _) : _) + -> ( jiCast ty (jvRef @lhs.cvarMp cvi) + ## J.Instr_Store ty (cvarOffset cvi) -- assume here it is a CVarInfo_Local as constructed above + , cvi {cvarType = ty} + , tag + ) + where cn' = hsnJavaLikeDataCon @lhs.pkgNm @lhs.topClassNm cn + ty = J.Type_Class cn' + cvi = @lhs.scrutineeCVarInfo + (Scrutinee_Int i : _) + -> ( emptyJI + , @lhs.scrutineeCVarInfo + , i + ) + _ -> (emptyJI,@lhs.scrutineeCVarInfo,0) +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Offset of locals +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +TBD: assume presence of self, assume size == 1 +TBD: outside current lexical level, cannot be accessed locally, is closure (which is only half baked available in JVM) + +%%[(8888 jscript) +ATTR AllNT [ localOffset: {J.Local} | | ] +ATTR AllPat [ | offsetOffset: {J.Local} | ] + +SEM CodeAGItf + | AGItf loc . localOffset = 0 -- dummy value + +SEM CExpr + | Lam (loc.localOffset,body.localOffset) + = if @hasFunHere + then (methArgOffset0 , methArgOffset0 + length @nmArgL) + else (@lhs.localOffset, @lhs.localOffset ) + | Let loc . localOffset = @lhs.localOffset + @nLocals + | Case alts . localOffset = @altsLocalOffset + +SEM CAlt + | Alt pat . offsetOffset = @lhs.localOffset + expr . localOffset = @pat.offsetOffset +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Case alt: names of fields, used to access fields in object representing data constructor +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jscript) +ATTR AllPatFld [ | dataFldNmL: {[HsName]} | ] + +SEM CPat + | Con binds . dataFldNmL = jsDataFldNames @lhs.dataGam @tag + +SEM CPatFld + | Fld (loc.objFldNm,lhs.dataFldNmL) = hdAndTl' (panic "ToJScript.CPatFld.Fld.dataFldNmL") @lhs.dataFldNmL +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Case: offsets of offsets in tuple +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jscript) +ATTR AllPat [ | | offsetBinds USE {++} {[]} : {[(HsName,CVarInfo,J.Expr)]} ] +%%] + +%%[(8 jscript) +%%] +-- dummy +SEM CPatFld + | Fld loc.cviField = CVarInfo_None + +%%[(8 jscript) +SEM CPatFld + | Fld (loc.cviField,loc.offsetBinds) + = case @lhs.ctag of + CTagRec + -> case @offset.whatBelow of + ExprIsInt i -> (mkf $ Left i,[]) + ExprIsVar n -> (mkf $ Right n,[]) + {- + _ -> (mkf $ Right n,[(n,CVarInfo_Local t o,mkj @offset.js)]) + where n = @varnm + o = @lhs.offsetOffset + (mkj,t) = (id,()) + -} + where mkf o = CVarInfo_TupFld tyDefault @lhs.scrutineeCVarInfo o + CTag _ cn _ _ _ + -> case @offset.whatBelow of + ExprIsInt i -> (CVarInfo_DataFld tyDefault @lhs.scrutineeCVarInfo hsnUnknown (show @objFldNm),[]) + _ -> panic "Core.ToJScript.CPatFld.Fld.cviField" + -- where cn' = hsnJavaLikeDataCon @lhs.pkgNm @lhs.topClassNm cn +%%] + +%%[(8888 jscript) +SEM CPatFld + | Fld (loc.cviField,lhs.offsetOffset,loc.offsetBinds) + = case @lhs.ctag of + CTagRec + -> case @offset.whatBelow of + ExprIsInt i -> (mkf $ Left i,@lhs.offsetOffset,[]) + ExprIsVar n -> (mkf $ Right n,@lhs.offsetOffset,[]) + _ -> (mkf $ Right n,o+1,[(n,CVarInfo_Local t o,mkj @offset.js)]) + where n = @varnm + o = @lhs.offsetOffset + (mkj,t) = (id,()) + where mkf o = CVarInfo_TupFld tyDefault @lhs.scrutineeCVarInfo o + CTag _ cn _ _ _ + -> case @offset.whatBelow of + ExprIsInt i -> (CVarInfo_DataFld tyDefault @lhs.scrutineeCVarInfo cn' (hsnJavaLikeDataFldAt i),@lhs.offsetOffset,[]) + _ -> panic "Core.ToJazy.CPatFld.Fld.cviField" + where cn' = hsnJavaLikeDataCon @lhs.pkgNm @lhs.topClassNm cn +%%] + +%%[(8888 jscript) +SEM CAlt + | Alt loc . offsetsJI = j [ ji ## J.Instr_Store t o | (_,CVarInfo_Local t o,ji) <- @pat.offsetBinds ] +%%] + +%%[(8888 jscript) +SEM CAlt + | Alt loc . offsetsJI = j [ ji ## J.Instr_Store t o | (_,CVarInfo_Local t o,ji) <- @pat.offsetBinds ] +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Generation: App as args ++ func +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jscript) +ATTR CExpr [ | | jsArgFunL: {[J.Expr]} ] + +SEM CExpr + | App loc . jsArgFunL = @argUnpackWrap @arg.js : @func.jsArgFunL + | * - App Ann lhs . jsArgFunL = [@js] +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Generation: Lam as body + args +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jscript) +ATTR CExpr [ | | jsBody: {J.Expr} ] + +SEM CExpr + | Lam loc . jsBody = @body.jsBody + | * - Lam Ann lhs . jsBody = @js +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Generation: expr +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jscript) hs +-- | tracing +jsTr :: PP x => String -> x -> Seq.Seq J.Stat +jsTr m x = Seq.singleton $ J.Stat_Expr $ J.Expr_Call (jsVar $ mkHNm "trace") [J.Expr_Str m, J.Expr_Inline $ showPP $ pp x] + +-- constant +jsIntConst :: Integral x => x -> J.Expr +jsIntConst i = J.Expr_Int $ fromIntegral i + +-- var +jsVar :: HSNM x => x -> J.Expr +jsVar nm = J.Expr_Var $ mkHNm nm + +-- call +jsCall :: HSNM n => n -> [J.Expr] -> J.Expr +jsCall f as = J.Expr_Call (jsVar $ mkHNm f) as + +-- apply +jsApp :: J.Expr -> [J.Expr] -> J.Expr +jsApp f as + = J.Expr_New $ jsCall nm (f : as') + where (nm,_,as') = jsArgsPack as + nArgs = length as' + +-- lam +jsFun :: HsName -> [HsName] -> [J.Stat] -> J.Expr +jsFun fNm as stats + = J.Expr_New $ jsCall (nmFunN $ length as) (extra ++ [J.Expr_Fun Nothing as stat]) + where stat = J.Stat_Block stats +%%[[8 + extra = [J.Expr_Str $ show fNm] +%%][100 + extra = [] +%%]] + +-- force evaluation +jsEvl :: J.Expr -> J.Expr +jsEvl x = jsCall nmEval [x] + +-- assign +jsAssign :: HSNM x => x -> J.Expr -> J.Stat +jsAssign n e = J.Stat_Assign (jsVar $ mkHNm n) e + +-- new tuple +jsNewTup :: [J.Expr] -> J.Expr +jsNewTup = J.Expr_Arr + +-- | field names used for data constructors, either as provided by program, or made up here +-- 20101012 AD, note: internally generated datatypes not yet have correct meta info, so fill up names as needed, as temporary hack +jsDataFldNames :: DataGam -> CTag -> [HsName] +jsDataFldNames dataGam ctag + = zipWith (\o mbn -> maybe o hsnQualified mbn) hsnLclSupply $ nms ++ fill + where nms = maybe [] (\(_,dti) -> map fst $ dtiFldTyL dti) $ dataGamTagLookup ctag dataGam + fill = repeat Nothing + +-- either new data constructor or tuple +jsNewTupOrData :: DataGam -> HsName -> HsName -> CTag -> [J.Expr] -> J.Expr +jsNewTupOrData dataGam _ _ ctag as + = case ctag of + CTag _ _ t _ _ -> J.Expr_Obj $ ((nmTag,jsIntConst t):) + $ zip (jsDataFldNames dataGam ctag) as + CTagRec -> jsNewTup as + +-- | body +jsBody :: (J.Expr -> J.Stat) -> Seq.Seq JBind -> Seq.Seq J.Stat -> J.Expr -> [J.Stat] +jsBody mkRet binds stats lastExpr + = Seq.toList $ + Seq.map (\(JBind _ n _ e _) -> J.jsVarDecl n e) binds + `Seq.union` stats + `Seq.union` Seq.fromList [mkRet lastExpr] +%%] + + +%%[(8888 jscript) hs +-- constant +jiIntConst :: Integral x => x -> J.JInstr +jiIntConst i = j $ J.Instr_Const $ J.Const_Int $ fromIntegral i + +jiStrConst :: String -> J.JInstr +jiStrConst s = j $ J.Instr_Const $ J.Const_String s + +-- new something +jiNew :: HsName -> [(J.JInstr,J.Type)] -> J.JInstr +jiNew nmCl argL + = J.Instr_New nmCl + ## J.Instr_Dup (J.Type_Class nmCl) + ## map fst argL + ## J.Instr_Invoke J.InvokeMode_Special (J.Const_Method nmCl "" (map snd argL) Nothing) + +-- put into (static) field +jiPut :: J.ClassRef -> Bool -> J.JInstr -> String -> J.Type -> J.JInstr +jiPut clNm static e n t + = (if static then emptyJI else j $ J.Instr_Load (J.Type_Class clNm) 0 ) ## e ## J.Instr_Put static (J.Const_Field clNm n t) + +-- new tuple +jiNewTup :: [J.JInstr] -> J.JInstr +jiNewTup as + = jiIntConst nArgs + ## J.Instr_NewArray jtyObj + ## [ J.Instr_Dup jtyObj + ## jiIntConst o + ## a + ## J.Instr_AStore jtyObj + | (o,a) <- zip [0..] as + ] + where nArgs = length as + +-- cast to type +jiCast :: J.Type -> J.JInstr -> J.JInstr +jiCast ty ji + = ji + ## J.Instr_CheckCast ty + +-- apply +jiApp :: J.JInstr -> [J.JInstr] -> J.JInstr +jiApp f as + = jiCast jtyEvl f + ## as' + ## J.Instr_Invoke J.InvokeMode_Virtual (J.Const_Method nmEvl nm (replicate nArgs ty) (Just jtyApp)) + where (nm,ty,as') = jiArgsPack as + nArgs = length as' + +-- set an indirection +jiSetInd :: J.JInstr -> J.JInstr -> J.JInstr +jiSetInd ind val + = ind ## val + ## J.Instr_Invoke J.InvokeMode_Virtual (J.Const_Method nmInd nmIndSet [jtyObj] Nothing) + +-- either new data constructor or tuple +jiNewTupOrData :: J.ClassRef -> J.ClassRef -> CTag -> [J.JInstr] -> J.JInstr +jiNewTupOrData pkg mod ctag as + = case ctag of + CTag _ cn _ _ _ -> jiNew (hsnJavaLikeDataCon pkg mod cn) [ (a,jtyObj) | a <- as ] + CTagRec -> jiNewTup as + +-- force evaluation +jiEvl :: J.JInstr -> J.JInstr +jiEvl x = x ## J.Instr_Invoke J.InvokeMode_Static (J.Const_Method nmEvl nmEval [jtyObj] (Just jtyObj)) + +%%] + +%%[(8888 jscript) hs +jiToCd :: J.JInstr -> J.Code +jiToCd i = J.Code_Code Nothing Nothing (Seq.toList i) +%%] + +%%[(8 jscript) +ATTR CExpr [ | | js: {J.Expr} ] +%%] + +%%[(8 jscript) +SEM CExpr + | Var loc . js = jvRef @lhs.cvarMp @cvi + | Int loc . js = jsIntConst @int + | Char loc . js = jsIntConst (ord @char) -- J.Expr_Char @char + | String loc . js = J.Expr_Str @str + | Tup loc . js = jsNewTupOrData @lhs.dataGam @lhs.pkgNm @lhs.topClassNm @tag [] + | App loc . js = if @isTopApp' + then let (f:as) = reverse @jsArgFunL + in case @func.appFunKind of + AppFunKind_Tag tag -> jsNewTupOrData @lhs.dataGam @lhs.pkgNm @lhs.topClassNm tag as + AppFunKind_FFI -> @func.resPackWrap $ @func.mkFFI f as + _ -> jsApp f as + else J.Expr_Str "*** ERR APP ***" + | FFI loc . (mkArgsJS,mkResJS,mkFFI) + = ffiJScriptMkCall @lhs.opts False @impEntNm @argMbConL @resMbCon + . js = let ent = jsVar $ mkHNm @impEntNm + ffi = @mkFFI ent [] + in if null @argMbConL then @mkResJS ffi else ent + | Let loc . (jbindsLet,jstatsLet,js) + = if @isGlobal + then ( @binds.jbinds, Seq.empty, @body.js ) + else let binds = [ ((offof n),t,e) | JBind n _ t e _ <- Seq.toList @binds.jbinds ] + offof n = cvarOffset $ panicJust "ToJScript.CExpr.Let.js offset" $ Map.lookup n @cvarMpNew + initbinds + = case @categ of + CBindings_Rec + -> Seq.fromList [ J.Stat_VarDecl o $ Just $ jsCall nmInd [] | (o,_,_) <- binds ] + `Seq.union` Seq.fromList [ J.Stat_Expr $ jsCall nmIndSet [jsVar o, e] | (o,_,e) <- binds ] + _ -> Seq.fromList [ J.Stat_VarDecl o (Just e) | (o,_,e) <- binds ] + in ( Seq.empty, initbinds, @body.js ) + | Case loc . (jstatsCase,js) + = let alts = case @alts.altsJsL of + [(_,stats,e)] + -> (stats,e) + as -> ( Seq.fromList $ + [ J.Stat_VarDecl swRes Nothing + , J.Stat_Switch @scrutineeTagJS + [ J.Alt_Alt tag $ Seq.toList $ stats `Seq.union` Seq.fromList [jsAssign swRes e, J.Stat_Break] + | (tag,stats,e) <- as + ] + ] + , jsVar swRes + ) + where swRes = hsnJScriptVar False @lhs.pkgNm @lhs.topClassNm $ hsnUniqifyUID HsNameUniqifier_JSSwitchResult @lUniq nmSwitchRes + in alts + loc . lUniq : UNIQUEREF gUniq + | CaseAltFail loc . js = @errorExpr.js + | Ann loc . js = @expr.js + | * - Var Int Char String App Tup Let CaseAltFail Lam FFI Case Ann + loc . js = J.Expr_Str "*** TODO ***" +%%] + +%%[(8 jscript) +ATTR AllAlt [ | | altsJsL USE {++} {[]} : {[(Int,Seq.Seq J.Stat,J.Expr)]} ] +%%] + +%%[(8 jscript) +SEM CAlt + | Alt loc . altsJsL = [(@scrutineeTag,@expr.jstats,@expr.js)] +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Additional unwrapping of arguments resp packing of res, in particular for FFI call +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jscript) +ATTR CExpr [ | | argUnpackWrapL : {[J.Expr -> J.Expr]} ] + +SEM CExpr + | FFI lhs . argUnpackWrapL = @mkArgsJS + | App (loc.argUnpackWrap,lhs.argUnpackWrapL) + = hdAndTl' id @func.argUnpackWrapL + | * - FFI App Ann + lhs . argUnpackWrapL = [] +%%] + +%%[(8 jscript) +ATTR CExpr [ | | resPackWrap : {J.Expr -> J.Expr} ] + +SEM CExpr + | FFI lhs . resPackWrap = @mkResJS + | App lhs . resPackWrap = @func.resPackWrap + | * - FFI App Ann + lhs . resPackWrap = id +%%] + +%%[(8 jscript) +ATTR CExpr [ | | mkFFI : {J.Expr -> [J.Expr] -> J.Expr} ] + +SEM CExpr + | App lhs . mkFFI = @func.mkFFI + | * - FFI App Ann + lhs . mkFFI = \f _ -> f +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Dealing with >5 args +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jscript) hs +-- pack > 5 args into tuple, otherwise normal +jsArgsPack :: [J.Expr] -> (String,(),[J.Expr]) +jsArgsPack = javalikeArgsPack (-1) ((),(),J.Expr_Arr,nmAppN) +%%] + +%%[(8 jscript) hs +-- unpack > 5 args from tuple, otherwise normal +jsArgsUnpack :: ([HsName]->[HsName]) -> [HsName] -> ([(HsName,())],[(J.Expr,())],[(HsName,CVarInfo)]) +jsArgsUnpack toRef = javalikeArgsUnpack maxBound ((), (), (), toRef, jsIntConst, \_ a -> a, \n -> take n hsnLclSupply) +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Generation: single binding +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jscript) hs +type JBind = JBind' () J.Expr () +type JBinds = JBinds' () J.Expr () +%%] + +%%[(8 jscript) hs +jBind :: HsName -> HsName -> J.Expr -> JBinds +jBind = jBind' (tyDefault, id, const ()) +%%] + +%%[(8 jscript) +SEM CBindAspect + | Bind Val loc . jsExpr = (if @lhs.evalCtx == EvalCtx_Eval then jsEvl else id) @expr.js +%%] + +%%[(8888 jscript) +SEM CBindAspect + | Bind Val loc . jiExpr = (if @lhs.evalCtx == EvalCtx_Eval then jiEvl else id) @expr.ji +%%] + +%%[(8 jscript) +SEM CBindAspect + | Bind lhs . jbinds = {- if @isThrowOutMain then Seq.empty else -} jBind @lhs.nm @varnm @js +%%] + +%%[(8 jscript) +ATTR CExpr [ | | jstats: {Seq.Seq J.Stat} ] + +SEM CExpr + | Let lhs . jstats = @jstatsLet `Seq.union` @body.jstats + | Case lhs . jstats = @jstatsCase + | Lam lhs . jstats = if @hasFunHere then Seq.empty else @body.jstats + | * - Let Case Lam Ann + lhs . jstats = Seq.empty +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Generation: FFI binding +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8888 jscript) hs +basicTyJBox :: BasicJazy -> (J.JInstr -> J.JInstr,J.Type) +basicTyJBox t + = case t of + BasicJazy_Int -> (bx nmInt J.Type_Int ,J.Type_Int ) + BasicJazy_Char -> (bx nmChar J.Type_Char ,J.Type_Char ) + BasicJazy_Object -> (id ,jtyObj ) + BasicJazy_String -> (id ,jtyStr ) +%%[[97 + BasicJazy_Byte -> (bx nmByte J.Type_Byte ,J.Type_Byte ) + BasicJazy_Short -> (bx nmShort J.Type_Short ,J.Type_Short ) + BasicJazy_Long -> (bx nmLong J.Type_Long ,J.Type_Long ) + BasicJazy_Float -> (bx nmFloat J.Type_Float ,J.Type_Float ) + BasicJazy_Double -> (bx nmDouble J.Type_Double,J.Type_Double) + BasicJazy_Integer -> (id ,jtyInteger ) +%%]] +%%[[98 + BasicJazy_Handle -> (id ,jtyHandle ) + BasicJazy_ByteArray -> (id ,jtyByteArray ) +%%]] + where bx nm ty jiVal = jiNew nm [(jiVal,ty)] + +basicTyJUnbox :: Bool -> BasicJazy -> (J.JInstr -> J.JInstr,J.Type) +basicTyJUnbox doEval t + = case t of + BasicJazy_Int -> (un1 nmInt jtyInt "intValue" J.Type_Int ,J.Type_Int ) + BasicJazy_Char -> (un1 nmChar jtyChar "charValue" J.Type_Char ,J.Type_Char ) + BasicJazy_Object -> (un2 jtyObj ,jtyObj ) + BasicJazy_String -> (un2 jtyStr ,jtyStr ) +%%[[97 + BasicJazy_Byte -> (un1 nmByte jtyByte "byteValue" J.Type_Byte ,J.Type_Byte ) + BasicJazy_Short -> (un1 nmShort jtyShort "shortValue" J.Type_Short ,J.Type_Short ) + BasicJazy_Long -> (un1 nmLong jtyLong "longValue" J.Type_Long ,J.Type_Long ) + BasicJazy_Float -> (un1 nmFloat jtyFloat "floatValue" J.Type_Float ,J.Type_Float ) + BasicJazy_Double -> (un1 nmDouble jtyDouble "doubleValue" J.Type_Double,J.Type_Double) + BasicJazy_Integer -> (un2 jtyInteger ,jtyInteger ) +%%]] +%%[[98 + BasicJazy_Handle -> (un2 jtyHandle ,jtyHandle ) + BasicJazy_ByteArray -> (un2 jtyByteArray ,jtyByteArray ) +%%]] + where un1 nmTy ty nmGet tyRes jiVal + = un2 ty jiVal + ## J.Instr_Invoke J.InvokeMode_Virtual (J.Const_Method nmTy nmGet [] (Just tyRes)) + un2 ty jiVal + = jiCast ty (if doEval then jiEvl jiVal else jiVal) +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Generation: methods +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8888 jscript) hs +jmInitInstWith :: [(J.JInstr,J.Type)] -> J.JInstr -> J.ClassRef -> J.ClassRef -> [(String)] -> J.Method +jmInitInstWith jiInitL ji thisNm superNm fldL + = J.Method_Method [J.Flag_Public] "" (replicate nArgs jtyObj) retTy + (jiToCd + $ J.Instr_Load jtyObj 0 + ## map fst jiInitL + ## J.Instr_Invoke J.InvokeMode_Special (J.Const_Method superNm "" (map snd jiInitL) Nothing) + ## [ jiPut thisNm False (j $ J.Instr_Load jtyObj o) f jtyObj | (o,f) <- zip (methArgOffsets nArgs) fldL ] + ## ji + ## J.Instr_Return retTy + ) + where retTy = Nothing + nArgs = length fldL + +jmInit0InstWith :: J.JInstr -> J.ClassRef -> J.ClassRef -> J.Method +jmInit0InstWith ji thisNm superNm = jmInitInstWith [] ji thisNm superNm [] + +jmInit0Inst :: J.ClassRef -> J.ClassRef -> J.Method +jmInit0Inst = jmInit0InstWith emptyJI + +jmEvalN :: Int -> [J.Type] -> J.JInstr -> J.Method +jmEvalN n args ji + = J.Method_Method [J.Flag_Public] (nmEvalN n) args retTy + (jiToCd + $ ji + ## J.Instr_Return retTy + ) + where retTy = Just jtyObj + +jmEvalSet :: J.JInstr -> J.Method +jmEvalSet ji + = J.Method_Method [J.Flag_Public] "evalSet" [] retTy + (jiToCd + $ J.Instr_Load jtyObj 0 + ## ji + ## J.Instr_Invoke J.InvokeMode_Virtual (J.Const_Method (nmAppN 0) "setValue" [jtyObj] retTy) + ## J.Instr_Return retTy + ) + where retTy = Nothing +%%] + +%%[(8 jscript) +SEM CModule + | Mod loc . jmodStats = jsBody J.Stat_Expr @expr.jbinds @expr.jstats + $ jsEvl +%%[[99 + $ (\m -> jsApp m [J.Expr_Arr []]) +%%]] + @expr.js +%%] + +%%[(8888 jscript) +SEM CModule + | Mod loc . methClinit = J.Method_Method [J.Flag_Static] "" [] Nothing + (jiToCd + $ [ e ## J.Instr_Put True (J.Const_Field @moduleClassNm (show $ hsnJavaLikeVarToFld n) t) + | JBind _ n t e _ <- Seq.toList @expr.jbinds + ] + ## J.Instr_Return Nothing + ) + . methInit = jmInit0Inst @moduleNm nmObj + . methMainNm = if ehcOptGenTrace @lhs.opts then "runVisuallyTraced" else "runTimed" + . methMain = let d f = jiNew (hsnJavaLikeDataCon @pkgNm @topClassNm $ ehcOptBuiltin @lhs.opts f) [] +%%[[99 + v f = jvRef @lhs.cvarMp (cvarGlob jtyObj @moduleClassNm n (hsnJScriptVar @pkgNm @topClassNm n)) + where n = ehcOptBuiltin @lhs.opts f +%%]] + in J.Method_Method [J.Flag_Public,J.Flag_Static] "main" [J.Type_Array jtyStr] Nothing + (jiToCd + $ d ehbnBoolTrue + ## d ehbnBoolFalse + ## J.Instr_Invoke J.InvokeMode_Static (J.Const_Method nmRTS "setBoolConstructors" [jtyObj,jtyObj] Nothing) + ## d ehbnDataOrderingAltEQ + ## d ehbnDataOrderingAltLT + ## d ehbnDataOrderingAltGT + ## J.Instr_Invoke J.InvokeMode_Static (J.Const_Method nmRTS "setOrderingConstructors" [jtyObj,jtyObj,jtyObj] Nothing) +%%[[99 + ## d ehbnDataListAltNil + ## v ehbnDataListAltCons + ## J.Instr_Invoke J.InvokeMode_Static (J.Const_Method nmRTS "setListConstructors" [jtyObj,jtyObj] Nothing) +%%]] + ## @expr.ji + ## J.Instr_Invoke J.InvokeMode_Static (J.Const_Method nmRTS @methMainNm [jtyObj] Nothing) + ## J.Instr_Return Nothing + ) +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Generation: classes +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8888 jscript) hs +type JClasses = Seq.Seq J.Class +%%] + +%%[(8888 jscript) hs +jCls :: J.Flags -> J.ClassRef -> J.ClassRef -> J.Fields -> J.Methods -> J.Classes -> J.Class +jCls flags nmThis nmSuper flds meths subs + = J.Class_Class 0 49 flags nmThis nmSuper [] flds meths subs + +jFunCls :: HsName -> Int -> [J.Type] -> [(J.JInstr,J.Type)] -> J.JInstr -> JBinds -> JClasses -> (JClasses,J.JInstr) +jFunCls thisNm nOrigArgs args jiInitL jbody jbinds subclasses + = ( Seq.fromList + [ jCls [J.Flag_Public,J.Flag_Static] thisNm superNm + (map jbindFld $ Seq.toList jbinds) + [ jmInitInstWith jiInitL emptyJI thisInitNm superNm [] + , if nOrigArgs == 0 then jmEvalSet jbody else jmEvalN nOrigArgs args jbody + ] + (Seq.toList subclasses) + ] + , jiNew thisNm [] + ) + where superNm = nmCafOrFunN nOrigArgs + thisInitNm = thisNm +%%] + +%%[(8 jscript) +SEM CExpr + | Lam loc . js = if @hasFunHere + then let as = [o | (o,_) <- @jsArgTyL] + v = mkHNm "_" + t1 x = if ehcOptGenTrace @lhs.opts + then Seq.unions [ jsTr (n ">" @lamNm) $ m $ [s " <- "] ++ intersperse (s ", ") (map p as) + , x + , Seq.singleton $ J.Stat_VarDecl v (Just @body.jsBody) + , jsTr (n "<" @lamNm) $ m [s " -> ", s v] + ] + else x + where m l = hlist $ intersperse (pp "+") l + s x = pp (show x) + s' x = pp (show $ show x) + p x = pp x + n p x = p ++ show x + b = if ehcOptGenTrace @lhs.opts then jsVar v else @body.jsBody + in jsFun @origLamNm as $ jsBody J.Stat_Ret @body.jbinds (t1 @body.jstats) b + else J.Expr_Str "*** ERR LAM ***" +%%] + +%%[(8888 jscript) +SEM CExpr + | Lam loc . (subClasses,ji) = if @hasFunHere + then let funNmJiL= [(jiStrConst (show @lamNm),jtyStr)] + classNm = hsnJavaLikeVarCls @lhs.pkgNm @lhs.topClassNm @lamNm + in jFunCls classNm (length @nmArgL) @jiArgTyL (@clsInitArgL ++ funNmJiL) @body.jiBody @body.jbinds @body.subClasses + else (@body.subClasses, emptyJI) +%%] + +%%[(8 jscript) hs +-- | construct the ffi call +ffiJScriptMkCall + :: EHCOpts + -> Bool -- do eval of args + -> String -- name of ffi entity + -> [Maybe HsName] -- list of (possibly) type constructor names of arguments + -> Maybe HsName -- and result + -> ( [J.Expr -> J.Expr] -- additional unwrapping for each argument + , J.Expr -> J.Expr -- and result + , J.Expr -> [J.Expr] -> J.Expr -- and primitive call itself + ) +ffiJScriptMkCall + = javalikeMkFFICall + ( const tyDefault,\_ _ -> bx,\_ -> bx + , \_ _ _ f as -> J.Expr_Call f as + , jsEvl, tyDefault + ) + where bx = (id,tyDefault) +%%] + +%%[(8 jscript) +SEM CBindAspect + | Bind loc . js = let dflt = @jsExpr + in if @lhs.isGlobal + then if @isCAF + then jsApp (jsFun @lhs.nm [] $ jsBody J.Stat_Ret @expr.jbinds @expr.jstats @jsExpr) [] + -- Seq.toList $ @expr.jstats `Seq.union` Seq.fromList [J.Stat_Ret @jsExpr]) [] + else dflt + else dflt +%%] + +%%[(8888 jscript) +SEM CBindAspect + | Bind loc . (subClasses,ji) = let dflt = (@expr.subClasses, @jiExpr) + in if @lhs.isGlobal + then if @isCAF + then jFunCls (hsnJavaLikeVarCls @lhs.pkgNm @lhs.topClassNm @varnm) 0 [] [] @jiExpr @expr.jbinds @expr.subClasses + else dflt + else dflt + lhs . subClasses = if @isThrowOutMain then Seq.empty else @subClasses +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Generation: toplevel +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jscript) +ATTR CodeAGItf CModule [ | | js: {J.JScriptModule} ] +%%] + +%%[(8 jscript) +SEM CModule + | Mod lhs . js = J.JScriptModule_Mod $ @jsModTraceStats ++ @jsModInitStats ++ @jmodStats +%%[[8 + loc . jsModInitStats = [] +%%][20 + loc . jsModInitStats = let prefixes = nub . catMaybes . map hsnQualifier + in map (\n -> jsAssign n $ J.Expr_Obj []) $ concat $ reverse $ takeWhile (not.null) $ iterate prefixes $ Set.toList @expr.usedModNmS +%%]] +%%[[8 + loc . jsModTraceStats = if ehcOptGenTrace @lhs.opts then [jsAssign (mkHNm "traceOn") J.Expr_True] else [] +%%][100 + loc . jsModTraceStats = [] +%%]] +%%] + + + + + diff --git a/EHC/src/ehc/Core/ToJazy.cag b/EHC/src/ehc/Core/ToJazy.cag index 5bef0c4eb..8c6a2c68a 100644 --- a/EHC/src/ehc/Core/ToJazy.cag +++ b/EHC/src/ehc/Core/ToJazy.cag @@ -15,7 +15,7 @@ %%[(8 jazy) hs import(EH.Util.Utils, qualified EH.Util.FastSeq as Seq) %%] -%%[(8 jazy) hs import({%{EH}Base.Builtin},{%{EH}Base.Builtin2},{%{EH}BuiltinPrims},{%{EH}Base.BasicAnnot}) +%%[(8 jazy) hs import({%{EH}Base.Builtin},{%{EH}Base.Builtin2},{%{EH}BuiltinPrims},{%{EH}Base.BasicAnnot},{%{EH}Base.GenJavaLike}) %%] %%[(8 jazy) hs import(qualified {%{EH}JVMClass} as J) @@ -32,7 +32,7 @@ %%% Interface %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%[(8 jazy).WRAPPER ag import({Core/AbsSyn},{Core/CommonLev},{Core/CommonBindNm},{Core/CommonPred},{Core/CommonCtxtPred},{Core/CommonFFI}) +%%[(8 jazy).WRAPPER ag import({Core/AbsSyn},{Core/CommonLev},{Core/CommonBindNm},{Core/CommonJavaLike},{Core/CommonPred},{Core/CommonCtxtPred},{Core/CommonFFI}) WRAPPER CodeAGItf %%] @@ -81,40 +81,12 @@ emptyJI = Seq.empty ATTR CodeAGItf AllNT [ opts: EHCOpts | | ] %%] -%%[(8 jazy) -ATTR AllNT [ topClassNm: HsName pkgNm: HsName | | ] -%%[[8 -ATTR AllNT [ moduleClassNm: HsName | | ] -%%][99 -ATTR AllNT - CodeAGItf CModule [ moduleClassNm: HsName | | ] -ATTR CodeAGItf CModule [ | | moduleClassNm: HsName ] -%%]] -%%] - -%%[(8 jazy) -SEM CModule - | Mod loc . topClassNm = @moduleNm - . pkgNm = @moduleNm -%%[[8 - . moduleClassNm = @moduleNm -%%][20 - . moduleClassNm = hsnSetQual @moduleNm $ hsnQualified @moduleNm -%%]] - -SEM CodeAGItf - | AGItf loc . topClassNm = hsnUnknown - . pkgNm = hsnUnknown -%%[[8 - . moduleClassNm = hsnUnknown -%%][99 -%%]] -%%] - %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Names %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%[(8 jazy) hs +nmFunSuff :: Int -> String nmFunSuff n | n > 5 = "N" | n >= 0 = show n | otherwise = "" @@ -130,7 +102,7 @@ nmAppN n = mkHNm ("uu.jazy.core.Apply" ++ nmFunSuff n) nmEvl = mkHNm "uu.jazy.core.Eval" nmEval = nmEvalN (-1) nmTag = "tag" -nmSet = "set" +nmIndSet = "set" nmEvalN n = "eval" ++ nmFunSuff n nmApplyN n = "apply" ++ nmFunSuff n nmRTS = mkHNm "uu.jazy.ehc.RTS" @@ -152,52 +124,30 @@ nmToTuple = "toTuple" %%] %%[(8 jazy) hs --- name of a variable -nmVar :: HsName -> HsName -> HsName -> HsName -nmVar pkg mod v +hsnJazyVar :: HsName -> HsName -> HsName -> HsName %%[[8 - = safeNm v +hsnJazyVar = hsnJavaLikeVar (id, id, id) %%][20 - = hsnPrefix "_" $ safeNm $ handleUpper $ hsnQualified v - where handleUpper v - = case hsnBaseUnpack v of - Just (s@(c:vs), mk) | isUpper c -> mk (s ++ "_") - _ -> v -%%]] - --- name of the class of a variable -nmVarCls :: HsName -> HsName -> HsName -> J.ClassRef -nmVarCls pkg mod v -%%[[8 - = hsnSuffix mod ("-" ++ show v) -%%][20 - = hsnSetQual pkg v -%%]] - --- field name of var name -nmVarToFld :: HsName -> HsName -nmVarToFld v -%%[[8 - = v -%%][20 - = {- (\x -> tr "ToJazy.nmVarToFld" (v >#< x) x) $ -} hsnQualified v +hsnJazyVar = hsnJavaLikeVar (hsnQualified, hsnPrefix "_", id) %%]] +%%] +%%[(8888 jazy) hs -- name of class of data type -nmDataTy :: HsName -> HsName -> HsName -> J.ClassRef -nmDataTy pkg mod d = safeNm d `hsnSuffix` "_Ty" +hsnJavaLikeDataTy :: HsName -> HsName -> HsName -> J.ClassRef +hsnJavaLikeDataTy pkg mod d = hsnSafeJavaLike d `hsnSuffix` "_Ty" -- name of class of data constructor -nmDataCon :: HsName -> HsName -> HsName -> J.ClassRef -nmDataCon pkg mod d = safeNm d `hsnSuffix` "_Con" +hsnJavaLikeDataCon :: HsName -> HsName -> HsName -> J.ClassRef +hsnJavaLikeDataCon pkg mod d = hsnSafeJavaLike d `hsnSuffix` "_Con" -- name of field of data -nmDataFldAt :: Int -> String -nmDataFldAt i = show i +hsnJavaLikeDataFldAt :: Int -> String +hsnJavaLikeDataFldAt i = show i -- all names of fields of data -nmDataFlds :: Int -> [String] -nmDataFlds arity = map nmDataFldAt [0..arity-1] +hsnJavaLikeDataFlds :: Int -> [String] +hsnJavaLikeDataFlds arity = map hsnJavaLikeDataFldAt [0..arity-1] %%] %%[(8 jazy) hs @@ -208,21 +158,20 @@ nmSetOrEvlN 0 = "evalSet" nmSetOrEvlN n = nmEvalN n %%] -%%[(8 jazy) hs --- ensure a name valid for JVM -safeNm :: HsName -> HsName -safeNm - = hsnMapQualified (concatMap safe) . hsnFixUniqifiers - where safe '.' = "_dot" - safe ':' = "_colon" - safe '/' = "_fslash" - -- safe '<' = "_lt" - -- safe '>' = "_gt" - safe '\\' = "_bslash" - safe '[' = "_lbrack" - safe ']' = "_rbrack" - safe '@' = "_at" - safe c = [c] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Safe name +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jazy) +SEM CBindAspect + | * loc . varnm = hsnJazyVar @lhs.pkgNm @lhs.topClassNm @lhs.nm + loc . varnm : HsName + +SEM CExpr + | Var loc . varnm = hsnJazyVar @lhs.pkgNm @lhs.topClassNm @nm + +SEM CPatFld + | Fld loc . varnm = hsnJazyVar @lhs.pkgNm @lhs.topClassNm @fldNm %%] %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -268,45 +217,6 @@ methArgOffsets :: Int -> [Int] methArgOffsets arity = [methArgOffset0 .. arity - methArgOffset0 + 1] %%] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%% Safe name -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -%%[(8 jazy) -SEM CBindAspect - | * loc . varnm = nmVar @lhs.pkgNm @lhs.topClassNm @lhs.nm - loc . varnm : HsName - -SEM CExpr - | Var loc . varnm = nmVar @lhs.pkgNm @lhs.topClassNm @nm - -SEM CPatFld - | Fld loc . varnm = nmVar @lhs.pkgNm @lhs.topClassNm @fldNm -%%] - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%% Level, Let's also one level higher -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -%%[(8 jazy) -SEM CExpr - | Let binds . lev = @lhs.lev + 1 - -%%] - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%% Special treatment of main. Admittedly a hack -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -%%[(8 jazy) -SEM CBindAspect -%%[[8 - | Bind loc . isThrowOutMain = False -%%][20 - | Bind loc . isThrowOutMain = @lhs.isGlobal && @lhs.nm == hsnMain -%%]] -%%] - %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Labels %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -335,155 +245,44 @@ SEM CAlt %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%[(8 jazy) hs -data CVarInfo - = CVarInfo_This -- this object - { cvarType :: J.Type - } - | CVarInfo_Local -- a local on the stack - { cvarType :: J.Type - , cvarOffset :: J.Local - } - | CVarInfo_DataFld -- a field of a datatype alternative - { cvarType :: J.Type - , cvarData :: CVarInfo - , cvarClassLocNm :: J.ClassRef - , cvarFldNm :: String - } - | CVarInfo_TupFld -- a field of a tuple - { cvarType :: J.Type - , cvarTuple :: CVarInfo - , cvarInx :: Either J.Local HsName - } - | CVarInfo_Global -- a global - { cvarType :: J.Type - , cvarClassLocNm :: J.ClassRef - , cvarFldNm :: String - } - | CVarInfo_None - -type CVarMp = Map.Map HsName CVarInfo +type CVarInfo = CVarInfo' J.Type J.Local J.Local +type CVarMp = CVarMp' J.Type J.Local J.Local %%] %%[(8 jazy) hs -cvarGlob :: J.Type -> J.ClassRef -> HsName -> HsName -> CVarInfo -cvarGlob ty clNm nm safeVarNm - = CVarInfo_Global ty clNm' (show safeVarNm) -%%[[8 - where clNm' = clNm -%%][20 - where clNm' = maybe clNm (\m -> hsnSetQual m $ hsnQualified m) $ hsnQualifier nm -%%]] +tyDefault = jtyObj %%] %%[(8 jazy) hs jvRef :: CVarMp -> CVarInfo -> J.JInstr -jvRef cvarMp vi - = case vi of - CVarInfo_This t - -> j $ J.Instr_Load t 0 - CVarInfo_Local t o - -> j $ J.Instr_Load t o - CVarInfo_DataFld t cvid cl f - -> jvRef cvarMp cvid ## J.Instr_Get False (J.Const_Field cl f t) - CVarInfo_TupFld t cvit f - -> jvRef cvarMp cvit ## o ## J.Instr_ALoad jtyObj - where o = case f of - Left o -> jiIntConst o - Right n -> jvRef cvarMp $ panicJust "ToJazy.jvRef" $ Map.lookup n cvarMp - CVarInfo_Global t cl f - -> j $ J.Instr_Get True (J.Const_Field cl f t) - CVarInfo_None - -> panic "Core.ToJazy.jvRef.CVarInfo_None" -%%] - -%%[(8 jazy) -ATTR AllBind [ | | bindNmL USE {++} {[]} : {[HsName]} ] - -SEM CBind - | Bind loc . bindNmL = [@nm] +jvRef + = cvarToRef + ( \t -> j $ J.Instr_Load t 0 + , \t o -> j $ J.Instr_Load t o + , \t cl f -> j $ J.Instr_Get True (J.Const_Field cl f t) + , \t e cl f -> e ## J.Instr_Get False (J.Const_Field cl f t) + , \ e o -> e ## o ## J.Instr_ALoad jtyObj + , jiIntConst + ) %%] %%[(8 jazy) -ATTR AllPat [ | | patCVarMp USE {`Map.union`} {Map.empty} : CVarMp ] - -SEM CPatFld - | Fld loc . patCVarMp = Map.singleton @fldNm @cviField +SEM CExpr + | Let loc . nmToRefAssocL = zip @binds.bindNmL [@lhs.localOffset .. ] %%] %%[(8 jazy) -ATTR AllNT [ cvarMp: CVarMp | | ] - -SEM CodeAGItf - | AGItf loc . cvarMp = Map.empty - SEM CExpr | Lam loc . (jiArgTyL,clsInitArgL,lamBindings) = if @hasFunHere then jiArgsUnpack @nmArgL else ([],[],[]) - . cvarMp = Map.fromList @lamBindings `Map.union` @lhs.cvarMp - | Let loc . (nLocals,cvarMpNew) - = if @isGlobal - then (0,Map.empty) - else let nLocals = length @binds.bindNmL - in ( nLocals - , Map.fromList - [ (n,CVarInfo_Local jtyObj o) - | (o,n) <- zip [@lhs.localOffset .. ] @binds.bindNmL - ] - ) - . cvarMp = @cvarMpNew `Map.union` @lhs.cvarMp - -SEM CAlt - | Alt loc . cvarMpOffsets = Map.fromList [ (n,cvi) | (n,cvi,_) <- @pat.offsetBinds ] - expr . cvarMp = Map.unions [@cvarMpOffsets, @pat.patCVarMp, @lhs.cvarMp] -%%] - -%%[(8 jazy) -SEM CExpr - | Var loc . cvi = Map.findWithDefault (cvarGlob jtyObj @lhs.moduleClassNm @nm @varnm) @nm @lhs.cvarMp -%%]] -%%] - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%% Case: scrutinee type (i.e. tag) -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -%%[(8 jazy) hs -data Scrutinee - = Scrutinee_Tag CTag - | Scrutinee_Int Int - | Scrutinee_Var HsName - | Scrutinee_Other String -%%] - -%%[(8 jazy) -ATTR AllAlt CPat [ | | scrutinees USE {++} {[]} : {[Scrutinee]} ] - -SEM CPat - | Con lhs . scrutinees = [Scrutinee_Tag @tag] - | Var lhs . scrutinees = [Scrutinee_Var @pnm] - | Int lhs . scrutinees = [Scrutinee_Int @int] - | Char lhs . scrutinees = [Scrutinee_Other "char"] - | * - Con Var Int Char Ann - lhs . scrutinees = [Scrutinee_Other "other"] -%%] - -%%[(8 jazy) -ATTR AllPatFld [ ctag: CTag | | ] - -SEM CPat - | Con binds . ctag = @tag %%] %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Case: scrutinee %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%[(8 jazy) -ATTR AllAlt AllPat [ scrutineeCVarInfo: CVarInfo | | ] -%%] - %%[(8 jazy) SEM CExpr | Case loc . altsLocalOffset = @lhs.localOffset + 1 @@ -511,7 +310,7 @@ SEM CExpr , cvi ) where cvi = mkcvi (J.Type_Class tn') - tn' = nmDataTy @lhs.pkgNm @lhs.topClassNm tn + tn' = hsnJavaLikeDataTy @lhs.pkgNm @lhs.topClassNm tn mkcvi ty = CVarInfo_Local ty @lhs.localOffset (Scrutinee_Other x : _) -> panic ("Core.ToJazy.CExpr.Case.Scrutinee_Other: " ++ x ++ " : not yet implemented") @@ -529,7 +328,7 @@ SEM CAlt , cvi {cvarType = ty} , tag ) - where cn' = nmDataCon @lhs.pkgNm @lhs.topClassNm cn + where cn' = hsnJavaLikeDataCon @lhs.pkgNm @lhs.topClassNm cn ty = J.Type_Class cn' cvi = @lhs.scrutineeCVarInfo (Scrutinee_Int i : _) @@ -583,16 +382,16 @@ SEM CPatFld -> case @offset.whatBelow of ExprIsInt i -> (mkf $ Left i,@lhs.offsetOffset,[]) ExprIsVar n -> (mkf $ Right n,@lhs.offsetOffset,[]) - _ -> (mkf $ Right n,o+1,[(n,CVarInfo_Local t o,mkji @offset.ji)]) + _ -> (mkf $ Right n,o+1,[(n,CVarInfo_Local t o,mkj @offset.ji)]) where n = @varnm o = @lhs.offsetOffset - (mkji,t) = basicTyJUnbox True BasicJazy_Int - where mkf o = CVarInfo_TupFld jtyObj @lhs.scrutineeCVarInfo o + (mkj,t) = basicTyJUnbox True BasicJazy_Int + where mkf o = CVarInfo_TupFld tyDefault @lhs.scrutineeCVarInfo o CTag _ cn _ _ _ -> case @offset.whatBelow of - ExprIsInt i -> (CVarInfo_DataFld jtyObj @lhs.scrutineeCVarInfo cn' (nmDataFldAt i),@lhs.offsetOffset,[]) + ExprIsInt i -> (CVarInfo_DataFld tyDefault @lhs.scrutineeCVarInfo cn' (hsnJavaLikeDataFldAt i),@lhs.offsetOffset,[]) _ -> panic "Core.ToJazy.CPatFld.Fld.cviField" - where cn' = nmDataCon @lhs.pkgNm @lhs.topClassNm cn + where cn' = hsnJavaLikeDataCon @lhs.pkgNm @lhs.topClassNm cn %%] %%[(8 jazy) @@ -600,41 +399,6 @@ SEM CAlt | Alt loc . offsetsJI = j [ ji ## J.Instr_Store t o | (_,CVarInfo_Local t o,ji) <- @pat.offsetBinds ] %%] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%% Various contextual info -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -%%[(8 jazy) -ATTR AllExprOnly [ mbLamNm: {Maybe HsName} | | ] - -SEM CExpr - | App Lam loc . mbLamNm = Nothing - -SEM CAlt - | Alt loc . mbLamNm = Nothing - -SEM CBindAspect - | Bind Val expr . mbLamNm = Just @varnm - -SEM CPatFld - | Fld offset . mbLamNm = Nothing - -SEM CModule - | Mod expr . mbLamNm = Nothing -%%] - -%%[(8 jazy) -SEM CExpr - | Lam loc . (hasFunHere,lamNm) - = if @lhs.whatAbove /= ExprIsLam - then (True,fromJust @lhs.mbLamNm) - else (False,hsnUnknown) - | App loc . isTopApp = isNothing $ whatExprMbApp @lhs.whatAbove - -SEM CBindAspect - | Bind Val loc . isCAF = @expr.whatBelow /= ExprIsLam -%%] - %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Type of an expression %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -651,7 +415,7 @@ SEM CExpr | Lam lhs . jty = jtyFun | App lhs . jty = jtyApp | * - Int Char String Lam App Ann CaseAltFail - loc . jty = jtyObj + loc . jty = tyDefault %%] %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -671,14 +435,11 @@ SEM CExpr %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%[(8 jazy) -ATTR CExpr [ | | nmArgL: {[HsName]} jiBody: {J.JInstr} ] +ATTR CExpr [ | | jiBody: {J.JInstr} ] SEM CExpr - | Lam loc . nmArgL = @arg : @body.nmArgL - . jiBody = @body.jiBody - loc . nmArgL : {[HsName]} - | * - Lam Ann lhs . nmArgL = [] - . jiBody = @ji + | Lam loc . jiBody = @body.jiBody + | * - Lam Ann lhs . jiBody = @ji %%] %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -738,13 +499,13 @@ jiApp f as jiSetInd :: J.JInstr -> J.JInstr -> J.JInstr jiSetInd ind val = ind ## val - ## J.Instr_Invoke J.InvokeMode_Virtual (J.Const_Method nmInd nmSet [jtyObj] Nothing) + ## J.Instr_Invoke J.InvokeMode_Virtual (J.Const_Method nmInd nmIndSet [jtyObj] Nothing) -- either new data constructor or tuple jiNewTupOrData :: J.ClassRef -> J.ClassRef -> CTag -> [J.JInstr] -> J.JInstr jiNewTupOrData pkg mod ctag as = case ctag of - CTag _ cn _ _ _ -> jiNew (nmDataCon pkg mod cn) [ (a,jtyObj) | a <- as ] + CTag _ cn _ _ _ -> jiNew (hsnJavaLikeDataCon pkg mod cn) [ (a,jtyObj) | a <- as ] CTagRec -> jiNewTup as -- force evaluation @@ -769,16 +530,17 @@ SEM CExpr | String loc . ji = jiNew nmStr [(j $ J.Instr_Const $ J.Const_String @str , jtyStr )] | Var loc . ji = jvRef @lhs.cvarMp @cvi | Tup loc . ji = jiNewTupOrData @lhs.pkgNm @lhs.topClassNm @tag [] - | App loc . ji = if @isTopApp + | App loc . ji = if @isTopApp' then let (f:as) = reverse @jiArgFunL in case @func.appFunKind of AppFunKind_Tag tag -> jiNewTupOrData @lhs.pkgNm @lhs.topClassNm tag as - AppFunKind_FFI -> @func.resPackWrap $ as ## f + AppFunKind_FFI -> @func.resPackWrap $ @func.mkFFI f as _ -> jiApp f as else emptyJI - | FFI loc . (mkArgsJI,mkResJI,primJI) - = ffiJazyMkCall @lhs.opts False @impEntNm @argMbConL @resMbCon - . ji = if null @argMbConL then @mkResJI @primJI else @primJI + | FFI loc . (mkArgsJI,mkResJI,mkFFI) + = ffiJazyMkCall @lhs.opts False @impEntNm @argMbConL @resMbCon + . ji = let ffi = @mkFFI (panic "ToJazy.CExpr.FFI.mkFFI") [] + in if null @argMbConL then @mkResJI ffi else ffi | Let loc . (jbindsLet,ji) = if @isGlobal then ( @binds.jbinds, @body.ji ) else let binds = [ ((offof n),t,e) | JBind n _ t e _ <- Seq.toList @binds.jbinds ] @@ -839,6 +601,15 @@ SEM CExpr lhs . resPackWrap = id %%] +%%[(8 jazy) +ATTR CExpr [ | | mkFFI : {J.JInstr -> [J.JInstr] -> J.JInstr} ] + +SEM CExpr + | App lhs . mkFFI = @func.mkFFI + | * - FFI App Ann + lhs . mkFFI = \f _ -> f +%%] + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Dealing with >5 args %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -846,24 +617,13 @@ SEM CExpr %%[(8 jazy) hs -- pack > 5 args into tuple, otherwise normal jiArgsPack :: [J.JInstr] -> (String,J.Type,[J.JInstr]) -jiArgsPack args - | nArgs > 5 = (nm,jtyTup,[jiNewTup args]) - | otherwise = (nm,jtyObj,args) - where nArgs = length args - nm = nmApplyN nArgs +jiArgsPack = javalikeArgsPack 5 (jtyTup,jtyObj,jiNewTup,nmApplyN) %%] %%[(8 jazy) hs -- unpack > 5 args from tuple, otherwise normal -jiArgsUnpack :: [HsName] -> ([J.Type],[(J.JInstr,J.Type)],[(HsName,CVarInfo)]) -jiArgsUnpack args - | nArgs > 5 = ([jtyTup] , [(jiIntConst nArgs,J.Type_Int)], mkMp [ CVarInfo_TupFld jtyObj tup (Left o) | o <- [0..] ]) - | otherwise = (replicate nArgs jtyObj, [] , mkMp [ CVarInfo_Local jtyObj o | o <- offs ]) - where nArgs = length args - offs@(off0:_) - = methArgOffsets nArgs - tup = CVarInfo_Local jtyTup off0 - mkMp = zip args +jiArgsUnpack :: [HsName] -> ([(J.Local,J.Type)],[(J.JInstr,J.Type)],[(HsName,CVarInfo)]) +jiArgsUnpack = javalikeArgsUnpack 5 (jtyTup,jtyObj,J.Type_Int,\a -> methArgOffsets (length a), jiIntConst,\n _ -> methArgOffsets n, methArgOffsets) %%] %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -871,31 +631,13 @@ jiArgsUnpack args %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%[(8 jazy) hs -data JBind - = JBind - { jbindOrigNm :: HsName - , jbindNm :: HsName - , jbindTy :: J.Type - , jbindJI :: J.JInstr - , jbindFld :: J.Field - } -type JBinds = Seq.Seq JBind +type JBind = JBind' J.Type J.JInstr J.Field +type JBinds = JBinds' J.Type J.JInstr J.Field %%] %%[(8 jazy) hs jBind :: HsName -> HsName -> J.JInstr -> JBinds -jBind nmOrig nm ji - = Seq.singleton - $ JBind nmOrig - nm' - jtyObj {- @expr.jty -} - ji - (J.Field_Field [J.Flag_Public,J.Flag_Static] (show nm') jtyObj {- @expr.jty -} Nothing) - where nm' = nmVarToFld nm -%%] - -%%[(8 jazy) -ATTR AllBind CExpr [ | | jbinds USE {`Seq.union`} {Seq.empty}: JBinds] +jBind = jBind' (tyDefault, hsnJavaLikeVarToFld, \nm -> J.Field_Field [J.Flag_Public,J.Flag_Static] (show nm) tyDefault {- @expr.jty -} Nothing) %%] %%[(8 jazy) @@ -907,9 +649,6 @@ SEM CBindAspect SEM CBindAspect | Bind lhs . jbinds = if @isThrowOutMain then Seq.empty else jBind @lhs.nm @varnm @ji -- | FFI lhs . jbinds = jBind @lhs.nm @varnm @ji - -SEM CExpr - | Let lhs . jbinds = @jbindsLet `Seq.union` @body.jbinds %%] %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -1014,16 +753,16 @@ jmEvalSet ji SEM CModule | Mod loc . methClinit = J.Method_Method [J.Flag_Static] "" [] Nothing (jiToCd - $ [ e ## J.Instr_Put True (J.Const_Field @moduleClassNm (show $ nmVarToFld n) t) + $ [ e ## J.Instr_Put True (J.Const_Field @moduleClassNm (show $ hsnJavaLikeVarToFld n) t) | JBind _ n t e _ <- Seq.toList @expr.jbinds ] ## J.Instr_Return Nothing ) . methInit = jmInit0Inst @moduleNm nmObj . methMainNm = if ehcOptGenTrace @lhs.opts then "runVisuallyTraced" else "runTimed" - . methMain = let d f = jiNew (nmDataCon @pkgNm @topClassNm $ ehcOptBuiltin @lhs.opts f) [] + . methMain = let d f = jiNew (hsnJavaLikeDataCon @pkgNm @topClassNm $ ehcOptBuiltin @lhs.opts f) [] %%[[99 - v f = jvRef @lhs.cvarMp (cvarGlob jtyObj @moduleClassNm n (nmVar @pkgNm @topClassNm n)) + v f = jvRef @lhs.cvarMp (cvarGlob tyDefault @moduleClassNm n (hsnJazyVar @pkgNm @topClassNm n)) where n = ehcOptBuiltin @lhs.opts f %%]] in J.Method_Method [J.Flag_Public,J.Flag_Static] "main" [J.Type_Array jtyStr] Nothing @@ -1084,8 +823,8 @@ ATTR AllNT [ | | globClasses USE {`Seq.union`} {Seq.empty} : JClasses ] SEM CExpr | Lam loc . (subClasses,ji) = if @hasFunHere then let funNmJiL= [(jiStrConst (show @lamNm),jtyStr)] - classNm = nmVarCls @lhs.pkgNm @lhs.topClassNm @lamNm - in jFunCls classNm (length @nmArgL) @jiArgTyL (@clsInitArgL ++ funNmJiL) @body.jiBody @body.jbinds @body.subClasses + classNm = hsnJavaLikeVarCls @lhs.pkgNm @lhs.topClassNm @lamNm + in jFunCls classNm (length @nmArgL) (map snd @jiArgTyL) (@clsInitArgL ++ funNmJiL) @body.jiBody @body.jbinds @body.subClasses else (@body.subClasses, emptyJI) %%] @@ -1097,7 +836,7 @@ SEM CModule , conL ) | (dn,cs) <- @ctagsMp - , let dn' = nmDataTy @pkgNm @topClassNm dn + , let dn' = hsnJavaLikeDataTy @pkgNm @topClassNm dn conL = [ jCls [J.Flag_Public] cn' dn' [ J.Field_Field [J.Flag_Public] f jtyObj Nothing | f <- fldL ] [ jmInitInstWith [] (jiPut cn' False (jiIntConst (ctagTag ctag)) nmTag J.Type_Int) cn' dn' fldL @@ -1111,9 +850,9 @@ SEM CModule ] [] | (cn,ctag) <- cs - , let cn' = nmDataCon @pkgNm @topClassNm cn + , let cn' = hsnJavaLikeDataCon @pkgNm @topClassNm cn cn'ty = J.Type_Class cn' - fldL = nmDataFlds (ctagArity ctag) + fldL = hsnJavaLikeDataFlds (ctagArity ctag) ] ] . otherClasses = Seq.unions [ Seq.fromList @dataTypeClsL @@ -1149,51 +888,15 @@ ffiJazyMkCall -> Maybe HsName -- and result -> ( [J.JInstr -> J.JInstr] -- additional unwrapping for each argument , J.JInstr -> J.JInstr -- and result - , J.JInstr -- and primitive call itself + , J.JInstr -> [J.JInstr] -> J.JInstr -- and primitive call itself ) ffiJazyMkCall - opts doArgEval - impEntNm argMbConL resMbCon - = (mkArgsJI,mkResJI,primJI) - where lkupBuiltin = \n -> Map.lookup n m - where m = builtinKnownBoxedTyMp opts - mkxxbox how mbCon - = case mbCon of - Just c -> case lkupBuiltin c of - Just bi -> how (biJazyBasicTy bi) - _ -> dflt - _ -> dflt - where dflt = (jiEvl,jtyObj) - mkunbox = mkxxbox (basicTyJUnbox doArgEval) - mkbox = mkxxbox basicTyJBox - (mkArgsJI,argsTy) - = unzip $ map mkunbox argMbConL - (mkResJI,resTy) - = mkbox resMbCon - primJI = j $ J.Instr_Invoke J.InvokeMode_Static (J.Const_Method nmPrim impEntNm argsTy (Just resTy)) -%%] - -%%[(8 jazy) hs -ffiJazyMk - :: EHCOpts - -> HsName -- class name - -> HsName -- my name - -> String -- name of ffi entity - -> [Maybe HsName] -- list of (possibly) type constructor names of arguments - -> Maybe HsName -- and result - -> (JClasses,J.JInstr) -ffiJazyMk - opts - classNm nm impEntNm argMbConL resMbCon - = jFunCls classNm nArgs argTyL (clsInitArgL ++ funNmJiL) (mkResJI $ argsJI ## primJI) Seq.empty Seq.empty - where (mkArgsJI,mkResJI,primJI) = ffiJazyMkCall opts True impEntNm argMbConL resMbCon - nArgs = length argMbConL - argNmL = map mkHNm $ nmDataFlds nArgs - (argTyL,clsInitArgL,bindings) - = jiArgsUnpack argNmL - cvarMp = Map.fromList bindings - argsJI = zipWith (\mkji (_,cvi) -> mkji $ jvRef cvarMp cvi) mkArgsJI bindings - funNmJiL= [(jiStrConst (show nm),jtyStr)] + = javalikeMkFFICall + ( biJazyBasicTy,basicTyJUnbox,basicTyJBox + , \argsTy resTy impEntNm _ as + -> as ## J.Instr_Invoke J.InvokeMode_Static (J.Const_Method nmPrim impEntNm argsTy (Just resTy)) + , jiEvl, tyDefault + ) %%] %%[(8 jazy) @@ -1201,12 +904,12 @@ SEM CBindAspect | Bind loc . (subClasses,ji) = let dflt = (@expr.subClasses, @jiExpr) in if @lhs.isGlobal then if @isCAF - then jFunCls (nmVarCls @lhs.pkgNm @lhs.topClassNm @varnm) 0 [] [] @jiExpr @expr.jbinds @expr.subClasses + then jFunCls (hsnJavaLikeVarCls @lhs.pkgNm @lhs.topClassNm @varnm) 0 [] [] @jiExpr @expr.jbinds @expr.subClasses else dflt else dflt lhs . subClasses = if @isThrowOutMain then Seq.empty else @subClasses %%] - | FFI loc . classNm = nmVarCls @lhs.pkgNm @lhs.topClassNm (mkHNmBase @impEntNm) + | FFI loc . classNm = hsnJavaLikeVarCls @lhs.pkgNm @lhs.topClassNm (mkHNmBase @impEntNm) . (globClasses,ji)= ffiJazyMk @lhs.opts @classNm @lhs.nm {- or: @varnm -} @impEntNm @argMbConL @resMbCon %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -1222,6 +925,19 @@ SEM CModule | Mod lhs . jazy = Seq.toList @globClasses %%] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Special treatment of main. Admittedly a hack +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jazy) +SEM CBindAspect +%%[[8 + | Bind loc . isThrowOutMain = False +%%][20 + | Bind loc . isThrowOutMain = @lhs.isGlobal && @lhs.nm == hsnMain +%%]] +%%] + diff --git a/EHC/src/ehc/Core/Trf.chs b/EHC/src/ehc/Core/Trf.chs index 1c5aca838..e7f55b086 100644 --- a/EHC/src/ehc/Core/Trf.chs +++ b/EHC/src/ehc/Core/Trf.chs @@ -11,6 +11,9 @@ %%[(8 codegen) import(Control.Monad, Control.Monad.State) %%] +%%[(8 codegen) import({%{EH}Base.Target}) +%%] + %%[(8 codegen) import({%{EH}EHC.Common}) %%] @@ -106,7 +109,7 @@ trfCore opts dataGam modNm trfcore ; t_eta_red -- make names unique - ; t_ren_uniq + ; t_ren_uniq emptyRenUniqOpts -- from now on INVARIANT: keep all names globally unique -- ASSUME : no need to shadow identifiers @@ -140,7 +143,7 @@ trfCore opts dataGam modNm trfcore ; t_anormal u1 %%[[9 - ; when (ehcOptFullProgAnalysis opts) + ; when (targetDoesHPTAnalysis (ehcOptTarget opts)) t_fix_dictfld %%]] @@ -155,10 +158,12 @@ trfCore opts dataGam modNm trfcore -- float lam/CAF to global level ; t_float_glob - ; when (ehcOptFullProgAnalysis opts) + ; when (targetDoesHPTAnalysis (ehcOptTarget opts)) t_find_null ; when (ehcOptOptimizes Optimize_StrictnessAnalysis opts) t_ana_relev + ; when (targetIsJScript (ehcOptTarget opts)) + (t_ren_uniq (emptyRenUniqOpts {renuniqOptResetOnlyInLam = True})) } liftTrf :: String -> (CModule -> CModule) -> State TrfCore () @@ -187,7 +192,7 @@ trfCore opts dataGam modNm trfcore t_initial = liftTrf "initial" $ id t_eta_red = liftTrf "eta-red" $ cmodTrfEtaRed t_ann_simpl = liftTrf "ann-simpl" $ cmodTrfAnnBasedSimplify opts - t_ren_uniq = liftTrf "ren-uniq" $ cmodTrfRenUniq + t_ren_uniq o = liftTrf "ren-uniq" $ cmodTrfRenUniq o t_let_unrec = liftTrf "let-unrec" $ cmodTrfLetUnrec t_inl_letali = liftTrf "inl-letali" $ inlineLetAlias t_elim_trivapp = liftTrf "elim-trivapp" $ cmodTrfElimTrivApp opts diff --git a/EHC/src/ehc/Core/Trf/AnaRelevance.cag b/EHC/src/ehc/Core/Trf/AnaRelevance.cag index 6312d3878..8dfb3390a 100644 --- a/EHC/src/ehc/Core/Trf/AnaRelevance.cag +++ b/EHC/src/ehc/Core/Trf/AnaRelevance.cag @@ -70,6 +70,26 @@ cmodTrfAnaRelevance opts dataGam cmod ATTR AllCodeNT CodeAGItf [ opts: EHCOpts | | ] %%] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Configuration, only for debugging purposes to temporarily switch on/off specfic parts +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 codegen) hs +data WhatToRelevInfer + = WhatToRelevInfer_InstToBot -- specialize/instantiate types to bot (strict) + | WhatToRelevInfer_Quant -- quantify + deriving Eq +%%] + +%%[(8 codegen) +ATTR AllCodeNT [ whatTo: {[WhatToRelevInfer]} | | ] + +SEM CodeAGItf + | AGItf loc . whatTo = [ WhatToRelevInfer_Quant + , WhatToRelevInfer_InstToBot + ] +%%] + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% DataGam required tags (strictness info), FFI %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -140,16 +160,31 @@ SEM CExpr SEM CAlt | Alt loc . mbCTagEnv = do { ct <- @pat.mbCTag ; (argTyL,_) <- relevTyArgsFromCTag True ct Nothing (length @pat.nmL) @lhs.dataGam @lUniq - ; return $ gamFromAssocL $ zip @pat.nmL argTyL + ; return (gamFromAssocL $ zip @pat.nmL argTyL, argTyL) } - loc . patEnv = maybe (gamFromAssocL $ zipWith (\n u -> (n,fresh u)) @pat.nmL $ mkNewLevUIDL (length @pat.nmL) @lUniq2) - id @mbCTagEnv + loc . patFldGivenTyL = maybe (map freshLazy $ mkNewLevUIDL (length @pat.nmL) @lUniq3) + snd @mbCTagEnv + . patFldUsedTyL = map fresh $ mkNewLevUIDL (length @pat.nmL) @lUniq2 + . patEnv = gamFromAssocL $ zip @pat.nmL @patFldUsedTyL + -- maybe (gamFromAssocL $ zip @pat.nmL @patFldUsedTyL) + -- id @mbCTagEnv + pat . patFldTyL = zip @patFldGivenTyL @patFldUsedTyL expr . env = gamAddGam @patEnv @lhs.env loc . lUniq : UNIQUEREF gUniq loc . lUniq2 : UNIQUEREF gUniq + loc . lUniq3 : UNIQUEREF gUniq + loc . patFldUsedTyL : {[RelevTy]} +%%] + +%%[(8 codegen) +ATTR CPat CPatFldL CPatFld [ | patFldTyL: {[(RelevTy,RelevTy)]} | ] + +SEM CPatFld + | Fld (loc.patFldTy,lhs.patFldTyL) = hdAndTl @lhs.patFldTyL + loc . fldCoe = let (tgiven,tused) = @patFldTy + in RelevCoe_CastTy tgiven tused + %%] -SEM CAlt - | Alt expr . env = gamAddGam @pat.gathEnv @lhs.env %%[(8 codegen) ATTR AllBind -- AllPatFld AllPat @@ -350,7 +385,6 @@ SEM CExpr | Lam loc . hereBodyCoe = case @body.whatBelow of ExprIsLam -> RelevCoe_Id _ -> @body.coe - -- | Let loc . hereBodyCoe = @body.coe SEM CBindAspect | Bind loc . hereBindCoe = @expr.coe <.> maybe RelevCoe_Id (@finalRVarMp |=>) @mbBindCoe @@ -359,7 +393,8 @@ SEM CAltL | Cons loc . hereAltCoe = @hd.coe <.> (@hdFinalRVarMp |=> amsoCoe @amsoDw) SEM CPatFld - | Fld loc . hereOffCoe = @offset.coe + | Fld loc . hereOffCoe = @lhs.finalRVarMp |=> @offset.coe + . hereFldCoe = @lhs.finalRVarMp |=> @fldCoe %%] %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -421,6 +456,7 @@ SEM CExpr | Var Int Char Tup FFI lhs . rvarMp = amsLocalVarMp @ams `varmpPlus` @lhs.rvarMp | Case lhs . rvarMp = @alts.rvarMp -- skip @dflt + | Let body . rvarMp = @binds.extraBindRVarMp `varmpPlus` @binds.rvarMp %%] %%[(8 codegen) @@ -428,6 +464,13 @@ SEM CAltL | Cons hd . rvarMp = @rvarMpUp %%] +%%[(8 codegen) +ATTR AllBind [ forQuantRVarMp: RVarMp | | ] + +SEM CExpr + | Let binds . forQuantRVarMp = @binds.rvarMp +%%] + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Final VarMp distribution %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -439,21 +482,29 @@ SEM CodeAGItf | AGItf module . finalRVarMp = @module.rvarMp SEM CBindAspect - | Bind loc . finalRVarMp = @extraBindRVarMp `varmpPlus` @lhs.finalRVarMp + | Bind loc . finalRVarMp = {- @extraBindRVarMp `varmpPlus` -} @lhs.finalRVarMp -SEM CExpr - | Let body . finalRVarMp = @binds.extraBindRVarMp `varmpPlus` @lhs.finalRVarMp +-- SEM CExpr +-- | Let loc . finalRVarMp = @binds.extraBindRVarMp `varmpPlus` @lhs.finalRVarMp SEM CAltL - | Cons loc . hdFinalRVarMp = @altSolveVarMp `varmpPlus` @lhs.finalRVarMp + | Cons loc . hdFinalRVarMp = @altSolveVarMp -- `varmpPlus` @lhs.finalRVarMp hd . finalRVarMp = @hdFinalRVarMp %%] +%%[(8888 codegen) +ATTR AllBind [ forQuantRVarMp: RVarMp | | ] + +SEM CExpr + | Let binds . forQuantRVarMp = @lhs.finalRVarMp +%%] + %%[(8 codegen) ATTR AllBind [ | | extraBindRVarMp USE {`varmpPlus`} {emptyVarMp}: RVarMp ] SEM CBindAspect - | Bind loc . extraBindRVarMp = @strictVarMp + | Bind loc . extraBindRVarMp = if WhatToRelevInfer_InstToBot `elem` @lhs.whatTo then @strictVarMp else emptyVarMp + -- @strictVarMp %%] %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -580,25 +631,27 @@ SEM CBindAspect . (quantTy,quantVarMp,quantRemQualS) = case @ty of t@(RelevTy_Fun _ _ _ _) - -> relevtyQuant [RelevTyQuantHow_Solve,RelevTyQuantHow_RemoveAmbig] + -> relevtyQuant ([RelevTyQuantHow_Solve] ++ how) @rvarMpExpr @expr.qualS t + where how | WhatToRelevInfer_Quant `elem` @lhs.whatTo = [RelevTyQuantHow_RemoveAmbig,RelevTyQuantHow_Quant] + | otherwise = [] t -> (m |=> t, m, q) where (q,m) = assSolve @lhs.boundRelevTyVarS (Set.map (@rvarMpExpr |=>) @expr.qualS) - . bindTy = @lhs.finalRVarMp |=> @quantTy + . bindTy = @lhs.forQuantRVarMp |=> @quantTy . (strictTy,strictVarMp) = case @bindTy of t@(RelevTy_Fun _ qs a r@(RelevTy_Ana (AnaEval_Var rv))) -> (sty, smp2 `varmpPlus` smpAssume2 `varmpPlus` smp1 `varmpPlus` smpAssume1) where smpAssume1 = rvarmpEvalUnit rv bot (RelevTy_Fun vs' qs' a' r',smp1,rem1) - = relevtyQuant [RelevTyQuantHow_Solve,RelevTyQuantHow_RemoveAmbig] + = relevtyQuant [RelevTyQuantHow_Solve,RelevTyQuantHow_RemoveAmbig,RelevTyQuantHow_Quant] smpAssume1 (Set.fromList qs `Set.union` @quantRemQualS) (RelevTy_Fun [] [] a (smpAssume1 |=> r)) smpAssume2 = varmpUnions [ rvarmpEvalUnit v top | v <- vs' ] (sty,smp2,_) - = relevtyQuant [RelevTyQuantHow_Solve,RelevTyQuantHow_RemoveAmbig] + = relevtyQuant [RelevTyQuantHow_Solve,RelevTyQuantHow_RemoveAmbig,RelevTyQuantHow_Quant] smpAssume2 (Set.fromList qs' `Set.union` rem1) (RelevTy_Fun [] [] (smpAssume2 |=> a') r') t -> (m |=> t, m) - where (q,m) = assSolve Set.empty (Set.map (@lhs.finalRVarMp |=>) @quantRemQualS) + where (q,m) = assSolve Set.empty (Set.map (@lhs.forQuantRVarMp |=>) @quantRemQualS) . debugTy1 = case @rvarMpExpr |=> @ty of RelevTy_Fun _ _ a r -> RelevTy_Fun v q a r @@ -611,12 +664,18 @@ SEM CBindAspect where q = @lhs.finalRVarMp |=> Set.toList @expr.qualS t -> t . tyAspectL = [ CBindAspect_RelevTy acbaspkeyDefault @bindTy - , CBindAspect_RelevTy acbaspkeyStrict @strictTy + -- , CBindAspect_RelevTy acbaspkeyStrict @strictTy -- , CBindAspect_RelevTy acbaspkeyDebug @debugTy2 ] + ++ (if WhatToRelevInfer_InstToBot `elem` @lhs.whatTo + then [CBindAspect_RelevTy acbaspkeyStrict $ @lhs.finalRVarMp |=> @strictTy] + else [] + ) loc . ty : RelevTy + loc . strictTy : RelevTy loc . exprKnTy : RelevTy loc . quantVarMp : RVarMp + loc . strictVarMp : RVarMp loc . quantRemQualS : RelevQualS loc . exprEnv : REnv loc . mbBindCoe : {Maybe RelevCoe} @@ -690,7 +749,7 @@ SEM CAltL CAlt_Alt p e -> CAlt_Alt p (annCoe @hereAltCoe e) : @tl.cTrf SEM CPatFld - | Fld lhs . cTrf = CPatFld_Fld @lbl (annCoe @hereOffCoe @offset.cTrf) @fldNm + | Fld lhs . cTrf = CPatFld_Fld @lbl (annCoe @hereOffCoe @offset.cTrf) @fldNm [CBindAnn_Coe @hereFldCoe] %%] %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% diff --git a/EHC/src/ehc/Core/Trf/RenUniq.cag b/EHC/src/ehc/Core/Trf/RenUniq.cag index 655922153..23d14645b 100644 --- a/EHC/src/ehc/Core/Trf/RenUniq.cag +++ b/EHC/src/ehc/Core/Trf/RenUniq.cag @@ -10,6 +10,8 @@ %%[(8 codegen) hs module {%{EH}Core.Trf.RenUniq} import(Data.Maybe,Data.Char,Control.Monad(liftM),qualified Data.Map as Map) %%] +%%[(8 codegen) hs import(EH.Util.Utils) +%%] %%[(8 codegen) hs import({%{EH}Base.Common},{%{EH}Base.Builtin},{%{EH}Core},{%{EH}Ty}) %%] %%[(8 codegen) hs import({%{EH}AbstractCore}) @@ -27,14 +29,44 @@ PRAGMA strictcase %%% Haskell itf %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%[(8 codegen) hs export(RenUniqOpts(..),emptyRenUniqOpts) +data RenUniqOpts + = RenUniqOpts + { renuniqOptResetOnlyInLam :: Bool -- restart numbering in lambda only, throwing away all name modifiers previously added + } + +emptyRenUniqOpts :: RenUniqOpts +emptyRenUniqOpts = RenUniqOpts False +%%] + %%[(8 codegen) hs export(cmodTrfRenUniq) -cmodTrfRenUniq :: CModule -> CModule -cmodTrfRenUniq cmod +cmodTrfRenUniq :: RenUniqOpts -> CModule -> CModule +cmodTrfRenUniq ropts cmod = let t = wrap_CodeAGItf (sem_CodeAGItf (CodeAGItf_AGItf cmod)) - (Inh_CodeAGItf {gUniq_Inh_CodeAGItf = uidStart}) + (Inh_CodeAGItf { gUniq_Inh_CodeAGItf = uidStart + , ropts_Inh_CodeAGItf = ropts + }) in cTrf_Syn_CodeAGItf t %%] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Global info +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 codegen) +ATTR AllCodeNT CodeAGItf [ ropts: RenUniqOpts | | ] +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Dependencies for AG visits +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(99 codegen) +SEM CModule + | Mod expr.gUniq < expr.protectedBindingNames + expr.gUniq < expr.aRenMp +%%] + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Unique %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -76,48 +108,140 @@ ATTR CodeAGItf [ | | cTrf: CModule ] %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%[(8 codegen) hs -type ARenMp = Map.Map HsName HsName +type NmMp = Map.Map HsName HsName +type ARenMp + = ( NmMp -- forward map, from old -> new + , NmMp -- backward map, from new -> old + ) + +emptyARenMp :: ARenMp +emptyARenMp = (Map.empty, Map.empty) %%] %%[(8 codegen) hs -- breaks assumption that globals are qualified, locals not. Problem in future when records are used for globals and access differs. -mkUniq :: HsName -> HsName -> UID -> HsName -mkUniq q n u - = +mkUniqGlob :: NmMp -> HsName -> HsName -> Maybe UID -> (HsName,NmMp) +mkUniqGlob mb q n mbU + = ( %%[[20 - (if hsnIsQual n - then id - else hsnSetQual q - ) $ + (if hsnIsQual n + then id + else hsnSetQual q + ) $ %%]] - hsnUniqifyUID HsNameUniqifier_GloballyUnique u n + maybe n (\u -> hsnUniqifyUID HsNameUniqifier_GloballyUnique u n) mbU + , mb + ) +%%] + +%%[(8 codegen) hs +-- breaks assumption that globals are qualified, locals not. Problem in future when records are used for globals and access differs. +mkUniqLoc :: NmMp -> HsName -> HsName -> Maybe UID -> (HsName,NmMp) +mkUniqLoc mb q n mbU + = ( n3 + , Map.insert n3 n mb + ) + where n2 = hsnStripUniqifiers $ hsnQualified n + n3 | Map.member n2 mb = hsnUniqifyUID HsNameUniqifier_Blank (panicJust "RenUniq.mkUniqLoc" mbU) n2 + | otherwise = n2 %%] %%[(8 codegen) hs %%[[8 -aRenAdd :: Bool -> [HsName] -> UID -> ARenMp -> ARenMp -aRenAdd isGlob nL u m +aRenAdd :: RenUniqOpts -> Bool -> [HsName] -> UID -> ARenMp -> ARenMp +aRenAdd ropts isGlob nL u mfb@(mf,mb) %%][20 -aRenAdd :: Bool -> HsName -> [HsName] -> UID -> ARenMp -> ARenMp -aRenAdd isGlob q nL u m +aRenAdd :: RenUniqOpts -> Bool -> HsName -> [HsName] -> UID -> ARenMp -> ARenMp +aRenAdd ropts isGlob q nL u mfb@(mf,mb) %%]] - = Map.fromList [ (n,mkNm n u) | (n,u) <- zip nL uL ] `Map.union` m + -- = (Map.fromList [ (n,mkNm n u) | (n,u) <- zip nL uL ] `Map.union` mf, mb) + = foldr (\(n,u) (mf,mb) -> let (n',mb') = mkNm mb n u in (Map.insert n n' mf,mb')) mfb $ zip nL uL where uL = mkNewUIDL (length nL) u - doChngNm n = not isGlob || n `Map.member` m - mkNm n u = if doChngNm n + mkNm mb n u %%[[8 - then mkUniq hsnUnknown n u + | doChng = mkUniq mb hsnUnknown n (Just u) %%][20 - then mkUniq q n u + | doChng && isUnqualifiedGlob + = mkUniq mb q n Nothing + | doChng = mkUniq mb q n (Just u) +%%]] + | otherwise = (n,mb) + where doChng + = isChangeable +%%[[20 + || isUnqualifiedGlob + isUnqualifiedGlob = isGlob && not onlyLam && isNothing (hsnQualifier n) && n /= hsnMain %%]] - else n + isChangeable = not isGlob || n `Map.member` mf + onlyLam = renuniqOptResetOnlyInLam ropts + mkUniq | onlyLam = mkUniqLoc + | otherwise = mkUniqGlob %%] %%[(8 codegen) hs aRenRepl :: ARenMp -> HsName -> HsName -aRenRepl m n = maybe n id . Map.lookup n $ m +aRenRepl (mf,_) n = maybe n id . Map.lookup n $ mf %%] +%%[(8 codegen) +ATTR CExpr [ | accumARenMp: ARenMp | ] + +SEM CExpr + | Let loc . isGlobal = @lhs.lev == cLevModule + . addToARenMp = \m -> aRenAdd @lhs.ropts @isGlobal +%%[[20 + @lhs.moduleNm +%%]] + @binds.nmL @lUniq m + body . accumARenMp = if @isGlobal + then @addToARenMp @lhs.accumARenMp + else @lhs.accumARenMp + loc . aRenMp = if @isGlobal + then @lhs.aRenMp + else @addToARenMp @lhs.aRenMp + lhs . accumARenMp = @body.accumARenMp + | Lam body . accumARenMp = aRenAdd @lhs.ropts False +%%[[20 + @lhs.moduleNm +%%]] + [@arg] @lUniq @lhs.aRenMp + loc . aRenMp = @body.accumARenMp + | * - Lam Let Char Int String Tup FFI Var Ann +%%[[9 + CoeArg Hole +%%]] +%%[[97 + Integer +%%]] + first__ . accumARenMp = @lhs.aRenMp + loc . aRenMp = @last__.accumARenMp + | * - Let Ann lhs . accumARenMp = @lhs.accumARenMp + loc . accumARenMp = @lhs.aRenMp + +SEM CAlt + | Alt expr . accumARenMp = aRenAdd @lhs.ropts False +%%[[20 + @lhs.moduleNm +%%]] + @pat.nmL @lUniq @lhs.aRenMp + loc . aRenMp = @expr.accumARenMp + +SEM CBindAspect + | Bind Val expr . accumARenMp = @lhs.aRenMp + loc . aRenMp = @expr.accumARenMp + +SEM CModule + | Mod expr . accumARenMp = @lhs.aRenMp + loc . aRenMp = @expr.accumARenMp + +SEM MbCExpr + | Just just . accumARenMp = @lhs.aRenMp + loc . aRenMp = @just.accumARenMp + +SEM CPatFld + | Fld offset . accumARenMp = @lhs.aRenMp + loc . aRenMp = @offset.accumARenMp +%%] %%[(8 codegen) @@ -134,7 +258,7 @@ ATTR AllMetaVal [ | | protectableBindingNames : {[HsName]} ] %%[(8 codegen) SEM CodeAGItf - | AGItf module . aRenMp = Map.empty + | AGItf module . aRenMp = emptyARenMp . lev = cLevModule SEM CBind %%[[8 @@ -156,23 +280,23 @@ SEM CPatRest | Var lhs . nmL = [@nm] SEM CExpr - | Let loc . aRenMp = aRenAdd (@lhs.lev == cLevModule) @binds.nmL @lUniq @lhs.aRenMp + | Let -- loc . aRenMp = aRenAdd (@lhs.lev == cLevModule) @binds.nmL @lUniq @lhs.aRenMp binds . lev = @lhs.lev + 1 - | Lam loc . aRenMp = aRenAdd False [@arg] @lUniq @lhs.aRenMp + | Lam -- loc . aRenMp = aRenAdd False [@arg] @lUniq @lhs.aRenMp body . lev = if @body.isLamBody then @lhs.lev + 1 else @lhs.lev SEM CAlt - | Alt loc . aRenMp = aRenAdd False @pat.nmL @lUniq @lhs.aRenMp + | Alt -- loc . aRenMp = aRenAdd False @pat.nmL @lUniq @lhs.aRenMp expr . lev = @lhs.lev + 1 %%] %%[(20 codegen) SEM CExpr - | Let loc . aRenMp := aRenAdd (@lhs.lev == cLevModule) @lhs.moduleNm @binds.nmL @lUniq @lhs.aRenMp - | Lam loc . aRenMp := aRenAdd False @lhs.moduleNm [@arg] @lUniq @lhs.aRenMp + -- | Let loc . aRenMp := aRenAdd (@lhs.lev == cLevModule) @lhs.moduleNm @binds.nmL @lUniq @lhs.aRenMp + -- | Lam loc . aRenMp := aRenAdd False @lhs.moduleNm [@arg] @lUniq @lhs.aRenMp SEM CAlt - | Alt loc . aRenMp := aRenAdd False @lhs.moduleNm @pat.nmL @lUniq @lhs.aRenMp + -- | Alt loc . aRenMp := aRenAdd False @lhs.moduleNm @pat.nmL @lUniq @lhs.aRenMp %%] %%[(8 codegen) @@ -192,7 +316,8 @@ SEM CBind | Bind lhs . cTrf = CBind_Bind (aRenRepl @lhs.aRenMp @nm) @bindAspects.cTrf SEM CPatFld - | Fld lhs . cTrf = CPatFld_Fld @lbl @offset.cTrf (aRenRepl @lhs.aRenMp @fldNm) -- @pat.cTrf + -- | Fld lhs . cTrf = CPatFld_Fld @lbl @offset.cTrf (aRenRepl @lhs.aRenMp @fldNm) @fldAnns.cTrf -- @pat.cTrf + | Fld lhs . cTrf = CPatFld_Fld @lbl @offset.cTrf (aRenRepl @aRenMp @fldNm) @fldAnns.cTrf -- @pat.cTrf SEM CPat | Var lhs . cTrf = CPat_Var (aRenRepl @lhs.aRenMp $ @pnm) diff --git a/EHC/src/ehc/Core/Utils.chs b/EHC/src/ehc/Core/Utils.chs index 92e280131..bc8a2772a 100644 --- a/EHC/src/ehc/Core/Utils.chs +++ b/EHC/src/ehc/Core/Utils.chs @@ -7,7 +7,10 @@ %%% Core utilities %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%[(8 codegen) module {%{EH}Core.Utils} import(qualified Data.Map as Map,Data.Maybe,{%{EH}Base.Builtin},{%{EH}Opts},{%{EH}Base.Common},{%{EH}Ty},{%{EH}Core},{%{EH}Gam.Full}) +%%[(8 codegen) module {%{EH}Core.Utils} +%%] + +%%[(8 codegen) hs import({%{EH}Base.Builtin},{%{EH}Opts},{%{EH}Base.Common},{%{EH}Ty},{%{EH}Core},{%{EH}Gam.Full}) %%] %%[(8 codegen) hs import({%{EH}AbstractCore}) @@ -19,7 +22,14 @@ %%] %%[(8 codegen) import({%{EH}VarMp},{%{EH}Substitutable}) %%] -%%[(8 codegen) import(Data.List,qualified Data.Set as Set,Data.List,qualified Data.Map as Map,EH.Util.Utils) +%%[(8 codegen) import(Data.List,Data.Maybe,qualified Data.Set as Set,Data.List,qualified Data.Map as Map,EH.Util.Utils) +%%] + +%%[(20 codegen) import(Control.Monad.State, Data.Array) +%%] +%%[(20 codegen) import(qualified EH.Util.FastSeq as Seq) +%%] +%%[(20 codegen) import({%{EH}Core.FvS}, {%{EH}Core.ModAsMap}) %%] -- debug @@ -167,7 +177,7 @@ foffMkOff (FldComputeOffset _ e) o = (o,e) foffLabel :: FldOffset -> HsName foffLabel FldImplicitOffset = hsnUnknown -foffLabel foff = foffLabel' foff +foffLabel foff = foffLabel' foff %%] %%[(8 codegen) export(FieldSplitL,fsL2PatL) @@ -227,4 +237,100 @@ patBindLOffset ) %%] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Module merge by pulling in only that which is required +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +cModMergeByPullingIn is independent of AST, so should be placed in shared module when used for (say) GRIN + +%%[(20 codegen) hs export(cModMergeByPullingIn) +data PullState cat bind + = PullState + { pullstBinds :: Seq.Seq (CDbBindLetInfo'2 cat bind) -- pulled in bindings + , pullstPulledNmS :: !HsNameS -- pulled in names + , pullstToDo :: ![HsName] -- todo + } + +emptyPullState :: PullState cat bind +emptyPullState = PullState Seq.empty Set.empty [] + +-- | merge by pulling in that which is required only +cModMergeByPullingIn + :: -- function giving bindings for name + (HsName -- name + -> Maybe + ( cat -- category + , [bind] -- and bindings + , HsNameS -- pulled in names (might be > 1 for mutual recursiveness) + ) ) + -> (expr -> HsNameS) -- extract free vars + -> (bind -> [expr]) -- extract relevant exprs for binding + -> ([(cat,[bind])] -> mod -> mod) + -- update module with pulled bindings + -> expr -- start of pulling in, usually top level name "main" + -> ( (mod -> mod) -- conversion of resulting module + , HsNameS -- modules from which something was taken + ) +cModMergeByPullingIn + pullIn getExprFvS getBindExprs updMod + rootExpr + = ( updMod (Seq.toList $ pullstBinds st) + , Set.map (panicJust "cModMergeByPullingIn" . hsnQualifier) $ pullstPulledNmS st + ) + where (_,st) = runState (pull) (emptyPullState {pullstToDo = Set.toList $ getExprFvS rootExpr}) + pull = do + s <- get + case pullstToDo s of + (nm:nmRest) + | nm `Set.notMember` pullstPulledNmS s && isJust mbPull + -> do let pulledNms = pullstPulledNmS s `Set.union` pulled + newNms + = -- (\x -> tr "cModMergeByPullingIn.pulledNms" (nm >#< show x) x) $ + (Set.unions $ map (Set.unions . map getExprFvS . getBindExprs) binds) + `Set.difference` pulledNms + put $ + s { pullstToDo = Set.toList newNms ++ nmRest + , pullstBinds = Seq.singleton (cat,binds) `Seq.union` pullstBinds s + , pullstPulledNmS = pulledNms + } + pull + | otherwise + -> do put $ + s { pullstToDo = nmRest + } + pull + where mbPull@(~(Just (cat,binds,pulled))) = pullIn nm + _ -> return () +%%] + +%%[(20 codegen) hs export(cModMerge2) +-- | merge by pulling +cModMerge2 :: ([CModule],CModule) -> CModule +cModMerge2 (mimpL,mmain) + = mkM mmain + where (mkM,_) = cModMergeByPullingIn lkupPull cexprFvS cbindExprs + (\bs (CModule_Mod modNm _ _) -> CModule_Mod modNm (acoreLetN bs $ rootExpr) allTags) + rootExpr + rootExpr = cmoddbMainExpr modDbMain + allTags = concatMap cmoddbTagsMp $ modDbMain : modDbImp + modDbMain = cexprModAsDatabase mmain + modDbImp = map cexprModAsDatabase mimpL + modDbMp = Map.unions [ Map.singleton (cmoddbModNm db) db | db <- modDbMain : modDbImp ] + lkupMod n = -- (\x -> tr "cModMerge2.lkupMod" (n >#< fmap cmoddbModNm x) x) $ + maybe (Just modDbMain) (\m -> Map.lookup m modDbMp) $ hsnQualifier n + lkupPull n = do + db <- lkupMod n + (bi,_) <- cmoddbLookup n db + let (cat,bsarr) = cmoddbBindArr db ! bi + bs = elems bsarr + return ( cat, bs + , -- (\x -> tr "cModMerge2.lkupPull" (n >#< show x) x) $ + Set.fromList $ map cbindNm bs + ) +%%] + lkupMod n = do + m <- (\x -> tr "cModMerge2.lkupMod" (n >#< x) x) $ + hsnQualifier n + Map.lookup m modDbMp + diff --git a/EHC/src/ehc/EH/InferClass.cag b/EHC/src/ehc/EH/InferClass.cag index e42536469..404e011f8 100644 --- a/EHC/src/ehc/EH/InferClass.cag +++ b/EHC/src/ehc/EH/InferClass.cag @@ -78,7 +78,8 @@ SEM Decl decls . gathDataGam = emptyGam lhs . gathDeclDataGam = if ehcCfgClassViaRec @lhs.opts then emptyGam - else let dgi = mkDGIPlain @dataDictNm Ty_Any [@dataDictNm] (@dataDictNm `Map.singleton` emptyDataTagInfo {dtiCTag = @dataDictTag}) + else let dgi = mkDGIPlain @dataDictNm Ty_Any [@dataDictNm] (@dataDictNm `Map.singleton` dti) + dti = emptyDataTagInfo {dtiCTag = @dataDictTag, dtiConNm = @dataDictNm} in gamSingleton @dataDictNm dgi . gathDataGam = @lhs.gathDataGam %%] diff --git a/EHC/src/ehc/EH/ToCore.cag b/EHC/src/ehc/EH/ToCore.cag index f2eebc450..010b93744 100644 --- a/EHC/src/ehc/EH/ToCore.cag +++ b/EHC/src/ehc/EH/ToCore.cag @@ -501,7 +501,7 @@ SEM Expr (\isNewtype (DataTagInfo { dtiConNm = conNm - , dtiFldMp = fldMp + -- , dtiFldMp = fldMp , dtiConFldAnnL = annL , dtiCTag = ctag }) -> mkDataCBindL @lhs.opts ctag annL conNm isNewtype diff --git a/EHC/src/ehc/EHC.chs b/EHC/src/ehc/EHC.chs index 0d4d15d46..634e9b38b 100644 --- a/EHC/src/ehc/EHC.chs +++ b/EHC/src/ehc/EHC.chs @@ -10,7 +10,7 @@ %%[1 module Main %%] -%%[1 import(System.Console.GetOpt) +%%[1 import(System.Console.GetOpt, System) %%] %%[1.fastseq import(qualified EH.Util.FastSeq as Seq) %%] @@ -230,8 +230,8 @@ Order is significant. %%[8 type FileSuffMp = [(FileSuffix,EHCompileUnitState)] -fileSuffMpHs :: FileSuffMp -fileSuffMpHs +mkFileSuffMpHs :: EHCOpts -> FileSuffMp +mkFileSuffMpHs opts = [ ( Just "hs" , ECUSHaskell HSStart ) %%[[99 , ( Just "lhs" , ECUSHaskell LHSStart ) @@ -244,10 +244,10 @@ fileSuffMpHs -- currently not supported , ( Just "grin", ECUSGrin ) %%]] + ] %%[[(90 codegen) - , ( Just "c" , ECUSC CStart ) + ++ (if targetIsOnUnixAndOrC (ehcOptTarget opts) then [ ( Just "c" , ECUSC CStart ) ] else []) %%]] - ] %%] %%[8 @@ -435,6 +435,7 @@ doCompileRun fnL@(fn:_) opts , initialState ) = fromJust mbPrep searchPath = ehcOptImportFileLocPath opts + fileSuffMpHs = mkFileSuffMpHs opts %%[[8 comp mbFp nm = do { mbFoundFp <- cpFindFileForFPath fileSuffMpHs searchPath (Just nm) mbFp @@ -460,6 +461,10 @@ doCompileRun fnL@(fn:_) opts }) ; when isTopModule (cpUpdCU nm (ecuSetIsTopMod True)) + -- ; cpUpdCU nm (ecuSetIsTopMod isTopModule) -- ???? not equivalent to above +%%[[99 + ; cpUpdCU nm (ecuSetTarget (ehcOptTarget opts)) +%%]] ; case fpsFound of (fp:_) -> do { nm' <- cpEhcModuleCompile1 (Just HSOnlyImports) nm diff --git a/EHC/src/ehc/EHC/Common.chs b/EHC/src/ehc/EHC/Common.chs index 22da59dcb..ba92e1362 100644 --- a/EHC/src/ehc/EHC/Common.chs +++ b/EHC/src/ehc/EHC/Common.chs @@ -10,7 +10,7 @@ Used by all compiler driver code -- general imports %%[1 import(Data.List, Data.Char, Data.Maybe) export(module Data.Maybe, module Data.List, module Data.Char) %%] -%%[1 import(Control.Monad.State, IO, System) export(module IO, module Control.Monad.State, module System) +%%[1 import(Control.Monad.State, IO, System) export(module IO, module Control.Monad.State) %%] %%[1 import(EH.Util.CompileRun, EH.Util.Pretty, EH.Util.FPath, EH.Util.Utils) export(module EH.Util.CompileRun, module EH.Util.Pretty, module EH.Util.FPath, module EH.Util.Utils) %%] @@ -37,17 +37,17 @@ The state HS compilation can be in %%[8 export(HSState(..)) data HSState - = HSStart -- starting from .hs - | HSAllSem -- done all semantics for .hs + = HSStart -- starting from .hs + | HSAllSem -- done all semantics for .hs %%[[20 - | HSOnlyImports -- done imports from .hs - | HIStart -- starting from .hi - | HIAllSem -- done all semantics for .hi - | HIOnlyImports -- done imports from .hi + | HSOnlyImports -- done imports from .hs + | HIStart -- starting from .hi + | HIAllSem -- done all semantics for .hi + | HIOnlyImports -- done imports from .hi %%]] %%[[99 - | LHSStart -- starting from .lhs - | LHSOnlyImports -- done imports from .lhs + | LHSStart -- starting from .lhs + | LHSOnlyImports -- done imports from .lhs %%]] deriving (Show,Eq) %%] @@ -123,11 +123,11 @@ data EHCompileUnitState %%[8 export(EHCompileUnitKind(..)) data EHCompileUnitKind - = EHCUKind_HS -- Haskell: .hs .lhs .hi + = EHCUKind_HS -- Haskell: .hs .lhs .hi %%[[90 - | EHCUKind_C -- C: .c + | EHCUKind_C -- C: .c %%]] - | EHCUKind_None -- Nothing + | EHCUKind_None -- Nothing deriving Eq %%] @@ -197,3 +197,37 @@ mkOutputFPath :: FPATH nm => EHCOpts -> nm -> FPath -> String -> FPath mkOutputFPath = mkInOrOutputFPathFor OutputFor_Module %%] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Construction of output names +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[8 export(mkPerModuleOutputFPath) +-- | FPath for per module output +mkPerModuleOutputFPath :: EHCOpts -> Bool -> HsName -> FPath -> String -> FPath +mkPerModuleOutputFPath opts doSepBy_ modNm fp suffix + = fpO modNm fp +%%[[8 + where fpO m f= mkOutputFPath opts m f suffix +%%][99 + where fpO m f= case ehcOptPkg opts of + Just _ -> nm_ + _ | doSepBy_ -> nm_ + | otherwise -> mkOutputFPath opts m f suffix + where nm_ = mkOutputFPath opts (hsnMapQualified (const base) m) (fpathSetBase base f) suffix + where base = hsnShow "_" "_" m +%%]] +%%] + +%%[8 export(mkPerExecOutputFPath) +-- | FPath for final executable +mkPerExecOutputFPath :: EHCOpts -> HsName -> FPath -> Maybe String -> FPath +mkPerExecOutputFPath opts modNm fp mbSuffix + = fpExec + where fpExecBasedOnSrc = maybe (mkOutputFPath opts modNm fp "") (\s -> mkOutputFPath opts modNm fp s) mbSuffix +%%[[8 + fpExec = fpExecBasedOnSrc +%%][99 + fpExec = maybe fpExecBasedOnSrc id (ehcOptMbOutputFile opts) +%%]] +%%] + diff --git a/EHC/src/ehc/EHC/CompilePhase/Cleanup.chs b/EHC/src/ehc/EHC/CompilePhase/Cleanup.chs index e0dd6f32d..e265caa4f 100644 --- a/EHC/src/ehc/EHC/CompilePhase/Cleanup.chs +++ b/EHC/src/ehc/EHC/CompilePhase/Cleanup.chs @@ -7,6 +7,9 @@ Cleanup between phases %%[99 module {%{EH}EHC.CompilePhase.Cleanup} %%] +%%[99 import({%{EH}Base.Optimize}) +%%] + -- general imports %%[99 import({%{EH}EHC.Common}) %%] @@ -55,25 +58,27 @@ cpCleanupEH modNm %%] %%[(99 codegen) export(cpCleanupCore) -cpCleanupCore :: HsName -> EHCompilePhase () -cpCleanupCore modNm - = cpUpdCU modNm - (\e -> e { ecuMbCore = Nothing +cpCleanupCore :: [HsName] -> EHCompilePhase () +cpCleanupCore modNmL + = cpSeq [cl m | m <- modNmL] + where cl m = cpUpdCU m + (\e -> e { ecuMbCore = Nothing %%[[(99 tycore) - , ecuMbTyCore = Nothing + , ecuMbTyCore = Nothing %%]] - , ecuMbCoreSem = Nothing - } - ) + , ecuMbCoreSem = Nothing + } + ) %%] %%[(99 codegen grin) export(cpCleanupGrin,cpCleanupFoldBytecode,cpCleanupBytecode) -cpCleanupGrin :: HsName -> EHCompilePhase () -cpCleanupGrin modNm - = cpUpdCU modNm - (\e -> e { ecuMbGrin = Nothing - } - ) +cpCleanupGrin :: [HsName] -> EHCompilePhase () +cpCleanupGrin modNmL + = cpSeq [cl m | m <- modNmL] + where cl m = cpUpdCU m + (\e -> e { ecuMbGrin = Nothing + } + ) cpCleanupFoldBytecode :: HsName -> EHCompilePhase () cpCleanupFoldBytecode modNm @@ -103,7 +108,7 @@ cpCleanupCU modNm -- TODO think about this a bit longer. ; cr <- get ; let (_,opts) = crBaseInfo' cr - ; when (not $ ehcOptFullProgAnalysis opts) $ cpCleanupGrin modNm + ; when (ehcOptOptimizationScope opts < OptimizationScope_WholeGrin) $ cpCleanupGrin [modNm] %%]] } diff --git a/EHC/src/ehc/EHC/CompilePhase/CompileC.chs b/EHC/src/ehc/EHC/CompilePhase/CompileC.chs index 1a07a07e0..e87747e45 100644 --- a/EHC/src/ehc/EHC/CompilePhase/CompileC.chs +++ b/EHC/src/ehc/EHC/CompilePhase/CompileC.chs @@ -41,9 +41,6 @@ gccDefs opts builds builds ++ map (\x -> (x,Nothing)) [ "_" ++ map (\c -> case c of {'.' -> '_'; c -> c}) (Cfg.verFull Cfg.version) ] -%%[[(99 codegen grin) - -- ++ (if ehcOptFullProgAnalysis opts then ["_FULL_PROGRAM_ANALYSIS"] else []) -%%]] %%] %%[(99 codegen) @@ -68,20 +65,8 @@ cpCompileWithGCC how othModNmL modNm EHCUKind_C -> fp %%]] _ -> mkOutputFPath opts modNm fp "c" -%%[[8 - fpO m f= mkOutputFPath opts m f "o" -%%][99 - fpO m f= case ehcOptPkg opts of - Just _ -> mkOutputFPath opts (hsnMapQualified (const base) m) (fpathSetBase base f) "o" - where base = hsnShow "_" "_" m - _ -> mkOutputFPath opts m f "o" -%%]] - fpExecBasedOnSrc = maybe (mkOutputFPath opts modNm fp "") (\s -> mkOutputFPath opts modNm fp s) Cfg.mbSuffixExec -%%[[8 - fpExec = fpExecBasedOnSrc -%%][99 - fpExec = maybe fpExecBasedOnSrc id (ehcOptMbOutputFile opts) -%%]] + fpO m f = mkPerModuleOutputFPath opts False m f "o" + fpExec = mkPerExecOutputFPath opts modNm fp Cfg.mbSuffixExec variant= Cfg.installVariant opts (fpTarg,targOpt,linkOpts,linkLibOpt,dotOFilesOpt,genOFiles) = case how of @@ -93,19 +78,24 @@ cpCompileWithGCC how othModNmL modNm , %%[[99 map (mkl2 Cfg.INST_LIB_PKG2) - (if ehcOptFullProgAnalysis opts then [] else pkgKeyDirL) + (if ehcOptWholeProgOptimizationScope opts then [] else pkgKeyDirL) ++ %%]] map (mkl Cfg.INST_LIB) - Cfg.libnamesGccPerVariant + Cfg.libnamesRts ++ map (\l -> Cfg.mkInstallFilePrefix opts Cfg.INST_LIB_SHARED variant "" ++ Cfg.mkCLibFilename "" l) (Cfg.libnamesGcc opts) ++ map ("-l" ++) Cfg.libnamesGccEhcExtraExternalLibs - , if ehcOptFullProgAnalysis opts + , +%%[[20 + if ehcOptWholeProgOptimizationScope opts then [ ] - else [ fpathToStr $ fpO m fp | m <- othModNmL2, let (_,_,_,fp) = crBaseInfo m cr ] + else +%%]] + [ fpathToStr $ fpO m fp | m <- othModNmL2, let (_,_,_,fp) = crBaseInfo m cr ] , [] ) - where mkl how l = Cfg.mkCLibFilename (Cfg.mkInstallFilePrefix opts how variant l) l + where -- mkl how l = Cfg.mkCLibFilename (Cfg.mkInstallFilePrefix opts how variant l) l + mkl how l = Cfg.mkInstalledRts opts Cfg.mkCLibFilename how variant l %%[[99 mkl2 how (l,d) = Cfg.mkCLibFilename (d ++ "/") @@ -174,7 +164,7 @@ cpPreprocessWithCPP pkgKeyDirL modNm ) -} (do { let defs = [ "UHC", "TARGET_" ++ (map toUpper $ show $ ehcOptTarget opts) ] %%[[(99 codegen grin) - ++ (if ehcOptFullProgAnalysis opts then ["UHC_FULL_PROGRAM_ANALYSIS"] else []) + ++ (if targetDoesHPTAnalysis (ehcOptTarget opts) then ["UHC_FULL_PROGRAM_ANALYSIS"] else []) %%]] -- (pkgKeyL,_) = crPartitionIntoPkgAndOthers cr othModNmL preCPP = mkShellCmd @@ -188,6 +178,10 @@ cpPreprocessWithCPP pkgKeyDirL modNm ) ; when (ehcOptVerbosity opts >= VerboseALot) (do { cpMsg modNm VerboseALot "CPP" + ; lift $ putStrLn ("pkg db: " ++ show (ehcOptPkgDb opts)) + ; lift $ putStrLn ("pkg srch filter: " ++ (show $ ehcOptPackageSearchFilter opts)) + ; lift $ putStrLn ("exposed pkgs: " ++ show (pkgExposedPackages $ ehcOptPkgDb opts)) + ; lift $ putStrLn ("pkgKeyDirL: " ++ show pkgKeyDirL) ; lift $ putStrLn preCPP }) ; when (crModCanCompile modNm cr) diff --git a/EHC/src/ehc/EHC/CompilePhase/CompileJScript.chs b/EHC/src/ehc/EHC/CompilePhase/CompileJScript.chs new file mode 100644 index 000000000..adca460fe --- /dev/null +++ b/EHC/src/ehc/EHC/CompilePhase/CompileJScript.chs @@ -0,0 +1,87 @@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% EHC Compile XXX +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +JScript compilation + +%%[(8 codegen jscript) module {%{EH}EHC.CompilePhase.CompileJScript} +%%] + +%%[(8 codegen jscript) import(System.Directory) +%%] + +-- general imports +%%[(8 codegen jscript) import({%{EH}EHC.Common}) +%%] +%%[(8 codegen jscript) import({%{EH}EHC.CompileUnit}) +%%] +%%[(8 codegen jscript) import({%{EH}EHC.CompileRun}) +%%] + +%%[(8 codegen jscript) import(qualified {%{EH}Config} as Cfg) +%%] +%%[(8 codegen jscript) import({%{EH}EHC.Environment}) +%%] +%%[(8 codegen jscript) import({%{EH}Base.Target}) +%%] + +%%[(8 codegen jscript) import({%{EH}Core.ToJScript}) +%%] +%%[(8 codegen jscript) import({%{EH}Base.Bits},{%{EH}JScript.Pretty}) +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Compile actions: JScript linking +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 codegen jscript) export(cpJScript) +cpJScript :: String -> [String] -> EHCompilePhase () +cpJScript archive files + = do { cr <- get + ; let (_,opts) = crBaseInfo' cr + cmd = mkShellCmd $ [Cfg.shellCmdCat] ++ files ++ [">", archive] + ; when (ehcOptVerbosity opts >= VerboseALot) (lift $ putStrLn cmd) + ; cpSystem cmd + } +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Compile actions: JScript compilation +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 codegen jscript) export(cpCompileJScript) +cpCompileJScript :: FinalCompileHow -> [HsName] -> HsName -> EHCompilePhase () +cpCompileJScript how othModNmL modNm + = do { cr <- get + ; let (ecu,_,opts,fp) = crBaseInfo modNm cr + mbJs = ecuMbJScript ecu + fpO m f = mkPerModuleOutputFPath opts True m f Cfg.suffixJScriptLib + fpM = fpO modNm fp + fpExec = mkPerExecOutputFPath opts modNm fp (Just "js") + ; when (isJust mbJs && targetIsJScript (ehcOptTarget opts)) + (do { cpMsg modNm VerboseALot "Emit JScript" + ; when (ehcOptVerbosity opts >= VerboseDebug) + (do { lift $ putStrLn $ "fpO : " ++ fpathToStr fpM + ; lift $ putStrLn $ "fpExec: " ++ fpathToStr fpExec + }) + ; let ppMod = ppJScriptModule (fromJust mbJs) + ; lift $ putPPFPath fpM ("//" >#< modNm >-< ppMod) 1000 + ; case how of + FinalCompile_Exec + -> do { cpJScript (fpathToStr fpExec) (rts ++ (map fpathToStr $ oth ++ [fpM])) + } + where rts = map (Cfg.mkInstalledRts opts Cfg.mkJScriptLibFilename Cfg.INST_LIB (Cfg.installVariant opts)) Cfg.libnamesRts +%%[[8 + oth = [] +%%][20 + oth | ehcOptWholeProgOptimizationScope opts = [] + | otherwise = [ fpO m fp | m <- othModNmL, let (_,_,_,fp) = crBaseInfo m cr ] +%%]] + _ -> return () + } + ) + } +%%] + + + diff --git a/EHC/src/ehc/EHC/CompilePhase/CompileLLVM.chs b/EHC/src/ehc/EHC/CompilePhase/CompileLLVM.chs index c3997931d..5b0c78583 100644 --- a/EHC/src/ehc/EHC/CompilePhase/CompileLLVM.chs +++ b/EHC/src/ehc/EHC/CompilePhase/CompileLLVM.chs @@ -43,7 +43,7 @@ cpCompileWithLLVM modNm ] -} = map (\lib -> "-l " ++ lib) - $ map (mkl Cfg.INST_LIB) Cfg.libnamesGccPerVariant + $ map (mkl Cfg.INST_LIB) Cfg.libnamesRts ++ map (\l -> Cfg.mkInstallFilePrefix opts Cfg.INST_LIB_SHARED variant "" ++ Cfg.mkCLibFilename "" l) (Cfg.libnamesGcc opts) ++ map ("-l" ++) Cfg.libnamesGccEhcExtraExternalLibs where mkl how l = Cfg.mkCLibFilename (Cfg.mkInstallFilePrefix opts how variant "") l diff --git a/EHC/src/ehc/EHC/CompilePhase/Link.chs b/EHC/src/ehc/EHC/CompilePhase/Link.chs index c9a91c202..69cd5355e 100644 --- a/EHC/src/ehc/EHC/CompilePhase/Link.chs +++ b/EHC/src/ehc/EHC/CompilePhase/Link.chs @@ -23,6 +23,8 @@ Linking %%] %%[(99 codegen jazy) import({%{EH}EHC.CompilePhase.CompileJVM}) export(cpLinkJar) %%] +%%[(9999 codegen jscript) import({%{EH}EHC.CompilePhase.CompileJScript}) export(cpLinkJScript) +%%] %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Compile actions: Linking into library for package diff --git a/EHC/src/ehc/EHC/CompilePhase/Output.chs b/EHC/src/ehc/EHC/CompilePhase/Output.chs index 0fd1c7e15..ef60804fd 100644 --- a/EHC/src/ehc/EHC/CompilePhase/Output.chs +++ b/EHC/src/ehc/EHC/CompilePhase/Output.chs @@ -144,26 +144,24 @@ cpOutputJava suff modNm %%[(8 codegen grin) export(cpOutputGrin) cpOutputGrin :: Bool -> String -> HsName -> EHCompilePhase () cpOutputGrin binary suff modNm - = do { cr <- get - ; let (ecu,crsi,opts,fp) = crBaseInfo modNm cr - mbGrin = ecuMbGrin ecu - grin = panicJust "cpOutputGrin" mbGrin - mkb x = x ++ suff - fpG = mkOutputFPath opts (mkHNm $ mkb $ show modNm) (fpathUpdBase mkb fp) "grin" - fnG = fpathToStr fpG - ; when (True) -- ehcOptFullProgAnalysis opts) - (do { cpMsg modNm VerboseALot "Emit Grin" + = do { cr <- get + ; let (ecu,crsi,opts,fp) = crBaseInfo modNm cr + mbGrin = ecuMbGrin ecu + grin = panicJust "cpOutputGrin" mbGrin + mkb x = x ++ suff + fpG = mkOutputFPath opts (mkHNm $ mkb $ show modNm) (fpathUpdBase mkb fp) "grin" + fnG = fpathToStr fpG + ; cpMsg modNm VerboseALot "Emit Grin" %%[[8 - ; lift $ putPPFPath fpG (ppGrModule grin) 1000 --TODO ? getal + ; lift $ putPPFPath fpG (ppGrModule grin) 1000 --TODO ? getal %%][20 - ; lift (if binary - then do { fpathEnsureExists fpG - ; putSerializeFile fnG grin - } - else putPPFPath fpG (ppGrModule grin) 1000 --TODO ? getal - ) + ; lift (if binary + then do { fpathEnsureExists fpG + ; putSerializeFile fnG grin + } + else putPPFPath fpG (ppGrModule grin) 1000 --TODO ? getal + ) %%]] - }) } %%] diff --git a/EHC/src/ehc/EHC/CompilePhase/TopLevelPhases.chs b/EHC/src/ehc/EHC/CompilePhase/TopLevelPhases.chs index 1a78719d6..4533701e4 100644 --- a/EHC/src/ehc/EHC/CompilePhase/TopLevelPhases.chs +++ b/EHC/src/ehc/EHC/CompilePhase/TopLevelPhases.chs @@ -26,6 +26,11 @@ level 2..6 : with prefix 'cpEhc' %%[8 import(qualified Data.Map as Map,qualified Data.Set as Set) %%] +%%[8 import({%{EH}Base.Optimize}) +%%] +%%[(8 codegen) import({%{EH}Base.Target}) +%%] + %%[8 import({%{EH}EHC.Common}) %%] %%[8 import({%{EH}EHC.CompileUnit}) @@ -53,9 +58,11 @@ level 2..6 : with prefix 'cpEhc' %%] %%[(8 codegen java) import({%{EH}EHC.CompilePhase.CompileJVM}) %%] +%%[(8 codegen jscript) import({%{EH}EHC.CompilePhase.CompileJScript}) +%%] %%[99 import({%{EH}Base.PackageDatabase}) %%] -%%[(99 codegen) import({%{EH}Base.Target},{%{EH}EHC.CompilePhase.Link}) +%%[(99 codegen) import({%{EH}EHC.CompilePhase.Link}) %%] %%[20 import({%{EH}EHC.CompilePhase.Module}) %%] @@ -65,7 +72,9 @@ level 2..6 : with prefix 'cpEhc' %%] -- Language syntax: Core -%%[(20 codegen grin) import(qualified {%{EH}Core} as Core(cModMerge)) +%%[(20 codegen) import(qualified {%{EH}Core} as Core(cModMerge)) +%%] +%%[(20 codegen) import({%{EH}Core.Utils} (cModMerge2)) %%] -- Language syntax: TyCore %%[(8 codegen tycore) import(qualified {%{EH}TyCore.Full2} as C) @@ -83,42 +92,53 @@ Top level entry point into compilation by the compiler driver, apart from import %%] %%[20 +-- | top lever driver for after all per-module work has been done, and whole program stuff like combining/linking can start cpEhcFullProgLinkAllModules :: [HsName] -> EHCompilePhase () cpEhcFullProgLinkAllModules modNmL = do { cr <- get ; let (mainModNmL,impModNmL) = splitMain cr modNmL (_,opts) = crBaseInfo' cr -- ' - ; cpMsg (head modNmL) VerboseDebug ("Main mod split: " ++ show mainModNmL ++ ": " ++ show impModNmL) + ; when (not $ null modNmL) + (cpMsg (head modNmL) VerboseDebug ("Main mod split: " ++ show mainModNmL ++ ": " ++ show impModNmL)) ; case mainModNmL of [mainModNm] | ehcOptDoLinking opts - -> cpSeq ( (if ehcOptFullProgAnalysis opts - then [ cpEhcFullProgPostModulePhases opts modNmL (impModNmL,mainModNm) - -- , cpMsg mainModNm VerboseDebug "XX" - , cpEhcCorePerModulePart2 (ehcOptEarlyModMerge opts) mainModNm - -- , cpMsg mainModNm VerboseDebug "YY" - ] - else [] - ) - ++ [cpEhcExecutablePerModule FinalCompile_Exec impModNmL mainModNm] - ) + -> case () of + () | ehcOptOptimizationScope opts >= OptimizationScope_WholeCore + -> cpSeq ( hpt + ++ [ when (targetIsGrinBytecode (ehcOptTarget opts)) (cpProcessBytecode mainModNm) +%%[[99 + , cpCleanupGrin [mainModNm] +%%]] + ] + + ++ exec + ) + | targetDoesHPTAnalysis (ehcOptTarget opts) + -> cpSeq $ hpt ++ exec + | otherwise + -> cpSeq exec + where exec = [ cpEhcExecutablePerModule FinalCompile_Exec impModNmL mainModNm ] + hpt = [ cpEhcFullProgPostModulePhases opts modNmL (impModNmL,mainModNm) + , cpEhcCorePerModulePart2 mainModNm + ] | otherwise - -> cpSetLimitErrs 1 "compilation run" [rngLift emptyRange Err_MayNotHaveMain mainModNm] + -> cpSetLimitErrs 1 "compilation run" [rngLift emptyRange Err_MayNotHaveMain mainModNm] _ | ehcOptDoLinking opts - -> cpSetLimitErrs 1 "compilation run" [rngLift emptyRange Err_MustHaveMain] + -> cpSetLimitErrs 1 "compilation run" [rngLift emptyRange Err_MustHaveMain] | otherwise %%[[20 - -> return () + -> return () %%][99 - -> case ehcOptPkg opts of - Just (PkgOption_Build pkg) - | targetAllowsOLinking (ehcOptTarget opts) - -> cpLinkO impModNmL pkg + -> case ehcOptPkg opts of + Just (PkgOption_Build pkg) + | targetAllowsOLinking (ehcOptTarget opts) + -> cpLinkO impModNmL pkg %%[[(99 jazy) - | targetAllowsJarLinking (ehcOptTarget opts) - -> cpLinkJar Nothing impModNmL (JarMk_Pkg pkg) + | targetAllowsJarLinking (ehcOptTarget opts) + -> cpLinkJar Nothing impModNmL (JarMk_Pkg pkg) %%]] - _ -> return () + _ -> return () %%]] } where splitMain cr = partition (\n -> ecuHasMain $ crCU n cr) @@ -172,7 +192,7 @@ cpEhcFullProgPostModulePhases, cpEhcGrinFullProgPostModulePhases, cpEhcCoreFullP :: EHCOpts -> [HsName] -> ([HsName],HsName) -> EHCompilePhase () cpEhcFullProgPostModulePhases opts modNmL modSpl - = (if ehcOptEarlyModMerge opts + = (if ehcOptOptimizationScope opts >= OptimizationScope_WholeCore then cpEhcCoreFullProgPostModulePhases else cpEhcGrinFullProgPostModulePhases ) opts modNmL modSpl @@ -181,7 +201,7 @@ cpEhcGrinFullProgPostModulePhases opts modNmL (impModNmL,mainModNm) = cpSeq ([ cpSeq [cpEnsureGrin m | m <- modNmL] , mergeIntoOneBigGrin %%[[99 - , cpSeq [cpCleanupGrin m | m <- impModNmL] -- clean up unused Grin (moved here from cpCleanupCU) + , cpCleanupGrin impModNmL -- clean up unused Grin (moved here from cpCleanupCU) %%]] ] ++ (if ehcOptDumpGrinStages opts then [cpOutputGrin False "-fullgrin" mainModNm] else []) @@ -190,7 +210,7 @@ cpEhcGrinFullProgPostModulePhases opts modNmL (impModNmL,mainModNm) ) where mergeIntoOneBigGrin = do { cr <- get - ; cpUpdCU mainModNm (ecuStoreGrin (Grin.grModMerge [ panicJust "cpEhcFullProgPostModulePhases.mergeIntoOneBigGrin" $ ecuMbGrin $ crCU m cr + ; cpUpdCU mainModNm (ecuStoreGrin (Grin.grModMerge [ panicJust "cpEhcGrinFullProgPostModulePhases.mergeIntoOneBigGrin" $ ecuMbGrin $ crCU m cr | m <- modNmL ] ) ) @@ -216,14 +236,14 @@ cpEhcCoreFullProgPostModulePhases opts modNmL (impModNmL,mainModNm) ) where mergeIntoOneBigCore = do { cr <- get + ; cpUpdCU mainModNm + $ ecuStoreCore + $ cModMerge2 ([ mOf m cr | m <- impModNmL ], mOf mainModNm cr) %%[[99 - ; cpSeq [cpCleanupCore m | m <- modNmL] -- clean up Core and CoreSem (it can still be read through cr in the next statement) + ; cpCleanupCore impModNmL -- clean up Core and CoreSem (it can still be read through cr in the next statement) %%]] - ; cpUpdCU mainModNm (ecuStoreCore (Core.cModMerge [ panicJust "cpEhcFullProgPostModulePhases.mergeIntoOneBigCore" $ ecuMbCore $ crCU m cr - | m <- modNmL - ] - ) ) } + where mOf m cr = panicJust "cpEhcCoreFullProgPostModulePhases.mergeIntoOneBigCore" $ ecuMbCore $ crCU m cr %%] %%[20 haddock @@ -424,8 +444,8 @@ cpEhcModuleCompile1 targHSState modNm %%]] modNm ; cpEhcHaskellModuleCommonPhases True True opts modNm - ; when (ehcOptFullProgAnalysis opts) - (cpEhcCoreGrinPerModuleDoneFullProgAnalysis (ehcOptEarlyModMerge opts) modNm) + ; when (ehcOptWholeProgHPTAnalysis opts) + (cpEhcCoreGrinPerModuleDoneFullProgAnalysis modNm) ; cpUpdCU modNm (ecuStoreState (ECUSHaskell HSAllSem)) ; return defaultResult } @@ -442,19 +462,24 @@ cpEhcModuleCompile1 targHSState modNm %%]] ; cpEhcEhModuleCommonPhases True True True opts modNm - ; when (ehcOptFullProgAnalysis opts) - (cpEhcCoreGrinPerModuleDoneFullProgAnalysis (ehcOptEarlyModMerge opts) modNm) + ; when (ehcOptWholeProgHPTAnalysis opts) + (cpEhcCoreGrinPerModuleDoneFullProgAnalysis modNm) ; cpUpdCU modNm (ecuStoreState (ECUSEh EHAllSem)) ; return defaultResult } %%[[90 (ECUSC CStart,_) + | targetIsOnUnixAndOrC (ehcOptTarget opts) -> do { cpSeq [ cpMsg modNm VerboseMinimal "Compiling C" , cpCompileWithGCC FinalCompile_Module [] modNm , cpUpdCU modNm (ecuStoreState (ECUSC CAllSem)) ] ; return defaultResult } + | otherwise + -> do { cpMsg modNm VerboseMinimal "Skipping C" + ; return defaultResult + } %%]] %%[[(8 codegen grin) (ECUSGrin,_) @@ -483,11 +508,11 @@ cpEhcEhModuleCommonPhases :: Bool -> Bool -> Bool -> EHCOpts -> HsName -> EHComp cpEhcEhModuleCommonPhases isMainMod isTopMod doMkExec opts modNm = cpSeq ([ cpEhcEhAnalyseModuleDefs modNm %%[[(8 codegen) - , cpEhcCorePerModulePart1 (ehcOptEarlyModMerge opts) modNm + , cpEhcCorePerModulePart1 modNm %%]] ] %%[[(8 codegen grin) - ++ (if ehcOptFullProgAnalysis opts + ++ (if ehcOptWholeProgHPTAnalysis opts then [] else [cpEhcCoreGrinPerModuleDoneNoFullProgAnalysis opts isMainMod isTopMod doMkExec modNm] ) @@ -755,10 +780,15 @@ Part 1 Core processing, on a per module basis, part1 is done always %%] %%[(8 codegen) -cpEhcCorePerModulePart1 :: Bool -> HsName -> EHCompilePhase () -cpEhcCorePerModulePart1 earlyMerge modNm +cpEhcCorePerModulePart1 :: HsName -> EHCompilePhase () +cpEhcCorePerModulePart1 modNm = do { cr <- get ; let (_,_,opts,_) = crBaseInfo modNm cr +%%[[8 + earlyMerge = False +%%][20 + earlyMerge = ehcOptOptimizationScope opts >= OptimizationScope_WholeCore +%%]] ; cpSeq ( [ cpStepUID ] %%[[(8 tycore) @@ -785,11 +815,19 @@ Part 2 Core processing, part2 is done either for individual modules or after ful %%] %%[(8 codegen) -cpEhcCorePerModulePart2 :: Bool -> HsName -> EHCompilePhase () -cpEhcCorePerModulePart2 earlyMerge modNm - = cpSeq [ when earlyMerge $ cpProcessCoreRest modNm - , cpProcessGrin modNm - ] +cpEhcCorePerModulePart2 :: HsName -> EHCompilePhase () +cpEhcCorePerModulePart2 modNm + = do { cr <- get + ; let (_,_,opts,_) = crBaseInfo modNm cr +%%[[8 + earlyMerge = False +%%][20 + earlyMerge = ehcOptOptimizationScope opts >= OptimizationScope_WholeCore +%%]] + ; cpSeq [ when earlyMerge $ cpProcessCoreRest modNm + , when (targetIsGrin (ehcOptTarget opts)) (cpProcessGrin modNm) + ] + } %%] %%[(8 codegen grin) haddock @@ -799,25 +837,26 @@ Core+grin processing, on a per module basis, may only be done when no full progr %%[(8 codegen grin) cpEhcCoreGrinPerModuleDoneNoFullProgAnalysis :: EHCOpts -> Bool -> Bool -> Bool -> HsName -> EHCompilePhase () cpEhcCoreGrinPerModuleDoneNoFullProgAnalysis opts isMainMod isTopMod doMkExec modNm - = cpSeq ( [ cpEhcCorePerModulePart2 (ehcOptEarlyModMerge opts) modNm + = cpSeq ( [ cpEhcCorePerModulePart2 modNm %%[[20 , cpMsg modNm VerboseDebug "cpFlowOptim" , cpFlowOptim modNm %%]] %%[[99 - , cpCleanupGrin modNm + , cpCleanupGrin [modNm] %%]] - , cpProcessBytecode modNm + , when doesGrin (cpProcessBytecode modNm) ] ++ (if not isMainMod || doMkExec then let how = if doMkExec then FinalCompile_Exec else FinalCompile_Module in [cpEhcExecutablePerModule how [] modNm] else [] ) - ++ [ cpMsg modNm VerboseALot "Core+Grin done" + ++ [ cpMsg modNm VerboseALot ("Core" ++ (if doesGrin then "+Grin" else "") ++ " done") , cpMsg modNm VerboseDebug ("isMainMod: " ++ show isMainMod) ] ) + where doesGrin = targetIsGrinBytecode (ehcOptTarget opts) %%] %%[(8 codegen grin) haddock @@ -825,26 +864,29 @@ Core+grin processing, on a per module basis, may only be done when full program %%] %%[(8 codegen grin) -cpEhcCoreGrinPerModuleDoneFullProgAnalysis :: Bool -> HsName -> EHCompilePhase () -cpEhcCoreGrinPerModuleDoneFullProgAnalysis earlyMerge modNm - = cpSeq ( [ cpEhcCorePerModulePart2 earlyMerge modNm +cpEhcCoreGrinPerModuleDoneFullProgAnalysis :: HsName -> EHCompilePhase () +cpEhcCoreGrinPerModuleDoneFullProgAnalysis modNm + = cpSeq ( [ cpEhcCorePerModulePart2 modNm , cpEhcExecutablePerModule FinalCompile_Exec [] modNm - , cpMsg modNm VerboseALot "Full Program Analysis Core+Grin done" + , cpMsg modNm VerboseALot "Full Program Analysis (Core+Grin) done" ] ) %%] -%%[(8 codegen grin) haddock +%%[(8 codegen) haddock Make final executable code, either still partly or fully (i.e. also linking) %%] -%%[(8 codegen grin) +%%[(8 codegen) cpEhcExecutablePerModule :: FinalCompileHow -> [HsName] -> HsName -> EHCompilePhase () cpEhcExecutablePerModule how impModNmL modNm = cpSeq [ cpCompileWithGCC how impModNmL modNm , cpCompileWithLLVM modNm %%[[(8 jazy) , cpCompileJazyJVM how impModNmL modNm +%%]] +%%[[(8 jscript) + , cpCompileJScript how impModNmL modNm %%]] ] %%] @@ -925,7 +967,8 @@ cpProcessCoreBasic modNm %%[[20 , cpFlowHILamMp modNm %%]] - , when (ehcOptEmitCore opts) (cpOutputCore True "" "core" modNm) + -- , when (ehcOptEmitCore opts) (cpOutputCore True "" "core" modNm) + , cpOutputCore True "" "core" modNm %%[[(8888 codegen java) , when (ehcOptEmitJava opts) (cpOutputJava "java" modNm) %%]] @@ -947,18 +990,22 @@ cpProcessCoreFold modNm %%] %%[(8 codegen) --- folded core -> grin and jazy +-- folded core -> grin, jazy, and the rest cpProcessCoreRest :: HsName -> EHCompilePhase () cpProcessCoreRest modNm = do { cr <- get ; let (_,_,opts,_) = crBaseInfo modNm cr ; cpSeq ( [ cpTranslateCore2Grin modNm ] - ++ (if ehcOptFullProgAnalysis opts then [ cpOutputGrin True "" modNm ] else []) + -- ++ (if ehcOptWholeProgHPTAnalysis opts then [ cpOutputGrin True "" modNm ] else []) + ++ (if targetIsGrin (ehcOptTarget opts) then [ cpOutputGrin True "" modNm ] else []) %%[[(8 jazy) ++ [ cpTranslateCore2Jazy modNm ] %%]] +%%[[(8 jscript) + ++ [ cpTranslateCore2JScript modNm ] +%%]] %%[[99 - ++ [ cpCleanupCore modNm ] + ++ [ cpCleanupCore [modNm] ] %%]] ) } @@ -974,7 +1021,7 @@ cpProcessGrin modNm ++ [cpTransformGrin modNm] ++ (if ehcOptDumpGrinStages opts then [cpOutputGrin False "-099-final" modNm] else []) ++ (if ehcOptEmitBytecode opts then [cpTranslateGrin2Bytecode modNm] else []) - ++ (if ehcOptFullProgAnalysis opts then [cpTranslateGrin modNm] else []) + ++ (if targetDoesHPTAnalysis (ehcOptTarget opts) then [cpTranslateGrin modNm] else []) ) } %%] diff --git a/EHC/src/ehc/EHC/CompilePhase/TransformGrin.chs b/EHC/src/ehc/EHC/CompilePhase/TransformGrin.chs index a2af168ad..e3c80f5cf 100644 --- a/EHC/src/ehc/EHC/CompilePhase/TransformGrin.chs +++ b/EHC/src/ehc/EHC/CompilePhase/TransformGrin.chs @@ -7,6 +7,9 @@ Grin transformation %%[8 module {%{EH}EHC.CompilePhase.TransformGrin} %%] +%%[8 import({%{EH}Base.Target}) +%%] + -- general imports %%[8 import(qualified Data.Map as Map) %%] @@ -62,7 +65,7 @@ cpTransformGrin :: HsName -> EHCompilePhase () cpTransformGrin modNm = do { cr <- get ; let (ecu,_,opts,_) = crBaseInfo modNm cr - forBytecode = not (ehcOptFullProgAnalysis opts) + forBytecode = targetIsGrinBytecode (ehcOptTarget opts) optimizing = ehcOptOptimizes Optimize_GrinLocal opts {- for debugging diff --git a/EHC/src/ehc/EHC/CompilePhase/Translations.chs b/EHC/src/ehc/EHC/CompilePhase/Translations.chs index 9e7624607..da750cf7c 100644 --- a/EHC/src/ehc/EHC/CompilePhase/Translations.chs +++ b/EHC/src/ehc/EHC/CompilePhase/Translations.chs @@ -11,6 +11,9 @@ Translation to another AST %%[8 import(qualified Data.Map as Map, qualified Data.Set as Set, qualified EH.Util.FastSeq as Seq) %%] +%%[(20 codegen) import({%{EH}Base.Optimize}) +%%] + %%[8 import({%{EH}EHC.Common}) %%] %%[8 import({%{EH}EHC.CompileUnit}) @@ -46,9 +49,11 @@ Translation to another AST %%[(8 codegen grin) import({%{EH}GrinByteCode.ToC}(gbmod2C)) %%] --- Jazy/JVM semantics +-- Jazy/JVM/JScript semantics %%[(8 codegen jazy) import({%{EH}Core.ToJazy}) %%] +%%[(8 codegen jscript) import({%{EH}Core.ToJScript}) +%%] %%[(8 codegen java) import({%{EH}Base.Bits},{%{EH}JVMClass.ToBinary}) %%] @@ -199,6 +204,18 @@ cpTranslateCore2Jazy modNm } %%] +%%[(8 codegen jscript) export(cpTranslateCore2JScript) +cpTranslateCore2JScript :: HsName -> EHCompilePhase () +cpTranslateCore2JScript modNm + = do { cr <- get + ; let (ecu,crsi,opts,fp) = crBaseInfo modNm cr + mbCore = ecuMbCore ecu + coreInh = crsiCoreInh crsi + ; when (isJust mbCore && targetIsJScript (ehcOptTarget opts)) + (cpUpdCU modNm $ ecuStoreJScript $ cmod2JScriptModule opts (Core2GrSem.dataGam_Inh_CodeAGItf coreInh) $ fromJust mbCore) + } +%%] + %%[(8 codegen grin) export(cpTranslateGrin2Bytecode) cpTranslateGrin2Bytecode :: HsName -> EHCompilePhase () cpTranslateGrin2Bytecode modNm @@ -208,22 +225,26 @@ cpTranslateGrin2Bytecode modNm ; when (ehcOptVerbosity opts >= VerboseDebug) (lift $ putStrLn ("crsiModOffMp: " ++ show (crsiModOffMp crsi))) %%]] - ; let modNmLL= crCompileOrder cr - mbGrin = ecuMbGrin ecu + ; let mbGrin = ecuMbGrin ecu grin = panicJust "cpTranslateGrin2Bytecode1" mbGrin %%[[20 - expNmOffMp - = crsiExpNmOffMp modNm crsi + isWholeProg = ehcOptOptimizationScope opts >= OptimizationScope_WholeGrin + expNmOffMp | ecuIsMainMod ecu = Map.empty + | otherwise = crsiExpNmOffMp modNm crsi optim = crsiOptim crsi + impNmL | isWholeProg = [] + | otherwise = ecuImpNmL ecu + modOffMp | isWholeProg = Map.filterWithKey (\n _ -> n == modNm) $ crsiModOffMp crsi + | otherwise = crsiModOffMp crsi %%]] (bc,errs) = grinMod2ByteCodeMod opts %%[[20 (Core2GrSem.lamMp_Inh_CodeAGItf $ crsiCoreInh crsi) -- (HI.hiiLamMp $ ecuHIInfo ecu) - (if ecuIsMainMod ecu then [ m | (m,_) <- sortOn snd $ Map.toList $ Map.map fst $ crsiModOffMp crsi ] else []) + (if ecuIsMainMod ecu then [ m | (m,_) <- sortOn snd $ Map.toList $ Map.map fst modOffMp ] else []) -- (ecuImpNmL ecu) (Map.fromList [ (n,(o,mp)) - | (o,n) <- zip [0..] (ecuImpNmL ecu) + | (o,n) <- zip [0..] impNmL , let (_,mp) = panicJust ("cpTranslateGrin2Bytecode2: " ++ show n) (Map.lookup n (crsiModOffMp crsi)) ]) expNmOffMp diff --git a/EHC/src/ehc/EHC/CompileRun.chs b/EHC/src/ehc/EHC/CompileRun.chs index f5d9e71bf..b38194db1 100644 --- a/EHC/src/ehc/EHC/CompileRun.chs +++ b/EHC/src/ehc/EHC/CompileRun.chs @@ -10,7 +10,7 @@ An EHC compile run maintains info for one compilation invocation -- general imports %%[8 import(qualified Data.Map as Map,qualified Data.Set as Set) %%] -%%[8 import(System.Cmd) +%%[8 import(System, System.Cmd(rawSystem)) %%] %%[99 import(System.Directory) %%] diff --git a/EHC/src/ehc/EHC/CompileUnit.chs b/EHC/src/ehc/EHC/CompileUnit.chs index 08f8e7a0a..73af03202 100644 --- a/EHC/src/ehc/EHC/CompileUnit.chs +++ b/EHC/src/ehc/EHC/CompileUnit.chs @@ -25,6 +25,8 @@ An EHC compile unit maintains info for one unit of compilation, a Haskell (HS) m %%] %%[(8 jazy) hs import(qualified {%{EH}JVMClass} as Jvm) %%] +%%[(8 jscript) hs import(qualified {%{EH}JScript} as JS) +%%] -- Language semantics: HS, EH %%[8 import(qualified {%{EH}EH.MainAG} as EHSem, qualified {%{EH}HS.MainAG} as HSSem) %%] @@ -53,8 +55,8 @@ An EHC compile unit maintains info for one unit of compilation, a Haskell (HS) m %%[(9999 codegen grin) import({%{EH}GrinCode.Trf.ForceEval}, {%{EH}GrinByteCode.Trf.ForceEval}) %%] --- pragma -%%[99 hs import(qualified {%{EH}Base.Pragma} as Pragma) +-- pragma, target +%%[99 hs import(qualified {%{EH}Base.Pragma} as Pragma, {%{EH}Base.Target}) %%] -- debug @@ -100,6 +102,7 @@ data EHCCompileSeqNr } deriving (Eq,Ord) +zeroEHCCompileSeqNr :: EHCCompileSeqNr zeroEHCCompileSeqNr = EHCCompileSeqNr 0 0 instance Show EHCCompileSeqNr where @@ -141,6 +144,9 @@ data EHCompileUnit %%]] %%[[(8 jazy) , ecuMbJVMClassL :: !(Maybe (HsName,[Jvm.Class])) +%%]] +%%[[(8 jscript) + , ecuMbJScript :: !(Maybe JS.JScriptModule) %%]] , ecuState :: !EHCompileUnitState %%[[20 @@ -167,6 +173,7 @@ data EHCompileUnit %%]] %%[[99 , ecuMbOpts :: (Maybe EHCOpts) -- possibly per module adaption of options (caused by pragmas) + , ecuTarget :: Target -- target for which we compile , ecuPragmas :: !(Set.Set Pragma.Pragma) -- pragmas of module , ecuUsedNames :: ModEntRelFilterMp -- map holding actually used names, to later filter cache of imported hi's to be included in this module's hi %%]] @@ -234,6 +241,9 @@ emptyECU %%]] %%[[(8 jazy) , ecuMbJVMClassL = Nothing +%%]] +%%[[(8 jscript) + , ecuMbJScript = Nothing %%]] , ecuState = ECUSUnknown %%[[20 @@ -260,6 +270,7 @@ emptyECU %%]] %%[[99 , ecuMbOpts = Nothing + , ecuTarget = defaultTarget , ecuPragmas = Set.empty , ecuUsedNames = Map.empty %%]] @@ -323,6 +334,11 @@ instance CompileUnit EHCompileUnit HsName FileLoc EHCompileUnitState where %%][20 cuImports = ecuImpNmL %%]] +%%[[99 + cuParticipation u = if not (Set.null $ Set.filter (Pragma.pragmaIsExcludeTarget $ ecuTarget u) $ ecuPragmas u) + then [CompileParticipation_NoImport] + else [] +%%]] instance FPathError Err @@ -399,6 +415,11 @@ ecuStoreJVMClassL :: EcuUpdater (HsName,[Jvm.Class]) ecuStoreJVMClassL x ecu = ecu { ecuMbJVMClassL = Just x } %%] +%%[(8 jscript) export(ecuStoreJScript) +ecuStoreJScript :: EcuUpdater (JS.JScriptModule) +ecuStoreJScript x ecu = ecu { ecuMbJScript = Just x } +%%] + ecuStoreJVMClassFPathL :: EcuUpdater [FPath] ecuStoreJVMClassFPathL x ecu = ecu { ecuMbJVMClassL = Just (Right x) } @@ -496,10 +517,13 @@ ecuStoreDirIsWritable :: EcuUpdater Bool ecuStoreDirIsWritable x ecu = ecu { ecuDirIsWritable = x } %%] -%%[99 export(ecuStoreOpts,ecuStorePragmas,ecuStoreUsedNames) +%%[99 export(ecuStoreOpts,ecuStorePragmas,ecuStoreUsedNames,ecuSetTarget) ecuStoreOpts :: EcuUpdater EHCOpts ecuStoreOpts x ecu = ecu { ecuMbOpts = Just x } +ecuSetTarget :: EcuUpdater Target +ecuSetTarget x ecu = ecu { ecuTarget = x } + ecuStorePragmas :: EcuUpdater (Set.Set Pragma.Pragma) ecuStorePragmas x ecu = ecu { ecuPragmas = x } diff --git a/EHC/src/ehc/EHC/GrinCompilerDriver.chs b/EHC/src/ehc/EHC/GrinCompilerDriver.chs index 201d91265..bfdff3ecb 100644 --- a/EHC/src/ehc/EHC/GrinCompilerDriver.chs +++ b/EHC/src/ehc/EHC/GrinCompilerDriver.chs @@ -13,7 +13,7 @@ %%] %%[(8 codegen grin) import(EH.Util.Pretty, EH.Util.CompileRun, EH.Util.FPath) %%] -%%[(8 codegen grin) import({%{EH}Base.Common}, {%{EH}Base.Builtin}, {%{EH}Opts}, {%{EH}Scanner.Scanner}, {%{EH}Scanner.Common(grinScanOpts)}) +%%[(8 codegen grin) import({%{EH}Base.Common}, {%{EH}Base.Target}, {%{EH}Base.Builtin}, {%{EH}Opts}, {%{EH}Scanner.Scanner}, {%{EH}Scanner.Common(grinScanOpts)}) %%] %%[(8 codegen grin) import({%{EH}GrinCode}, {%{EH}GrinCode.Parser}, {%{EH}GrinCode.Pretty}) %%] @@ -225,7 +225,7 @@ doCompileGrin input opts ; transformCodeIterated copyPropagation "copyPropagation" ; caWriteGrin "-179-final" ; caWriteHptMap "-180-hpt" - ; when (ehcOptFullProgAnalysis options) + ; when (targetDoesHPTAnalysis (ehcOptTarget options)) ( do { caGrin2Silly ; caWriteSilly "-201" "sil" pretty ehcOptDumpGrinStages ; transformSilly inlineExpr "InlineExpr" ; caWriteSilly "-202" "sil" pretty ehcOptDumpGrinStages ; transformSilly elimUnused "ElimUnused" ; caWriteSilly "-203" "sil" pretty ehcOptDumpGrinStages diff --git a/EHC/src/ehc/Foreign.cag b/EHC/src/ehc/Foreign.cag index e05d1c2ba..7a20e8504 100644 --- a/EHC/src/ehc/Foreign.cag +++ b/EHC/src/ehc/Foreign.cag @@ -10,12 +10,15 @@ %%[90 hs module {%{EH}Foreign} import({%{EH}Base.Common}) %%] -%%[90 hs export(ForeignEnt(..), CCall(..), PlainCall(..), ForeignAGItf(..)) +%%[90 hs export(ForeignEnt(..), CCall(..), PlainCall(..), PrimCall(..), ForeignAGItf(..)) %%] %%[9999 hs import({%{EH}Base.ForceEval}) %%] +%%[9090 hs import({%{EH}BuiltinPrims}) +%%] + %%[90 hs import(Control.Monad, {%{EH}Base.Binary}, {%{EH}Base.Serialize}) %%] %%[90 hs import(Data.Typeable(Typeable), Data.Generics(Data)) @@ -42,10 +45,12 @@ instance ForceEval ForeignEnt instance Serialize ForeignEnt where sput (ForeignEnt_CCall a) = sputWord8 0 >> sput a sput (ForeignEnt_PlainCall a) = sputWord8 1 >> sput a + sput (ForeignEnt_PrimCall a) = sputWord8 2 >> sput a sget = do t <- sgetWord8 case t of 0 -> liftM ForeignEnt_CCall sget 1 -> liftM ForeignEnt_PlainCall sget + 2 -> liftM ForeignEnt_PrimCall sget instance Serialize CCall where sput (CCall_Id a b c d) = sputWord8 0 >> sput a >> sput b >> sput c >> sput d @@ -65,4 +70,10 @@ instance Serialize PlainCall where case t of 0 -> liftM PlainCall_Id sget +instance Serialize PrimCall where + sput (PrimCall_Id a b) = sputWord8 0 >> sput a >> sput b + sget = do t <- sgetWord8 + case t of + 0 -> liftM2 PrimCall_Id sget sget + %%] diff --git a/EHC/src/ehc/Foreign/AbsSyn.cag b/EHC/src/ehc/Foreign/AbsSyn.cag index 6f45e3987..4db72db4b 100644 --- a/EHC/src/ehc/Foreign/AbsSyn.cag +++ b/EHC/src/ehc/Foreign/AbsSyn.cag @@ -13,6 +13,7 @@ DATA ForeignAGItf DATA ForeignEnt | CCall ent : CCall | PlainCall ent : PlainCall + | PrimCall ent : PrimCall %%] %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -30,6 +31,16 @@ DATA CCall | Empty %%] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Primitive Call: name of entity, and optional semantics of which the backend knows how to deal with +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[90 +DATA PrimCall + | Id nm : String + mbKnownPrim : {Maybe KnownPrim} +%%] + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Default/Plain Call: only name of entity %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -44,6 +55,6 @@ DATA PlainCall %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%[90 -SET AllForeign = ForeignEnt CCall PlainCall +SET AllForeign = ForeignEnt CCall PlainCall PrimCall %%] diff --git a/EHC/src/ehc/Foreign/Extract.cag b/EHC/src/ehc/Foreign/Extract.cag index 07c186b13..ece714f11 100644 --- a/EHC/src/ehc/Foreign/Extract.cag +++ b/EHC/src/ehc/Foreign/Extract.cag @@ -29,13 +29,14 @@ WRAPPER ForeignAGItf %%[90 hs export(ForeignExtraction(..)) data ForeignExtraction = ForeignExtraction - { forextractIncludes :: [String] - , forextractEnt :: String - , forextractOptIsStatic :: Bool - , forextractOptIsPtr :: Bool + { forextractIncludes :: ![String] + , forextractEnt :: !String + , forextractMbKnownPrim :: !(Maybe KnownPrim) + , forextractOptIsStatic :: !Bool + , forextractOptIsPtr :: !Bool } -emptyForeignExtraction = ForeignExtraction [] "??" False False +emptyForeignExtraction = ForeignExtraction [] "??" Nothing False False %%] %%[90 hs export(foreignEntExtract) @@ -54,6 +55,9 @@ foreignEntExtract ty %%[90 ATTR ForeignAGItf AllForeign [ | | extr: ForeignExtraction ] +SEM PrimCall + | Id lhs . extr = emptyForeignExtraction {forextractEnt = @nm, forextractMbKnownPrim = @mbKnownPrim} + SEM PlainCall | Id lhs . extr = emptyForeignExtraction {forextractEnt = @nm} @@ -61,6 +65,7 @@ SEM CCall | Id lhs . extr = ForeignExtraction (maybeToList @mbInclude) @nm + Nothing @isStatic @asPointer | * - Id lhs . extr = emptyForeignExtraction diff --git a/EHC/src/ehc/Foreign/Parser.chs b/EHC/src/ehc/Foreign/Parser.chs index 42481fed0..d49bd3265 100644 --- a/EHC/src/ehc/Foreign/Parser.chs +++ b/EHC/src/ehc/Foreign/Parser.chs @@ -64,7 +64,8 @@ type ForeignParser ep = PlainParser Token ep pForeignEnt :: FFIWay -> Maybe String -> ForeignParser ForeignEnt pForeignEnt way dfltNm = case way of - FFIWay_CCall -> ForeignEnt_CCall <$> pCCall dfltNm + FFIWay_CCall -> ForeignEnt_CCall <$> pCCall dfltNm + FFIWay_Prim -> ForeignEnt_PrimCall <$> pPrimCall dfltNm _ -> ForeignEnt_PlainCall <$> pPlainCall dfltNm pCCall :: Maybe String -> ForeignParser CCall @@ -120,6 +121,12 @@ pPlainCall dfltNm `opt` PlainCall_Id nm where nm = maybe "" id dfltNm +pPrimCall :: Maybe String -> ForeignParser PrimCall +pPrimCall dfltNm + = PrimCall_Id <$> (pForeignVar `opt` nm) <*> pKnownPrim + where nm = maybe "" id dfltNm + pKnownPrim = pMb (pAnyFromMap pKeyTk allKnownPrimMp) + pForeignVar :: ForeignParser String pForeignVar = tokGetVal <$> (pVARID <|> pCONID) %%] diff --git a/EHC/src/ehc/Foreign/Pretty.cag b/EHC/src/ehc/Foreign/Pretty.cag index c777a4052..bc897b826 100644 --- a/EHC/src/ehc/Foreign/Pretty.cag +++ b/EHC/src/ehc/Foreign/Pretty.cag @@ -33,6 +33,9 @@ instance PP ForeignEnt where %%[90 ATTR ForeignAGItf AllForeign [ | | pp: PP_Doc ] +SEM PrimCall + | Id lhs . pp = pp @nm >#< maybe empty pp @mbKnownPrim + SEM PlainCall | Id lhs . pp = pp @nm diff --git a/EHC/src/ehc/GrinByteCode/ToC.cag b/EHC/src/ehc/GrinByteCode/ToC.cag index e18099969..d96064231 100644 --- a/EHC/src/ehc/GrinByteCode/ToC.cag +++ b/EHC/src/ehc/GrinByteCode/ToC.cag @@ -462,7 +462,7 @@ SEM Instr %%[[8 d = noInx %%][20 - d = Map.findWithDefault noInx (panicJust "ToC.Instr.Call" $ hsnQualifier nm) @lhs.impNmMp + d = Map.findWithDefault noInx (panicJust ("ToC.Instr.Call: " ++ show nm) $ hsnQualifier nm) @lhs.impNmMp %%]] e = maybe noInx id $ @lhs.lkupLookupFunctionInfoInx nm _ -> dflt diff --git a/EHC/src/ehc/GrinCode/Trf/EvalElim.cag b/EHC/src/ehc/GrinCode/Trf/EvalElim.cag index 834f0c6ce..d779495ff 100644 --- a/EHC/src/ehc/GrinCode/Trf/EvalElim.cag +++ b/EHC/src/ehc/GrinCode/Trf/EvalElim.cag @@ -91,7 +91,7 @@ Note: when HPT analysis is done, in apply the name f is used instead of f'. %%[(8 codegen grin) hs import(qualified Data.Set as Set,qualified Data.Map as Map, Data.Maybe) %%] -%%[(8 codegen grin) hs import({%{EH}Base.Builtin}, {%{EH}Base.Common}, {%{EH}Opts}, {%{EH}GrinCode.Common}, {%{EH}GrinCode}) +%%[(8 codegen grin) hs import({%{EH}Base.Builtin}, {%{EH}Base.Target}, {%{EH}Base.Common}, {%{EH}Opts}, {%{EH}GrinCode.Common}, {%{EH}GrinCode}) %%] %%[(8 codegen grin) hs import(qualified {%{EH}Config} as Cfg) @@ -130,7 +130,7 @@ WRAPPER GrAGItf %%[(8 codegen grin) hs optsAllowNodePtrMix :: EHCOpts -> Bool -optsAllowNodePtrMix opts = not (ehcOptFullProgAnalysis opts) +optsAllowNodePtrMix opts = targetIsGrinBytecode (ehcOptTarget opts) %%] %%[(8 codegen grin) diff --git a/EHC/src/ehc/HS/AbsSyn.cag b/EHC/src/ehc/HS/AbsSyn.cag index 2b8cbaf66..5032816ab 100644 --- a/EHC/src/ehc/HS/AbsSyn.cag +++ b/EHC/src/ehc/HS/AbsSyn.cag @@ -316,6 +316,9 @@ DATA Pragma className : Name fieldName : Name defaultName : Name + | ExcludeIfTarget + range : Range + targetNames : {[String]} SET AllPragma = Pragma Pragmas diff --git a/EHC/src/ehc/HS/ModImpExp.cag b/EHC/src/ehc/HS/ModImpExp.cag index 327bcaf4b..1528ca7ae 100644 --- a/EHC/src/ehc/HS/ModImpExp.cag +++ b/EHC/src/ehc/HS/ModImpExp.cag @@ -20,6 +20,8 @@ %%[20 hs import(qualified EH.Util.Rel as Rel,{%{EH}Module}) %%] +%%[(99 codegen) hs import ({%{EH}Base.Target}) +%%] %%[99 hs import(qualified {%{EH}Base.Pragma} as Pragma) %%] diff --git a/EHC/src/ehc/HS/Parser.chs b/EHC/src/ehc/HS/Parser.chs index a28c9188b..1604d5b83 100644 --- a/EHC/src/ehc/HS/Parser.chs +++ b/EHC/src/ehc/HS/Parser.chs @@ -129,7 +129,8 @@ pPragma' mk <$> pLANGUAGE_prag <*> pCommas (tokMkQName <$> conid) <|> (\t cl fld val r -> mk r $ Pragma_Derivable (mkRange1 t) (tokMkQName cl) (tokMkQName fld) (tokMkQName val)) <$> pDERIVABLE_prag <*> gtycon' tyconsym <*> var <*> qvar - -- <|> (\t ps r -> mk r $ Pragma_OptionsGHC (mkRange1 t) ps) <$> pOPTIONSGHC_prag <*> pCommas (tokMkQName <$ pMINUS <*> conid) + <|> (\t targ r -> mk r $ Pragma_ExcludeIfTarget (mkRange1 t) (map tokMkStr $ concat targ)) + <$> pEXCLUDEIFTARGET_prag <*> pList1Sep pCOMMA (pList1 (conid <|> varid)) ) pPragma :: HSParser Pragma diff --git a/EHC/src/ehc/HS/Pragmas.cag b/EHC/src/ehc/HS/Pragmas.cag index e3da547ae..104b13076 100644 --- a/EHC/src/ehc/HS/Pragmas.cag +++ b/EHC/src/ehc/HS/Pragmas.cag @@ -22,6 +22,9 @@ SEM Pragma lhs . gathPragmas = Set.fromList $ catMaybes [ Map.lookup p Pragma.allSimplePragmaMp | p <- @pragmaNames ] | Derivable lhs . gathPragmas = Set.singleton (Pragma.Pragma_Derivable @className @fieldName @defaultName) + | ExcludeIfTarget + loc . targets = catMaybes $ map (\t -> Map.lookup t supportedTargetMp) @targetNames + lhs . gathPragmas = Set.singleton (Pragma.Pragma_ExcludeIfTarget @targets) SEM Module | Module diff --git a/EHC/src/ehc/HS/Pretty.cag b/EHC/src/ehc/HS/Pretty.cag index 102286934..95bc6a01b 100755 --- a/EHC/src/ehc/HS/Pretty.cag +++ b/EHC/src/ehc/HS/Pretty.cag @@ -139,6 +139,8 @@ SEM Pragma loc . pp = "LANGUAGE" >#< ppCommas @pragmas | Derivable loc . pp = "DERIVABLE" >#< @className >#< @fieldName >#< @defaultName + | ExcludeIfTarget + loc . pp = "EXCLUDE_IF_TARGET" >#< ppCommas @targetNames %%] %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% diff --git a/EHC/src/ehc/JScript.cag b/EHC/src/ehc/JScript.cag new file mode 100644 index 000000000..986dfc4ae --- /dev/null +++ b/EHC/src/ehc/JScript.cag @@ -0,0 +1,54 @@ +%%[0 +%include lhs2TeX.fmt +%include afp.fmt +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Haskell importable interface to JScript/AbsSyn +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jscript) hs module {%{EH}JScript} import({%{EH}Base.Common}) +%%] + +%%[(8 jscript) hs export(JScriptModule(..), Stat(..), StatL, NmExpr, NmExprL, Expr(..), ExprL, MbExpr, AGItf(..)) +%%] + +%%[(8 jscript) hs export(Alt(..), AltL) +%%] + +%%[(8 jscript) ag import({JScript/AbsSyn}) +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Instances +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jscript) hs +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Smart constructors +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jscript) hs export(jsVarDecl) +-- | declare a var, or a field in object, depending on name being qualified +jsVarDecl :: HsName -> Expr -> Stat +%%[[8 +jsVarDecl n e = Stat_VarDecl n (Just e) +%%][20 +jsVarDecl n e + = case hsnQualifier n of + Just _ -> Stat_Assign (Expr_Var n) e + _ -> Stat_VarDecl n (Just e) +%%]] +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Observations +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jscript) hs export(exprMbVar) +exprMbVar :: Expr -> Maybe HsName +exprMbVar (Expr_Var n) = Just n +exprMbVar _ = Nothing +%%] diff --git a/EHC/src/ehc/JScript/AbsSyn.cag b/EHC/src/ehc/JScript/AbsSyn.cag new file mode 100644 index 000000000..cf9e0f4a0 --- /dev/null +++ b/EHC/src/ehc/JScript/AbsSyn.cag @@ -0,0 +1,113 @@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Abstract syntax for JavaScript files +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[doesWhat doclatex +Representation of the subset of JavaScript required for UHC codegeneration. + +This AST and semantics are under construction. +%%] + +%%[(8 jscript) +DATA AGItf + | AGItf module : JScriptModule + +DATA JScriptModule + | Mod decls : StatL +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Statements +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jscript) +DATA Stat + | VarDecl nm : {HsName} + mbExpr : MbExpr + | FunDecl expr : Expr + | Assign to : Expr + expr : Expr + | Expr expr : Expr + | Block stats : StatL + | Throw expr : Expr + | Ret expr : Expr + | Switch expr : Expr + alts : AltL + | Break + +TYPE StatL = [Stat] +%%] + +%%[(8 jscript) +SET AllStat = StatL Stat +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Expressions +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jscript) +DATA Expr + | Var nm : {HsName} + | Int int : {Integer} + | Str str : {String} + | Char char : {Char} + | Sel expr : Expr + nm : {HsName} + | Call fun : Expr + args : ExprL + | New expr : Expr -- must be a Call + | Fun mbNm : {Maybe HsName} + args : {[HsName]} + body : Stat + | Arr elts : ExprL + | ArrInx arr : Expr + inx : Expr + | Obj elts : NmExprL + | ObjFld obj : Expr + fld : {HsName} + | This + | True + | False + | Inline str : {String} -- for debuggin + + +TYPE NmExpr = (HsName,Expr) +TYPE NmExprL = [NmExpr] + +TYPE ExprL = [Expr] +TYPE MbExpr = MAYBE Expr +%%] + +%%[(8 jscript) +SET AllExpr = ExprL Expr MbExpr NmExpr NmExprL +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Alternatives (of switch) +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jscript) +DATA Alt + | Alt tag : {Int} + stats : StatL + +TYPE AltL = [Alt] +%%] + +%%[(8 jscript) +SET AllAlt = Alt AltL +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Sets +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jscript) +SET AllNT + = AllStat + AllExpr + AllAlt + JScriptModule +%%] + diff --git a/EHC/src/ehc/JScript/Pretty.cag b/EHC/src/ehc/JScript/Pretty.cag new file mode 100644 index 000000000..9923c75ea --- /dev/null +++ b/EHC/src/ehc/JScript/Pretty.cag @@ -0,0 +1,112 @@ +%%[0 +%include lhs2TeX.fmt +%include afp.fmt +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Haskell importable interface to JScript pretty print +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jscript) hs module {%{EH}JScript.Pretty} import(EH.Util.Pretty,{%{EH}Base.Common},{%{EH}JScript}) +%%] + +%%[(8 jscript).WRAPPER ag import({JScript/AbsSyn}) +WRAPPER AGItf +%%] + +%%[(8 jscript) hs export(ppJScriptModule) +ppJScriptModule :: JScriptModule -> PP_Doc +ppJScriptModule ent + = let t = wrap_AGItf + (sem_AGItf (AGItf_AGItf ent)) + Inh_AGItf + in pp_Syn_AGItf t +%%] + +instance Show JScriptModule where + show t = "JScriptModule t" + +instance PP JScriptModule where + pp t = ppJScriptModule t + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Utilities & combinators +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jscript) hs +ppStat :: PP_Doc -> PP_Doc +ppStat x = x >|< ";" +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% JScript entity +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[(8 jscript) +ATTR + AGItf AllNT + - NmExprL NmExpr ExprL MbExpr StatL AltL + [ | | pp USE {>-<} {empty}: PP_Doc ] + +SEM Expr + | Var loc . pp = pp @nm + | Int loc . pp = pp $ show @int + | Str loc . pp = pp $ show @str + | Char loc . pp = pp $ show @char + | Sel loc . pp = @expr.pp >|< "." >|< @nm + | Call loc . pp = @fun.pp >|< ppParensCommas @args.ppL + -- | Fun loc . pp = "function" >|< maybe empty (\n -> " " >|< n) @mbNm >|< ppParensCommas @args >|< @body.pp + | Fun loc . pp = "function" >|< maybe empty (\n -> " " >|< n) @mbNm >|< ppParensCommas @args >-< @body.pp + | New loc . pp = "new" >#< @expr.pp + | Arr loc . pp = ppBracketsCommas @elts.ppL + | ArrInx loc . pp = {- ppParens -} @arr.pp >|< ppBrackets @inx.pp + | Obj loc . pp = ppCurlysCommas $ map (\(x,y) -> x >|< ":" >|< y) @elts.ppL + | ObjFld loc . pp = @obj.pp >|< "." >|< @fld + | This loc . pp = pp "this" + | True loc . pp = pp "true" + | False loc . pp = pp "false" + | Inline loc . pp = pp @str + +SEM Stat + -- | VarDecl lhs . pp = ppStat $ "var" >#< @nm >|< maybe empty (\e -> "=" >|< e ) @mbExpr.ppMb + | VarDecl lhs . pp = ppStat $ + case @mbExpr.ppMb of + Just e -> pp "var" >#< @nm >|< "=" >-< indent 1 e + _ -> pp "var" >#< @nm + | FunDecl lhs . pp = @expr.pp + -- | Assign lhs . pp = ppStat $ @nm >|< "=" >|< @expr.pp + | Assign lhs . pp = ppStat $ @to.pp >|< "=" >-< indent 1 @expr.pp + | Expr lhs . pp = ppStat $ @expr.pp + -- | Block lhs . pp = ppListSep "{" "}" "" @stats.ppL + | Block lhs . pp = ppCurlys $ vlist @stats.ppL + | Throw lhs . pp = ppStat $ "throw" >#< @expr.pp + | Ret loc . pp = ppStat $ "return" >#< @expr.pp + | Switch loc . pp = "switch" >|< ppParens @expr.pp >-< indent 1 (ppCurlys $ vlist @alts.ppL) + | Break loc . pp = ppStat $ pp "break" + +SEM Alt + | Alt lhs . pp = "case" >#< @tag >|< ":" >-< indent 1 (vlist @stats.ppL) + +SEM JScriptModule + | Mod lhs . pp = vlist @decls.ppL +%%] + +%%[(8 jscript) +SEM ExprL StatL AltL [ | | ppL: {[PP_Doc]} ] + | Cons lhs . ppL = @hd.pp : @tl.ppL + | Nil lhs . ppL = [] +%%] + +%%[(8 jscript) +ATTR NmExprL NmExpr [ | | ppL USE {++} {[]} : {[(HsName,PP_Doc)]} ] + +SEM NmExpr + | Tuple lhs . ppL = [(@x1, @x2.pp)] +%%] + +%%[(8 jscript) +SEM MbExpr [ | | ppMb: {Maybe PP_Doc} ] + | Just lhs . ppMb = Just @just.pp + | Nothing lhs . ppMb = Nothing +%%] + diff --git a/EHC/src/ehc/Opts.chs b/EHC/src/ehc/Opts.chs index a5da1732f..518af5a7b 100644 --- a/EHC/src/ehc/Opts.chs +++ b/EHC/src/ehc/Opts.chs @@ -116,14 +116,30 @@ tycoreOptMp %%% Derived options %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -These are there for (temporary) backwards compatibility. +Some are there for (temporary) backwards compatibility. -%%[(8 codegen grin) export(ehcOptFullProgAnalysis) --- do full GRIN program analysis -ehcOptFullProgAnalysis :: EHCOpts -> Bool -ehcOptFullProgAnalysis opts - = targetIsFullProgAnal (ehcOptTarget opts) - || ehcOptOptimizationScope opts >= OptimizationScope_WholeProgram +%%[(20 codegen) export(ehcOptWholeProgOptimizationScope) +-- do something with whole program +ehcOptWholeProgOptimizationScope :: EHCOpts -> Bool +ehcOptWholeProgOptimizationScope opts + = ehcOptOptimizationScope opts >= OptimizationScope_WholeGrin +%%] + +%%[(20 codegen) export(ehcOptEarlyModMerge) +-- compatibility option +ehcOptEarlyModMerge :: EHCOpts -> Bool +ehcOptEarlyModMerge opts + = ehcOptOptimizationScope opts >= OptimizationScope_WholeCore +%%] + +%%[(8 codegen grin) export(ehcOptWholeProgHPTAnalysis) +-- do whole program analysis, with HPT +ehcOptWholeProgHPTAnalysis :: EHCOpts -> Bool +ehcOptWholeProgHPTAnalysis opts + = targetDoesHPTAnalysis (ehcOptTarget opts) +%%[[20 + || ehcOptWholeProgOptimizationScope opts +%%]] %%] %%[(8 codegen grin) export(ehcOptErrAboutBytecode) @@ -173,14 +189,14 @@ ehcOptEmitCLR = targetIsCLR . ehcOptTarget -- generate Core ehcOptEmitCore :: EHCOpts -> Bool ehcOptEmitCore opts - = ehcOptFullProgAnalysis opts || targetIsCore (ehcOptTarget opts) + = ehcOptWholeProgHPTAnalysis opts || targetIsCore (ehcOptTarget opts) %%] %%[(8 codegen tycore) export(ehcOptEmitTyCore,ehcOptTyCore) -- generate TyCore ehcOptEmitTyCore :: EHCOpts -> Bool ehcOptEmitTyCore opts - = {- ehcOptFullProgAnalysis opts || -} targetIsTyCore (ehcOptTarget opts) + = {- ehcOptWholeProgHPTAnalysis opts || -} targetIsTyCore (ehcOptTarget opts) ehcOptTyCore :: EHCOpts -> Bool ehcOptTyCore opts = ehcOptEmitTyCore opts || isJust (ehcOptUseTyCore opts) @@ -275,7 +291,7 @@ ehcCmdLineOpts , Option "" ["gen-trace-assign"] (boolArg optSetGenTrace2) "trace assignments in C (no)" , Option "" ["gen-rtsinfo"] (ReqArg oRTSInfo "") "flags for rts info dumping (default=0)" , Option "" ["dump-grin-stages"] (boolArg optDumpGrinStages) "dump intermediate Grin and Silly transformation stages (no)" - , Option "" ["early-mod-merge"] (boolArg optEarlyModMerge) "merge modules early, at Core stage (no)" +-- , Option "" ["early-mod-merge"] (boolArg optEarlyModMerge) "merge modules early, at Core stage (no)" %%][100 %%]] %%[[(8 codegen java) @@ -405,7 +421,11 @@ ehcCmdLineOpts oTarget _ o = o %%][(8 codegen) oTarget s o = o { ehcOptTarget = target - , ehcOptOptimizationScope = if targetIsFullProgAnal target then OptimizationScope_WholeProgram else oscope +%%[[20 + , ehcOptOptimizationScope = if targetDoesHPTAnalysis target + then max oscope OptimizationScope_WholeGrin + else oscope +%%]] } where target = Map.findWithDefault defaultTarget s supportedTargetMp oscope = ehcOptOptimizationScope o @@ -434,14 +454,14 @@ ehcCmdLineOpts %%[[(8 codegen grin) Just "grin" -> o -- { ehcOptEmitGrin = True } Just "bc" -> o -- { ehcOptEmitBytecode = True - -- , ehcOptFullProgAnalysis = False + -- , ehcOptWholeProgHPTAnalysis = False -- } Just m | m `elem` ["bexe","bexec"] -> o { ehcOptTarget = Target_Interpreter_Grin_C } Just "c" -> o -- { ehcOptEmitC = True - -- , ehcOptFullProgAnalysis = True + -- , ehcOptWholeProgHPTAnalysis = True -- , ehcOptEmitExecBytecode = False -- , ehcOptEmitBytecode = False -- , ehcOptErrAboutBytecode = False @@ -452,7 +472,7 @@ ehcCmdLineOpts } Just "llvm" -> o -- { ehcOptEmitLLVM = True - -- , ehcOptFullProgAnalysis = True + -- , ehcOptWholeProgHPTAnalysis = True -- , ehcOptEmitExecBytecode = False -- , ehcOptEmitBytecode = False -- , ehcOptErrAboutBytecode = False @@ -498,14 +518,28 @@ ehcCmdLineOpts = o' {ehcOptOptimizations = optimizeRequiresClosure os} where (o',doSetOpts) = case ms of - Just olevel@(c:_) | isDigit c && l >= 0 && l < (maxsc * maxlev) - -> ( o { ehcOptOptimizationLevel = toEnum lev, ehcOptOptimizationScope = toEnum sc } - , True - ) + Just (clevel:',':cscope:_) + | isJust mbO -> (fromJust mbO o, True) + where mbO = mbLevelScope (Just clevel) (Just cscope) + Just (',':cscope:_) + | isJust mbO -> (fromJust mbO o, True) + where mbO = mbLevelScope Nothing (Just cscope) + {- + Just olevel@(clevel:',':cscope:_) + | isDigit clevel && isDigit cscope && l >= 0 && l < maxlev && s >= 0 && s < maxscp + -> ( o { ehcOptOptimizationLevel = toEnum l, ehcOptOptimizationScope = toEnum s } + , True + ) + where l = read [clevel] :: Int + s = read [cscope] :: Int + -} + Just olevel@(clevel:_) + | isDigit clevel && l >= 0 && l < (maxscp * maxlev) + -> ( o { ehcOptOptimizationLevel = toEnum lev, ehcOptOptimizationScope = toEnum sc } + , True + ) where l = read olevel :: Int (sc,lev) = quotRem l maxlev - maxlev = fromEnum (maxBound :: OptimizationLevel) + 1 - maxsc = fromEnum (maxBound :: OptimizationScope) + 1 Just optname@(_:_) -> case break (== '=') optname of (nm, yesno) @@ -522,6 +556,19 @@ ehcCmdLineOpts _ -> (o, False) os | doSetOpts = Map.findWithDefault Set.empty (ehcOptOptimizationLevel o') optimizationLevelMp | otherwise = ehcOptOptimizations o' + maxlev = fromEnum (maxBound :: OptimizationLevel) + 1 + maxscp = fromEnum (maxBound :: OptimizationScope) + 1 + {- + -} + mbLevelScope ml ms + | isJust l && isJust s = Just (\o -> o { ehcOptOptimizationLevel = toEnum (fromJust l), ehcOptOptimizationScope = toEnum (fromJust s) }) + | otherwise = Nothing + where l = r ehcOptOptimizationLevel maxlev ml + s = r ehcOptOptimizationScope maxscp ms + r dflt mx m + | x >= 0 && x < mx = Just x + | otherwise = Nothing + where x = (maybe (fromEnum $ dflt o) (\c -> read [c]) m) :: Int %%]] %%]] %%[[9 @@ -640,7 +687,7 @@ optSetGenCaseDefault o b = o { ehcOptGenCaseDefault = b } optSetGenCmt o b = o { ehcOptGenCmt = b } optSetGenDebug o b = o { ehcOptGenDebug = b } optDumpGrinStages o b = o { ehcOptDumpGrinStages = b {-, ehcOptEmitGrin = b -} } -optEarlyModMerge o b = o { ehcOptEarlyModMerge = b } +-- optEarlyModMerge o b = o { ehcOptEarlyModMerge = b } %%] %%[(20 codegen) diff --git a/EHC/src/ehc/Opts/Base.chs b/EHC/src/ehc/Opts/Base.chs index e8b2ebe8b..3ad24a861 100644 --- a/EHC/src/ehc/Opts/Base.chs +++ b/EHC/src/ehc/Opts/Base.chs @@ -161,7 +161,7 @@ data EHCOpts , ehcOptGenRTSInfo :: Int -- flags to tell rts to dump internal info, currently: 1=on , ehcOptDumpGrinStages :: Bool -- dump intermediate Grin transformation stages - , ehcOptEarlyModMerge :: Bool -- produce OneBigCore instead of OneBigGrin; useful for future Core-only optimizations + -- , ehcOptEarlyModMerge :: Bool -- produce OneBigCore instead of OneBigGrin; useful for future Core-only optimizations %%]] %%[[8 , ehcOptEmitHS :: Bool @@ -283,7 +283,7 @@ emptyEHCOpts , ehcOptGenRTSInfo = 0 , ehcOptDumpGrinStages = False - , ehcOptEarlyModMerge = False + -- , ehcOptEarlyModMerge = False %%]] %%[[8 , ehcOptVerbosity = VerboseNormal diff --git a/EHC/src/ehc/Scanner/Common.chs b/EHC/src/ehc/Scanner/Common.chs index 6d4a1196d..e409b2d65 100644 --- a/EHC/src/ehc/Scanner/Common.chs +++ b/EHC/src/ehc/Scanner/Common.chs @@ -941,17 +941,19 @@ tokKeywStrsHS94 = [ "unsafe", "threadsafe", "dynamic" ] pLANGUAGE_prag , -- pOPTIONSGHC_prag , pDERIVABLE_prag , + pEXCLUDEIFTARGET_prag, pOPRAGMA , pCPRAGMA :: IsParser p Token => p Token pLANGUAGE_prag = pKeyTk "LANGUAGE" pDERIVABLE_prag = pKeyTk "DERIVABLE" +pEXCLUDEIFTARGET_prag = pKeyTk "EXCLUDE_IF_TARGET" -- pOPTIONSGHC_prag = pKeyTk "OPTIONS_GHC" pOPRAGMA = pKeyTk "{-#" pCPRAGMA = pKeyTk "#-}" -tokPragmaStrsHS99= [ "LANGUAGE", "DERIVABLE" {-, "OPTIONS_GHC" , "INLINE", "NOINLINE", "SPECIALIZE" -} ] +tokPragmaStrsHS99= [ "LANGUAGE", "DERIVABLE", "EXCLUDE_IF_TARGET" {-, "OPTIONS_GHC" , "INLINE", "NOINLINE", "SPECIALIZE" -} ] %%] pDEPRECATED_prag = pKeyTk "deprecated_prag" diff --git a/EHC/src/ehc/TyCore/Base.chs b/EHC/src/ehc/TyCore/Base.chs index 00b2cab28..b54704f87 100644 --- a/EHC/src/ehc/TyCore/Base.chs +++ b/EHC/src/ehc/TyCore/Base.chs @@ -90,16 +90,6 @@ metasMapVal :: (MetaVal -> MetaVal) -> Metas -> Metas metasMapVal f (b,v) = (b,f v) %%] -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%%% Context: what is above/below -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -%%[(8888 codegen tycore) hs export(WhatExpr(..)) -data WhatExpr - = ExprIsLam | ExprIsApp | ExprIsVar HsName | ExprIsInt Int | ExprIsOther - deriving Eq -%%] - %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Context: strictness as required by context %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% diff --git a/EHC/src/ehc/TyCore/ToCore.cag b/EHC/src/ehc/TyCore/ToCore.cag index 5db756ead..2f68def7b 100644 --- a/EHC/src/ehc/TyCore/ToCore.cag +++ b/EHC/src/ehc/TyCore/ToCore.cag @@ -253,7 +253,7 @@ SEM PatRest ATTR AllFldBind [ | | l0CoreL USE {++} {[]} : CPatFldL ] SEM FldBind - | Fld lhs . l0CoreL = [CPatFld_Fld hsnUnknown @offset.core @nm] + | Fld lhs . l0CoreL = [CPatFld_Fld hsnUnknown @offset.core @nm []] %%] %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% diff --git a/EHC/src/ehc/files-ag-d.dep b/EHC/src/ehc/files-ag-d.dep index a06c62c4f..234c37a37 100644 --- a/EHC/src/ehc/files-ag-d.dep +++ b/EHC/src/ehc/files-ag-d.dep @@ -4,6 +4,7 @@ Ty Core TyCore JVMClass +JScript Foreign GrinCode GrinByteCode diff --git a/EHC/src/ehc/files-ag-s.dep b/EHC/src/ehc/files-ag-s.dep index b01d9953a..b14b8e6db 100644 --- a/EHC/src/ehc/files-ag-s.dep +++ b/EHC/src/ehc/files-ag-s.dep @@ -28,12 +28,15 @@ TyCore/ToCore.cag TyCore/SubstApply.cag TyCore/Check.cag JVMClass/ToBinary.cag +JScript/Pretty.cag Error/Pretty.cag Core/ToGrin.cag Core/ToJazy.cag +Core/ToJScript.cag Core/Pretty.cag Core/Subst.cag Core/FvS.cag +Core/ModAsMap.cag Core/UsedModNms.cag Core/Trf/ConstProp.cag Core/Trf/EtaRed.cag diff --git a/EHC/src/ehc/files1.mk b/EHC/src/ehc/files1.mk index abd324cf0..5eab12844 100644 --- a/EHC/src/ehc/files1.mk +++ b/EHC/src/ehc/files1.mk @@ -61,7 +61,7 @@ EHC_HS_UTIL_SRC_CHS := $(patsubst %,$(SRC_EHC_PREFIX)%.chs,\ $(addprefix Cil/,Common TyTag) \ $(addprefix Opts/,Base) \ $(addprefix Pred/,ToCHR CHR Evidence EvidenceToCore EvidenceToTyCore Heuristics CommonCHR RedGraph) \ - $(addprefix Base/,UID Parser Parser2 Pragma Binary Serialize Strictness GenC Hashable Target BasicAnnot Common Builtin Builtin2 HsName Debug Trie CfgPP LaTeX HtmlCommon Bits FileSearchLocation PackageDatabase ParseUtils Optimize) \ + $(addprefix Base/,UID Parser Parser2 Pragma Binary Serialize Strictness GenC GenJavaLike Hashable Target BasicAnnot Common Builtin Builtin2 HsName Debug Trie CfgPP LaTeX HtmlCommon Bits FileSearchLocation PackageDatabase ParseUtils Optimize) \ $(addprefix Scanner/,Common Machine Scanner Token TokenParser) \ $(addsuffix /Parser,Ty EH HS Foreign Core GrinCode) \ $(addprefix Ty/,FIEnv FIEnv2 FitsInCommon FitsInCommon2 FitsIn Utils1 Utils2 AppSpineGam Trf/BetaReduce) \ @@ -73,7 +73,7 @@ EHC_HS_UTIL_SRC_CHS := $(patsubst %,$(SRC_EHC_PREFIX)%.chs,\ $(addprefix EHC/,Common Environment CompileUnit CompileGroup CompileRun GrinCompilerDriver InitialSetup \ $(addprefix CompilePhase/,Parsers Output Translations Transformations \ FlowBetweenPhase TransformGrin Semantics \ - CompileLLVM CompileC CompileJVM Link \ + CompileLLVM CompileC CompileJVM CompileJScript Link \ Cleanup Module TopLevelPhases \ ) ) \ Debug/HighWaterMark \ @@ -435,6 +435,11 @@ $(EHC_HS_CFGINSTALL_DRV_HS): $(EHC_MKF) $(MK_SHARED_MKF) echo "" ; \ echo "mkJarFilename dirprefix pkg = \"$(call FUN_MK_JAVALIB_FILENAME,\" ++ dirprefix ++ \",\" ++ pkg ++ \")\"" ; \ echo "" ; \ + if test x$(ENABLE_JSCRIPT) = xyes ; \ + then \ + echo "mkJScriptLibFilename dirprefix pkg = \"$(call FUN_MK_JSLIB_FILENAME,\" ++ dirprefix ++ \",\" ++ pkg ++ \")\"" ; \ + echo "" ; \ + fi ; \ echo "mkInternalPkgFileBase pkg variant target tvariant = \"$(call FUN_PKG_VARIANT_TARGET_TVARIANT,\" ++ pkg ++ \",\" ++ variant ++ \",\" ++ target ++ \",\" ++ tvariant ++ \")\"" ; \ echo "" ; \ echo "mkPkgIncludeDir libdirprefix = \"$(call FUN_MK_PKG_INC_DIR,\" ++ libdirprefix ++ \")\"" ; \ diff --git a/EHC/src/ehc/files2.mk b/EHC/src/ehc/files2.mk index 172c6b136..04aa32c33 100644 --- a/EHC/src/ehc/files2.mk +++ b/EHC/src/ehc/files2.mk @@ -79,6 +79,8 @@ ehc-codegentargetspecific-C: ehc-codegentargetspecific-jazy: +ehc-codegentargetspecific-jscript: + ehc-codegentargetspecific-core: ehc-codegentargetspecific-clr: diff --git a/EHC/src/ehc/variant.mk b/EHC/src/ehc/variant.mk index bbd9880d8..8720c2fa4 100644 --- a/EHC/src/ehc/variant.mk +++ b/EHC/src/ehc/variant.mk @@ -6,19 +6,10 @@ # aspects, EHC_ASPECTS to be configured at top level, for now here ########################################################################################### -EHC_ASPECTS := $(if $(ASPECTS),$(ASPECTS),base hmtyinfer codegen grin noHmTyRuler $(if $(ENABLE_JAVA),java jazy,) $(if $(ENABLE_LLVM),llvm,) $(if $(ENABLE_CLR),clr,) $(if $(ENABLE_TYCORE),tycore,) $(if $(ENABLE_TAUPHI),tauphi,)) +EHC_ASPECTS := $(if $(ASPECTS),$(ASPECTS),base hmtyinfer codegen grin noHmTyRuler $(if $(ENABLE_JAVA),java jazy,) $(if $(ENABLE_LLVM),llvm,) $(if $(ENABLE_JSCRIPT),jscript,) $(if $(ENABLE_CLR),clr,) $(if $(ENABLE_TYCORE),tycore,) $(if $(ENABLE_TAUPHI),tauphi,)) EHC_ASPECTS_SUFFIX := $(if $(ASPECTS),-$(subst $(space),-,$(ASPECTS)),) EHC_ASPECTS_SUFFIX2 := $(subst -,,$(EHC_ASPECTS_SUFFIX)) -########################################################################################### -# config depending on EHC_ASPECTS, EHC_VARIANT: Booleans telling whether some aspect is used -########################################################################################### - -EHC_CFG_USE_GRIN := $(filter grin,$(EHC_ASPECTS)) -EHC_CFG_USE_CODEGEN := $(filter $(EHC_VARIANT),$(EHC_CODE_VARIANTS)) -EHC_CFG_USE_PRELUDE := $(filter $(EHC_VARIANT),$(EHC_PREL_VARIANTS) $(EHC_OTHER_PREL_VARIANTS)) -EHC_CFG_IS_A_VARIANT := $(filter $(EHC_VARIANT),$(EHC_VARIANTS)) - ########################################################################################### # variant, EHC_VARIANT to be configured at top level, by a recursive make invocation ########################################################################################### @@ -79,12 +70,35 @@ LIB_EHC_INS_FLAG := $(INSTALLFORBLDABS_FLAG_PREFIX)$(LIB_EHC_PKG_NAME) EHC_BASE := $(LIB_EHC_BASE)C +########################################################################################### +# config depending on EHC_ASPECTS, EHC_VARIANT: Booleans telling whether some aspect is used +########################################################################################### + +# backend uses UNIX/C facilities (or emulation thereof) +# this should coincide with targetIsOnUnixAndOrC in src/ehc/Base/Target +EHC_CFG_USE_UNIX_AND_C := $(filter $(EHC_VARIANT_TARGET),C bc jazy) + +# grin is used? +EHC_CFG_USE_GRIN := $(filter grin,$(EHC_ASPECTS)) + +# variant does codegeneration? +EHC_CFG_USE_CODEGEN := $(filter $(EHC_VARIANT),$(EHC_CODE_VARIANTS)) + +# variant uses prelude +EHC_CFG_USE_PRELUDE := $(filter $(EHC_VARIANT),$(EHC_PREL_VARIANTS) $(EHC_OTHER_PREL_VARIANTS)) + +# +EHC_CFG_IS_A_VARIANT := $(filter $(EHC_VARIANT),$(EHC_VARIANTS)) + ########################################################################################### # ehc runtime config ########################################################################################### -# assumed packages, useful only for prelude variants -EHC_PACKAGES_ASSUMED := uhcbase base array filepath old-locale old-time unix directory random haskell98 +# assumed packages, useful only for prelude variants; order matters. +# EHC_PACKAGES_ALL := uhcbase base array filepath old-locale old-time unix directory random haskell98 +EHC_PACKAGES_ASSUMED := uhcbase base array \ + $(if $(EHC_CFG_USE_UNIX_AND_C),filepath old-locale old-time unix directory random,) \ + haskell98 ########################################################################################### # installation locations for ehc building time diff --git a/EHC/src/jscript/core/interpreter.cjs b/EHC/src/jscript/core/interpreter.cjs new file mode 100644 index 000000000..917285c0a --- /dev/null +++ b/EHC/src/jscript/core/interpreter.cjs @@ -0,0 +1,458 @@ + +%%[(8 jscript).debugStuff +var traceOn = false ; + +function trace( m, s ) { + if ( traceOn ) { + console.log(m + ": " + s) ; + } +} + +var evalCounter = 0 ; +var nodeCounter = 0 ; +%%] + +%%[(100 jscript) -8.debugStuff +%%] + +// interface to eval +%%[(8 jscript) +function _e_( x ) { +%%[[8 + trace( "> _e_", x ) ; +%%][100 +%%]] + while ( x && x.__eOrV__ ) { + if ( typeof x.__eOrV__ == 'function' ) { +%%[[8 + trace( ">> _e_()", typeof x + "/" + typeof x.__eOrV__ + ":" + x ) ; +%%][100 +%%]] + x = x.__eOrV__() ; +%%[[8 + trace( "<< _e_()", typeof x + "/" + typeof x.__eOrV__ + ":" + x ) ; +%%][100 +%%]] + } else { +%%[[8 + trace( ">> _e_", typeof x + "/" + typeof x.__eOrV__ + ":" + x ) ; +%%][100 +%%]] + x = x.__eOrV__ ; +%%[[8 + trace( "<< _e_", typeof x + "/" + typeof x.__eOrV__ + ":" + x ) ; +%%][100 +%%]] + } + } +%%[[8 + ++evalCounter ; + trace( "< _e_", x ) ; +%%][100 +%%]] + return x ; +} + +// Apply node, not enough args +_A_undersat_.prototype = { + __aN__ : function ( args ) { + var needs = this.needsNrArgs() ; + if ( args.length < needs ) { + return new _A_undersat_( this, args ) ; + } else if ( args.length == needs ) { +%%[[8 + trace("> _A_undersat_.__aN__(=sat)", this + "(|args#" + args.length + "=(|" + args + "|)|)") ; +%%][100 +%%]] + return this.fun.__aN__( this.args.concat( args ) ) ; + } else { +%%[[8 + trace("> _A_undersat_.__aN__(>sat)", this + "(|args#" + args.length + "=(|" + args.slice( 0, needs ) + "|)+(|" + args.slice( needs ) + "|)|)") ; +%%][100 +%%]] + var fun = _e_( this.__aN__( args.slice( 0, needs ) ) ) ; + return { + __eOrV__ : function() { + return fun.__aN__( args.slice( needs ) ) ; + } } ; + } + } , + needsNrArgs : function() { + return this.fun.needsNrArgs() - this.args.length ; + } , +%%[[8 + getName : function () { + return "A-" + this.needsNrArgs() + "#" + this.nodeId + "'" ; + } , + toString : function () { + return "(" + this.getName() + "=" + this.fun + "@" + this.args + ")" ; + } +%%][100 +%%]] +} +function _A_undersat_( fun, args ) { + // this.needs = fun.needs - args.length ; + this.fun = fun ; + this.args = args ; +%%[[8 + this.nodeId = ++nodeCounter ; +%%][100 +%%]] +} + +// Apply node, unknown how much is missing or too much +_A_.prototype = { + __aN__ : function ( args ) { + var fun = _e_(this) ; + return { + __eOrV__ : function() { + return fun.__aN__( args ) ; + } } ; + } , +%%[[8 + getName : function () { + return "A" + this.args.length + "#" + this.nodeId + "'" + this.fun.getName() ; + } , + getVal : function () { + return "V#" + this.nodeId + "'" + this.__eOrV__ ; + } , + toString : function () { + if ( typeof this.__eOrV__ == 'function' ) { + return "(" + this.getName() + "@args#" + this.args.length + "=(|" + this.args + "|))" ; + } else { + return "(" + this.getVal() + ")" ; + } + } +%%][100 +%%]] +} +function _A_( fun, args ) { + this.__eOrV__ = function() { +%%[[8 + trace("> _A_.__eOrV__", fun + "(|args#" + args.length + "=" + args + "|)") ; +%%][100 +%%]] + // var x = _e_( fun.__aN__( args ) ) ; + var x = ( fun.__aN__( args ) ) ; + this.__eOrV__ = x ; +%%[[8 + trace("< _A_.__eOrV__", fun + "(|args#" + args.length + "=" + args + "|)") ; + trace("< ->", this + " -> " + x) ; +%%][100 +%%]] + return x ; + } +%%[[8 + this.fun = fun ; + this.args = args ; + this.nodeId = ++nodeCounter ; +%%][100 +%%]] +} + +// Function node +_F_.prototype = { + __aN__ : function ( args ) { + if ( args.length < this.needs ) { + return new _A_undersat_( this, args ) ; + } else if ( args.length == this.needs ) { +%%[[8 + trace( "> _F_.__aN__(=sat)", this + "(|args#" + args.length + "=" + args + "|)") ; +%%][100 +%%]] + var x = this.__evN__.apply( null, args ) ; +%%[[8 + trace( "< _F_.__aN__(=sat)", this + "(|args#" + args.length + "=" + args + "|)") ; + trace( "< ->", x) ; +%%][100 +%%]] + return x ; + } else { +%%[[8 + trace( "> _F_.__aN__(>sat)", this + "(|needs#" + this.needs + "args#" + args.length + "=" + args + "|)") ; +%%][100 +%%]] + var fun = _e_( this.__evN__.apply( null, args.slice( 0, this.needs ) ) ) ; + var remargs = args.slice( this.needs ) ; +%%[[8 + trace( "< _F_.__aN__(>sat)", fun + "(|needs#" + this.needs + "remargs#" + remargs.length + "=" + remargs + "|)") ; + trace( "< ->", fun) ; +%%][100 +%%]] + return { + __eOrV__ : function() { + return fun.__aN__( remargs ) ; + } } ; + } + } , + needsNrArgs : function() { + return this.needs ; + } , +%%[[8 + getName : function () { + return "F" + this.needs + "#" + this.nodeId + "'" + this.name ; + } , + toString : function () { + return "(" + this.getName() + ")" ; + } +%%][100 +%%]] +} +%%[[8 +function _F_( name, evalN ) { +%%][100 +function _F_( evalN ) { +%%]] + this.needs = evalN.length ; + this.__evN__ = evalN ; +%%[[8 + this.name = name ; + this.nodeId = ++nodeCounter ; +%%][100 +%%]] +} +%%] + +%%[8 +%%] +// function construction wrappers +function _f_(f) { + return new _F_(f) ; +} + +%%[8 +%%] +// strict application wrappers +function _e1_(f,a) { + return _e_( f.__aN__([a]) ) ; +} + +function _e2_(f,a,b) { + return _e_( f.__aN__([a,b]) ) ; +} + +function _e3_(f,a,b,c) { + return _e_( f.__aN__([a,b,c]) ) ; +} + +function _e4_(f,a,b,c,d) { + return _e_( f.__aN__([a,b,c,d]) ) ; +} + +function _e5_(f,a,b,c,d,e) { + return _e_( f.__aN__([a,b,c,d,e]) ) ; +} + +function _eN_(f,a) { + return _e_( f.__aN__(a) ) ; +} + +%%[8 +// lazy application wrappers +function _a0_(f) { + return new _A_(f,[]) ; +} +%%] + +function _a1_(f,a) { + return new _A_(f,[a]) ; +} + +function _a2_(f,a,b) { + return new _A_(f,[a,b]) ; +} + +function _a3_(f,a,b,c) { + return new _A_(f,[a,b,c]) ; +} + +function _a4_(f,a,b,c,d) { + return new _A_(f,[a,b,c,d]) ; +} + +function _a5_(f,a,b,c,d,e) { + return new _A_(f,[a,b,c,d,e]) ; +} + +function _aN_(f,a) { + return new _A_(f,a) ; +} + +%%[8 +// indirection +function _i_() { + return new _A_(function(){throw "_i_: attempt to prematurely evaluate indirection";},[]) ; +} + +function _i_set_(i,x) { + i.__eOrV__ = x ; +} +%%] + +// setup +function init() { +} + +function cons(x,y) { return [0,x,y]; } +function head(l) { return l[1]; } +function tail(l) { return l[2]; } +var nil = [1] ; +function isNil(x) { return x[0] == 1 ; } + + +function show( x ) { + var x = _e_(x) ; + document.write( ""+_e_(x) ) ; +} + +function showList( l ) { + var list = _e_(l) ; + switch (list[0]) { + case 0 : + document.write( _e_(head(list)) + ":" ) ; + showList( tail(list) ) ; + break ; + case 1 : + document.write( "[]" ) ; + break ; + } +} + +// test: sieve +function testSieve() { + var id = _f_( function(a) { + // trace( "id: " + a ) ; + return a ; + } ) ; + var even = _f_( function(a) { + // return __e__(a[0]) % 2 == 0 ; + return _a2_( eq, _a2_( mod, a, 2 ), 0 ) ; + } ) ; + var eq = _f_( function(a,b) { + return _e_(a) == _e_(b) ; + } ) ; + var ne = _f_( function(a,b) { + return _e_(a) != _e_(b) ; + } ) ; + var add = _f_( function(a,b) { + return _e_(a) + _e_(b) ; + } ) ; + var sub = _f_( function(a,b) { + return _e_(a) - _e_(b) ; + } ) ; + var mul = _f_( function(a,b) { + return _e_(a) * _e_(b) ; + } ) ; + var div = _f_( function(a,b) { + return Math.floor ( _e_(a) / _e_(b) ) ; + } ) ; + var mod = _f_( function(a,b) { + return ( _e_(a) % _e_(b) ) ; + } ) ; + var from = _f_( function(a) { + return cons( a, _a1_( from, _a2_( add, a, 1 ) ) ) ; + } ) ; + var last = _f_( function(a) { + var list = _e_(a) ; + switch (list[0]) { + case 0 : + var list2 = _e_(tail(list)) ; + switch (list2[0]) { + case 0 : + return _a1_( last, tail(list) ) ; + case 1 : + return head(list) ; + } + case 1 : + return undefined ; + } + } ) ; + var take = _f_( function(a,b) { + var len = _e_(a) ; + var list = _e_(b) ; + if ( len <= 0 || isNil(list) ) { + return nil ; + } else { + return cons( head(list), _a2_( take, _a2_( sub, len, 1 ), tail(list) ) ) ; + } + } ) ; + var filter = _f_( function(a,b) { + var list = _e_(b) ; + var test = _e1_( a, head(list) ) ; + if ( test ) { + return cons( head(list), _a2_( filter, a, tail(list) ) ) ; + } else { + return _a2_( filter, a, tail(list) ) ; + } + } ) ; + var notMultiple = _f_( function(a,b) { + return _a2_( ne, _a2_( mul, _a2_( div, b, a), a ), b ) ; + } ) ; + var notMultiple2 = _f_( function(a,b) { + var x = _e_(a) ; + var y = _e_(b) ; + return (Math.floor(y / x) * x) != y ; + } ) ; + var sieve = _f_( function(a) { + var list = _e_(a) ; + return cons( head(list), _a1_( sieve, _a2_( filter, _a1_( notMultiple2, head(list) ), tail(list) ) ) ) ; + } ) ; + var sieve2 = _f_( function(nmz,a) { + var list = _e_(a) ; + return cons( head(list), _a2_( sieve2, _a1_( id, nmz ), _a2_( filter, _a1_( nmz, head(list) ), tail(list) ) ) ) ; + } ) ; + var mainSieve = _a2_( take, 1000, _a1_( sieve, _a1_( from, 2 ) ) ) ; + var mainSieve2 = _a2_( take, 500, _a2_( sieve2, _a1_( id, notMultiple2 ), _a1_( from, 2 ) ) ) ; + + // running it... + evalCounter = 0 ; + var d = new Date() ; + var t1 = d.getTime() ; + // showList( mainSieve ) ; + show( _a1_( last, mainSieve ) ) ; + d = new Date() ; + var t2 = d.getTime() - t1 ; + document.write("
time= " + t2 + " ms" + ((evalCounter>0) ? ", nreval= " + evalCounter + ", ms/ev= " + (t2/evalCounter) : "") + "
") ; +} + +function testMisc() { + trace("load & init ok") ; + var plus = _f_( function(a,b){return _e_(a)+_e_(b);}) ; + trace("plus: " + plus) ; + var inc1 = _f_( function(a){trace("inc: " + a) ; var x = _e_(a) ; return x+1;}) ; + trace("inc1: " + inc1) ; + var inc2 = plus.__aN__([10]) ; + trace("inc2: " + inc2) ; + var two1 = 2 ; + // var two2 = new AppN_WHNF(2) ; + var two3 = new _A_(new _F_(0,function(){return 2;}),[]) ; + var arr = [two1] ; + // trace("two2: " + two2) ; + trace("two3: " + two3) ; + trace("two3 eval: " + _e_(two3)) ; + trace("two3: " + two3) ; + trace("two3 eval: " + _e_(two3)) ; + trace("arr: " + arr) ; + var x1 = inc2.__aN__( arr ) ; + trace("inc 2: " + x1) ; + var x2 = new _A_( inc2, arr ) ; + trace("inc del 2: " + x2) ; + trace("inc del 2 eval: " + _e_(x2)) ; +} + +function tryOut() { + var f = function(a,b) {} ; + var l = cons(1,nil) ; + // trace(ToPropertyDescriptor(f)) ; + // trace(ToPropertyDescriptor(Function)) ; + // trace(ToPropertyDescriptor("a")) ; + // trace(ToPropertyDescriptor(String)) ; + trace("f "+f.length) ; +} + +function main() { + init() ; + // testMisc() ; + // tryOut() ; + testSieve() ; +} diff --git a/EHC/src/jscript/files.mk b/EHC/src/jscript/files.mk new file mode 100644 index 000000000..116c595a1 --- /dev/null +++ b/EHC/src/jscript/files.mk @@ -0,0 +1,75 @@ +########################################################################################### +# location of these srcs +########################################################################################### + +SRC_JSCRIPT_PREFIX := $(SRC_PREFIX)jscript/ + +########################################################################################### +# this file +########################################################################################### + +JSCRIPT_MKF := $(patsubst %,$(SRC_JSCRIPT_PREFIX)%.mk,files) + +########################################################################################### +# build location +########################################################################################### + +JSCRIPT_BLD_JSCRIPT_PREFIX := $(EHC_BLD_VARIANT_ASPECTS_PREFIX)jscript/ + +########################################################################################### +# install location, config +########################################################################################### + +# js package +JSCRIPT_PKG_NAME := $(RTS_PKG_NAME) +JSCRIPT_PKG_CORE_NAME := core +JSCRIPT_PKG_RTS_NAME := rts +JSCRIPT_PKG_EHC_NAME := uhc +JSCRIPT_PKG_CORE_DIRNAME := $(JSCRIPT_PKG_CORE_NAME) +JSCRIPT_PKG_UHC_DIRNAME := $(JSCRIPT_PKG_UHC_NAME) + +# install location +INSTALLABS_JSCRIPT_LIB_PREFIX := $(call FUN_INSTALLABS_VARIANT_LIB_TARGET_PREFIX,$(EHC_VARIANT_ASPECTS),$(EHC_VARIANT_TARGET)) + +# install +INSTALL_LIB_JSCRIPT := $(call FUN_MK_JSLIB_FILENAME,$(INSTALLABS_JSCRIPT_LIB_PREFIX),$(JSCRIPT_PKG_NAME)) + +########################################################################################### +# names of sources + deriveds +########################################################################################### + +# sources +JSCRIPT_JS_JSCRIPT_SRC_JS := $(wildcard $(SRC_JSCRIPT_PREFIX)$(JSCRIPT_PKG_CORE_DIRNAME)/*.js) +JSCRIPT_JS_JSCRIPT_SRC_CJS = $(wildcard $(SRC_JSCRIPT_PREFIX)$(JSCRIPT_PKG_CORE_DIRNAME)/*.cjs) \ + $(wildcard $(SRC_JSCRIPT_PREFIX)$(JSCRIPT_PKG_RTS_NAME)/*.cjs) \ + $(wildcard $(SRC_JSCRIPT_PREFIX)$(JSCRIPT_PKG_UHC_DIRNAME)/*.cjs) + +# derived +JSCRIPT_JS_JSCRIPT_DRV_JS := $(patsubst $(SRC_JSCRIPT_PREFIX)%.cjs,$(JSCRIPT_BLD_JSCRIPT_PREFIX)%.js,$(JSCRIPT_JS_JSCRIPT_SRC_CJS)) + +# all src files +JSCRIPT_ALL_SRC := $(JSCRIPT_JS_JSCRIPT_SRC_JS) $(JSCRIPT_JS_JSCRIPT_SRC_CJS) + +# all js files to be compiled, src of derived +JSCRIPT_ALL_SRCDRV_JS := $(JSCRIPT_JS_JSCRIPT_SRC_JS) $(JSCRIPT_JS_JSCRIPT_DRV_JS) + +########################################################################################### +# top level build +########################################################################################### + +# library install +$(INSTALL_LIB_JSCRIPT): $(JSCRIPT_ALL_SRCDRV_JS) $(JSCRIPT_MKF) + mkdir -p $(@D) + cat $(JSCRIPT_ALL_SRCDRV_JS) > $@ + touch $@ + +########################################################################################### +# build rules for subparts +########################################################################################### + +$(JSCRIPT_JS_JSCRIPT_DRV_JS): $(JSCRIPT_BLD_JSCRIPT_PREFIX)%.js: $(SRC_JSCRIPT_PREFIX)%.cjs + mkdir -p $(@D) + $(SHUFFLE_JS) $(LIB_EHC_SHUFFLE_DEFS) --gen-reqm="($(EHC_VARIANT) $(EHC_ASPECTS))" --base=$(*F) --variant-order="$(EHC_SHUFFLE_ORDER)" $< > $@ && \ + touch $@ + + diff --git a/EHC/src/jscript/rts/prim.cjs b/EHC/src/jscript/rts/prim.cjs new file mode 100644 index 000000000..e083f72fd --- /dev/null +++ b/EHC/src/jscript/rts/prim.cjs @@ -0,0 +1,140 @@ +Data constructors must be in lexicographical ordering, using _tag_ (field name must coincide with codegen) + +%%[[8 +PrimDataOrdering_EQ = {_tag_ : 0} +PrimDataOrdering_GT = {_tag_ : 1} +PrimDataOrdering_LT = {_tag_ : 2} + +PrimDataBool_False = {_tag_ : 0} +PrimDataBool_True = {_tag_ : 1} + +PrimMkBool = function(x) { return ( (x) ? PrimDataBool_True : PrimDataBool_False ) ; } +%%]] + +%%[[8 +// signed, int +primAddInt = function(x,y) {return x+y ;} +primSubInt = function(x,y) {return x-y ;} +primMulInt = function(x,y) {return x*y ;} + +primDivInt = function(x,y) {var r = x/y ; return ( (r<0) ? r-1 : r ) ;} +primModInt = function(x,y) {var r = x%y ; return ( (r > 0 && y < 0 || r < 0 && y > 0) ? r+y : r ) ;} +primDivModInt = function(x,y) {return [primDivInt (x,y), primModInt(x,y)] ;} + +primQuotInt = function(x,y) {return x/y ;} +primRemInt = function(x,y) {return x%y ;} +primQuotRemInt = function(x,y) {return [x/y, x%y] ;} + +primNegInt = function(x) {return -x ;} +primComplementInt = function(x) {return ~x ;} + +primShiftLeftInt = function(x,y) {return x<>y ;} + +primEqInt = function(x,y) {return PrimMkBool(x==y) ;} +primNeInt = function(x,y) {return PrimMkBool(x!=y) ;} +primLtInt = function(x,y) {return PrimMkBool(x< y) ;} +primGtInt = function(x,y) {return PrimMkBool(x> y) ;} +primLeInt = function(x,y) {return PrimMkBool(x<=y) ;} +primGeInt = function(x,y) {return PrimMkBool(x>=y) ;} + +primCmpInt = function(x,y) {return ( (x>y) ? PrimDataOrdering_GT : ( (x 64 && x < 91 ; } +primCharIsLower = function(x) { return x > 96 && x < 123 ; } +%%]] + +Represent packed strings as Javascript strings + +%%[[8 +primPackedStringNull = function(x) { return PrimMkBool(x.length == 0) ; } +primPackedStringHead = function(x) { return x.charCodeAt(0) ; } +primPackedStringTail = function(x) { return x.slice(1) ; } +primPackedStringToInteger = function(x) { return parseInt(x) ; } +%%]] + +Represent bytearrays as Javascript strings + +%%[[8 +primByteArrayLength = function(x) { return x.length ; } +primByteArrayToPackedString = primUnsafeId ; +%%]] + +%%[[8 +primThrowException = function(x) { throw x ; } +primExitWith = function(x) { throw "EXIT:" + x ; } +%%]] + +%%[[8 +primShowInteger = function(x) { return x.toString() ; } +primShowDouble = primShowInteger +primShowFloat = primShowInteger +%%]] + +%%[[8 +primHPutChar = function(h,c) { + switch(c) { + case 10 : + document.write("
") ; + break ; + default : + document.write(String.fromCharCode(c)) ; + break ; + } + return [] ; +} +%%] + diff --git a/EHC/src/libutil/EH/Util/CompileRun.hs b/EHC/src/libutil/EH/Util/CompileRun.hs index d8d78aab4..6b9c0fc7a 100644 --- a/EHC/src/libutil/EH/Util/CompileRun.hs +++ b/EHC/src/libutil/EH/Util/CompileRun.hs @@ -14,6 +14,8 @@ module EH.Util.CompileRun , CompileModName(..) , CompileRunStateInfo(..) + , CompileParticipation(..) + , FileLocatable(..) , mkEmptyCompileRun @@ -61,6 +63,14 @@ forgetM m ; return () } +------------------------------------------------------------------------- +-- The way a CompileUnit can participate +------------------------------------------------------------------------- + +data CompileParticipation + = CompileParticipation_NoImport + deriving (Eq, Ord) + ------------------------------------------------------------------------- -- Interfacing with actual state info ------------------------------------------------------------------------- @@ -69,22 +79,26 @@ class CompileModName n where mkCMNm :: String -> n class CompileUnitState s where - cusDefault :: s - cusUnk :: s - cusIsUnk :: s -> Bool - cusIsImpKnown :: s -> Bool + cusDefault :: s + cusUnk :: s + cusIsUnk :: s -> Bool + cusIsImpKnown :: s -> Bool class CompileUnit u n l s | u -> n l s where - cuDefault :: u - cuFPath :: u -> FPath - cuUpdFPath :: FPath -> u -> u - cuLocation :: u -> l - cuUpdLocation :: l -> u -> u - cuKey :: u -> n - cuUpdKey :: n -> u -> u - cuState :: u -> s - cuUpdState :: s -> u -> u - cuImports :: u -> [n] + cuDefault :: u + cuFPath :: u -> FPath + cuUpdFPath :: FPath -> u -> u + cuLocation :: u -> l + cuUpdLocation :: l -> u -> u + cuKey :: u -> n + cuUpdKey :: n -> u -> u + cuState :: u -> s + cuUpdState :: s -> u -> u + cuImports :: u -> [n] + cuParticipation :: u -> [CompileParticipation] + + -- defaults + cuParticipation _ = [] class FPathError e => CompileRunError e p | e -> p where crePPErrL :: [e] -> PP_Doc @@ -310,9 +324,12 @@ cpFindFileForFPath suffs sp mbModNm mbFp -- Gather all imports ------------------------------------------------------------------------- +-- | recursively extract imported modules cpImportGatherFromMods - :: (Show n,Ord n,CompileUnit u n l s,CompileRunError e p,CompileUnitState s) - => (Maybe prev -> n -> CompilePhase n u i e (x,Maybe prev)) -> [n] -> CompilePhase n u i e () + :: (Show n, Ord n, CompileUnit u n l s, CompileRunError e p, CompileUnitState s) + => (Maybe prev -> n -> CompilePhase n u i e (x,Maybe prev)) -- extract imports from 1 module + -> [n] -- to be imported modules + -> CompilePhase n u i e () cpImportGatherFromMods imp1Mod modNmL = do { cr <- get ; cpSeq ( [ one Nothing modNm | modNm <- modNmL ] @@ -322,7 +339,10 @@ cpImportGatherFromMods imp1Mod modNmL where one prev modNm = do { (_,new) <- imp1Mod prev modNm ; cpHandleErr - ; imps new modNm + ; cr <- get + ; if CompileParticipation_NoImport `elem` cuParticipation (crCU modNm cr) + then cpDelCU modNm + else imps new modNm } imps prev m = do { cr <- get @@ -385,6 +405,12 @@ cpUpdCU modNm upd = do { cpUpdCUWithKey modNm (\k u -> (k, upd u)) ; return () } + +-- | delete unit +cpDelCU :: (Ord n,CompileUnit u n l s) => n -> CompilePhase n u i e () +cpDelCU modNm + = do { modify (\cr -> cr {crCUCache = Map.delete modNm $ crCUCache cr}) + } {- = do { cr <- get ; let cu = (maybe (upd cuDefault) upd (crMbCU modNm cr)) diff --git a/EHC/src/shuffle/files.mk b/EHC/src/shuffle/files.mk index 470573418..fa740b816 100644 --- a/EHC/src/shuffle/files.mk +++ b/EHC/src/shuffle/files.mk @@ -91,6 +91,7 @@ SHUFFLE_AG_PRE := $(SHUFFLE) --ag --preamble=yes --lhs2tex=no --line=no --comp SHUFFLE_PLAIN := $(SHUFFLE) --plain --preamble=no --lhs2tex=no --line=no SHUFFLE_C := $(SHUFFLE_PLAIN) SHUFFLE_JAVA := $(SHUFFLE_PLAIN) +SHUFFLE_JS := $(SHUFFLE_PLAIN) # setting --line=yes for AG is not possible because of uuagc's weird interpretation of the layout rule diff --git a/EHC/src/text2text/Common.hs b/EHC/src/text2text/Common.hs index 3bfd4bf6a..37eece16c 100644 --- a/EHC/src/text2text/Common.hs +++ b/EHC/src/text2text/Common.hs @@ -19,6 +19,15 @@ module Common , hPutOutLn , cmbMb + + , dhtmTagAttrs, dhtmTag, dhtmTag' + , dhtmCmt + , dhtmOpenCloseAttrs, dhtmOpenClose + , dhtmOne + + , ensureHtmlCharsAreEscaped + + , HeaderSeqNrMp ) where @@ -36,16 +45,18 @@ import qualified EH.Util.FastSeq as Seq data TextType = TextType_DocLaTeX | TextType_TWiki + | TextType_Html | TextType_None deriving (Eq,Ord) instance Show TextType where show TextType_DocLaTeX = "doclatex" show TextType_TWiki = "twiki" + show TextType_Html = "html" show TextType_None = "none" texttypeMp :: Map.Map String TextType -texttypeMp = Map.fromList [ (show t, t) | t <- [TextType_DocLaTeX,TextType_TWiki] ] +texttypeMp = Map.fromList [ (show t, t) | t <- [TextType_DocLaTeX,TextType_TWiki,TextType_Html] ] ------------------------------------------------------------------------- -- Options @@ -149,3 +160,50 @@ putOutFile fn ou wid ; hClose h } +------------------------------------------------------------------------- +-- Shared OutDoc Html combinators & utils +------------------------------------------------------------------------- + +-- | a tag + attributes +dhtmTagAttrs :: (Out a, Out x) => a -> [x] -> OutDoc +dhtmTagAttrs a as = "<" +++ a +++ (if null as then emptyout else outListSep " " "" " " as) +++ ">" + +-- | a tag +dhtmTag :: forall a . Out a => a -> OutDoc +dhtmTag a = dhtmTagAttrs a ([] :: [a]) + +-- | single direct open+close tag +dhtmTag' :: Out a => a -> OutDoc +dhtmTag' a = "<" +++ a +++ "/>" + +-- | comment +dhtmCmt :: Out a => a -> OutDoc +dhtmCmt a = dhtmTag ("!-- " +++ a +++ " --") + +-- | open + close, body inside + attributes +dhtmOpenCloseAttrs :: (Out x, Out env) => env -> [x] -> x -> OutDoc +dhtmOpenCloseAttrs env attrs body = dhtmTagAttrs env attrs +++ body +++ dhtmTag ("/" +++ env) + +-- | open + close, body inside +dhtmOpenClose :: (Out body, Out env) => env -> body -> OutDoc +dhtmOpenClose env body = dhtmOpenCloseAttrs env [] body + +-- | single open+close tag, including body inside tag +dhtmOne :: (Out body, Out env) => env -> body -> OutDoc +dhtmOne env body = dhtmTag' (env +++ " " +++ body) + +-- | escape html chars +ensureHtmlCharsAreEscaped :: String -> String +ensureHtmlCharsAreEscaped + = concatMap asis + where asis '<' = c "lt" + asis '>' = c "gt" + asis c = [c] + c ch = "&" ++ ch ++ ";" + +------------------------------------------------------------------------- +-- Header numbering +------------------------------------------------------------------------- + +type HeaderSeqNrMp = Map.Map Int Int + diff --git a/EHC/src/text2text/Text/To/Common.ag b/EHC/src/text2text/Text/To/Common.ag index c65f3d7c2..e61f7609a 100644 --- a/EHC/src/text2text/Text/To/Common.ag +++ b/EHC/src/text2text/Text/To/Common.ag @@ -13,3 +13,10 @@ SEM TextItem | LineFeed lhs . lines = Seq.singleton (Line_LF @pp) | * - LineFeed lhs . lines = Seq.singleton (Line_Item @pp) -} + +------------------------------------------------------------------------- +-- Global info +------------------------------------------------------------------------- + +ATTR AGItf AllNT [ opts: Opts | | ] + diff --git a/EHC/src/text2text/Text/To/CommonHeaderNumbering.ag b/EHC/src/text2text/Text/To/CommonHeaderNumbering.ag new file mode 100644 index 000000000..b23f61e3a --- /dev/null +++ b/EHC/src/text2text/Text/To/CommonHeaderNumbering.ag @@ -0,0 +1,47 @@ +------------------------------------------------------------------------- +-- Header numbering +------------------------------------------------------------------------- + +ATTR AllText AllTable [ | headerLevel: Int headerSeqNrMp: HeaderSeqNrMp | ] +ATTR HeaderLevel [ | headerLevel: Int | allowHeaderCounting: Bool ] + +SEM AGItf + | AGItf loc . headerLevel = -1 + . headerSeqNrMp + = Map.empty + +SEM HeaderLevel + | Level lhs . headerLevel = @level + +SEM HeaderLevel + | Level lhs . allowHeaderCounting + = True + | Paragraph lhs . allowHeaderCounting + = False + +SEM TextItem + | Header (loc.headerTxt,lhs.headerSeqNrMp) + = if @level.allowHeaderCounting + then let mkTxt h m = concat $ intersperse "." [ show $ fromJust $ Map.lookup l m | l <- [0 .. h] ] + seqNr h = fromJust $ Map.lookup h @lhs.headerSeqNrMp + in case @lhs.headerLevel `compare` @level.headerLevel of + GT -> ( mkTxt @level.headerLevel m, m ) + where m = Map.insert @level.headerLevel (seqNr @level.headerLevel + 1) @lhs.headerSeqNrMp + EQ -> ( mkTxt @lhs.headerLevel m, m ) + where m = Map.insert @lhs.headerLevel (seqNr @lhs.headerLevel + 1) @lhs.headerSeqNrMp + LT -> ( mkTxt @level.headerLevel m, m ) + where m = Map.insert @level.headerLevel 1 @lhs.headerSeqNrMp + else ( "", @lhs.headerSeqNrMp ) + +------------------------------------------------------------------------- +-- Itemize level +------------------------------------------------------------------------- + +ATTR AllText AllTable [ itemizeLevel: Int | | ] + +SEM TextItem + | Itemize loc . itemizeLevel= @lhs.itemizeLevel + 1 + +SEM AGItf + | AGItf loc . itemizeLevel= 0 + diff --git a/EHC/src/text2text/Text/To/DocLaTeX.ag b/EHC/src/text2text/Text/To/DocLaTeX.ag index 4b4523be8..1eda4f49f 100644 --- a/EHC/src/text2text/Text/To/DocLaTeX.ag +++ b/EHC/src/text2text/Text/To/DocLaTeX.ag @@ -62,12 +62,6 @@ dltxBeginEnd :: (Out body, Out env) => env -> body -> OutDoc dltxBeginEnd env body = dltxOptsBeginEnd env emptyout body } -------------------------------------------------------------------------- --- Global info -------------------------------------------------------------------------- - -ATTR AGItf AllNT [ opts: Opts | | ] - ------------------------------------------------------------------------- -- Graphics has caption? ------------------------------------------------------------------------- diff --git a/EHC/src/text2text/Text/To/Html.ag b/EHC/src/text2text/Text/To/Html.ag new file mode 100644 index 000000000..a76a361bd --- /dev/null +++ b/EHC/src/text2text/Text/To/Html.ag @@ -0,0 +1,280 @@ +------------------------------------------------------------------------- +-- Convert Text to Html +------------------------------------------------------------------------- + +{ +module Text.To.Html + ( textToOutDoc + ) + where + +import Data.Maybe +import Data.Char +import Data.List +import qualified Data.Map as Map +import qualified Data.Set as Set + +import EH.Util.FPath +import qualified EH.Util.FastSeq as Seq +import EH.Util.ScanUtils + +import Common +import Text +} + +------------------------------------------------------------------------- +-- Interfacing +------------------------------------------------------------------------- + +WRAPPER AGItf + +{ +textToOutDoc :: Opts -> AGItf -> OutDoc +textToOutDoc opts txt + = out_Syn_AGItf t + where t = wrap_AGItf (sem_AGItf txt) + (Inh_AGItf { opts_Inh_AGItf = opts + }) +} + +------------------------------------------------------------------------- +-- AST +------------------------------------------------------------------------- + +INCLUDE "Text/AbsSyn.ag" +INCLUDE "Text/To/Common.ag" +INCLUDE "Text/To/CommonHeaderNumbering.ag" + +------------------------------------------------------------------------- +-- Is text a twiki word? +------------------------------------------------------------------------- + +{ +isHtmlChar :: Char -> Bool +isHtmlChar = isAlphaNum + +isHtmlWord :: String -> Bool +isHtmlWord s + = is 0 s + where is st (c:_ ) | isLower c && st == 0 = False + is st (c:s') | isUpper c && (st == 0 || st == 2) = is (st+1) s' + is st (c:s') | isLower c && st == 1 = is (st+1) s' + is st (c:_ ) | not (isHtmlChar c) = False + is 3 _ = True + is st (_:s') = is st s' + is _ _ = False +} + +------------------------------------------------------------------------- +-- Ensure text is for a Html anchor +------------------------------------------------------------------------- + +{ +ensureHtmlAnchor :: Out a => a -> OutDoc +ensureHtmlAnchor x = out $ filter isHtmlChar $ outToString $ out x +} + +------------------------------------------------------------------------- +-- Combinators +------------------------------------------------------------------------- + +{ +dtwkLbl :: Out a => a -> OutDoc +dtwkLbl a = "#LabeL" +++ ensureHtmlAnchor a + +dtwkCmd :: Out c => c -> OutDoc +dtwkCmd c = "%" +++ c +++ "%" + +dtwkHdr :: Int -> OutDoc +dtwkHdr l = "\n---+" +++ replicate l '+' +++ " " + +dtwkRef :: (Out lbl,Out txt) => lbl -> txt -> OutDoc +dtwkRef lbl txt = "[[" +++ lbl +++ "][" +++ txt +++ "]]" + +} + +{ +dtwkArg :: Out a => a -> OutDoc +dtwkArg a = "{" +++ a +++ "}" + +dtwkArgs :: [OutDoc] -> OutDoc +dtwkArgs a = outList $ map dtwkArg a +} + +------------------------------------------------------------------------- +-- Itemize style +------------------------------------------------------------------------- + +ATTR AllText AllTable [ itemizePrefix: OutDoc | | ] + +SEM TextItem + | Itemize loc . itemizePrefix + = replicate (3 * @lhs.itemizeLevel) ' ' +++ @itemizestyle.out + +SEM AGItf + | AGItf loc . itemizePrefix + = emptyout + +------------------------------------------------------------------------- +-- How to make a reference +------------------------------------------------------------------------- + +ATTR RefType [ | | mkRefOut: {OutDoc -> OutDoc -> OutDoc} ] -- \reftext text -> ... + +SEM RefType + | Local loc . mkRefOut = \r t -> dtwkRef (dtwkLbl $ ensureHtmlAnchor r) t + | URL EhcWeb UhcWeb STWiki + loc . mkRefOut = dtwkRef + | EhcSrc loc . mkRefOut = \r t -> t +++ " (" +++ dhtmOpenClose "code" r +++ ")" + | Cite loc . mkRefOut = \_ t -> t + +------------------------------------------------------------------------- +-- How to make a label +------------------------------------------------------------------------- + +ATTR LabelType [ | | mkLblOut: {OutDoc -> OutDoc} ] -- \lbl -> ... + +SEM LabelType + | Local Global loc . mkLblOut = \x -> dhtmOpenCloseAttrs "a" ["name=\"" +++ x +++ "\""] emptyout + +------------------------------------------------------------------------- +-- How to make a header +------------------------------------------------------------------------- + +ATTR HeaderLevel [ | | mkHdrOut: {OutDoc -> OutDoc -> OutDoc} ] -- \numberingprefix text -> ... + +SEM HeaderLevel + | Level loc . mkHdrOut = \n t -> dhtmOpenClose ("h" +++ (@level+1)) (n +++ " " +++ t) + | Paragraph loc . mkHdrOut = \_ t -> dhtmTag' "p" +++ dhtmOpenClose "b" t + +------------------------------------------------------------------------- +-- Selectively modifying html text +------------------------------------------------------------------------- + +ATTR AllText AllTable [ allowHtmlAsIs: Bool | | ] +ATTR GroupType [ | | allowHtmlAsIs: Bool ] + +SEM AGItf + | AGItf loc . allowHtmlAsIs + = False + +SEM GroupType + | Verbatim loc . allowHtmlAsIs + = True + | * - Verbatim loc . allowHtmlAsIs + = False + +------------------------------------------------------------------------- +-- Selectively modifying wikiwords +------------------------------------------------------------------------- + +ATTR AllText AllTable [ allowWikiWord: Bool | | ] + +SEM AGItf + | AGItf loc . allowWikiWord + = False + +SEM TextItem + | Label Styled RefTo + loc . allowWikiWord + = True + +------------------------------------------------------------------------- +-- Linefeeding +------------------------------------------------------------------------- + +SEM TextItem + | Line LineFeed CommentLF + loc . lf = out "\n" + | ParBreak loc . par = dhtmTag' "p" + +------------------------------------------------------------------------- +-- Replacement, as OutDoc +------------------------------------------------------------------------- + +ATTR AGItf AllNT [ | | out USE {+++} {emptyout}: OutDoc ] + +SEM TextItem + | Space loc . out = out @str + | NonSpace loc . out = if not @lhs.allowHtmlAsIs + then out (ensureHtmlCharsAreEscaped @str) + else out @str + | CommentLF loc . out = dhtmCmt @str +++ @lf + | Line loc . out = @str +++ @lf + | LineFeed loc . out = @lf + | ParBreak loc . out = @par + | T2T loc . out = ("@@[" +++ show @texttype) +++ "should not happen!!" +++ "@@]" -- for now + | RefTo loc . out = dhtmOpenCloseAttrs "a" ["href=\"" +++ @reftype.out +++ @reftext.out +++ "\""] @text.out + | Styled loc . out = dhtmOpenClose @style.out @text.out + | VerbatimInline loc . out = dhtmOpenClose "code" (ensureHtmlCharsAreEscaped @str) + | BreakLine loc . out = dhtmTag' "br" + | HorRuler loc . out = dhtmTag' "hr" + | Header loc . out = @level.mkHdrOut (if optGenHeaderNumbering @lhs.opts then @headerTxt +++ " " else emptyout) @text.out -- TBD + | Group loc . out = foldr dhtmOpenClose @text.out @envtype.outL + | DocumentContent loc . out = dhtmOpenClose "body" @text.out + | Table loc . out = dhtmOpenClose "center" + $ dhtmOpenCloseAttrs "table" [@tablefmt.out] {- @extratext.out +++ -} @rows.out + | Itemize loc . out = dhtmOpenClose @itemizestyle.out @text.out + | ItemizeItem loc . out = dhtmOpenClose "li" @text.out + | Title loc . out = emptyout -- TBD + | Author loc . out = emptyout -- TBD + | Import loc . out = emptyout -- TBD + | Label loc . out = @lbltype.mkLblOut @reftext.out + | MakeTitle loc . out = emptyout -- TBD + | DocumentHeader loc . out = dhtmTag "!DOCTYPE HTML" + | GraphicsInline loc . out = let f = fpathSetDir "http://www.cs.uu.nl/groups/ST/Projects/ehc" $ fpathSetSuff "gif" $ fpathFromStr $ outToString @text.out -- TBD + in dhtmOpenClose "center" $ dhtmOne "img" ("src=\"" +++ fpathToStr f +++ "\"") + | TOC loc . out = emptyout -- TBD + +SEM RefType + | Local loc . out = out "#" + | URL loc . out = emptyout -- TBD + | STWiki loc . out = emptyout -- TBD + | EhcWeb loc . out = out "http://www.cs.uu.nl/wiki/Ehc/" + | UhcWeb loc . out = out "http://www.cs.uu.nl/wiki/UHC/" + | EhcSrc loc . out = out "EHCHOME/" -- TBD + | Cite loc . out = emptyout -- TBD + +SEM TextStyle + | Bold loc . out = out "b" + | Italic loc . out = out "i" + | Teletype loc . out = out "tt" + | Emphasized loc . out = out "em" + +SEM GroupType + | Verbatim loc . out = out "pre" + lhs . outL = [out "blockquote", @out] + +SEM ItemizeStyle + | Bullet lhs . out = out "ul" + | Number lhs . out = out "ol" + +{- +SEM HeaderLevel + | Level lhs . out = dtwkHdr @level + | Paragraph lhs . out = out "\n" + +-} +SEM TableColFormat + | JustifyLeft loc . out = out "align=left" + | JustifyCenter loc . out = out "align=center" + | JustifyRight loc . out = out "align=right" + | SepbyLine loc . out = emptyout + +SEM TableRow + | Row lhs . out = dhtmOpenClose "tr" @cols.out -- +++ @extrabrktext.out + +SEM TableField + | Fld lhs . out = dhtmOpenClose "td" {- @extraseptext.out +++ -} @fld.out + +------------------------------------------------------------------------- +-- Replacement, as [OutDoc] +------------------------------------------------------------------------- + +ATTR + TableFields TableRows GroupType + [ | | outL USE {++} {[]}: {[OutDoc]} ] + +SEM TableRows TableFields + | Cons lhs . outL = @hd.out : @tl.outL + | Nil lhs . outL = [] diff --git a/EHC/src/text2text/Text/To/TWiki.ag b/EHC/src/text2text/Text/To/TWiki.ag index ac18b74fa..90666a678 100644 --- a/EHC/src/text2text/Text/To/TWiki.ag +++ b/EHC/src/text2text/Text/To/TWiki.ag @@ -43,20 +43,7 @@ textToOutDoc opts txt INCLUDE "Text/AbsSyn.ag" INCLUDE "Text/To/Common.ag" - -------------------------------------------------------------------------- --- Adapt html specific chars -------------------------------------------------------------------------- - -{ -ensureHtmlCharsAreEscaped :: String -> String -ensureHtmlCharsAreEscaped - = concatMap asis - where asis '<' = c "lt" - asis '>' = c "gt" - asis c = [c] - c ch = "&" ++ ch ++ ";" -} +INCLUDE "Text/To/CommonHeaderNumbering.ag" ------------------------------------------------------------------------- -- Is text a twiki word? @@ -101,23 +88,9 @@ dtwkCmd c = "%" +++ c +++ "%" dtwkHdr :: Int -> OutDoc dtwkHdr l = "\n---+" +++ replicate l '+' +++ " " -dhtmTag :: Out a => a -> OutDoc -dhtmTag a = "<" +++ a +++ ">" - -dhtmTag' :: Out a => a -> OutDoc -dhtmTag' a = "<" +++ a +++ "/>" - -dhtmCmt :: Out a => a -> OutDoc -dhtmCmt a = dhtmTag ("!-- " +++ a +++ " --") - dtwkRef :: (Out lbl,Out txt) => lbl -> txt -> OutDoc dtwkRef lbl txt = "[[" +++ lbl +++ "][" +++ txt +++ "]]" -dhtmOpenClose :: (Out body, Out env) => env -> body -> OutDoc -dhtmOpenClose env body = dhtmTag env +++ body +++ dhtmTag ("/" +++ env) - -dhtmOne :: (Out body, Out env) => env -> body -> OutDoc -dhtmOne env body = dhtmTag' (env +++ " " +++ body) } { @@ -128,63 +101,6 @@ dtwkArgs :: [OutDoc] -> OutDoc dtwkArgs a = outList $ map dtwkArg a } -------------------------------------------------------------------------- --- Global info -------------------------------------------------------------------------- - -ATTR AGItf AllNT [ opts: Opts | | ] - -------------------------------------------------------------------------- --- Header numbering -------------------------------------------------------------------------- - -{ -type HeaderSeqNrMp = Map.Map Int Int -} - -ATTR AllText AllTable [ | headerLevel: Int headerSeqNrMp: HeaderSeqNrMp | ] -ATTR HeaderLevel [ | headerLevel: Int | allowHeaderCounting: Bool ] - -SEM AGItf - | AGItf loc . headerLevel = -1 - . headerSeqNrMp - = Map.empty - -SEM HeaderLevel - | Level lhs . headerLevel = @level - -SEM HeaderLevel - | Level lhs . allowHeaderCounting - = True - | Paragraph lhs . allowHeaderCounting - = False - -SEM TextItem - | Header (loc.headerTxt,lhs.headerSeqNrMp) - = if @level.allowHeaderCounting - then let mkTxt h m = concat $ intersperse "." [ show $ fromJust $ Map.lookup l m | l <- [0 .. h] ] - seqNr h = fromJust $ Map.lookup h @lhs.headerSeqNrMp - in case @lhs.headerLevel `compare` @level.headerLevel of - GT -> ( mkTxt @level.headerLevel m, m ) - where m = Map.insert @level.headerLevel (seqNr @level.headerLevel + 1) @lhs.headerSeqNrMp - EQ -> ( mkTxt @lhs.headerLevel m, m ) - where m = Map.insert @lhs.headerLevel (seqNr @lhs.headerLevel + 1) @lhs.headerSeqNrMp - LT -> ( mkTxt @level.headerLevel m, m ) - where m = Map.insert @level.headerLevel 1 @lhs.headerSeqNrMp - else ( "", @lhs.headerSeqNrMp ) - -------------------------------------------------------------------------- --- Itemize level -------------------------------------------------------------------------- - -ATTR AllText AllTable [ itemizeLevel: Int | | ] - -SEM TextItem - | Itemize loc . itemizeLevel= @lhs.itemizeLevel + 1 - -SEM AGItf - | AGItf loc . itemizeLevel= 0 - ------------------------------------------------------------------------- -- Itemize style ------------------------------------------------------------------------- diff --git a/EHC/src/text2text/Text2Text.hs b/EHC/src/text2text/Text2Text.hs index f81b2f8a2..0df91096e 100644 --- a/EHC/src/text2text/Text2Text.hs +++ b/EHC/src/text2text/Text2Text.hs @@ -41,6 +41,7 @@ import Plugin -- for plugin: generation of output import qualified Text.To.DocLaTeX as O_DocLaTeX import qualified Text.To.TWiki as O_TWiki +import qualified Text.To.Html as O_Html -- for plugin: parsing input import qualified Text.Parser.DocLaTeX as P_DocLaTeX @@ -96,6 +97,11 @@ pluginMp { plgToOutDoc = Just O_TWiki.textToOutDoc } ) + , ( TextType_Html + , defaultPlugin + { plgToOutDoc = Just O_Html.textToOutDoc + } + ) ] ------------------------------------------------------------------------- diff --git a/EHC/src/text2text/files.mk b/EHC/src/text2text/files.mk index 91e2c7467..671aa302a 100644 --- a/EHC/src/text2text/files.mk +++ b/EHC/src/text2text/files.mk @@ -38,10 +38,15 @@ $(patsubst $(SRC_TEXT2TEXT_PREFIX)%.ag,$(TEXT2TEXT_BLD_PREFIX)%.hs,$(TEXT2TEXT_T : $(TEXT2TEXT_TEXT2DOCLTX_DPDS_SRC_AG) TEXT2TEXT_TEXT2TWIKI_MAIN_SRC_AG := $(patsubst %,$(SRC_TEXT2TEXT_PREFIX)%.ag,Text/To/TWiki) -TEXT2TEXT_TEXT2TWIKI_DPDS_SRC_AG := $(patsubst %,$(SRC_TEXT2TEXT_PREFIX)%.ag,Text/AbsSyn Text/To/Common) +TEXT2TEXT_TEXT2TWIKI_DPDS_SRC_AG := $(patsubst %,$(SRC_TEXT2TEXT_PREFIX)%.ag,Text/AbsSyn Text/To/Common Text/To/CommonHeaderNumbering) $(patsubst $(SRC_TEXT2TEXT_PREFIX)%.ag,$(TEXT2TEXT_BLD_PREFIX)%.hs,$(TEXT2TEXT_TEXT2TWIKI_MAIN_SRC_AG)) \ : $(TEXT2TEXT_TEXT2TWIKI_DPDS_SRC_AG) +TEXT2TEXT_TEXT2HTML_MAIN_SRC_AG := $(patsubst %,$(SRC_TEXT2TEXT_PREFIX)%.ag,Text/To/Html) +TEXT2TEXT_TEXT2HTML_DPDS_SRC_AG := $(patsubst %,$(SRC_TEXT2TEXT_PREFIX)%.ag,Text/AbsSyn Text/To/Common Text/To/CommonHeaderNumbering) +$(patsubst $(SRC_TEXT2TEXT_PREFIX)%.ag,$(TEXT2TEXT_BLD_PREFIX)%.hs,$(TEXT2TEXT_TEXT2HTML_MAIN_SRC_AG)) \ + : $(TEXT2TEXT_TEXT2HTML_DPDS_SRC_AG) + TEXT2TEXT_TEXT2UNIFCONT_MAIN_SRC_AG := $(patsubst %,$(SRC_TEXT2TEXT_PREFIX)%.ag,Text/Trf/UniformContent) TEXT2TEXT_TEXT2UNIFCONT_DPDS_SRC_AG := $(patsubst %,$(SRC_TEXT2TEXT_PREFIX)%.ag,Text/AbsSyn) $(patsubst $(SRC_TEXT2TEXT_PREFIX)%.ag,$(TEXT2TEXT_BLD_PREFIX)%.hs,$(TEXT2TEXT_TEXT2UNIFCONT_MAIN_SRC_AG)) \ @@ -50,11 +55,13 @@ $(patsubst $(SRC_TEXT2TEXT_PREFIX)%.ag,$(TEXT2TEXT_BLD_PREFIX)%.hs,$(TEXT2TEXT_T TEXT2TEXT_AG_D_MAIN_SRC_AG := $(TEXT2TEXT_AGTEXT_MAIN_SRC_AG) TEXT2TEXT_AG_S_MAIN_SRC_AG := $(TEXT2TEXT_TEXT2DOCLTX_MAIN_SRC_AG) \ $(TEXT2TEXT_TEXT2TWIKI_MAIN_SRC_AG) \ + $(TEXT2TEXT_TEXT2HTML_MAIN_SRC_AG) \ $(TEXT2TEXT_TEXT2UNIFCONT_MAIN_SRC_AG) TEXT2TEXT_AG_ALL_DPDS_SRC_AG := $(sort \ $(TEXT2TEXT_TEXT2DOCLTX_DPDS_SRC_AG) \ $(TEXT2TEXT_TEXT2TWIKI_DPDS_SRC_AG) \ + $(TEXT2TEXT_TEXT2HTML_DPDS_SRC_AG) \ $(TEXT2TEXT_TEXT2UNIFCONT_DPDS_SRC_AG) \ $(TEXT2TEXT_AGTEXT_DPDS_SRC_AG) \ ) diff --git a/EHC/src/text2text/text2text.cabal.in b/EHC/src/text2text/text2text.cabal.in index f29f36d4f..b38172ca1 100644 --- a/EHC/src/text2text/text2text.cabal.in +++ b/EHC/src/text2text/text2text.cabal.in @@ -24,6 +24,7 @@ executable text2text , Text.Parser , Text.To.DocLaTeX , Text.To.TWiki + , Text.To.Html extensions: TypeSynonymInstances, MultiParamTypeClasses, Rank2Types, FlexibleContexts, ImpredicativeTypes hs-source-dirs: @TOP_ABS@/build/text2text diff --git a/EHC/test/benchmark/runbenchmark.pl.in b/EHC/test/benchmark/runbenchmark.pl.in index bb01741d3..4d7e94971 100644 --- a/EHC/test/benchmark/runbenchmark.pl.in +++ b/EHC/test/benchmark/runbenchmark.pl.in @@ -4,15 +4,15 @@ use Time::HiRes qw(gettimeofday tv_interval); @dirs = ("nofib/imag/bernouilli", "nofib/imag/binarytrees", "nofib/imag/digits-of-e1", "nofib/imag/digits-of-e2", "nofib/imag/exp3_8", "nofib/imag/gen-regexps", "nofib/imag/integrate", "nofib/imag/loop", "nofib/imag/nsieve", "nofib/imag/paraffins", "nofib/imag/partial-sums", "nofib/imag/pidigits", "nofib/imag/primes", "nofib/imag/queens", "nofib/imag/recursive", "nofib/imag/rfib-int", "nofib/imag/rfib-integer", "nofib/imag/rfib-double", "nofib/imag/ru_list", "nofib/imag/tak", "nofib/imag/wheel-sieve1", "nofib/imag/wheel-sieve2", "nofib/imag/x2n1", "nofib/real/infer" ); -@compilernames = ("uhc -O2 -tbc", "uhc -tC", "ghc", "ghc -O2"); +@compilernames = ("uhc -O2 -tbc", "uhc -O2,2 -tbc", "uhc -tC", "ghc", "ghc -O2"); for $dir (@dirs) { - @compilers = ("uhc -O2 -tbc --cpp --import-path=$dir", "uhc -tC --cpp --import-path=$dir", "ghc --make -cpp -i$dir", "ghc -O2 --make -cpp -i$dir"); + @compilers = ("uhc -O2 -tbc --cpp --import-path=$dir", "uhc -O2,2 -tbc --cpp --import-path=$dir", "uhc -tC --cpp --import-path=$dir", "ghc --make -cpp -i$dir", "ghc -O2 --make -cpp -i$dir"); - for $j (0,1,2,3) { + for $j (0,1,2,3,4) { $compiler = $compilers[$j]; diff --git a/EHC/text/SlidesIntro.cltex b/EHC/text/SlidesIntro.cltex index b39c74cd5..62d3d4941 100644 --- a/EHC/text/SlidesIntro.cltex +++ b/EHC/text/SlidesIntro.cltex @@ -525,7 +525,7 @@ infers kind @Eq :: Forall a . a -> a -> *@ { \frametitle{EH version 9: explicit implicit parameters} %%[[wrap=safecode -%%@[file:test/regress/9/eq2.eh%%] +%%@[file:test/regress/9/eqlist.eh%%] %%] } diff --git a/EHC/text/SlidesStatus.cltex b/EHC/text/SlidesStatus.cltex index ff7b2b098..70f47a651 100644 --- a/EHC/text/SlidesStatus.cltex +++ b/EHC/text/SlidesStatus.cltex @@ -1,4 +1,4 @@ -%%[currentStatus +%%[currentStatus2007 \frame { \frametitle{Current status} @@ -23,7 +23,7 @@ Working towards a release as a Haskell compiler } %%] -%%[currentWork +%%[currentWork2007 \frame { \frametitle{Current and future work} @@ -55,16 +55,165 @@ Working towards a release as a Haskell compiler } %%] -%%[XX +%%[currentUHCStatus201009 +\frame +{ +\frametitle{UHC 1.1.0: generic deriving} +Just released before ICFP +\begin{itemize} +\item {\color{red} Generic deriving} (Haskell Symposium) + +%%[[wrap=safecode +class Functor f where + fmap :: (a -> b) -> (f a -> f b) + +deriving instance Functor Maybe +deriving instance Functor [] +%%]] +\item<2> {\color{red} User programmable} deriving + +%%[[wrap=safecode +class Functor' f where + fmap' :: (a -> b) -> f a -> f b + +instance (Functor' f, Functor' g) => Functor' (f :*: g) where + fmap' f (a :*: b) = fmap' f a :*: fmap' f b + +fmapDefault = ... + +{-# DERIVABLE Functor fmap fmapDefault #-} +%%]] +\end{itemize} +} + +\frame +{ +\frametitle{UHC 1.1.0: cabal} +\begin{itemize} +\item {\color{red} Cabal} support (Cabal version |>| @1.9.2@) + \begin{itemize} + \item E.g. +%%[[wrap=verbatim +> cabal install containers-0.2.0.1 --uhc +%%]] + \item Package awareness + \item Sufficient library support for package @haskell98@ + \item Building executables up and coming + \end{itemize} +\item Implementers note + \begin{itemize} + \item Base libraries depend on non-standard features (E.g. extensible exceptions), hence difficult to port and/or bootstrap + \end{itemize} +\end{itemize} +} + +\frame +{ +\frametitle{UHC 1.1.0: defaulting} +\begin{itemize} +\item Per class {\color{red} @default@} (an alternative from Haskell Prime proposal) +\item In @Prelude@: + +%%[[wrap=safecode +default Num Integer +default Integral Integer +... +%%]] +\item Implementers note + \begin{itemize} + \item Would prefer replacing it by use of type annotations + syntactic sugar \\ + (kinda ad-hoc improving substitution) + \end{itemize} +\end{itemize} +} + +\frame +{ +\frametitle{UHC 1.1.0} +\begin{itemize} +\item Monomorphic pattern bindings +%%[[wrap=safecode +ab = ... -- unrestricted +(a,b) = ab -- monomorphic +%%]] +\item Runtime + \begin{itemize} + \item Customizable garbage collector (currently swap space) + \item For @Integer@: cloned `Libtommath', adapted (w.r.t. GC) \& extended + \end{itemize} +\item Compatibility + \begin{itemize} + \item Haskell98 (no |n ^ + ^ k| patterns) + \item Haskell2010 (partial FFI, no pattern guards, some LANGUAGE pragmas) + \end{itemize} +\end{itemize} +} + %%] -%%[XX +%%[futureUHCWork201009 +\frame +{ +\frametitle{Current and future work} +\begin{itemize} +\item Release focus + \begin{itemize} + \item Current: make it work (cabal, haskell98, haskell2010, bug fixing) + \item Future: better combine whole-progam analysis work into compiler pipeline, complete alternate backends, optimizations + \end{itemize} +%if False +\item Unique selling point + \begin{itemize} + \item Current: allow (relatively) easy experimentation; \\ + for developers only + \item Future: + \end{itemize} +%endif +\item Experiments \& partially done + \begin{itemize} + \item Intermediate typed core (combi of Henk, calling conventions, GHC's core) + \item Partially working backends: jvm, llvm + \end{itemize} +\item Can I use UHC? Of course! But: + \begin{itemize} + \item Is work in progress + \item Not (yet) used for realworld programming + \end{itemize} +\item \verb|http://www.cs.uu.nl/wiki/UHC| +% \item<2> Finally, when Dutch is a problem, pronounce UHC like: \\ ``You Hate C'' +\end{itemize} +} %%] %%[XX +\frame +{ +\frametitle{Current and future work} +\begin{itemize} +\item +\end{itemize} +} %%] -%%[XX +%%[irritations201009 +\frame +{ +\frametitle{Irritations} +\begin{itemize} +\item Alternative to @default@ + \begin{itemize} + \item explicit annotations +%%[[wrap=safecode +show (1 :: Int) +%%]] + \item + syntactic sugar +%%[[wrap=safecode +show (1 :: Int) +%%]] + \end{itemize} +\end{itemize} +} + %%] %%[XX diff --git a/EHC/text/ToolDocEHC.cltex b/EHC/text/ToolDocEHC.cltex index 1f06420b8..2701e38c2 100644 --- a/EHC/text/ToolDocEHC.cltex +++ b/EHC/text/ToolDocEHC.cltex @@ -542,6 +542,7 @@ Type @make help@ to see what more can be build: Apart from the usual options @./configure@ accepts the following options enabling a particular feature: \begin{itemize} \item \verb|--enable-java|. Enable @jazy@ backend. +\item \verb|--enable-jscript|. Enable @jscript@ backend. \item \verb|--enable-llvm|. Enable @llvm@ backend. \item \verb|--enable-clr|. Enable @clr@ backend. \item \verb|--enable-tycore|. Enable @TyCore@ typed core intermediate representation. @@ -1058,14 +1059,15 @@ UHC allows pragmas, wrapped inside special commentlike delimiters \verb|{-#| and \end{verbatim} The following pragmas are supported. \begin{itemize} -\item \verb|{-# LANGAUGE pragma #-}| pragmas, where pragma may be: +\item \verb|{-# LANGAUGE pragma #-}| (file header) pragmas, where pragma may be: \begin{itemize} -\item @CPP@: switch on \href{http://gcc.gnu.org/onlinedocs/cpp/}{cpp} preprocessing. +\item @CPP@ : switch on \href{http://gcc.gnu.org/onlinedocs/cpp/}{cpp} preprocessing. \item @NoImplicitPrelude@: don't automatically import @Prelude@ and/or assume its presence. \item @GenericDeriving@, @NoGenericDeriving@: turn on/off respectively generic deriving, default is on. \item @ExtensibleRecords@: turn on special syntax for extensible records. Available for internal backwards compatibility, but otherwise useless as codegeneration and runtime currently does not support extensible records. It reserves the operators \verb|#| and \verb|:=| for record selection and update respectively. \end{itemize} \item \verb|{-# DERIVING class field generic-function #-}| pragma: see \lref{generic-deriving}{generic deriving}. +\item \verb|{-# EXCLUDE_IF_TARGET targets #-}| (file header pragma) make the module invisible for compilation. This is a (hopefully) temporary measure to deal with the abilities of distinctive backend. For example, the @jscript@ backend does not support (e.g.) file access. \end{itemize} Other or unsupported pragmas are silently ignored, even when appropriate currently no warning will be given. The text inside the pragma delimiters is then treated as normal comment, as were it inside plain \verb|{-| and \verb|-}| comment delimiters. @@ -1416,6 +1418,14 @@ therefore make compilation fail. JVM expects this to be done per .class file. Because all functions and CAFs have a separate class definition this becomes quite costly in terms of jar file size and runtime startup time. \end{itemize} +\subsubsection{@jscript@: Core based JavaScript, no whole program analysis} + +\begin{itemize} +\item Only when enabled via @configure --enable-jscript@. +\item Runs for latest variant, but all FFI related to the usual OS stuff is not available. +\item No exceptions. +\end{itemize} + %%] %%[backendsPartial doclatex @@ -1511,7 +1521,7 @@ This is not yet used, except for experimenting with code generation with extra d \item \verb|plain|: nothing special. \item \verb|debug|: debugging experiments. \end{itemize} -\item \verb|-O[]|, \verb|--optimise[=]|. Optimisation level. Currently this makes little difference as few optimisations are implemented. Levels: +\item \verb|-O[][,]|, \verb|--optimise[=][,]|. Optimisation level and scope. Currently this makes little difference as few optimisations are implemented. Levels: \begin{itemize} \item \verb|0|: none. \item \verb|1| (default): basic. @@ -1519,6 +1529,12 @@ This is not yet used, except for experimenting with code generation with extra d \item \verb|3|: all \item \verb|[=Bool]|: turn on/off optimization option \verb|| on top of those already defined. See also @--meta-optimizations@ \lref{optimizations}{optimizations}. \end{itemize} + The scope determines at which point the optimizations are done, by default on a per module basis, optionally on a whole program by linking in an earlier compiler pipeline stage. + The linking then only pulls in that what is required, and can do the cheaper optimisations on the full program as well. + \begin{itemize} + \item \verb|0|: per module (default). + \item \verb|1|: link per module GRIN to whole program GRIN, and continue from there (not yet implemented) + \item \verb|2|: link per module Core to whole program COre, and continue from ther; Core precedes GRIN in the compiler pipeline. \item \verb|--no-recomp|. Don't check for the necessity to recompile, recompile allways instead. \item \verb|--no-prelude|. Don't assume the presence of @Prelude@. \item \verb|--no-hi-check|. Don't use out of date of compiler version w.r.t. to .hi files as a reason to recompile. diff --git a/EHC/text/files-targets.mk b/EHC/text/files-targets.mk index 6dce4252d..b988854ba 100644 --- a/EHC/text/files-targets.mk +++ b/EHC/text/files-targets.mk @@ -404,4 +404,10 @@ text-variant-slides-uhcinternals: TEXT_SHUFFLE_VARIANT=62 \ text-variant-dflt-once +text-variant-slides-uhcstatus: + $(MAKE) \ + LHS2TEX_OPTS_VARIANT_CONFIG="--set=yesBeamer --set=storyStatus --unset=asArticle --set=asSlides --unset=useHyperref --unset=refToPDF" \ + TEXT_SHUFFLE_VARIANT=63 \ + text-variant-dflt-once + diff --git a/EHC/text/files-variants.mk b/EHC/text/files-variants.mk index 83398918f..857d02484 100644 --- a/EHC/text/files-variants.mk +++ b/EHC/text/files-variants.mk @@ -15,7 +15,8 @@ TEXT_PRIV_VARIANTS += flops06-ruler-paper flops06-ruler \ scratch scratch2 \ poster posterLDL posterTrOrPr poster-uhcarch \ slides-ruler slides-ruler-long \ - slides-explimpl slides-explimpl-fpnl slides-overview slides-status \ + slides-explimpl slides-explimpl-fpnl slides-overview \ + slides-status slides-uhcstatus \ slides-ehcstruct slides-ehcstruct-ufmg slides-hs09-uhcarch slides-uhcarch \ slides-uhcinternals \ gbm \ @@ -120,6 +121,7 @@ TEXT_SUBS += AGMiniPrimer StoryIntro StoryEH1 StoryEH2 StoryAFP Scratch \ # 60: doc: library # 61: doc: Jazy backend # 62: slides "UHC Internals" (AFP2010) +# 63: slides UHC status # 77: scratch (article format) TEXT_SHUFFLE_ORDER += \ @@ -152,6 +154,7 @@ TEXT_SHUFFLE_ORDER += \ 18 < 28, \ 18 < 53, \ 18 < 62, \ + 18 < 63, \ 26 < 24, \ 26 < 25, \ 26 < 36, \ diff --git a/EHC/text/files2.mk b/EHC/text/files2.mk index 30cb3b586..abe97ec32 100644 --- a/EHC/text/files2.mk +++ b/EHC/text/files2.mk @@ -9,10 +9,12 @@ TEXT_BLD_PDF := $(DOC_PREFIX)$(TEXT_VARIANT).pdf TEXT_BLD_TWIKI := $(DOC_PREFIX)$(TEXT_VARIANT).twiki +TEXT_BLD_HTML := $(DOC_PREFIX)$(TEXT_VARIANT).html TEXT_ALL_PUB_PDFS := $(patsubst %,$(DOC_PREFIX)%.pdf,$(TEXT_PUB_VARIANTS)) TEXT_ALL_PDFONLY_PDFS := $(patsubst %,$(DOC_PREFIX)%.pdf,$(TEXT_PDFONLY_VARIANTS)) TEXT_ALL_DOCLTX_PDFS := $(patsubst %,$(DOC_PREFIX)%.pdf,$(TEXT_DOCLTX_VARIANTS)) TEXT_ALL_DOCLTX_TWIKIS := $(patsubst %,$(DOC_PREFIX)%.twiki,$(TEXT_DOCLTX_VARIANTS)) +TEXT_ALL_DOCLTX_HTMLS := $(patsubst %,$(DOC_PREFIX)%.html,$(TEXT_DOCLTX_VARIANTS)) TEXT_ALL_DOCLTX_GIFS := $(patsubst $(FIGS_SRC_PREFIX)%.pdf,$(DOC_PREFIX)%.gif,$(FIGS_ASIS_SRC_PDF)) ########################################################################################### @@ -31,6 +33,7 @@ TEXT_MAIN_DRV_STY := $(TEXT_MAIN_DRV_LSTY:.lsty=.sty) TEXT_DOCMAIN_DRV_TTEX := $(TEXT_TMP_VARIANT_PREFIX)$(TEXT_DOCMAIN).ttex TEXT_DOCMAIN_DRV_TEX := $(TEXT_DOCMAIN_DRV_TTEX:.ttex=.tex) TEXT_DOCMAIN_DRV_TWIKI := $(TEXT_DOCMAIN_DRV_TTEX:.ttex=.twiki) +TEXT_DOCMAIN_DRV_HTML := $(TEXT_DOCMAIN_DRV_TTEX:.ttex=.html) TEXT_DOCMAIN_DRV_STY := $(TEXT_TMP_VARIANT_PREFIX)$(TEXT_DOCMAIN)sty.sty # @@ -164,8 +167,9 @@ TEXT_ALL_PDFONLY_DPD := $(TEXT_MAIN_DRV_TEX) $(TEXT_SUBS_DRV_TEX) $(TEXT_MAIN_D $(TEXT_SUBS_ASIS_DRV) $(FIGS_XFIG_DRV_TEX) $(FIGS_XFIG_DRV_PDF) $(FIGS_EPS_DRV_PDF) $(FIGS_DOT_DRV_PDF) $(TEXT_RULER2_DEMO_STUFF) $(FIGS_ASIS_DRV) $(TEXT_HIDE_DRV_TEX) \ $(TEXT_GEN_BY_RULER_TABLE_TEX) $(TEXT_INCL_LIST_TEX) $(TEXT_RULEUX_ALL_DRV_TEX) $(TEXT_RULEUX_ALL_DRV_TEX) $(TEXT_EXPERIMENTS_SUBST_ALL_DRV_TEX) -TEXT_ALL_DOCLTX_DPD := $(TEXT_DOCMAIN_DRV_TEX) $(TEXT_DOCMAIN_DRV_TWIKI) $(TEXT_DOCMAIN_DRV_STY) $(FIGS_ASIS_DRV) +TEXT_ALL_DOCLTX_DPD := $(TEXT_DOCMAIN_DRV_TEX) $(TEXT_DOCMAIN_DRV_TWIKI) $(TEXT_DOCMAIN_DRV_HTML) $(TEXT_DOCMAIN_DRV_STY) $(FIGS_ASIS_DRV) TEXT_ALL_TWIKI_DPD := $(TEXT_DOCMAIN_DRV_TWIKI) $(FIGS_ALL_DRV_GIF) +TEXT_ALL_HTML_DPD := $(TEXT_DOCMAIN_DRV_HTML) $(FIGS_ALL_DRV_GIF) # all shuffle included material TEXT_SUBS_SHUFFLE1 := $(TEXT_SUBS_SRC_CLTEX) $(TEXT_RULES_3_DRV_CAG) $(RULER2_ALL_CHUNK_SRC) $(AGPRIMER_ALL_CHUNK_SRC) $(TEXT_RULES_EXPLAIN_3_DRV_CAG) \ @@ -187,6 +191,7 @@ TEXT_DIST_FILES := $(TEXT_ALL_SRC) TEXT_WWW_DOC_PDFS := $(TEXT_ALL_DOCLTX_PDFS) TEXT_WWW_DOC_GIFS := $(TEXT_ALL_DOCLTX_GIFS) TEXT_WWW_DOC_TWIKIS := $(TEXT_ALL_DOCLTX_TWIKIS) +TEXT_WWW_DOC_HTMLS := $(TEXT_ALL_DOCLTX_HTMLS) ########################################################################################### # variant dispatch rules for targets @@ -205,10 +210,11 @@ text-variant-dflt-once: $(TEXT_ALL_PDFONLY_DPD) cp $(TEXT_TMP_VARIANT_PREFIX)$(TEXT_MAIN).pdf $(TEXT_BLD_PDF) text-variant-dflt-doc: $(TEXT_ALL_DOCLTX_DPD) # $(TEXT_ALL_TWIKI_DPD) - mkdir -p $(dir $(TEXT_BLD_PDF)) $(dir $(TEXT_BLD_TWIKI)) + mkdir -p $(dir $(TEXT_BLD_PDF)) $(dir $(TEXT_BLD_TWIKI)) $(dir $(TEXT_BLD_HTML)) cd $(TEXT_TMP_VARIANT_PREFIX) ; $(PDFLATEX) $(TEXT_DOCMAIN) ; $(PDFLATEX) $(TEXT_DOCMAIN) cp $(TEXT_TMP_VARIANT_PREFIX)$(TEXT_DOCMAIN).pdf $(TEXT_BLD_PDF) cp $(TEXT_TMP_VARIANT_PREFIX)$(TEXT_DOCMAIN).twiki $(TEXT_BLD_TWIKI) + cp $(TEXT_TMP_VARIANT_PREFIX)$(TEXT_DOCMAIN).html $(TEXT_BLD_HTML) text-variant-dflt-bib: $(TEXT_ALL_PDFONLY_DPD) $(TEXT_BIB_DRV) mkdir -p $(dir $(TEXT_BLD_PDF)) @@ -252,14 +258,18 @@ $(TEXT_DOCMAIN_DRV_TTEX) : $(TEXT_MAIN_SRC_CLTEX) $(TEXT_SUBS_SHUFFLE) $(SHUFFLE mkdir -p $(@D) $(SHUFFLE) --gen=$(TEXT_SHUFFLE_VARIANT) --plain --text2text --lhs2tex=no --order="$(TEXT_SHUFFLE_ORDER)" $< $(TEXT_SUBS_SHUFFLE_ALIAS) > $@ -$(TEXT_DOCMAIN_DRV_TEX) : %.tex : %.ttex +$(TEXT_DOCMAIN_DRV_TEX) : %.tex : %.ttex $(TEXT2TEXT) $(TEXT2TEXT) --doclatex $< \ > $@ -$(TEXT_DOCMAIN_DRV_TWIKI) : %.twiki : %.ttex +$(TEXT_DOCMAIN_DRV_TWIKI) : %.twiki : %.ttex $(TEXT2TEXT) $(TEXT2TEXT) --twiki --gen-header-numbering=yes $< \ > $@ +$(TEXT_DOCMAIN_DRV_HTML) : %.html : %.ttex $(TEXT2TEXT) + $(TEXT2TEXT) --html --gen-header-numbering=yes $< \ + > $@ + $(TEXT_ALL_DOCLTX_GIFS): $(DOC_PREFIX)%.gif : $(FIGS_SRC_PREFIX)%.pdf $(TEXT_MKF) convert -trim $< $@ diff --git a/EHC/text/main.cltex b/EHC/text/main.cltex index dbc50f9ba..f69e0446f 100644 --- a/EHC/text/main.cltex +++ b/EHC/text/main.cltex @@ -1070,6 +1070,12 @@ version \date[AFP 2010, Aug 25]{AFP 2010, Aug 25} %%] +%%[63 +\title{Utrecht Haskell Compiler (UHC) \\ status and progress} +\author{Atze Dijkstra, Jeroen Fokker, Doaitse Swierstra} +\date{Oct 1, 2010} +%%] + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -3469,15 +3475,32 @@ We thank both (anonymous) reviewers for their extremely valuable and helpful com \section{Current status} -%%@SlidesStatus.currentStatus +%%@SlidesStatus.currentStatus2007 \section{Near future work} -%%@SlidesStatus.currentWork +%%@SlidesStatus.currentWork2007 %%] +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Slides for UHC status +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[63 +%%@Slides.titlepage + +\section{Current status} + +%%@SlidesStatus.currentUHCStatus201009 + +\section{Near future work} + +%%@SlidesStatus.futureUHCWork201009 + +%%] + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% diff --git a/EHC/www/files.mk b/EHC/www/files.mk index 2e92a4182..cd03d9c0d 100644 --- a/EHC/www/files.mk +++ b/EHC/www/files.mk @@ -11,7 +11,7 @@ WWW_HTML_SRC := $(addprefix $(WWW_SRC_PREFIX),ehc.html) WWW_ALL_SRC := $(WWW_HTML_SRC) # www accessible files -WWW_DOC_FILES := $(patsubst $(DOC_PREFIX)%,$(WWW_SRC_PREFIX)%,$(TEXT_WWW_DOC_PDFS) $(TEXT_WWW_DOC_TWIKIS) $(TEXT_WWW_DOC_GIFS)) +WWW_DOC_FILES := $(patsubst $(DOC_PREFIX)%,$(WWW_SRC_PREFIX)%,$(TEXT_WWW_DOC_PDFS) $(TEXT_WWW_DOC_TWIKIS) $(TEXT_WWW_DOC_HTMLS) $(TEXT_WWW_DOC_GIFS)) # distribution WWW_DIST_FILES := $(WWW_ALL_SRC)