diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# [Ajhc](http://ajhc.github.com/) - arafura-jhc [![Build Status](https://travis-ci.org/ajhc/ajhc.png)](https://travis-ci.org/ajhc/ajhc) +# [Ajhc](http://ajhc.metasepi.org/) - arafura-jhc [![Build Status](https://travis-ci.org/ajhc/ajhc.png)](https://travis-ci.org/ajhc/ajhc) A fork of [jhc](http://repetae.net/computer/jhc/). And also a Haskell compiler. @@ -11,9 +11,10 @@ ## How to build latest version - $ sudo apt-get install make locales autoconf libreadline-dev \ - libwww-perl libconfig-yaml-perl graphviz haskell-platform drift pandoc \ - libghc-readline-dev libghc-utf8-string-dev libghc-hssyck-dev + $ sudo apt-get install make locales autoconf libreadline-dev libwww-perl libconfig-yaml-perl \ + graphviz haskell-platform pandoc hscolour po4a libghc-temporary-dev libghc-haskeline-dev + libghc-utf8-string-dev libghc-hssyck-dev libghc-test-framework-th-dev libghc-test-framework-hunit-dev + libghc-test-framework-quickcheck2-dev libgc-dev gcc-multilib valgrind $ git clone git://github.com/ajhc/ajhc.git $ cd ajhc $ git checkout arafura @@ -40,6 +41,10 @@ The command [darcs send](http://darcs.net/Using/Send) sends email the patch to jhc author (= [John Meacham](http://repetae.net/)). +Perhaps you can get internal overview with following compile flow image: + +![](https://raw.github.com/ajhc/ajhc/arafura/docs/jhc_compile_flow.png) + ## Needing to install/build on Windows (experimental) ### Install msys @@ -67,11 +72,23 @@ http://www.haskell.org/platform/windows.html -### Install DrIFT +## Future plan - $ cabal install DrIFT-cabalized +### Yet -## Future plan +* No more depend on Perl (LWP and YAML). +* Rewrite Cortex-M3 base library with Ajhc. +* Analyze jhc internal (Japanese doc). + http://metasepi.org/posts/2013-01-31-jhc_internal_overview.html +* Find critical region of Ajhc for reentrant and thread safe. +* Port Haskell libraries on haskell-platform to Ajhc. +* Understand jhc's region inference. +* Find the method to implement GC that can be interrupted. +* Play with Android NDK. http://developer.android.com/tools/sdk/ndk/index.html +* Play with Google Native Client. https://developers.google.com/native-client/ +* Play with Nintendo DS. http://devkitpro.org/wiki/Getting_Started/devkitARM +* Get smaller RTS. Benchmark the RTS for running on custom FPGA CPU. +* Start rewritng NetBSD kernel with Ajhc. ### Done @@ -86,17 +103,4 @@ * Support LPCXpresso NXP LPX1769 with demo. * Pass all regress test, and enable regress fail setting on travis-ci. https://travis-ci.org/ajhc/ajhc - -### Yet - * No more depend on DrIFT. Use http://hackage.haskell.org/package/derive. -* No more depend on Perl (LWP and YAML). -* Rewrite Cortex-M3 base library with Ajhc. -* Analyze jhc internal (Japanese doc). - http://metasepi.org/posts/2013-01-31-jhc_internal_overview.html -* Find critical region of Ajhc for reentrant and thread safe. -* Port Haskell libraries on haskell-platform to Ajhc. -* Understand jhc's region inference. -* Find the method to implement GC that can be interrupted. -* Get smaller RTS. Benchmark the RTS for running on custom FPGA CPU. -* Start rewritng NetBSD kernel with Ajhc. diff --git a/ajhc.cabal b/ajhc.cabal --- a/ajhc.cabal +++ b/ajhc.cabal @@ -1,7 +1,7 @@ cabal-version: >= 1.10 name: ajhc build-type: Custom -version: 0.8.0.5 +version: 0.8.0.6 license: GPL-2 license-file: COPYING category: Compiler @@ -16,6 +16,11 @@ system, but rather generates what is needed as part of the compilation process. However, back ends do have specific run-time representations of data, which can be affected by things like the choice of garbage collector. + . + Perhaps you can get internal overview with following compile flow image: + . + . + <> homepage: http://ajhc.metasepi.org/ data-files: README.md @@ -24,14 +29,14 @@ examples/*.hs rts/HsFFI.h Makefile.cabalinst library_deps.make src/data/targets.ini src/StringTable/StringTable_cbits.h src/cbits/config.h src/hs_src_config.h src/data/Typeable.h utils/build_extlibs.prl - lib/haskell-extras/Data/Bits.hs lib/haskell-extras/Data/Maybe.hs lib/haskell-extras/Data/Bits.m4 lib/haskell-extras/Data/IORef.hs lib/haskell-extras/Data/Monoid.hs lib/haskell-extras/Data/Int.hs lib/haskell-extras/Data/Typeable.hs lib/haskell-extras/Data/Functor.hs lib/haskell-extras/Data/Char.hs lib/haskell-extras/Data/Array/Unboxed.hs lib/haskell-extras/Data/Array/IO.hs lib/haskell-extras/Data/Complex.hs lib/haskell-extras/Data/Array.hs lib/haskell-extras/Data/Version.hs lib/haskell-extras/Data/Function.hs lib/haskell-extras/Data/List.hs lib/haskell-extras/Data/Unique.hs lib/haskell-extras/Data/Ix.hs lib/haskell-extras/Data/Dynamic.hs lib/haskell-extras/Data/Unicode.hs lib/haskell-extras/Data/Word.hs lib/haskell-extras/Prelude.hs lib/haskell-extras/haskell-extras.yaml.m4 lib/haskell-extras/Unsafe/Coerce.hs lib/haskell-extras/Foreign.hs lib/haskell-extras/Typeable.hs lib/haskell-extras/Debug/Trace.hs lib/haskell-extras/System/IO/Pipe.hs lib/haskell-extras/System/IO/Binary.hs lib/haskell-extras/System/IO/Error.hs lib/haskell-extras/System/IO/Continuation.hs lib/haskell-extras/System/Random.hs lib/haskell-extras/System/Exit.hs lib/haskell-extras/System/Console/GetOpt.hs lib/haskell-extras/System/Time.hs lib/haskell-extras/System/Directory.hs lib/haskell-extras/System/CPUTime.hs lib/haskell-extras/System/Cmd.hs lib/haskell-extras/System/Environment.hs lib/haskell-extras/System/Info.hs lib/haskell-extras/System/IO.hs lib/haskell-extras/System/Locale.hs lib/haskell-extras/Text/Show/Functions.hs lib/haskell-extras/Text/Printf.hs lib/haskell-extras/Control/Monad/Fix.hs lib/haskell-extras/Control/Monad/Instances.hs lib/haskell-extras/Control/Exception.hs lib/haskell-extras/Control/Monad.hs lib/haskell-extras/Foreign/C.hs lib/haskell-extras/Foreign/ForeignPtr.hs lib/haskell-extras/Foreign/StablePtr.hs lib/haskell-extras/Foreign/Marshal/Pool.hs lib/haskell-extras/Foreign/Marshal/Error.hs lib/haskell-extras/Foreign/Marshal.hs lib/haskell98/Maybe.hs lib/haskell98/Random.hs lib/haskell98/Time.hs lib/haskell98/prologue.txt lib/haskell98/System.hs lib/haskell98/Ratio.hs lib/haskell98/Directory.hs lib/haskell98/CPUTime.hs lib/haskell98/haskell98.yaml lib/haskell98/Char.hs lib/haskell98/Complex.hs lib/haskell98/Array.hs lib/haskell98/List.hs lib/haskell98/IO.hs lib/haskell98/Ix.hs lib/haskell98/Monad.hs lib/haskell98/Locale.hs lib/haskell98/LICENSE lib/flat-foreign/Bits.hs lib/flat-foreign/Ptr.hs lib/flat-foreign/MarshalAlloc.hs lib/flat-foreign/MarshalError.hs lib/flat-foreign/Storable.hs lib/flat-foreign/CForeign.hs lib/flat-foreign/ForeignPtr.hs lib/flat-foreign/Int.hs lib/flat-foreign/StablePtr.hs lib/flat-foreign/MarshalArray.hs lib/flat-foreign/flat-foreign.yaml lib/flat-foreign/MarshalUtils.hs lib/flat-foreign/CTypes.hs lib/flat-foreign/Word.hs lib/flat-foreign/CError.hs lib/flat-foreign/CString.hs lib/applicative/Data/Foldable.hs lib/applicative/Data/Traversable.hs lib/applicative/Control/Applicative.hs lib/applicative/Control/Arrow.hs lib/applicative/Control/Category.hs lib/applicative/applicative.yaml lib/jhc/Numeric.hs lib/jhc/Data/Ratio.hs lib/jhc/Jhc/Order.hs lib/jhc/Jhc/Numeric.hs lib/jhc/Jhc/Maybe.hs lib/jhc/Jhc/Inst/Order.hs lib/jhc/Jhc/Inst/Storable.hs lib/jhc/Jhc/Inst/Show.hs lib/jhc/Jhc/Inst/PrimEnum.hs lib/jhc/Jhc/Inst/Enum.hs lib/jhc/Jhc/Inst/Num.hs lib/jhc/Jhc/Inst/Read.hs lib/jhc/Jhc/Enum.m4 lib/jhc/Jhc/Hole.hs lib/jhc/Jhc/String.hs lib/jhc/Jhc/Prim.hs lib/jhc/Jhc/Options.hs lib/jhc/Jhc/Show.hs lib/jhc/Jhc/Handle.hs lib/jhc/Jhc/ForeignPtr.hs lib/jhc/Jhc/Type/C.hs lib/jhc/Jhc/Type/Ptr.hs lib/jhc/Jhc/Type/Basic.hs lib/jhc/Jhc/Type/Handle.hs lib/jhc/Jhc/Type/Float.hs lib/jhc/Jhc/Type/Word.hs lib/jhc/Jhc/ACIO.hs lib/jhc/Jhc/JumpPoint.hs lib/jhc/Jhc/Int.hs lib/jhc/Jhc/Class/Real.hs lib/jhc/Jhc/Class/Ord.hs lib/jhc/Jhc/Class/Num.hs lib/jhc/Jhc/Float.hs lib/jhc/Jhc/Text/Read.hs lib/jhc/Jhc/Num.m4 lib/jhc/Jhc/List.hs lib/jhc/Jhc/Enum.hs lib/jhc/Jhc/IO.hs lib/jhc/Jhc/Order.m4 lib/jhc/Jhc/Monad.hs lib/jhc/Jhc/Addr.hs lib/jhc/Jhc/Basics.hs lib/jhc/Jhc/Num.hs lib/jhc/Jhc/Tuples.hs lib/jhc/System/IO/Unsafe.hs lib/jhc/System/Mem/StableName.hs lib/jhc/System/C/Stdio.hs lib/jhc/System/Mem.hs lib/jhc/Prelude/CType.hs lib/jhc/Prelude/Text.hs lib/jhc/Prelude/Float.hs lib/jhc/Prelude/IO.hs lib/jhc/Foreign/Ptr.hs lib/jhc/Foreign/Storable.hs lib/jhc/Foreign/C/String.hs lib/jhc/Foreign/C/Types.hs lib/jhc/Foreign/C/Error.hs lib/jhc/Foreign/Storable.m4 lib/jhc/Foreign/Marshal/Alloc.hs lib/jhc/Foreign/Marshal/Utils.hs lib/jhc/Foreign/Marshal/Array.hs lib/jhc/jhc.yaml lib/jhc-prim/jhc-prim.yaml lib/jhc-prim/Jhc/Prim/Bits.hs lib/jhc-prim/Jhc/Prim/Prim.hs lib/jhc-prim/Jhc/Prim/Rts.hs lib/jhc-prim/Jhc/Prim/Array.hs lib/jhc-prim/Jhc/Prim/IO.hs lib/jhc-prim/Jhc/Prim/Wrapper.hs lib/haskell2010/haskell2010.yaml.m4 lib/ext/bytestring.patch lib/ext/smallcheck.cabal lib/ext/parsec.cabal lib/ext/containers.cabal lib/ext/utility-ht.cabal lib/ext/html.cabal lib/ext/filepath.cabal lib/ext/bytestring.yaml lib/ext/pretty.cabal lib/ext/HUnit.cabal lib/ext/transformers.cabal lib/ext/deepseq.cabal lib/ext/xhtml.cabal lib/ext/Diff.cabal lib/ext/containers.patch lib/ext/QuickCheck.cabal lib/ext/safe.cabal + lib/haskell-extras/Data/Bits.hs lib/haskell-extras/Data/Maybe.hs lib/haskell-extras/Data/Bits.m4 lib/haskell-extras/Data/IORef.hs lib/haskell-extras/Data/Monoid.hs lib/haskell-extras/Data/Int.hs lib/haskell-extras/Data/Typeable.hs lib/haskell-extras/Data/Functor.hs lib/haskell-extras/Data/Char.hs lib/haskell-extras/Data/Array/Unboxed.hs lib/haskell-extras/Data/Array/IO.hs lib/haskell-extras/Data/Complex.hs lib/haskell-extras/Data/Array.hs lib/haskell-extras/Data/Version.hs lib/haskell-extras/Data/Function.hs lib/haskell-extras/Data/List.hs lib/haskell-extras/Data/Unique.hs lib/haskell-extras/Data/Ix.hs lib/haskell-extras/Data/Dynamic.hs lib/haskell-extras/Data/Unicode.hs lib/haskell-extras/Data/Word.hs lib/haskell-extras/Prelude.hs lib/haskell-extras/haskell-extras.yaml.m4 lib/haskell-extras/Unsafe/Coerce.hs lib/haskell-extras/Foreign.hs lib/haskell-extras/Typeable.hs lib/haskell-extras/Debug/Trace.hs lib/haskell-extras/System/IO/Pipe.hs lib/haskell-extras/System/IO/Binary.hs lib/haskell-extras/System/IO/Error.hs lib/haskell-extras/System/IO/Continuation.hs lib/haskell-extras/System/Random.hs lib/haskell-extras/System/Exit.hs lib/haskell-extras/System/Console/GetOpt.hs lib/haskell-extras/System/Time.hs lib/haskell-extras/System/Directory.hs lib/haskell-extras/System/CPUTime.hs lib/haskell-extras/System/Cmd.hs lib/haskell-extras/System/Environment.hs lib/haskell-extras/System/Info.hs lib/haskell-extras/System/IO.hs lib/haskell-extras/System/Locale.hs lib/haskell-extras/Text/Show/Functions.hs lib/haskell-extras/Text/Printf.hs lib/haskell-extras/Control/Monad/Fix.hs lib/haskell-extras/Control/Monad/Instances.hs lib/haskell-extras/Control/Concurrent.hs lib/haskell-extras/Control/Exception.hs lib/haskell-extras/Control/Monad.hs lib/haskell-extras/Foreign/C.hs lib/haskell-extras/Foreign/ForeignPtr.hs lib/haskell-extras/Foreign/StablePtr.hs lib/haskell-extras/Foreign/Marshal/Pool.hs lib/haskell-extras/Foreign/Marshal/Error.hs lib/haskell-extras/Foreign/Marshal.hs lib/haskell98/Maybe.hs lib/haskell98/Random.hs lib/haskell98/Time.hs lib/haskell98/prologue.txt lib/haskell98/System.hs lib/haskell98/Ratio.hs lib/haskell98/Directory.hs lib/haskell98/CPUTime.hs lib/haskell98/haskell98.yaml lib/haskell98/Char.hs lib/haskell98/Complex.hs lib/haskell98/Array.hs lib/haskell98/List.hs lib/haskell98/IO.hs lib/haskell98/Ix.hs lib/haskell98/Monad.hs lib/haskell98/Locale.hs lib/haskell98/LICENSE lib/flat-foreign/Bits.hs lib/flat-foreign/Ptr.hs lib/flat-foreign/MarshalAlloc.hs lib/flat-foreign/MarshalError.hs lib/flat-foreign/Storable.hs lib/flat-foreign/CForeign.hs lib/flat-foreign/ForeignPtr.hs lib/flat-foreign/Int.hs lib/flat-foreign/StablePtr.hs lib/flat-foreign/MarshalArray.hs lib/flat-foreign/flat-foreign.yaml lib/flat-foreign/MarshalUtils.hs lib/flat-foreign/CTypes.hs lib/flat-foreign/Word.hs lib/flat-foreign/CError.hs lib/flat-foreign/CString.hs lib/applicative/Data/Foldable.hs lib/applicative/Data/Traversable.hs lib/applicative/Control/Applicative.hs lib/applicative/Control/Arrow.hs lib/applicative/Control/Category.hs lib/applicative/applicative.yaml lib/jhc/Numeric.hs lib/jhc/Data/Ratio.hs lib/jhc/Jhc/Order.hs lib/jhc/Jhc/Numeric.hs lib/jhc/Jhc/Maybe.hs lib/jhc/Jhc/Inst/Order.hs lib/jhc/Jhc/Inst/Storable.hs lib/jhc/Jhc/Inst/Show.hs lib/jhc/Jhc/Inst/PrimEnum.hs lib/jhc/Jhc/Inst/Enum.hs lib/jhc/Jhc/Inst/Num.hs lib/jhc/Jhc/Inst/Read.hs lib/jhc/Jhc/Enum.m4 lib/jhc/Jhc/Hole.hs lib/jhc/Jhc/String.hs lib/jhc/Jhc/Prim.hs lib/jhc/Jhc/Options.hs lib/jhc/Jhc/Show.hs lib/jhc/Jhc/Handle.hs lib/jhc/Jhc/ForeignPtr.hs lib/jhc/Jhc/Type/C.hs lib/jhc/Jhc/Type/Ptr.hs lib/jhc/Jhc/Type/Basic.hs lib/jhc/Jhc/Type/Handle.hs lib/jhc/Jhc/Type/Float.hs lib/jhc/Jhc/Type/Word.hs lib/jhc/Jhc/ACIO.hs lib/jhc/Jhc/JumpPoint.hs lib/jhc/Jhc/Int.hs lib/jhc/Jhc/Class/Real.hs lib/jhc/Jhc/Class/Ord.hs lib/jhc/Jhc/Class/Num.hs lib/jhc/Jhc/Float.hs lib/jhc/Jhc/Text/Read.hs lib/jhc/Jhc/Num.m4 lib/jhc/Jhc/List.hs lib/jhc/Jhc/Enum.hs lib/jhc/Jhc/IO.hs lib/jhc/Jhc/Order.m4 lib/jhc/Jhc/Monad.hs lib/jhc/Jhc/Addr.hs lib/jhc/Jhc/Basics.hs lib/jhc/Jhc/Num.hs lib/jhc/Jhc/Tuples.hs lib/jhc/System/IO/Unsafe.hs lib/jhc/System/Mem/StableName.hs lib/jhc/System/C/Stdio.hs lib/jhc/System/Mem.hs lib/jhc/Prelude/CType.hs lib/jhc/Prelude/Text.hs lib/jhc/Prelude/Float.hs lib/jhc/Prelude/IO.hs lib/jhc/Foreign/Ptr.hs lib/jhc/Foreign/Storable.hs lib/jhc/Foreign/C/String.hs lib/jhc/Foreign/C/Types.hs lib/jhc/Foreign/C/Error.hs lib/jhc/Foreign/Storable.m4 lib/jhc/Foreign/Marshal/Alloc.hs lib/jhc/Foreign/Marshal/Utils.hs lib/jhc/Foreign/Marshal/Array.hs lib/jhc/jhc.yaml lib/jhc-prim/jhc-prim.yaml lib/jhc-prim/Jhc/Prim/Bits.hs lib/jhc-prim/Jhc/Prim/Prim.hs lib/jhc-prim/Jhc/Prim/Rts.hs lib/jhc-prim/Jhc/Prim/Array.hs lib/jhc-prim/Jhc/Prim/IO.hs lib/jhc-prim/Jhc/Prim/Wrapper.hs lib/haskell2010/haskell2010.yaml.m4 lib/ext/bytestring.patch lib/ext/smallcheck.cabal lib/ext/parsec.cabal lib/ext/containers.cabal lib/ext/utility-ht.cabal lib/ext/html.cabal lib/ext/filepath.cabal lib/ext/bytestring.yaml lib/ext/pretty.cabal lib/ext/HUnit.cabal lib/ext/transformers.cabal lib/ext/deepseq.cabal lib/ext/xhtml.cabal lib/ext/Diff.cabal lib/ext/containers.patch lib/ext/QuickCheck.cabal lib/ext/safe.cabal source-repository head type: git location: https://github.com/ajhc/ajhc.git library - hs-source-dirs: drift_processed src + hs-source-dirs: src default-language: Haskell98 c-sources: @@ -49,6 +54,7 @@ binary, bytestring, containers, + derive, directory, fgl, filepath, @@ -72,68 +78,21 @@ exposed-modules: C.FFI C.FromGrin2 + C.Generate C.Prims Cmm.Number - DataConstructors - Doc.DocLike - Doc.Pretty - E.Main - E.Program - E.Rules - E.Type - FlagDump - FrontEnd.Class - FrontEnd.Exports - FrontEnd.HsSyn - FrontEnd.Infix - FrontEnd.KindInfer - FrontEnd.Rename - FrontEnd.Representation - FrontEnd.SrcLoc - FrontEnd.Tc.Kind - FrontEnd.Tc.Module - FrontEnd.Tc.Type - FrontEnd.TypeSynonyms - FrontEnd.Warning - Grin.FromE - Grin.Grin - Grin.Main - Grin.Show - Ho.Build - Ho.Collected - Ho.Library - Ho.Type - Info.Info - Info.Types - Interactive - Name.Id - Name.Name - Options - PackedString - Stats - StringTable.Atom - Support.CFF - Support.TempDir - Util.BitSet - Util.GMap - Util.Gen - Util.HasSize - Util.Perhaps - Util.SHA1 - Util.SetLike - Version.Version - - other-modules: - C.Generate Cmm.Op Cmm.OpEval + DataConstructors DerivingDrift.DataP DerivingDrift.Drift DerivingDrift.RuleUtils DerivingDrift.StandardRules Doc.Attr Doc.Chars + Doc.DocLike Doc.PPrint + Doc.Pretty E.Annotate E.Arbitrary E.Binary @@ -149,12 +108,16 @@ E.LambdaLift E.LetFloat E.Lint + E.Main E.PrimDecode E.PrimOpt + E.Program + E.Rules E.SSimplify E.Show E.Subst E.Traverse + E.Type E.TypeAnalysis E.TypeCheck E.Values @@ -163,51 +126,83 @@ Fixer.Fixer Fixer.Supply Fixer.VMap + FlagDump FlagOpts + FrontEnd.Class FrontEnd.DataConsAssump FrontEnd.DeclsDepends FrontEnd.DependAnalysis FrontEnd.Desugar FrontEnd.Diagnostic + FrontEnd.Exports FrontEnd.FrontEnd FrontEnd.HsErrors FrontEnd.HsParser FrontEnd.HsPretty + FrontEnd.HsSyn + FrontEnd.Infix + FrontEnd.KindInfer FrontEnd.Lexer FrontEnd.ParseMonad FrontEnd.ParseUtils + FrontEnd.Rename + FrontEnd.Representation + FrontEnd.SrcLoc FrontEnd.Syn.Options FrontEnd.Syn.Traverse FrontEnd.Tc.Class + FrontEnd.Tc.Kind FrontEnd.Tc.Main + FrontEnd.Tc.Module FrontEnd.Tc.Monad + FrontEnd.Tc.Type FrontEnd.Tc.Unify FrontEnd.TypeSigs + FrontEnd.TypeSynonyms FrontEnd.TypeSyns FrontEnd.Unlit FrontEnd.Utils + FrontEnd.Warning GenUtil Grin.DeadCode Grin.Devolve Grin.EvalInline + Grin.FromE + Grin.Grin Grin.HashConst Grin.Lint + Grin.Main Grin.NodeAnalyze Grin.Noodle Grin.Optimize Grin.SSimplify + Grin.Show Grin.StorageAnalysis Grin.Val Grin.Whiz Ho.Binary + Ho.Build + Ho.Collected + Ho.Library Ho.ReadSource + Ho.Type Info.Binary + Info.Info Info.Properties + Info.Types + Interactive Name.Binary + Name.Id + Name.Name Name.Names Name.Prim Name.VConsts + Options + PackedString RawFiles + Stats + StringTable.Atom + Support.CFF Support.Cabal Support.CanType Support.Compat @@ -216,27 +211,35 @@ Support.IniParse Support.MD5 Support.MapBinaryInstance + Support.TempDir Support.Tickle Support.Transform Support.Tuple Support.Unparse + Util.BitSet Util.ContextMonad Util.ExitCodes Util.FilterInput + Util.GMap + Util.Gen Util.Graph Util.Graphviz + Util.HasSize Util.Histogram Util.Inst Util.IntBag Util.Interact Util.NameMonad Util.Once + Util.Perhaps Util.Progress Util.RWS Util.ReaderWriter Util.Relation + Util.SHA1 Util.SameShape Util.Seq + Util.SetLike Util.TrueSet Util.UnionFind Util.UnionSolve @@ -245,6 +248,9 @@ Util.VarName Util.YAML Version.Config + Version.Version + + other-modules: Paths_ajhc default-extensions: @@ -261,7 +267,7 @@ PostfixOperators, PatternGuards, LiberalTypeSynonyms, RankNTypes, TypeOperators, EmptyDataDecls, KindSignatures - ghc-options: -W -fno-warn-unused-matches -fwarn-type-defaults -i./drift_processed -i./src + ghc-options: -W -fno-warn-unused-matches -fwarn-type-defaults -i./src cc-options: -std=c99 cpp-options: -DUSE_HASKELINE -DWITH_CABAL @@ -277,6 +283,7 @@ binary, bytestring, containers, + derive, directory, fgl, filepath, diff --git a/drift_processed/C/FFI.hs b/drift_processed/C/FFI.hs deleted file mode 100644 --- a/drift_processed/C/FFI.hs +++ /dev/null @@ -1,52 +0,0 @@ -{- Generated by DrIFT (Automatic class derivations for Haskell) -} -{-# LINE 1 "src/C/FFI.hs" #-} -module C.FFI( - CallConv(..), - Safety(..), - FfiType(..), - FfiExport(..), - FfiSpec(..), - Requires(..) - ) where - -import C.Prims -import Data.Binary -import Data.Typeable - -type CName = String - -data FfiType = Import CName Requires - | ImportAddr CName Requires - | Wrapper - | Dynamic - deriving(Eq,Ord,Show) - -data FfiSpec = FfiSpec FfiType Safety CallConv - deriving(Eq,Ord,Show) - -data FfiExport = FfiExport { - ffiExportCName :: CName, - ffiExportSafety :: Safety, - ffiExportCallConv :: CallConv, - ffiExportArgTypes :: [ExtType], - ffiExportRetType :: ExtType - } - deriving(Eq,Ord,Show,Typeable) - {-! derive: Binary !-} -{-* Generated by DrIFT : Look, but Don't Touch. *-} -instance Data.Binary.Binary FfiExport where - put (FfiExport aa ab ac ad ae) = do - Data.Binary.put aa - Data.Binary.put ab - Data.Binary.put ac - Data.Binary.put ad - Data.Binary.put ae - get = do - aa <- get - ab <- get - ac <- get - ad <- get - ae <- get - return (FfiExport aa ab ac ad ae) - --- Imported from other files :- diff --git a/drift_processed/C/FromGrin2.hs b/drift_processed/C/FromGrin2.hs deleted file mode 100644 --- a/drift_processed/C/FromGrin2.hs +++ /dev/null @@ -1,1014 +0,0 @@ -{- Generated by DrIFT (Automatic class derivations for Haskell) -} -{-# LINE 1 "src/C/FromGrin2.hs" #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards,ViewPatterns #-} -module C.FromGrin2(compileGrin) where - -import Control.Monad.Identity -import Control.Monad.RWS(asks,tell,local,get,runRWST,RWST,MonadState(..),MonadWriter(..),MonadReader(..)) -import Data.Char -import Data.List -import Data.Maybe -import Data.Monoid(Monoid(..)) -import System.FilePath -import Text.PrettyPrint.HughesPJ(nest,($$),fsep) -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.UTF8 as BS -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Text.PrettyPrint.HughesPJ as P - -import C.FFI -import C.Generate -import C.Prims -import Cmm.Number -import Doc.DocLike -import Doc.PPrint -import Grin.Grin -import Grin.HashConst -import Grin.Noodle -import Grin.Show() -import Grin.Val -import Options -import PackedString -import StringTable.Atom -import Support.CanType -import Support.FreeVars -import Util.Gen -import Util.SetLike -import Util.UniqueMonad -import qualified Cmm.Op as Op -import qualified FlagOpts as FO - ---------------- --- C Monad ---------------- - -data Todo = TodoReturn | TodoExp [Expression] | TodoDecl Name Type | TodoNothing - -data Written = Written { - wRequires :: Requires, - wStructures :: Map.Map Name Structure, - wTags :: Set.Set Atom, - wAllocs :: Set.Set (Atom,Int), - wEnums :: Map.Map Name Int, - wFunctions :: Map.Map Name Function - } - {-! derive: Monoid !-} - --- special type representations when possible -data TyRep - = TyRepRawTag -- stored raw tag - | TyRepUntagged -- memory, without a tag - | TyRepRawVal !Bool -- stored raw argument and whether it is signed - -data Env = Env { - rTodo :: Todo, - rInscope :: Set.Set Name, - rStowed :: Set.Set Name, -- names that the garbage collector knows about - rDeclare :: Bool, - rEMap :: Map.Map Atom (Name,[Expression]), - rCPR :: Map.Map Atom TyRep, - rConst :: Set.Set Atom, - rGrin :: Grin - } - -rEMap_u f r@Env{rEMap = x} = r{rEMap = f x} -rInscope_u f r@Env{rInscope = x} = r{rInscope = f x} - -newtype C a = C (RWST Env Written HcHash Uniq a) - deriving(Monad,UniqueProducer,MonadState HcHash,MonadWriter Written,MonadReader Env,Functor) - -runC :: Grin -> C a -> ((a,HcHash,Written),Map.Map Atom TyRep) -runC grin (C m) = (execUniq1 (runRWST m startEnv emptyHcHash),ityrep) where - TyEnv tmap = grinTypeEnv grin - ityrep = Map.mapMaybeWithKey tyRep (fromDistinctAscList $ Util.SetLike.toList tmap) - startEnv = Env { - rCPR = ityrep, - rGrin = grin, - rStowed = Set.empty, - rDeclare = False, - rTodo = TodoExp [], - rEMap = mempty, - rConst = Map.keysSet $ Map.filter isConst ityrep, - rInscope = mempty - } - isConst TyRepRawVal {} = True - isConst TyRepRawTag {} = True - isConst _ = False - tyRep k _ | k == cChar = Just $ TyRepRawVal False - tyRep k _ | not (fopts FO.FullInt), k == cWord = Just $ TyRepRawVal False - tyRep k _ | not (fopts FO.FullInt), k == cInt = Just $ TyRepRawVal True - tyRep k TyTy { tySlots = [s], tySiblings = Just [k'] } | k == k', good s = Just $ TyRepRawVal False - tyRep k tyty | null (tySlots tyty) = Just TyRepRawTag - tyRep k tyty | Just xs <- tySiblings tyty, all triv [ x | x <- xs, x /= k] = Just TyRepUntagged where - triv x = case mlookup x tmap of - Just t -> null (tySlots t) - Nothing -> False - tyRep _ _ = Nothing --- tyRep k tyty | tySiblings tyty == Just [k] = Just TyRepUntagged - --cpr = iw `Map.union` Map.insert cChar False (Map.fromList [ (a,False) | (a,TyTy { tySlots = [s], tySiblings = Just [a'] }) <- Map.assocs tmap, a == a', isJust (good s) ]) - --iw = if fopts FO.FullInt then mempty else Map.fromList [(cInt,True), (cWord,False)] - good s = isJust $ do - ct <- Op.toCmmTy s - b <- Op.cmmTyBits ct - guard $ b <= 30 - Op.HintNone <- Op.cmmTyHint ct - return () - -tellFunctions :: [Function] -> C () -tellFunctions fs = tell mempty { wFunctions = Map.fromList $ map (\x -> (functionName x,x)) fs } - -localTodo :: Todo -> C a -> C a -localTodo todo (C act) = C $ local (\ r -> r { rTodo = todo }) act - --------------- --- entry point --------------- - -{-# NOINLINE compileGrin #-} -compileGrin :: Grin -> (LBS.ByteString,Requires) -compileGrin grin = (LBS.fromChunks code, req) where - code = [ - BS.fromString "#include \"jhc_rts_header.h\"\n", - BS.fromString $ P.render ans, - BS.fromString "\n" - ] - ans = vcat [ - vcat jgcs, - vcat includes, --- vcat cincludes, - text "", - enum_tag_t, - header, - cafs, - buildConstants cpr grin finalHcHash, - text "", - nh_stuff, - text "", - body - ] - jgcs | fopts FO.Jgc = [ text "static struct s_cache *" <> tshow (nodeCacheName m) <> char ';' | (m,_) <- Set.toList wAllocs] - | otherwise = empty - fromRequires (Requires s) = map (unpackPS . snd) (Set.toList s) - nh_stuff = text "const void * const nh_stuff[] = {" $$ fsep (punctuate (char ',') (cafnames ++ constnames ++ [text "NULL"])) $$ text "};" - includes = map include (filter ((".h" ==) . takeExtension) $ fromRequires req) --- cincludes = map include (filter ((".c" ==) . takeExtension) $ fromRequires req) - include fn = text "#include <" <> text fn <> text ">" - (header,body) = generateC (function (name "jhc_hs_init") voidType [] [Public] icaches:Map.elems fm) (Map.elems sm) - icaches :: Statement - icaches | fopts FO.Jgc = mconcat [ toStatement $ functionCall (name "find_cache") [reference (toExpression $ nodeCacheName t),toExpression $ name "saved_arena", tbsize (sizeof (structType $ nodeStructName t)), toExpression nptrs] | (t,nptrs) <- Set.toList wAllocs ] - | otherwise = mempty - cafnames = [ text "&_" <> tshow (varName v) | (v,_) <- grinCafs grin ] - constnames = map (\n -> text "&_c" <> tshow n) [ 1 .. length $ Grin.HashConst.toList finalHcHash] - ((cafs',finalHcHash,Written { wRequires = req, wFunctions = fm, wEnums = wenum, wStructures = sm, wTags = ts, .. }),cpr) = runC grin $ go >> mapM convertCAF (grinCafs grin) - enum_tag_t | null enums = mempty - | otherwise = text "enum {" $$ nest 4 (P.vcat (punctuate P.comma $ enums)) $$ text "};" - where - f t n = tshow t <> text " = " <> tshow (n :: Int) - enums = map (uncurry f) (Map.toList wenum) ++ (zipWith f (Set.toList (Set.map nodeTagName ts)) [0 ..]) - go = do - funcs <- liftM concat $ flip mapM (grinFuncs grin) $ \(a,l) -> do - convertFunc (mlookup a (grinEntryPoints grin)) (a,l) - tellFunctions funcs - h <- get - let tset = Set.fromList [ n | (HcNode n (_:_),_) <- hconsts] - tset' = Set.fromList [ n | (HcNode n [],_) <- hconsts] - hconsts = Grin.HashConst.toList h - mapM_ tellAllTags [ v | (HcNode _ vs,_) <- hconsts, Left v <- vs] - mapM_ declareStruct (Set.toList tset) - mapM_ tellTags (Set.toList $ tset `mappend` tset') - cafs = text "/* CAFS */" $$ (vcat $ cafs') - convertCAF (v,val@(NodeC a [])) = do - en <- declareEvalFunc True a - let ef = drawG $ f_TO_FPTR (reference $ variable en) - let ts = text "/* " <> text (show v) <> text " = " <> (text $ P.render (pprint val)) <> text "*/\n" <> - text "static node_t _" <> tshow (varName v) <> text " = { .head = " <> ef <> text " };\n" <> - text "#define " <> tshow (varName v) <+> text "(MKLAZY_C(&_" <> tshow (varName v) <> text "))\n"; - return ts - convertCAF _ = error "FromGrin2.compileGrin: bad." - -convertFunc :: Maybe FfiExport -> (Atom,Lam) -> C [Function] -convertFunc ffie (n,as :-> body) = do - s <- localTodo TodoReturn (convertBody body) - let bt = getType body - mmalloc [TyINode] = [a_MALLOC] - mmalloc [TyNode] = [a_MALLOC] - mmalloc _ = [] - ats = a_STD:mmalloc bt - fnname = nodeFuncName n - - fr <- convertTypes bt - as' <- flip mapM (zip [1 :: Int .. ] as) $ \ (ix,(Var v t)) -> do - t' <- convertType t - return $ if v == v0 then (name $ 'u':show ix,t') else (varName v,t') - - mstub <- case ffie of - Nothing -> return [] - Just ~(FfiExport cn Safe CCall argTys retTy) -> do - newVars <- mapM (liftM (name . show) . newVar . basicType') argTys - - let fnname2 = name cn - as2 = zip (newVars) (map basicType' argTys) - fr2 = basicType' retTy - - return [function fnname2 fr2 as2 [Public] - (creturn $ cast fr2 $ functionCall fnname $ (if fopts FO.Jgc then ([variable (name "saved_gc"), variable (name "saved_arena")] ++) else id) $ - zipWith cast (map snd as') - (map variable newVars))] - - return (function fnname fr (mgct as') ats s : mstub) - -fetchVar :: Var -> Ty -> C Expression -fetchVar (V 0) _ = return $ noAssign (err "fetchVar v0") -fetchVar v@(V n) _ | n < 0 = return $ (variable $ varName v) -fetchVar v ty = do - t <- convertType ty - is <- asks rInscope - let n = varName v - dclare <- asks rDeclare - return $ (if v == v0 then noAssign else id) $ if not dclare then variable n else localVariable t n - -fetchVar' :: Var -> Ty -> C (Name,Type) -fetchVar' (V n) _ | n < 0 = error "fetchVar': CAF" -fetchVar' v ty = do - t <- convertType ty - return $ (varName v,t) - -convertVals :: [Val] -> C Expression -convertVals [] = return emptyExpression -convertVals [x] = convertVal x -convertVals xs = do - ts <- mapM convertType (map getType xs) - xs <- mapM convertVal xs - return (structAnon (zip xs ts)) - -convertVal :: Val -> C Expression -convertVal v = cvc v where - cvc v = convertConst v >>= maybe (cv v) return - cv (Var v ty) = fetchVar v ty - cv (Const h) = do - cpr <- asks rConst - case h of - NodeC a ts -> do - bn <- basicNode a ts - case bn of - Just bn -> return (cast sptr_t bn) - _ -> do - (_,i) <- newConst cpr h - return $ variable (name $ 'c':show i ) - _ -> do - (_,i) <- newConst cpr h - return $ variable (name $ 'c':show i ) - cv h@(NodeC a ts) | valIsConstant h = do - cpr <- asks rConst - bn <- basicNode a ts - case bn of - Just bn -> return bn - _ -> do - (_,i) <- newConst cpr h - return $ f_PROMOTE (variable (name $ 'c':show i )) - - cv (ValPrim p [x] (TyPrim opty)) = do - x' <- convertVal x - case p of - Op (Op.UnOp n ta) r -> primUnOp n ta r x' - Op (Op.ConvOp n ta) r -> return $ castFunc n ta r x' - x -> return $ err ("convertVal: " ++ show x) - cv (ValPrim p [x,y] _) = do - x' <- convertVal x - y' <- convertVal y - case p of - Op (Op.BinOp n ta tb) r -> primBinOp n ta tb r x' y' - x -> return $ err ("convertVal: " ++ show x) - - cv x = return $ err ("convertVal: " ++ show x) - -convertTypes [] = return voidType -convertTypes [t] = convertType t -convertTypes xs = do - xs <- mapM convertType xs - return (anonStructType xs) - -convertType TyNode = return wptr_t -convertType TyINode = return sptr_t -convertType (TyPtr TyINode) = return $ ptrType sptr_t -convertType (TyPtr TyNode) = return $ ptrType wptr_t -convertType ~(TyPrim opty) = return (opTyToC opty) - -tyToC _ Op.TyBool = "bool" -tyToC dh (Op.TyComplex ty) = "_Complex " ++ tyToC dh ty -tyToC dh (Op.TyBits (Op.BitsExt s) _) = s -tyToC dh (Op.TyBits b h) = f b h where - f b Op.HintNone = f b dh - f b Op.HintUnsigned = case b of - (Op.Bits n) -> "uint" ++ show n ++ "_t" - (Op.BitsArch Op.BitsMax) -> "uintmax_t" - (Op.BitsArch Op.BitsPtr) -> "uintptr_t" - _ -> error "tyToC: unknown" - f b Op.HintSigned = case b of - (Op.Bits n) -> "int" ++ show n ++ "_t" - (Op.BitsArch Op.BitsMax) -> "intmax_t" - (Op.BitsArch Op.BitsPtr) -> "intptr_t" - _ -> error "tyToC: unknown" - f b Op.HintFloat = case b of - (Op.Bits 32) -> "float" - (Op.Bits 64) -> "double" - (Op.Bits 128) -> "__float128" - _ -> error "tyToC: unknown" - f _ _ = error "tyToC: unknown" -tyToC _ _ = error "FromGrin2.tToC: bad." - -opTyToCh hint opty = basicType (tyToC hint opty) -opTyToC opty = basicType (tyToC Op.HintUnsigned opty) -opTyToC' opty = tyToC Op.HintUnsigned opty - -localScope xs action = do - let fvs = freeVars xs - aas <- mapM (\ (v,t) -> do t <- convertType t ; return . toStatement $ localVariable t (varName v)) (filter ((v0 /=) . fst) $ Set.toList fvs) - local (rInscope_u $ Set.union (Set.map varName (freeVars xs))) (action . statementOOB $ mconcat aas) - -iDeclare action = local (\e -> e { rDeclare = True }) action - -convertBody :: Exp -> C Statement -convertBody Let { expDefs = defs, expBody = body } = do - u <- newUniq - nn <- flip mapM defs $ \FuncDef { funcDefName = name, funcDefBody = as :-> _ } -> do - vs' <- mapM convertVal as - let nm = (toName (show name ++ "_" ++ show u)) - return (as,(name,(nm,vs'))) - let done = (toName $ "done" ++ show u) - let localJumps xs action = localScope (fsts xs) $ \dcls -> local (rEMap_u (Map.fromList (snds xs) `mappend`)) (fmap (dcls &) action) - localJumps nn $ do - rs <- flip mapM defs $ \FuncDef { funcDefName = name, funcDefBody = as :-> b } -> do - ss <- convertBody b - return (annotate (show as) (label (toName (show name ++ "_" ++ show u))) & subBlock ss) - ss <- (convertBody body) - todo <- asks rTodo - case todo of - TodoReturn -> return (ss & mconcat rs); - _ -> return (ss & goto done & mconcat (intersperse (goto done) rs) & label done); -convertBody (e :>>= [] :-> e') = do - ss <- localTodo TodoNothing (convertBody e) - ss' <- convertBody e' - return (ss & ss') -convertBody (Return [v] :>>= [(NodeC t as)] :-> e') = nodeAssign v t as e' ---convertBody (Fetch v :>>= [(NodeC t as)] :-> e') = nodeAssign v t as e' -convertBody (Case v [p1@([NodeC _ (_:_)] :-> _),p2@([NodeC _ []] :-> _)]) = convertBody $ Case v [p2,p1] -convertBody (Case v@(getType -> TyNode) [[p1@(NodeC t fps)] :-> e1,[p2] :-> e2]) = do - scrut <- convertVal v - cpr <- asks rConst - tellTags t - let da (Var v _) e | v == v0 = convertBody e - da v@Var {} e = do - v'' <- iDeclare $ convertVal v - e' <- convertBody e - return $ v'' =* scrut & e' - da n1@(NodeC t _) (Return [n2@NodeC {}]) | n1 == n2 = convertBody (Return [v]) - da ~(NodeC t as) e = nodeAssign v t as e - am Var {} e = return e - am ~(NodeC t2 _) e = do - --tellTags t2 - --return $ annotate (show p2) (f_assert ((constant $ enum (nodeTagName t2)) `eq` tag) & e) - return $ annotate (show p2) e - tag = if null fps then f_FETCH_RAW_TAG scrut else f_FETCH_TAG scrut - ifscrut = if null fps then f_SET_RAW_TAG tenum `eq` scrut else tenum `eq` tag where - tenum = (constant $ enum (nodeTagName t)) - p1' <- da p1 e1 - p2' <- am p2 =<< da p2 e2 - return $ cif ifscrut p1' p2' - --- zero is usually faster to test for than other values, so flip them if zero is being tested for. -convertBody (Case v [v1, v2@([Lit n _] :-> _)]) | n == 0 = convertBody (Case v [v2,v1]) -convertBody (Case v@(getType -> t) [[p1] :-> e1, [p2] :-> e2]) | Set.null ((freeVars p2 :: Set.Set Var) `Set.intersection` freeVars e2) = do - scrut <- convertVal v - let cp ~(Lit i _) = constant (number $ fromIntegral i) - am e | isVar p2 = e - | otherwise = annotate (show p2) (f_assert ((cp p2) `eq` scrut) & e) - e1' <- convertBody e1 - e2' <- convertBody e2 - return $ cif (cp p1 `eq` scrut) e1' (am e2') -convertBody (Case v@(getType -> TyNode) ls) = do - scrut <- convertVal v - let tag = f_FETCH_TAG scrut - da ([(Var v _)] :-> e) | v == v0 = do - e' <- convertBody e - return $ (Nothing,e') - da ([v@(Var {})] :-> e) = do - v'' <- iDeclare $ convertVal v - e' <- convertBody e - return $ (Nothing,v'' =* scrut & e') - da ([n1@(NodeC t _)] :-> Return [n2@NodeC {}]) | n1 == n2 = do - tellTags t - e' <- convertBody (Return [v]) - return (Just (enum (nodeTagName t)),e') - da (~[(NodeC t as)] :-> e) = do - tellTags t - declareStruct t - as' <- iDeclare $ mapM convertVal as - e' <- convertBody e - let tmp = concrete t scrut - ass = mconcat [if needed a then a' =* (project' (arg i) tmp) else mempty | a' <- as' | a <- as | i <- [(1 :: Int) ..] ] - fve = freeVars e - needed ~(Var v _) = v `Set.member` fve - return $ (Just (enum (nodeTagName t)), ass & e') - ls' <- mapM da ls - return $ switch' tag ls' -convertBody (Case v ls) = do - scrut <- convertVal v - let da ([(Var vv _)] :-> e) | vv == v0 = do - e' <- convertBody e - return (Nothing,e') - da ([v@(Var {})] :-> e) = do - v'' <- iDeclare $ convertVal v - e' <- convertBody e - return (Nothing,v'' =* scrut & e') - da (~[(Lit i _)] :-> e) = do - e' <- convertBody e - return $ (Just (number $ fromIntegral i), e') - --da (~[x] :-> e) = da ( x :-> e ) - ls' <- mapM da ls - return $ switch' scrut ls' -convertBody (Error s t) = do - x <- asks rTodo - let jerr | null s = toStatement $ functionCall (name "jhc_exit") [constant $ number 255] - | otherwise = toStatement $ functionCall (name "jhc_error") [string s] - let f (TyPtr _) = return nullPtr - f TyNode = return nullPtr - f TyINode = return nullPtr - f (TyPrim x) = return $ cast (opTyToC x) (constant $ number 0) - f x = return $ err ("error-type " ++ show x) - g [] = return emptyExpression - g [x] = f x - g xs = do ts <- mapM convertType xs; xs <- mapM f xs ; return $ structAnon (zip xs ts) - case x of - TodoNothing -> return jerr - TodoExp _ -> return jerr - TodoDecl {} -> return jerr - TodoReturn -> do - v <- g t - return (jerr & creturn v) - -convertBody (BaseOp (StoreNode b) [n@NodeC {}]) = newNode region_heap (bool b wptr_t sptr_t) n >>= \(x,y) -> simpleRet y >>= \v -> return (x & v) -convertBody (BaseOp (StoreNode b) [n@NodeC {},region]) = newNode region (bool b wptr_t sptr_t) n >>= \(x,y) -> simpleRet y >>= \v -> return (x & v) - -convertBody (e :>>= [(Var vn _)] :-> e') | vn == v0 = do - ss <- localTodo TodoNothing (convertBody e) - ss' <- convertBody e' - return (ss & ss') - -convertBody (e :>>= [(Var vn' vt')] :-> e') | not (isCompound e) = do - (vn,vt) <- fetchVar' vn' vt' - ss <- localTodo (TodoDecl vn vt) (convertBody e) - ss' <- convertBody e' - return (ss & ss') - -convertBody (e :>>= [v@(Var vn vt)] :-> e') = do - v' <- convertVal v - vt <- convertType vt - let sdecl = statementOOB $ toStatement (localVariable vt (varName vn)) - ss <- localTodo (TodoExp [v']) (convertBody e) - ss' <- convertBody e' - return (sdecl & ss & ss') - -convertBody (e :>>= xs@(_:_:_) :-> e') = do - ts <- mapM (convertType . getType) xs - (dcl,st) <- newDeclVar (anonStructType ts) - vs <- iDeclare $ mapM convertVal xs - ss <- localTodo (TodoExp [st]) (convertBody e) - ss' <- convertBody e' - return $ dcl & ss & mconcat [ v =* projectAnon i st | v <- vs | i <- [0..] ] & ss' - --- mutable arrays and iorefs -convertBody (BaseOp PokeVal [Index base off,z]) = do - base <- convertVal base - off <- convertVal off - z' <- convertVal z - return $ indexArray base off =* z' -convertBody (BaseOp PokeVal [base,z]) = do - base <- convertVal base - z' <- convertVal z - return $ indexArray base (constant $ number 0) =* z' -convertBody (BaseOp PeekVal [Index base off]) | getType base == TyPtr tyINode = do - base <- convertVal base - off <- convertVal off - simpleRet (indexArray base off) -convertBody (BaseOp (Coerce ty) [v]) = do - v <- convertVal v - ty <- convertType ty - simpleRet $ cast ty v -convertBody (GcRoots vs b) = do - vs <- mapM convertVal vs - b' <- convertBody b - return $ subBlock (gc_roots vs & b') - --- return, promote and demote -convertBody (BaseOp Promote [v]) | getType v == tyINode = simpleRet =<< f_promote `liftM` convertVal v -convertBody (BaseOp Demote [n@Var {}]) | getType n == tyDNode = simpleRet =<< f_demote `liftM` convertVal n ---convertBody (Store n@Var {}) | getType n == tyDNode = simpleRet =<< f_demote `liftM` convertVal n - -convertBody (Return []) = simpleRet emptyExpression -convertBody (Return [v]) = simpleRet =<< convertVal v -convertBody (Return xs@(_:_:_)) = do - t <- asks rTodo - case t of - TodoExp [e] -> do - xs <- mapM convertVal xs - ss <- forMn xs $ \ (v,i) -> return (projectAnon i e =* v) - return (mconcat ss) - _ -> simpleRet =<< convertVals xs - -convertBody e = do - x <- asks rTodo - (ss,er) <- convertExp e - r <- simpleRet er - return (ss & r) - -simpleRet er = do - x <- asks rTodo - case x of - TodoReturn -> return (creturn er) - _ | isEmptyExpression er -> return mempty - TodoNothing -> return (toStatement er) - TodoExp [v] -> return (v =* er) - TodoDecl n t -> do newAssignVar t n er - TodoExp [] -> return $ toStatement er - _ -> error "simpleRet: odd rTodo" - -nodeAssign :: Val -> Atom -> [Val] -> Exp -> C Statement -nodeAssign v t as e' = do - cpr <- asks rCPR - v' <- convertVal v - case mlookup t cpr of - Just (TyRepRawVal signed) -> do - [arg] <- return as - t <- convertType $ getType arg - arg' <- iDeclare $ convertVal arg - let s = arg' =* cast t (if signed then f_RAW_GET_F v' else f_RAW_GET_UF v') - ss <- convertBody e' - return $ s & ss - _ -> do - declareStruct t - as' <- iDeclare $ mapM convertVal as - let ass = concat [perhapsM (a `Set.member` fve) $ a' =* (project' (arg i) (concrete t v')) | a' <- as' | Var a _ <- as | i <- [( 1 :: Int) ..] ] - fve = freeVars e' - ss' <- convertBody e' - return $ mconcat ass & ss' - ---isCompound Fetch {} = False -isCompound BaseOp {} = False -isCompound Return {} = False ---isCompound Store {} = False -isCompound Prim {} = False -isCompound _ = True - -mgc = if fopts FO.Jgc then ([v_gc, v_arena] ++) else id -mgct = if fopts FO.Jgc then ([(name "gc",gc_t), (name "arena",arena_t)] ++) else id - -convertExp :: Exp -> C (Statement,Expression) -convertExp (Prim Func { primArgTypes = as, primRetType = r, primRetArgs = rs@(_:_), ..} vs ty) = do - tell mempty { wRequires = primRequires } - vs' <- mapM convertVal vs - rt <- mapM convertType ty - --let rrs = map basicType' (r:rs) - ras <- mapM (newVar . basicType') rs - (stmt,rv) <- basicType' r `newTmpVar` (functionCall (name $ unpackPS funcName) ([ cast (basicType' t) v | v <- vs' | t <- as ] ++ map reference ras)) - return $ (stmt, structAnon (zip (rv:ras) rt)) -convertExp (Prim Func { primRetArgs = [], .. } vs ty) = do - tell mempty { wRequires = primRequires } - vs' <- mapM convertVal vs - rt <- convertTypes ty - let fcall = cast rt (functionCall (name $ unpackPS funcName) [ cast (basicType' t) v | v <- vs' | t <- primArgTypes ]) - return (if primSafety == Safe && fopts FO.Jgc then v_saved_gc =* v_gc else mempty,fcall) -convertExp (Prim p vs ty) = do - tell mempty { wRequires = primReqs p } - e <- convertPrim p vs ty - return (mempty,e) - ---convertExp (App a [fn,x] _) | a == funcApply = do --- fn' <- convertVal fn --- x' <- convertVal x --- return (mempty,(functionCall (name "eval") [v'])) -convertExp (BaseOp Eval [v]) = do - v' <- convertVal v - return (mempty,f_eval v') -convertExp (BaseOp GcTouch _) = do - return (mempty, emptyExpression) -convertExp (App a vs _) = do - lm <- asks rEMap - vs' <- mapM convertVal vs - case a `mlookup` lm of - Just (nm,as) -> do - let ss = [ a =* v | a <- as | v <- vs' ] - return (mconcat ss & goto nm, emptyExpression) - Nothing -> return $ (mempty, functionCall (toName (fromAtom a)) (mgc vs')) -convertExp (BaseOp Overwrite [v@(Var vv _),tn@(NodeC t as)]) | getType v == TyINode = do - v' <- convertVal v - as' <- mapM convertVal as - nt <- nodeTypePtr t - let tmp' = cast nt (f_FROM_SPTR v') - if not (tagIsSuspFunction t) && vv < v0 then do - (nns, nn) <- newNode region_heap fptr_t tn - return (nns & getHead (f_NODEP(f_FROM_SPTR v')) =* nn,emptyExpression) - else do - s <- tagAssign tmp' t - let ass = [project' (arg i) tmp' =* a | a <- as' | i <- [(1 :: Int) ..] ] - return (mconcat $ s:ass,emptyExpression) - -convertExp Alloc { expValue = v, expCount = c, expRegion = r } - | r == region_heap, TyINode == getType v = do - v' <- convertVal v - c' <- convertVal c - (malloc,tmp) <- jhc_malloc_ptrs c' =:: ptrType sptr_t - fill <- case v of - ValUnknown _ -> return mempty - _ -> do - i <- newVar (basicType "int") - return $ forLoop i (expressionRaw "0") c' $ indexArray tmp i =* v' - return (malloc `mappend` fill, tmp) -convertExp Alloc { expValue = v, expCount = c, expRegion = r } | - r == region_atomic_heap, TyPrim Op.bits_ptr == getType v = do - v' <- convertVal v - c' <- convertVal c - (malloc,tmp) <- jhc_malloc_atomic c' =:: ptrType uintptr_t - fill <- case v of - ValUnknown _ -> return mempty - _ -> do - i <- newVar (basicType "int") - return $ forLoop i (expressionRaw "0") c' $ indexArray tmp i =* v' - return (malloc `mappend` fill, tmp) - -convertExp e = return (err (show e),err "nothing") - -{- -ccaf :: (Var,Val) -> P.Doc -ccaf (v,val) = text "/* " <> text (show v) <> text " = " <> - (text $ P.render (pprint val)) <> text "*/\n" <> - text "static node_t _" <> tshow (varName v) <> text ";\n" <> - text "#define " <> tshow (varName v) <+> text "(MKLAZY_C(&_" <> - tshow (varName v) <> text "))\n"; --} - -buildConstants cpr grin fh = P.vcat (map cc (Grin.HashConst.toList fh)) where - --tyenv = grinTypeEnv grin - comm nn = text "/* " <> tshow (nn) <> text " */" - cc nn@(HcNode a zs,i) = comm nn $$ cd $$ def where - cd = text "static const struct" <+> tshow (nodeStructName a) <+> text "_c" <> tshow i <+> text "= {" <> hsep (punctuate P.comma (ntag ++ rs)) <> text "};" - --Just TyTy { tySiblings = sibs } = findTyTy tyenv a - ntag = case mlookup a cpr of - --Just [a'] | a' == a -> [] - Just _ -> [] - _ -> [text ".what =" <+> text "(what_t)SET_RAW_TAG(" <> tshow (nodeTagName a) <> text ")"] - def = text "#define c" <> tshow i <+> text "(TO_SPTR_C(P_WHNF, (sptr_t)&_c" <> tshow i <> text "))" - rs = [ f z i | (z,i) <- zip zs [ 1 :: Int .. ]] - f (Right i) a = text ".a" <> tshow a <+> text "=" <+> text ('c':show i) - f (Left (Var n _)) a = text ".a" <> tshow a <+> text "=" <+> tshow (varName n) - f (Left v) a = text ".a" <> tshow a <+> text "=" <+> text (show $ drawG e) where - Just e = fst3 . fst . runC grin $ convertConst v - -convertConst :: Val -> C (Maybe Expression) -convertConst (NodeC n as) | all valIsConstant as = basicNode n as -convertConst (Const (NodeC n as)) = fmap (fmap $ cast sptr_t) $ basicNode n as -convertConst v = return (f v) where - f :: Val -> Maybe Expression - f (Lit i (TyPrim Op.TyBool)) = return $ toExpression (i /= 0) - f (Lit i (TyPrim (Op.TyBits _ Op.HintFloat))) = return (constant $ floating (realToFrac i)) - f (Lit i _) = return (constant $ number (fromIntegral i)) - f (ValPrim p [] ty) = case p of - CConst _ s -> return $ expressionRaw $ unpackPS s - AddrOf _ t -> do rt <- convertType ty; return . cast rt $ expressionRaw ('&':unpackPS t) - PrimTypeInfo { primArgTy = arg, primTypeInfo = PrimSizeOf } -> - return $ expressionRaw ("sizeof(" ++ tyToC Op.HintUnsigned arg ++ ")") - PrimTypeInfo { primArgTy = arg, primTypeInfo = PrimMinBound } -> - return $ expressionRaw ("prim_minbound(" ++ tyToC Op.HintUnsigned arg ++ ")") - PrimTypeInfo { primArgTy = arg, primTypeInfo = PrimMaxBound } -> - return $ expressionRaw ("prim_maxbound(" ++ tyToC Op.HintUnsigned arg ++ ")") - PrimTypeInfo { primArgTy = arg, primTypeInfo = PrimUMaxBound } -> - return $ expressionRaw ("prim_umaxbound(" ++ tyToC Op.HintUnsigned arg ++ ")") - PrimString s -> return $ cast (basicType "uintptr_t") (expressionRaw (show s)) - x -> return $ err (show x) - f (ValPrim p [x] (TyPrim opty)) = do - x' <- f x - case p of - Op (Op.UnOp n ta) r -> primUnOp n ta r x' - Op (Op.ConvOp n ta) r -> return $ castFunc n ta r x' - x -> return $ err (show x) - f (ValPrim p [x,y] _) = do - x' <- f x - y' <- f y - case p of - Op (Op.BinOp n ta tb) r -> primBinOp n ta tb r x' y' - x -> return $ err (show x) - f x = fail "f" - ---convertPrim p vs = return (mempty,err $ show p) -convertPrim p vs ty - | (CConst _ s) <- p = do - return $ expressionRaw $ unpackPS s - | Op {} <- p = do - let [rt] = ty - convertVal (ValPrim p vs rt) - | (IFunc _ as r) <- p = do - v':vs' <- mapM convertVal vs - rt <- convertTypes ty - let fn = cast (funPtrType (basicType' r) (map basicType' as)) v' - return $ cast (rt) (indirectFunctionCall fn [ cast (basicType' t) v | v <- vs' | t <- as ]) - | (Peek t) <- p, [v] <- vs = do - v' <- convertVal v - return $ expressionRaw ("*((" <> (opTyToC' t) <+> "*)" <> (parens $ renderG v') <> char ')') - | (Poke t) <- p, [v,x] <- vs = do - v' <- convertVal v - x' <- convertVal x - return $ expressionRaw ("*((" <> (opTyToC' t) <+> "*)" <> (parens $ renderG v') <> text ") = " <> renderG x') - | (AddrOf _ t) <- p, [] <- vs = do - rt <- convertTypes ty - return . cast rt $ expressionRaw ('&':unpackPS t) - | otherwise = return $ err ("prim: " ++ show (p,vs)) - -signedOps = [ --- (Op.Div,"/"), -- TODO round to -Infinity --- (Op.Mod,"%"), -- TODO round to -Infinity - (Op.Quot,"/"), - (Op.Rem,"%"), - (Op.Shra,">>"), - (Op.Gt,">"), - (Op.Lt,"<"), - (Op.Gte,">="), - (Op.Lte,"<=") - ] - -floatOps = [ - (Op.FDiv,"/"), - (Op.FAdd,"+"), - (Op.FSub,"-"), - (Op.FMul,"*"), - (Op.FEq,"=="), - (Op.FNEq,"!="), - (Op.FGt,">"), - (Op.FLt,"<"), - (Op.FGte,">="), - (Op.FLte,"<=") - ] - -binopSigned :: Op.BinOp -> Maybe String -binopSigned b = lookup b signedOps - -castSigned ty v = return $ cast (basicType $ tyToC Op.HintSigned ty) v - -primBinOp n ta tb r a b - | Just fn <- Op.binopFunc ta tb n = return $ functionCall (toName fn) [a,b] - | Just (t,_) <- Op.binopInfix n = return $ operator t a b - | Just t <- binopSigned n = do - a <- castSigned ta a - b <- castSigned tb b - return $ operator t a b - | Just t <- lookup n floatOps = return $ operator t a b - | otherwise = return $ err ("primBinOp: " ++ show ((n,ta,tb,r),a,b)) - -primUnOp Op.Neg ta r a = do - a <- castSigned ta a - return $ uoperator "-" a -primUnOp Op.Com ta r a = do return $ uoperator "~" a -primUnOp Op.FNeg ta r a = do return $ uoperator "-" a -primUnOp op ta r a | Just fn <- Op.unopFloat ta op = return $ functionCall (toName fn) [a] -primUnOp n ta r a - | otherwise = return $ err ("primUnOp: " ++ show ((n,ta,r),a)) - -tagAssign :: Expression -> Atom -> C Statement -tagAssign e t | tagIsSuspFunction t = do - en <- declareEvalFunc False t - return $ getHead e =* f_TO_FPTR (reference (variable en)) -tagAssign e t = do - cpr <- asks rCPR - declareStruct t - tyenv <- asks (grinTypeEnv . rGrin) - --TyTy { tySiblings = sib } <- findTyTy tyenv t - case mlookup t cpr of - --Just [n'] | n' == t -> return mempty - Just _ -> return mempty - _ -> do - tellTags t - return . toStatement $ f_SET_MEM_TAG e (constant (enum $ nodeTagName t)) - -tellAllTags :: Val -> C () -tellAllTags (NodeC n vs) = tellTags n >> mapM_ tellAllTags vs -tellAllTags n = mapValVal tt n >> return () where - tt v = tellAllTags v >> return v - -tellTags :: Atom -> C () -tellTags t | tagIsSuspFunction t = return () -tellTags t = do - tyenv <- asks (grinTypeEnv . rGrin) - TyTy { tySiblings = sib } <- findTyTy tyenv t - case sib of --- Just [n'] | n' == t -> return () - Just rs -> tell mempty { wEnums = Map.fromList (zip (map nodeTagName rs) [0..]) } - Nothing -> tell mempty { wTags = Set.singleton t } - -newNode region ty ~(NodeC t as) = do - let sf = tagIsSuspFunction t - bn <- basicNode t as - cpr <- asks rCPR - case bn of - Just e -> return (mempty,if ty == wptr_t then e else cast ty e) - Nothing -> do - st <- nodeType t - as' <- mapM convertVal as - let wmalloc | fopts FO.Jgc = \_ -> functionCall (name "s_alloc") [toExpression $ name "gc", toExpression $ name "arena", (toExpression $ nodeCacheName t)] - | otherwise = jhc_malloc (reference (toExpression $ nodeCacheName t)) nptrs' - nptrs = length (filter (not . nonPtr . getType) as) + if sf then 1 else 0 - nptrs' = if nptrs > 0 && not sf && t `Map.notMember` cpr then nptrs + 1 else nptrs - malloc = wmalloc (sizeof st) - nonPtr TyPtr {} = False - nonPtr TyNode = False - nonPtr TyINode = False - nonPtr _ = True - (dtmp,tmp) <- case region == region_stack of - True -> do - v <- newVar st - return (mempty,reference v) - False -> do - tell mempty { wAllocs = Set.singleton (t,nptrs') } - ty `newTmpVar` malloc - let tmp' = concrete t tmp - ass = [ if isValUnknown aa then mempty else project' i tmp' =* a | a <- as' | aa <- as | i <- map arg [(1 :: Int) ..] ] - tagassign <- tagAssign tmp' t - let res = if sf then (f_MKLAZY tmp) else tmp - return (mconcat $ dtmp:tagassign:ass,res) - ------------------- --- declaring stuff ------------------- - -declareStruct n = do - grin <- asks rGrin - cpr <- asks rCPR - let TyTy { tySlots = ts, tySiblings = ss } = runIdentity $ findTyTy (grinTypeEnv grin) n - ts' <- mapM convertType ts - let (dis,needsDis) | tagIsSuspFunction n = ([(name "head",fptr_t)],False) - | null ts = ([],False) - | Just TyRepUntagged <- mlookup n cpr = ([],False) - | Just [n'] <- ss, n == n' = ([],False) - | otherwise = ([],True) - fields = (dis ++ zip [ name $ 'a':show i | i <- [(1 :: Int) ..] ] ts') - theStruct = basicStructure { - structureName = nodeStructName n, - structureFields = fields, - structureAligned = True, - structureHasDiscriminator = not $ null dis, - --structureNeedsDiscriminator = not (fopts FO.Jgc) && needsDis - structureNeedsDiscriminator = needsDis - } - unless (null fields) $ tell mempty { wStructures = Map.singleton (structureName theStruct) theStruct } - -basicNode :: Atom -> [Val] -> C (Maybe Expression) -basicNode a _ | tagIsSuspFunction a = return Nothing -basicNode a [] = do tellTags a ; return . Just $ (f_SET_RAW_TAG (constant $ enum (nodeTagName a))) -basicNode a [v] = do - cpr <- asks rCPR - case mlookup a cpr of - Just (TyRepRawVal signed) -> case v of - Lit i ty | a == cChar, Just c <- ch -> return $ Just (f_RAW_SET_UF (toExpression c)) where - ch = do - c <- toIntegral i - guard $ c >= ord minBound && c <= ord maxBound - c <- return $ chr c - guard $ isPrint c && isAscii c - return c - _ -> do - v <- convertVal v - return $ Just (if signed then f_RAW_SET_F v else f_RAW_SET_UF v) - _ -> return Nothing -basicNode _ _ = return Nothing - -instance Op.ToCmmTy Ty where - toCmmTy (TyPrim p) = Just p - toCmmTy _ = Nothing - -declareEvalFunc isCAF n = do - fn <- tagToFunction n - grin <- asks rGrin - declareStruct n - nt <- nodeType n - let ts = runIdentity $ findArgs (grinTypeEnv grin) n - fname = toName $ "E_" ++ show fn - aname = name "arg" - rvar = localVariable wptr_t (name "r") - atype = ptrType nt - body = rvar =* functionCall (toName (show $ fn)) (mgc [ project' (arg i) (variable aname) | _ <- ts | i <- [(1 :: Int) .. ] ]) - update = f_update (variable aname) rvar - addroot = if isCAF && fopts FO.Jgc then f_gc_add_root (cast sptr_t rvar) else emptyExpression - body' = if not isCAF && fopts FO.Jgc then subBlock (gc_roots [f_MKLAZY(variable aname)] & rest) else rest - rest = body & update & addroot & creturn rvar - tellFunctions [function fname wptr_t (mgct [(aname,atype)]) [a_STD, a_FALIGNED] body'] - return fname - -castFunc :: Op.ConvOp -> Op.Ty -> Op.Ty -> Expression -> Expression -castFunc co ta tb e | ta == tb = e -castFunc co _ Op.TyBool e = cast (basicType "bool") e -castFunc co Op.TyBool tb e = cast (opTyToC tb) e - -castFunc Op.Lobits _ tb e = cast (opTyToC tb) e -castFunc Op.U2U _ tb e = cast (opTyToC tb) e -castFunc Op.Zx _ tb e = cast (opTyToC tb) e - -castFunc Op.I2I tf tb e = cast (opTyToCh Op.HintSigned tb) (cast (opTyToCh Op.HintSigned tf) e) -castFunc Op.Sx tf tb e = cast (opTyToCh Op.HintSigned tb) (cast (opTyToCh Op.HintSigned tf) e) - -castFunc Op.F2I tf tb e = cast (opTyToCh Op.HintSigned tb) e -castFunc Op.I2F tf tb e = cast (opTyToC tb) (cast (opTyToCh Op.HintSigned tf) e) - -castFunc _ _ tb e = cast (opTyToC tb) e - ----------------------------- --- c constants and utilities ----------------------------- - -gc_roots vs = case length vs of --- 1 -> functionCall (name "gc_frame1") (v_gc:vs) --- 2 -> functionCall (name "gc_frame2") (v_gc:vs) - lvs -> functionCall (name "gc_frame0") (v_gc:constant (number (fromIntegral lvs)):vs) ---gc_end = functionCall (name "gc_end") [] -tbsize sz = functionCall (name "TO_BLOCKS") [sz] - -jhc_malloc_atomic sz | fopts FO.Jgc = functionCall (name "gc_array_alloc_atomic") [v_gc, v_arena, nullPtr, sz, toExpression (0::Int)] - | otherwise = jhc_malloc nullPtr (0::Int) (sizeof sptr_t *# sz) - -jhc_malloc ntn nptrs sz | fopts FO.Jgc = functionCall (name "gc_alloc") [v_gc, v_arena, ntn, tbsize sz, toExpression nptrs] --- | fopts FO.Jgc = functionCall (name "gc_alloc") [v_gc, v_arena, tbsize sz, toExpression nptrs] -jhc_malloc _ 0 sz = functionCall (name "jhc_malloc_atomic") [sz] -jhc_malloc _ _ sz = functionCall (name "jhc_malloc") [sz] - -jhc_malloc_ptrs sz | fopts FO.Jgc = functionCall (name "gc_array_alloc") [v_gc, v_arena, sz] -jhc_malloc_ptrs sz = functionCall (name "jhc_malloc") [sizeof sptr_t *# sz] - -f_assert e = functionCall (name "assert") [e] -f_FROM_SPTR e = functionCall (name "FROM_SPTR") [e] -f_NODEP e = functionCall (name "NODEP") [e] -f_RAW_SET_F e = functionCall (name "RAW_SET_F") [e] -f_RAW_SET_UF e = functionCall (name "RAW_SET_UF") [e] -f_RAW_GET_F e = functionCall (name "RAW_GET_F") [e] -f_RAW_GET_UF e = functionCall (name "RAW_GET_UF") [e] -f_MKLAZY e = functionCall (name "MKLAZY") [e] -f_TO_FPTR e = functionCall (name "TO_FPTR") [e] -f_eval e = functionCall (name "eval") (mgc [e]) -f_gc_add_root e = functionCall (name "gc_add_root") (mgc [e]) -f_promote e = functionCall (name "promote") [e] -f_PROMOTE e = functionCall (name "PROMOTE") [e] -f_FETCH_TAG e = functionCall (name "FETCH_TAG") [e] -f_FETCH_RAW_TAG e = functionCall (name "FETCH_RAW_TAG") [e] ---f_FETCH_MEM_TAG e = functionCall (name "FETCH_MEM_TAG") [e] -f_SET_RAW_TAG e = functionCall (name "SET_RAW_TAG") [e] -f_SET_MEM_TAG e v = functionCall (name "SET_MEM_TAG") [e,v] -f_demote e = functionCall (name "demote") [e] ---f_follow e = functionCall (name "follow") [e] -f_update x y = functionCall (name "update") [x,y] - -arg i = name $ 'a':show i - -varName (V n) | n < 0 = name $ 'g':show (- n) -varName (V n) = name $ 'v':show n - -nodeTagName :: Atom -> Name -nodeTagName a = toName (fromAtom a) -nodeFuncName :: Atom -> Name -nodeFuncName a = toName (fromAtom a) - -sptr_t = basicGCType "sptr_t" -uintptr_t = basicGCType "uintptr_t" -fptr_t = basicGCType "fptr_t" -wptr_t = basicGCType "wptr_t" -gc_t = basicGCType "gc_t" -arena_t = basicGCType "arena_t" -v_gc = variable (name "gc") -v_saved_gc = variable (name "saved_gc") -v_arena = variable (name "arena") - -a_STD = Attribute "A_STD" -a_FALIGNED = Attribute "A_FALIGNED" -a_MALLOC = Attribute "A_MALLOC" - -concrete :: Atom -> Expression -> Expression -concrete t e = cast (ptrType $ structType (nodeStructName t)) e - -getHead :: Expression -> Expression -getHead e = project' (name "head") e - -nodeTypePtr a = liftM ptrType (nodeType a) -nodeType a = return $ structType (nodeStructName a) -nodeStructName :: Atom -> Name -nodeStructName a = toName ('s':fromAtom a) -nodeCacheName a = toName ('c':fromAtom a) - -bool b x y = if b then x else y - -x =:: y = newTmpVar y x - -basicType' :: ExtType -> Type -basicType' b = basicType (show b) -{-* Generated by DrIFT : Look, but Don't Touch. *-} -instance Monoid Written where - mempty = Written mempty mempty mempty mempty mempty mempty - mappend (Written aa ab ac ad ae af) (Written aa' ab' ac' ad' ae' af') = Written (mappend aa aa')(mappend ab ab')(mappend ac ac')(mappend ad ad')(mappend ae ae')(mappend af af') - --- Imported from other files :- diff --git a/drift_processed/C/Prims.hs b/drift_processed/C/Prims.hs deleted file mode 100644 --- a/drift_processed/C/Prims.hs +++ /dev/null @@ -1,374 +0,0 @@ -{- Generated by DrIFT (Automatic class derivations for Haskell) -} -{-# LINE 1 "src/C/Prims.hs" #-} -{-# LANGUAGE OverloadedStrings #-} -module C.Prims where - -import Data.Binary -import Data.Monoid(Monoid(..)) -import Data.Typeable -import qualified Data.Set as Set - -import Doc.DocLike -import Doc.PPrint -import PackedString -import StringTable.Atom -import qualified Cmm.Op as Op - -import GHC.Exts - -data CallConv = CCall | StdCall | CApi | Primitive | DotNet - deriving(Eq,Ord,Show) - {-! derive: Binary !-} - -data Safety = Safe | Unsafe deriving(Eq,Ord,Show) - {-! derive: Binary !-} - -newtype ExtType = ExtType PackedString - deriving(Binary,IsString,Eq,Ord) - -instance Show ExtType where - show (ExtType p) = unpackPS p - -instance Show Requires where - show (Requires s) = show (Set.toList s) - -newtype Requires = Requires (Set.Set (CallConv,PackedString)) - deriving(Eq,Ord,Monoid,Binary) - -data DotNetPrim = DotNetField | DotNetCtor | DotNetMethod - deriving(Typeable, Eq, Ord, Show) - {-! derive: Binary !-} - -primReqs p = f p where - f CConst {} = primRequires p - f Func {} = primRequires p - f IFunc {} = primRequires p - f AddrOf {} = primRequires p - f _ = mempty - -data Prim = - PrimPrim Atom -- Special primitive implemented in the compiler somehow. - | CConst { - primRequires :: Requires, - primConst :: !PackedString - } -- C code which evaluates to a constant - | Func { - primRequires :: Requires, - funcName :: !PackedString, - primArgTypes :: [ExtType], - primRetType :: ExtType, - primRetArgs :: [ExtType], - primSafety :: Safety - } -- function call with C calling convention - | IFunc { - primRequires :: Requires, - primArgTypes :: [ExtType], - primRetType :: ExtType - } -- indirect function call with C calling convention - | AddrOf { - primRequires :: Requires, - primConst :: !PackedString -- address of linker name - } - | Peek { primArgTy :: Op.Ty } -- read value from memory - | Poke { primArgTy :: Op.Ty } -- write value to memory - | PrimTypeInfo { - primArgTy :: Op.Ty, - primRetTy :: Op.Ty, - primTypeInfo :: !PrimTypeInfo - } - | PrimString !PackedString -- address of a raw string. encoded in utf8. - | PrimDotNet { - primStatic :: !Bool, - primDotNet :: !DotNetPrim, - primIOLike :: !Bool, - primAssembly :: !PackedString, - primDotNetName :: !PackedString - } - | Op { - primCOp :: Op.Op Op.Ty, - primRetTy :: Op.Ty - } - deriving(Typeable, Eq, Ord, Show) - {-! derive: Binary !-} - -data PrimTypeInfo = PrimSizeOf | PrimMaxBound | PrimMinBound | PrimAlignmentOf | PrimUMaxBound - deriving(Typeable, Eq, Ord, Show) - {-! derive: Binary !-} - -primStaticTypeInfo :: Op.Ty -> PrimTypeInfo -> Maybe Integer -primStaticTypeInfo (Op.TyBits (Op.Bits b) _) w = Just ans where - bits = toInteger b - ans = case w of - PrimSizeOf -> bits `div` 8 - PrimAlignmentOf -> bits `div` 8 - PrimMinBound -> negate $ 2^(bits - 1) - PrimMaxBound -> 2^(bits - 1) - 1 - PrimUMaxBound -> 2^bits - 1 -primStaticTypeInfo _ _ = Nothing - --- | These primitives may safely be duplicated without affecting performance or --- correctness too adversly. either because they are cheap to begin with, or --- will be recombined in a later pass. - -primIsCheap :: Prim -> Bool -primIsCheap AddrOf {} = True -primIsCheap CConst {} = True -primIsCheap PrimString {} = True -primIsCheap PrimTypeInfo {} = True -primIsCheap Op { primCOp = op } = Op.isCheap op -primIsCheap _ = False - --- | whether a primitive represents a constant expression (assuming all its arguments are constant) --- TODO needs grin support -primIsConstant :: Prim -> Bool -primIsConstant CConst {} = True -primIsConstant AddrOf {} = True -primIsConstant PrimString {} = True -primIsConstant PrimTypeInfo {} = True -primIsConstant Op { primCOp = op } = Op.isEagerSafe op -primIsConstant _ = False - --- | whether a primitive can be eagarly evaluated. --- TODO needs grin support -primEagerSafe :: Prim -> Bool -primEagerSafe CConst {} = True -primEagerSafe PrimString {} = True -primEagerSafe AddrOf {} = True -primEagerSafe PrimTypeInfo {} = True -primEagerSafe Op { primCOp = op } = Op.isEagerSafe op -primEagerSafe _ = False - -primPrim s = PrimPrim $ toAtom s - -instance DocLike d => PPrint d ExtType where - pprint t = tshow t ---instance DocLike d => PPrint d PackedString where --- pprint t = text $ unpackPS t - -instance DocLike d => PPrint d Prim where - pprint (PrimPrim t) = text (fromAtom t) - pprint (CConst _ s) = parens (text $ unpackPS s) - pprint Func { .. } = parens (tshow primRetType) <> text (unpackPS funcName) <> tupled (map pprint primArgTypes) - pprint IFunc { .. } = parens (tshow primRetType) <> parens (char '*') <> tupled (map pprint primArgTypes) - pprint (AddrOf _ s) = char '&' <> text (unpackPS s) - pprint (PrimString s) = tshow s <> char '#' - pprint (Peek t) = char '*' <> tshow t - pprint (Poke t) = char '=' <> tshow t - pprint Op { primCOp = Op.BinOp bo ta tb, primRetTy = rt } | rt == ta && rt == tb = parens (pprint rt) <> tshow bo - pprint Op { primCOp = Op.UnOp bo ta, primRetTy = rt } | rt == ta = parens (pprint rt) <> tshow bo - pprint Op { primCOp = op, primRetTy = rt } = parens (pprint rt) <> pprint op - pprint PrimDotNet { primDotNet = dn, primDotNetName = nn} = parens (text (unpackPS nn)) - pprint PrimTypeInfo { primArgTy = at, primTypeInfo = PrimSizeOf } = text "sizeof" <> parens (tshow at) - pprint PrimTypeInfo { primArgTy = at, primTypeInfo = PrimAlignmentOf } = text "alignmentof" <> parens (tshow at) - pprint PrimTypeInfo { primArgTy = at, primTypeInfo = PrimMaxBound } = text "max" <> parens (tshow at) - pprint PrimTypeInfo { primArgTy = at, primTypeInfo = PrimUMaxBound } = text "umax" <> parens (tshow at) - pprint PrimTypeInfo { primArgTy = at, primTypeInfo = PrimMinBound } = text "min" <> parens (tshow at) - -instance DocLike d => PPrint d Op.Ty where - pprintAssoc _ n p = text (showsPrec n p "") -instance (DocLike d,Show v) => PPrint d (Op.Op v) where - pprintAssoc _ n p = text (showsPrec n p "") - -parseDotNetFFI :: Monad m => String -> m Prim -parseDotNetFFI s = ans where - init = PrimDotNet { primIOLike = False, primStatic = False, primDotNet = DotNetField, primAssembly = packString "", primDotNetName = packString "" } - ans = case words s of - ("static":rs) -> f rs init { primStatic = True } - rs -> f rs init - f ("field":rs) dn = g dn { primDotNet = DotNetField } rs - f ("ctor":rs) dn = g dn { primDotNet = DotNetCtor } rs - f ("method":rs) dn = g dn { primDotNet = DotNetMethod } rs - f _ _ = fail "invalid .NET ffi specification" - g dn ['[':rs] | (as,']':nm) <- span (/= ']') rs = return dn { primAssembly = packString as, primDotNetName = packString nm } - g dn [n] = return dn { primDotNetName = packString n } - g _ _ = fail "invalid .NET ffi specification" -{-* Generated by DrIFT : Look, but Don't Touch. *-} -instance Data.Binary.Binary CallConv where - put CCall = do - Data.Binary.putWord8 0 - put StdCall = do - Data.Binary.putWord8 1 - put CApi = do - Data.Binary.putWord8 2 - put Primitive = do - Data.Binary.putWord8 3 - put DotNet = do - Data.Binary.putWord8 4 - get = do - h <- Data.Binary.getWord8 - case h of - 0 -> do - return CCall - 1 -> do - return StdCall - 2 -> do - return CApi - 3 -> do - return Primitive - 4 -> do - return DotNet - _ -> fail "invalid binary data found" - -instance Data.Binary.Binary Safety where - put Safe = do - Data.Binary.putWord8 0 - put Unsafe = do - Data.Binary.putWord8 1 - get = do - h <- Data.Binary.getWord8 - case h of - 0 -> do - return Safe - 1 -> do - return Unsafe - _ -> fail "invalid binary data found" - -instance Data.Binary.Binary DotNetPrim where - put DotNetField = do - Data.Binary.putWord8 0 - put DotNetCtor = do - Data.Binary.putWord8 1 - put DotNetMethod = do - Data.Binary.putWord8 2 - get = do - h <- Data.Binary.getWord8 - case h of - 0 -> do - return DotNetField - 1 -> do - return DotNetCtor - 2 -> do - return DotNetMethod - _ -> fail "invalid binary data found" - -instance Data.Binary.Binary Prim where - put (PrimPrim aa) = do - Data.Binary.putWord8 0 - Data.Binary.put aa - put (CConst ab ac) = do - Data.Binary.putWord8 1 - Data.Binary.put ab - Data.Binary.put ac - put (Func ad ae af ag ah ai) = do - Data.Binary.putWord8 2 - Data.Binary.put ad - Data.Binary.put ae - Data.Binary.put af - Data.Binary.put ag - Data.Binary.put ah - Data.Binary.put ai - put (IFunc aj ak al) = do - Data.Binary.putWord8 3 - Data.Binary.put aj - Data.Binary.put ak - Data.Binary.put al - put (AddrOf am an) = do - Data.Binary.putWord8 4 - Data.Binary.put am - Data.Binary.put an - put (Peek ao) = do - Data.Binary.putWord8 5 - Data.Binary.put ao - put (Poke ap) = do - Data.Binary.putWord8 6 - Data.Binary.put ap - put (PrimTypeInfo aq ar as) = do - Data.Binary.putWord8 7 - Data.Binary.put aq - Data.Binary.put ar - Data.Binary.put as - put (PrimString at) = do - Data.Binary.putWord8 8 - Data.Binary.put at - put (PrimDotNet au av aw ax ay) = do - Data.Binary.putWord8 9 - Data.Binary.put au - Data.Binary.put av - Data.Binary.put aw - Data.Binary.put ax - Data.Binary.put ay - put (Op az aA) = do - Data.Binary.putWord8 10 - Data.Binary.put az - Data.Binary.put aA - get = do - h <- Data.Binary.getWord8 - case h of - 0 -> do - aa <- Data.Binary.get - return (PrimPrim aa) - 1 -> do - ab <- Data.Binary.get - ac <- Data.Binary.get - return (CConst ab ac) - 2 -> do - ad <- Data.Binary.get - ae <- Data.Binary.get - af <- Data.Binary.get - ag <- Data.Binary.get - ah <- Data.Binary.get - ai <- Data.Binary.get - return (Func ad ae af ag ah ai) - 3 -> do - aj <- Data.Binary.get - ak <- Data.Binary.get - al <- Data.Binary.get - return (IFunc aj ak al) - 4 -> do - am <- Data.Binary.get - an <- Data.Binary.get - return (AddrOf am an) - 5 -> do - ao <- Data.Binary.get - return (Peek ao) - 6 -> do - ap <- Data.Binary.get - return (Poke ap) - 7 -> do - aq <- Data.Binary.get - ar <- Data.Binary.get - as <- Data.Binary.get - return (PrimTypeInfo aq ar as) - 8 -> do - at <- Data.Binary.get - return (PrimString at) - 9 -> do - au <- Data.Binary.get - av <- Data.Binary.get - aw <- Data.Binary.get - ax <- Data.Binary.get - ay <- Data.Binary.get - return (PrimDotNet au av aw ax ay) - 10 -> do - az <- Data.Binary.get - aA <- Data.Binary.get - return (Op az aA) - _ -> fail "invalid binary data found" - -instance Data.Binary.Binary PrimTypeInfo where - put PrimSizeOf = do - Data.Binary.putWord8 0 - put PrimMaxBound = do - Data.Binary.putWord8 1 - put PrimMinBound = do - Data.Binary.putWord8 2 - put PrimAlignmentOf = do - Data.Binary.putWord8 3 - put PrimUMaxBound = do - Data.Binary.putWord8 4 - get = do - h <- Data.Binary.getWord8 - case h of - 0 -> do - return PrimSizeOf - 1 -> do - return PrimMaxBound - 2 -> do - return PrimMinBound - 3 -> do - return PrimAlignmentOf - 4 -> do - return PrimUMaxBound - _ -> fail "invalid binary data found" - --- Imported from other files :- diff --git a/drift_processed/Cmm/Op.hs b/drift_processed/Cmm/Op.hs deleted file mode 100644 --- a/drift_processed/Cmm/Op.hs +++ /dev/null @@ -1,894 +0,0 @@ -{- Generated by DrIFT (Automatic class derivations for Haskell) -} -{-# LINE 1 "src/Cmm/Op.hs" #-} -{-# OPTIONS -funbox-strict-fields #-} -module Cmm.Op where - -import Data.Binary -import Util.Gen -import Text.ParserCombinators.ReadP as P -import Text.Read.Lex - -{- - -Basic operations. These are chosen to be roughly equivalent to c-- operations, -but can be effectively used to generate C or assembly code as well. - -An operation consists of the operation itself, the type of the arguments and -return value, and a hint attached to each argument. - -A condition is that the operation must be fully determined by the operation -name and the type of its arguments. this specifically does not include the -hint. For instance, since whether a number is signed or unsigned is in the -hint, so the operation itself must say whether it is signed or unsigned. - -Also, distinct algorithms should be given different operations, for instance -floating point and integer comparison are so different that they should be -separate opcodes, even if it could be determined by the type they operate on. - --} - --- these take 2 arguments of the same type, and return one of the same type. --- an exception are the mulx routines, which may return a type exactly --- double in size of the original, and the shift and rotate routines, where the --- second argument may be of any width and is interpreted as an unsigned --- number. --- --- the invarient is that the return type is always exactly determined by the --- argument types - -data BinOp - = Add - | Sub - - | Mul - | Mulx - | UMulx - - | Div -- ^ round to -Infinity - | Mod -- ^ mod rounding to -Infinity - - | Quot -- ^ round to 0 - | Rem -- ^ rem rounding to 0 - - | UDiv -- ^ round to zero (unsigned) - | UMod -- ^ unsigned mod - - -- bitwise - | And - | Or - | Xor - | Shl - | Shr -- ^ shift right logical - | Shra -- ^ shift right arithmetic - | Rotl - | Rotr - - -- floating - | FAdd - | FSub - | FDiv - | FMul - | FPwr - | FAtan2 - - -- These all compare two things of the same type, and return a boolean. - | Eq - | NEq - | Gt - | Gte - | Lt - | Lte - -- unsigned versions - | UGt - | UGte - | ULt - | ULte - - -- floating point comparasons - | FEq - | FNEq - | FGt - | FGte - | FLt - | FLte - -- whether two values can be compared at all. - | FOrdered - deriving(Eq,Show,Ord,Read,Enum,Bounded) - {-! derive: Binary !-} - -data UnOp - = Neg -- ^ 2s compliment negation - | Com -- ^ bitwise compliment - -- floating - | FAbs -- ^ floating absolute value - | FNeg -- ^ floating point negation - | Sin - | Cos - | Tan - | Sinh - | Cosh - | Tanh - | Asin - | Acos - | Atan - | Log - | Exp - | Sqrt - -- exotic bit operations - | Bswap -- ^ Switch the order of the bytes in a word - | Ffs -- ^ Returns one plus the index of the least - -- significant 1-bit of x, 0 if x is zero. - | Clz -- ^ number of leading (from MSB) zeros, undefined if zero - | Ctz -- ^ number of trailing (from LSB) zeros, undefined if zero. - | Popcount -- ^ number of bits set to 1 in word - | Parity -- ^ number of bits set to 1 mod 2 - deriving(Eq,Show,Ord,Read,Enum,Bounded) - {-! derive: Binary !-} - --- conversion ops - -data ConvOp - = F2I -- ^ convert a floating point to an integral value via truncation - | F2U -- ^ convert a floating point to an unsigned integral value via truncation, negative values become zero - | U2F -- ^ convert an unsigned integral value to a floating point number - | I2F -- ^ convert an integral value to a floating point number - | F2F -- ^ convert a float from one precision to another, preserving value as much as possible - | Lobits -- ^ extract the low order bits - | Sx -- ^ sign extend a value (signed) - | Zx -- ^ zero extend a value (unsigned) - | I2I -- ^ perform a 'Lobits' or a 'Sx' depending on the sizes of the arguments - | U2U -- ^ perform a 'Lobits' or a 'Zx' depending on the sizes of the arguments - | B2B -- ^ a nop, useful for coercing hints (bits 2 bits) - deriving(Eq,Show,Ord,Read,Enum,Bounded) - {-! derive: Binary !-} - -data ValOp - = NaN - | PInf - | NInf - | PZero - | NZero - deriving(Eq,Show,Ord,Read,Bounded) - {-! derive: Binary !-} - -data ArchBits = BitsMax | BitsPtr | BitsUnknown - deriving(Eq,Ord) - {-! derive: Binary !-} - -data TyBits = Bits {-# UNPACK #-} !Int | BitsArch !ArchBits | BitsExt String - deriving(Eq,Ord) - {-! derive: Binary !-} - -data TyHint - = HintSigned - | HintUnsigned - | HintFloat -- an IEEE floating point value - | HintCharacter -- a unicode character, implies unsigned - | HintNone -- no hint - deriving(Eq,Ord) - {-! derive: Binary !-} - -data Ty - = TyBits !TyBits !TyHint - | TyBool - | TyComplex Ty - | TyVector !Int Ty - deriving(Eq,Ord) - {-! derive: Binary !-} - ---runReadP :: ReadP a -> String -> Maybe a ---runReadP rp s = case readP_to_S rp s of --- [(x,"")] -> Just x --- _ -> Nothing - -preadTy :: ReadP Ty -preadTy = choice cs where - cs = [ do string "bool"; return TyBool - , do char 's'; TyBits x _ <- preadTy; return $ TyBits x HintSigned - , do char 'u'; TyBits x _ <- preadTy; return $ TyBits x HintUnsigned - , do char 'f'; TyBits x _ <- preadTy; return $ TyBits x HintFloat - , do char 'c'; TyBits x _ <- preadTy; return $ TyBits x HintCharacter - , do string "bits<"; x <- manyTill P.get (char '>'); return $ TyBits (f x) HintNone - , do string "bits"; x <- readDecP; return $ TyBits (Bits x) HintNone - , do n <- readDecP; char '*'; t <- preadTy; return (TyVector n t) - , do string "i"; t <- preadTy; return (TyComplex t) - ] - f "ptr" = BitsArch BitsPtr - f "max" = BitsArch BitsMax - f "?" = BitsArch BitsUnknown - f x = BitsExt x - -readTy :: Monad m => String -> m Ty -readTy s = case runReadP preadTy s of - Nothing -> fail "readTy: not type" - Just x -> return x - -stringToOpTy :: String -> Ty -stringToOpTy s = case readTy s of - Just t -> t - _ -> error $ "stringToOpTy: " ++ show s - -bool = TyBool -bits_ptr = TyBits (BitsArch BitsPtr) HintNone -bits_max = TyBits (BitsArch BitsMax) HintNone -bits8 = TyBits (Bits 8) HintNone -bits16 = TyBits (Bits 16) HintNone -bits32 = TyBits (Bits 32) HintNone -bits64 = TyBits (Bits 64) HintNone - -class ToCmmTy a where - toCmmTy :: a -> Maybe Ty - -instance ToCmmTy Ty where - toCmmTy a = Just a - -instance ToCmmTy String where - toCmmTy s = readTy s - -cmmTyBits :: ToCmmTy a => a -> Maybe Int -cmmTyBits x = do TyBits (Bits b) _ <- toCmmTy x; return b -cmmTyHint x = do TyBits _ hint <- toCmmTy x; return hint - -instance Show TyHint where - showsPrec _ HintSigned = ('s':) - showsPrec _ HintUnsigned = ('u':) - showsPrec _ HintFloat = ('f':) - showsPrec _ HintCharacter = ('c':) - showsPrec _ HintNone = id - -instance Show Ty where - showsPrec _ TyBool = showString "bool" - showsPrec _ (TyBits b h) = shows h . showString "bits" . shows b - showsPrec _ (TyVector n t) = shows n . showChar '*' . shows t - showsPrec _ (TyComplex t) = showChar 'i' . shows t - -instance Show TyBits where - showsPrec _ (Bits n) = shows n - showsPrec _ (BitsExt s) = showChar '<' . showString s . showChar '>' - showsPrec _ (BitsArch s) = showChar '<' . shows s . showChar '>' - -instance Show ArchBits where - show BitsMax = "max" - show BitsPtr = "ptr" - show BitsUnknown = "?" - -data Op v - = BinOp BinOp v v - | UnOp UnOp v - | ValOp ValOp - | ConvOp ConvOp v - deriving(Eq,Show,Ord) - {-! derive: Binary !-} - -binopType :: BinOp -> Ty -> Ty -> Ty -binopType Mulx (TyBits (Bits i) h) _ = TyBits (Bits (i*2)) h -binopType UMulx (TyBits (Bits i) h) _ = TyBits (Bits (i*2)) h -binopType Eq _ _ = TyBool -binopType NEq _ _ = TyBool -binopType Gt _ _ = TyBool -binopType Gte _ _ = TyBool -binopType Lt _ _ = TyBool -binopType Lte _ _ = TyBool -binopType UGt _ _ = TyBool -binopType UGte _ _ = TyBool -binopType ULt _ _ = TyBool -binopType ULte _ _ = TyBool -binopType FEq _ _ = TyBool -binopType FNEq _ _ = TyBool -binopType FGt _ _ = TyBool -binopType FGte _ _ = TyBool -binopType FLt _ _ = TyBool -binopType FLte _ _ = TyBool -binopType FOrdered _ _ = TyBool -binopType _ t1 _ = t1 - -isCommutable :: BinOp -> Bool -isCommutable x = f x where - f Add = True - f Mul = True - f And = True - f Or = True - f Xor = True - f Eq = True - f NEq = True - f FAdd = True - f FMul = True - f FEq = True - f FNEq = True - f FOrdered = True - f _ = False - -commuteBinOp :: BinOp -> Maybe BinOp -commuteBinOp x | isCommutable x = return x -commuteBinOp Lt = return Gt -commuteBinOp Gt = return Lt -commuteBinOp Lte = return Gte -commuteBinOp Gte = return Lte -commuteBinOp ULt = return UGt -commuteBinOp UGt = return ULt -commuteBinOp ULte = return UGte -commuteBinOp UGte = return ULte -commuteBinOp FLt = return FGt -commuteBinOp FGt = return FLt -commuteBinOp FLte = return FGte -commuteBinOp FGte = return FLte -commuteBinOp _ = Nothing - -isAssociative :: BinOp -> Bool -isAssociative x = f x where - f Add = True - f Mul = True - f And = True - f Or = True - f Xor = True - f _ = False - -unopFloat :: Ty -> UnOp -> Maybe String -unopFloat (TyBits b HintFloat) op = g b =<< f op where - g (Bits 64) x = return x - g (Bits 32) x = return $ x ++ "f" - g _ _ = Nothing - f FAbs = return "fabs" - f Sin = return "sin" - f Cos = return "cos" - f Tan = return "tan" - f Sinh = return "sinh" - f Cosh = return "cosh" - f Tanh = return "tanh" - f Asin = return "asin" - f Acos = return "acos" - f Atan = return "atan" - f Sqrt = return "sqrt" - f Log = return "log" - f Exp = return "exp" - - f _ = Nothing -unopFloat _ _ = Nothing - -binopFunc :: Ty -> Ty -> BinOp -> Maybe String -binopFunc (TyBits b _) _ bop = g b =<< f bop where - g (Bits 64) x = return x - g (Bits 32) x = return $ x ++ "f" - g _ _ = Nothing - f FPwr = Just "pow" - f FAtan2 = Just "atan2" - f _ = Nothing -binopFunc TyBool _ bop = Nothing -binopFunc _ _ _ = error "Op.binopFunc: bad." - -binopInfix :: BinOp -> Maybe (String,Int) -binopInfix UDiv = Just ("/",8) -binopInfix Mul = Just ("*",8) -binopInfix UMod = Just ("%",8) -binopInfix Sub = Just ("-",7) -binopInfix Add = Just ("+",7) -binopInfix Shr = Just (">>",6) -binopInfix Shl = Just ("<<",6) -binopInfix And = Just ("&",5) -binopInfix Xor = Just ("^",4) -binopInfix Or = Just ("|",3) -binopInfix UGte = Just (">=",2) -binopInfix UGt = Just (">",2) -binopInfix ULte = Just ("<=",2) -binopInfix ULt = Just ("<",2) -binopInfix Eq = Just ("==",2) -binopInfix NEq = Just ("!=",2) -binopInfix _ = Nothing - -class IsOperator o where - isCheap :: o -> Bool - isEagerSafe :: o -> Bool - -instance IsOperator BinOp where - isCheap FAtan2 = False - isCheap _ = True - - isEagerSafe Div = False - isEagerSafe Mod = False - isEagerSafe Quot = False - isEagerSafe Rem = False - isEagerSafe UDiv = False - isEagerSafe UMod = False - isEagerSafe _ = True - -instance IsOperator UnOp where - isCheap _ = True - isEagerSafe _ = True - -instance IsOperator ConvOp where - isCheap _ = True - isEagerSafe _ = True - -instance IsOperator (Op v) where - isCheap (BinOp o _ _) = isCheap o - isCheap (UnOp o _) = isCheap o - isCheap (ConvOp o _) = isCheap o - isCheap _ = False - isEagerSafe (BinOp o _ _) = isEagerSafe o - isEagerSafe (UnOp o _) = isEagerSafe o - isEagerSafe (ConvOp o _) = isEagerSafe o - isEagerSafe _ = False -{-* Generated by DrIFT : Look, but Don't Touch. *-} -instance Data.Binary.Binary BinOp where - put Add = do - Data.Binary.putWord8 0 - put Sub = do - Data.Binary.putWord8 1 - put Mul = do - Data.Binary.putWord8 2 - put Mulx = do - Data.Binary.putWord8 3 - put UMulx = do - Data.Binary.putWord8 4 - put Div = do - Data.Binary.putWord8 5 - put Mod = do - Data.Binary.putWord8 6 - put Quot = do - Data.Binary.putWord8 7 - put Rem = do - Data.Binary.putWord8 8 - put UDiv = do - Data.Binary.putWord8 9 - put UMod = do - Data.Binary.putWord8 10 - put And = do - Data.Binary.putWord8 11 - put Or = do - Data.Binary.putWord8 12 - put Xor = do - Data.Binary.putWord8 13 - put Shl = do - Data.Binary.putWord8 14 - put Shr = do - Data.Binary.putWord8 15 - put Shra = do - Data.Binary.putWord8 16 - put Rotl = do - Data.Binary.putWord8 17 - put Rotr = do - Data.Binary.putWord8 18 - put FAdd = do - Data.Binary.putWord8 19 - put FSub = do - Data.Binary.putWord8 20 - put FDiv = do - Data.Binary.putWord8 21 - put FMul = do - Data.Binary.putWord8 22 - put FPwr = do - Data.Binary.putWord8 23 - put FAtan2 = do - Data.Binary.putWord8 24 - put Eq = do - Data.Binary.putWord8 25 - put NEq = do - Data.Binary.putWord8 26 - put Gt = do - Data.Binary.putWord8 27 - put Gte = do - Data.Binary.putWord8 28 - put Lt = do - Data.Binary.putWord8 29 - put Lte = do - Data.Binary.putWord8 30 - put UGt = do - Data.Binary.putWord8 31 - put UGte = do - Data.Binary.putWord8 32 - put ULt = do - Data.Binary.putWord8 33 - put ULte = do - Data.Binary.putWord8 34 - put FEq = do - Data.Binary.putWord8 35 - put FNEq = do - Data.Binary.putWord8 36 - put FGt = do - Data.Binary.putWord8 37 - put FGte = do - Data.Binary.putWord8 38 - put FLt = do - Data.Binary.putWord8 39 - put FLte = do - Data.Binary.putWord8 40 - put FOrdered = do - Data.Binary.putWord8 41 - get = do - h <- Data.Binary.getWord8 - case h of - 0 -> do - return Add - 1 -> do - return Sub - 2 -> do - return Mul - 3 -> do - return Mulx - 4 -> do - return UMulx - 5 -> do - return Div - 6 -> do - return Mod - 7 -> do - return Quot - 8 -> do - return Rem - 9 -> do - return UDiv - 10 -> do - return UMod - 11 -> do - return And - 12 -> do - return Or - 13 -> do - return Xor - 14 -> do - return Shl - 15 -> do - return Shr - 16 -> do - return Shra - 17 -> do - return Rotl - 18 -> do - return Rotr - 19 -> do - return FAdd - 20 -> do - return FSub - 21 -> do - return FDiv - 22 -> do - return FMul - 23 -> do - return FPwr - 24 -> do - return FAtan2 - 25 -> do - return Eq - 26 -> do - return NEq - 27 -> do - return Gt - 28 -> do - return Gte - 29 -> do - return Lt - 30 -> do - return Lte - 31 -> do - return UGt - 32 -> do - return UGte - 33 -> do - return ULt - 34 -> do - return ULte - 35 -> do - return FEq - 36 -> do - return FNEq - 37 -> do - return FGt - 38 -> do - return FGte - 39 -> do - return FLt - 40 -> do - return FLte - 41 -> do - return FOrdered - _ -> fail "invalid binary data found" - -instance Data.Binary.Binary UnOp where - put Neg = do - Data.Binary.putWord8 0 - put Com = do - Data.Binary.putWord8 1 - put FAbs = do - Data.Binary.putWord8 2 - put FNeg = do - Data.Binary.putWord8 3 - put Sin = do - Data.Binary.putWord8 4 - put Cos = do - Data.Binary.putWord8 5 - put Tan = do - Data.Binary.putWord8 6 - put Sinh = do - Data.Binary.putWord8 7 - put Cosh = do - Data.Binary.putWord8 8 - put Tanh = do - Data.Binary.putWord8 9 - put Asin = do - Data.Binary.putWord8 10 - put Acos = do - Data.Binary.putWord8 11 - put Atan = do - Data.Binary.putWord8 12 - put Log = do - Data.Binary.putWord8 13 - put Exp = do - Data.Binary.putWord8 14 - put Sqrt = do - Data.Binary.putWord8 15 - put Bswap = do - Data.Binary.putWord8 16 - put Ffs = do - Data.Binary.putWord8 17 - put Clz = do - Data.Binary.putWord8 18 - put Ctz = do - Data.Binary.putWord8 19 - put Popcount = do - Data.Binary.putWord8 20 - put Parity = do - Data.Binary.putWord8 21 - get = do - h <- Data.Binary.getWord8 - case h of - 0 -> do - return Neg - 1 -> do - return Com - 2 -> do - return FAbs - 3 -> do - return FNeg - 4 -> do - return Sin - 5 -> do - return Cos - 6 -> do - return Tan - 7 -> do - return Sinh - 8 -> do - return Cosh - 9 -> do - return Tanh - 10 -> do - return Asin - 11 -> do - return Acos - 12 -> do - return Atan - 13 -> do - return Log - 14 -> do - return Exp - 15 -> do - return Sqrt - 16 -> do - return Bswap - 17 -> do - return Ffs - 18 -> do - return Clz - 19 -> do - return Ctz - 20 -> do - return Popcount - 21 -> do - return Parity - _ -> fail "invalid binary data found" - -instance Data.Binary.Binary ConvOp where - put F2I = do - Data.Binary.putWord8 0 - put F2U = do - Data.Binary.putWord8 1 - put U2F = do - Data.Binary.putWord8 2 - put I2F = do - Data.Binary.putWord8 3 - put F2F = do - Data.Binary.putWord8 4 - put Lobits = do - Data.Binary.putWord8 5 - put Sx = do - Data.Binary.putWord8 6 - put Zx = do - Data.Binary.putWord8 7 - put I2I = do - Data.Binary.putWord8 8 - put U2U = do - Data.Binary.putWord8 9 - put B2B = do - Data.Binary.putWord8 10 - get = do - h <- Data.Binary.getWord8 - case h of - 0 -> do - return F2I - 1 -> do - return F2U - 2 -> do - return U2F - 3 -> do - return I2F - 4 -> do - return F2F - 5 -> do - return Lobits - 6 -> do - return Sx - 7 -> do - return Zx - 8 -> do - return I2I - 9 -> do - return U2U - 10 -> do - return B2B - _ -> fail "invalid binary data found" - -instance Data.Binary.Binary ValOp where - put NaN = do - Data.Binary.putWord8 0 - put PInf = do - Data.Binary.putWord8 1 - put NInf = do - Data.Binary.putWord8 2 - put PZero = do - Data.Binary.putWord8 3 - put NZero = do - Data.Binary.putWord8 4 - get = do - h <- Data.Binary.getWord8 - case h of - 0 -> do - return NaN - 1 -> do - return PInf - 2 -> do - return NInf - 3 -> do - return PZero - 4 -> do - return NZero - _ -> fail "invalid binary data found" - -instance Data.Binary.Binary ArchBits where - put BitsMax = do - Data.Binary.putWord8 0 - put BitsPtr = do - Data.Binary.putWord8 1 - put BitsUnknown = do - Data.Binary.putWord8 2 - get = do - h <- Data.Binary.getWord8 - case h of - 0 -> do - return BitsMax - 1 -> do - return BitsPtr - 2 -> do - return BitsUnknown - _ -> fail "invalid binary data found" - -instance Data.Binary.Binary TyBits where - put (Bits aa) = do - Data.Binary.putWord8 0 - Data.Binary.put aa - put (BitsArch ab) = do - Data.Binary.putWord8 1 - Data.Binary.put ab - put (BitsExt ac) = do - Data.Binary.putWord8 2 - Data.Binary.put ac - get = do - h <- Data.Binary.getWord8 - case h of - 0 -> do - aa <- Data.Binary.get - return (Bits aa) - 1 -> do - ab <- Data.Binary.get - return (BitsArch ab) - 2 -> do - ac <- Data.Binary.get - return (BitsExt ac) - _ -> fail "invalid binary data found" - -instance Data.Binary.Binary TyHint where - put HintSigned = do - Data.Binary.putWord8 0 - put HintUnsigned = do - Data.Binary.putWord8 1 - put HintFloat = do - Data.Binary.putWord8 2 - put HintCharacter = do - Data.Binary.putWord8 3 - put HintNone = do - Data.Binary.putWord8 4 - get = do - h <- Data.Binary.getWord8 - case h of - 0 -> do - return HintSigned - 1 -> do - return HintUnsigned - 2 -> do - return HintFloat - 3 -> do - return HintCharacter - 4 -> do - return HintNone - _ -> fail "invalid binary data found" - -instance Data.Binary.Binary Ty where - put (TyBits aa ab) = do - Data.Binary.putWord8 0 - Data.Binary.put aa - Data.Binary.put ab - put TyBool = do - Data.Binary.putWord8 1 - put (TyComplex ac) = do - Data.Binary.putWord8 2 - Data.Binary.put ac - put (TyVector ad ae) = do - Data.Binary.putWord8 3 - Data.Binary.put ad - Data.Binary.put ae - get = do - h <- Data.Binary.getWord8 - case h of - 0 -> do - aa <- Data.Binary.get - ab <- Data.Binary.get - return (TyBits aa ab) - 1 -> do - return TyBool - 2 -> do - ac <- Data.Binary.get - return (TyComplex ac) - 3 -> do - ad <- Data.Binary.get - ae <- Data.Binary.get - return (TyVector ad ae) - _ -> fail "invalid binary data found" - -instance (Data.Binary.Binary v) => Data.Binary.Binary (Op v) where - put (BinOp aa ab ac) = do - Data.Binary.putWord8 0 - Data.Binary.put aa - Data.Binary.put ab - Data.Binary.put ac - put (UnOp ad ae) = do - Data.Binary.putWord8 1 - Data.Binary.put ad - Data.Binary.put ae - put (ValOp af) = do - Data.Binary.putWord8 2 - Data.Binary.put af - put (ConvOp ag ah) = do - Data.Binary.putWord8 3 - Data.Binary.put ag - Data.Binary.put ah - get = do - h <- Data.Binary.getWord8 - case h of - 0 -> do - aa <- Data.Binary.get - ab <- Data.Binary.get - ac <- Data.Binary.get - return (BinOp aa ab ac) - 1 -> do - ad <- Data.Binary.get - ae <- Data.Binary.get - return (UnOp ad ae) - 2 -> do - af <- Data.Binary.get - return (ValOp af) - 3 -> do - ag <- Data.Binary.get - ah <- Data.Binary.get - return (ConvOp ag ah) - _ -> fail "invalid binary data found" - --- Imported from other files :- diff --git a/drift_processed/DataConstructors.hs b/drift_processed/DataConstructors.hs deleted file mode 100644 --- a/drift_processed/DataConstructors.hs +++ /dev/null @@ -1,1027 +0,0 @@ -{- Generated by DrIFT (Automatic class derivations for Haskell) -} -{-# LINE 1 "src/DataConstructors.hs" #-} -{-# LANGUAGE OverloadedStrings #-} -module DataConstructors( - AliasType(..), - boxPrimitive, - collectDeriving, - conSlots, - constructionExpression, - Constructor(..), - DataFamily(..), - DataTable(..), - DataTableMonad(..), - dataTablePrims, - deconstructionExpression, - deriveClasses, - extractIO, - extractIO', - extractPrimitive, - ExtTypeInfo(..), - extTypeInfoExtType, - followAlias, - followAliases, - getConstructor, - getConstructorArities, - getProduct, - getSiblings, - lookupExtTypeInfo, - mktBox, - modBox, - numberSiblings, - onlyChild, - pprintTypeOfCons, - primitiveAliases, - removeNewtypes, - samplePrimitiveDataTable, - showDataTable, - Slot(..), - slotTypes, - slotTypesHs, - tAbsurd, - toDataTable, - typesCompatable, - updateLit - ) where - -import Control.Monad.Identity -import Control.Monad.Writer(tell,execWriter) -import Data.Maybe -import Data.Monoid hiding(getProduct) -import Data.List(sortBy) -import qualified Data.Map as Map hiding(map) -import qualified Data.Set as Set hiding(map) - -import C.Prims -import Data.Binary -import Doc.DocLike as D -import Doc.PPrint -import Doc.Pretty -import E.Binary() -import E.E -import E.Show -import E.Subst -import E.Traverse -import E.TypeCheck -import E.Values -import FrontEnd.Class(instanceName) -import FrontEnd.HsSyn -import FrontEnd.SrcLoc -import FrontEnd.Syn.Traverse -import FrontEnd.Tc.Type -import GenUtil -import Info.Types -import Name.Id -import Name.Name as Name -import Name.Names -import Name.VConsts -import PackedString -import Support.CanType -import Support.FreeVars -import Support.MapBinaryInstance -import Support.Unparse -import Util.HasSize -import Util.SameShape -import Util.SetLike as S -import Util.VarName -import qualified Cmm.Op as Op -import qualified Util.Graph as G -import qualified Util.Seq as Seq - -tipe' (TAp t1 t2) = liftM2 eAp (tipe' t1) (tipe' t2) -tipe' (TArrow t1 t2) = do - t1' <- tipe' t1 - t2' <- tipe' t2 - return $ EPi (tVr emptyId (t1')) t2' -tipe' (TCon (Tycon n k)) | Just n' <- Map.lookup n primitiveAliases = return $ ELit litCons { litName = n', litType = kind k } -tipe' (TCon (Tycon n k)) = return $ ELit litCons { litName = n, litType = kind k } -tipe' (TVar tv@Tyvar { tyvarKind = k}) = do - v <- lookupName tv - return $ EVar $ tVr v (kind k) -tipe' (TForAll [] (_ :=> t)) = tipe' t -tipe' (TExists [] (_ :=> t)) = tipe' t -tipe' (TForAll xs (_ :=> t)) = do - xs' <- flip mapM xs $ \tv -> do - v <- newName (map anonymous [35 .. ]) () tv - return $ tVr v (kind $ tyvarKind tv) - t' <- tipe' t - return $ foldr EPi t' xs' -- [ tVr n (kind k) | n <- [2,4..] | k <- xs ] -tipe' ~(TExists xs (_ :=> t)) = do - xs' <- flip mapM xs $ \tv -> do - --v <- newName [70,72..] () tv - --return $ tVr v (kind $ tyvarKind tv) - return $ (kind $ tyvarKind tv) - t' <- tipe' t - return $ ELit litCons { litName = unboxedNameTuple TypeConstructor (length xs' + 1), litArgs = (t':xs'), litType = eHash } - -kind (KBase KUTuple) = eHash -kind (KBase KHash) = eHash -kind (KBase Star) = eStar -kind (KBase (KNamed t)) = ESort (ESortNamed t) -kind (Kfun k1 k2) = EPi (tVr emptyId (kind k1)) (kind k2) -kind k = error $ "DataConstructors.kind: cannot convert " ++ show k - -data AliasType = ErasedAlias | RecursiveAlias - deriving(Eq,Ord,Show) - {-! derive: Binary !-} - --- these apply to types -data DataFamily = - DataAbstract -- abstract internal type, has children of representation unknown and irrelevant. - | DataNone -- children don't apply. data constructor for instance - | DataPrimitive -- primitive type, children are all numbers. - | DataEnum {-# UNPACK #-} !Int -- bounded integral type, argument is maximum number - | DataNormal [Name] -- child constructors - | DataAlias !AliasType - deriving(Eq,Ord,Show) - {-! derive: Binary !-} - --- | Record describing a data type. --- * is also a data type containing the type constructors, which are unlifted, yet boxed. - -data Constructor = Constructor { - conName :: Name, -- name of constructor - conType :: E, -- type of constructor - conExpr :: E, -- expression which constructs this value - conOrigSlots :: [Slot], -- original slots - conInhabits :: Name, -- what constructor it inhabits, similar to conType, but not quite. - conVirtual :: Maybe [Name], -- whether this is a virtual constructor that translates into an enum and its siblings - conChildren :: DataFamily, - conCTYPE :: Maybe ExtType -- external type - } deriving(Show) - {-! derive: Binary !-} - -data Slot = - SlotNormal E - | SlotUnpacked E !Name [E] - | SlotExistential TVr - deriving(Eq,Ord,Show) - {-! derive: Binary !-} - -mapESlot f (SlotExistential t) = SlotExistential t { tvrType = f (tvrType t) } -mapESlot f (SlotNormal e) = SlotNormal $ f e -mapESlot f (SlotUnpacked e n es) = SlotUnpacked (f e) n (map f es) - -conSlots s = getSlots $ conOrigSlots s - -getSlots ss = concatMap f ss where - f (SlotNormal e) = [e] - f (SlotUnpacked _ _ es) = es - f (SlotExistential e) = [tvrType e] - -getHsSlots ss = map f ss where - f (SlotNormal e) = e - f (SlotUnpacked e _ es) = e - f (SlotExistential e) = tvrType e - -newtype DataTable = DataTable (Map.Map Name Constructor) - deriving(Monoid) - -instance Binary DataTable where - put (DataTable dt) = putMap dt - get = fmap DataTable getMap - -emptyConstructor = Constructor { - conName = error "emptyConstructor.conName", - conType = Unknown, - conOrigSlots = [], - conExpr = Unknown, - conInhabits = error "emptyConstructor.conInhabits", - conVirtual = Nothing, - conCTYPE = Nothing, - conChildren = DataNone - } - -instance HasSize DataTable where - size (DataTable d) = Map.size d - -{-# NOINLINE getConstructor #-} -getConstructor :: Monad m => Name -> DataTable -> m Constructor -getConstructor n _ | isJust me = return (emptyConstructor { - conName = n, conType = e, - conExpr = foldr ELam (foldl eAp (mktBox e) (map EVar tvrs)) tvrs, - conInhabits = s_Star, conOrigSlots = map SlotNormal sts }) where - sts = map tvrType ss - tvrs = [ tvr { tvrIdent = i , tvrType = t } | i <- anonymousIds | t <- sts ] - (_,ss) = fromPi e - me@(~(Just e)) = fromConjured modBox n `mplus` fromConjured modAbsurd n -getConstructor n _ | RawType <- nameType n = return $ primitiveConstructor n -getConstructor n _ | Just v <- fromUnboxedNameTuple n, DataConstructor <- nameType n = return $ snd $ tunboxedtuple v -getConstructor n _ | Just v <- fromUnboxedNameTuple n, TypeConstructor <- nameType n = return $ fst $ tunboxedtuple v -getConstructor n (DataTable map) = case Map.lookup n map of - Just x -> return x - Nothing -> fail $ "getConstructor: " ++ show (nameType n,n) - --- | return the single constructor of product types -getProduct :: Monad m => DataTable -> E -> m Constructor -getProduct dataTable e | (ELit LitCons { litName = cn }) <- - followAliases dataTable e, Just c <- getConstructor cn dataTable = f c where - f c | DataNormal [x] <- conChildren c = getConstructor x dataTable - | otherwise = fail "Not Product type" -getProduct _ _ = fail "Not Product type" - -tunboxedtuple :: Int -> (Constructor,Constructor) -tunboxedtuple n = (typeCons,dataCons) where - dataCons = emptyConstructor { - conName = dc, - conType = dtipe, - conOrigSlots = map (SlotNormal . EVar) typeVars, - conExpr = foldr ($) (ELit litCons - { litName = dc - , litArgs = map EVar vars - , litType = ftipe - }) (map ELam vars), - conInhabits = tc - } - typeCons = emptyConstructor { - conName = tc, - conType = foldr EPi eHash (replicate n tvr { tvrType = eStar }), - conOrigSlots = replicate n (SlotNormal eStar), - conExpr = tipe, - conInhabits = s_Hash, - conChildren = DataNormal [dc] - } - dc = unboxedNameTuple DataConstructor n - tc = unboxedNameTuple TypeConstructor n - tipe = foldr ELam ftipe typeVars - typeVars = take n [ tvr { tvrType = eStar, tvrIdent = v } | v <- anonymousIds ] - vars = [ tvr { tvrType = EVar t, tvrIdent = v } | v <- map anonymous [ n + 8, n + 9 ..] | t <- typeVars ] - ftipe = ELit (litCons { litName = tc, litArgs = map EVar typeVars, litType = eHash }) - dtipe = foldr EPi (foldr EPi ftipe [ v { tvrIdent = emptyId } | v <- vars]) typeVars - --- | conjured data types, these data types are created as needed and can be of any type, their --- actual type is encoded in their names. --- --- Absurd - this is a type that it used to default otherwise unconstrained --- types, it is not special in any particular way but is just an arbitrary type --- to give to things. --- --- Box - this type can be used to represent any boxed values. It is considered --- equivalent to all boxed values so is not a very precise type. It is used in --- the final stages of compilation before core mangling so that optimizations --- that were previously blocked by type variables can be carried out. - -tAbsurd k = ELit (litCons { - litName = nameConjured modAbsurd k, litArgs = [], litType = k }) -mktBox k = ELit (litCons { - litName = nameConjured modBox k, litArgs = [], - litType = k, litAliasFor = af }) where - af = case k of - EPi TVr { tvrType = t1 } t2 -> Just (ELam tvr { tvrType = t1 } (mktBox t2)) - _ -> Nothing - -tarrow = emptyConstructor { - conName = tc_Arrow, - conType = EPi (tVr emptyId eStar) (EPi (tVr emptyId eStar) eStar), - conOrigSlots = [SlotNormal eStar,SlotNormal eStar], - conExpr = ELam (tVr va1 eStar) (ELam (tVr va2 eStar) (EPi (tVr emptyId (EVar $ tVr va1 eStar)) (EVar $ tVr va2 eStar))), - conInhabits = s_Star, - conChildren = DataAbstract - } - -primitiveConstructor name = emptyConstructor { - conName = name, - conType = eHash, - conExpr = ELit (litCons { litName = name, litArgs = [], litType = eHash }), - conInhabits = s_Hash, - conChildren = DataPrimitive - } - -sortName :: ESort -> Name -sortName s = f s where - f EStar = s_Star -- the sort of boxed lazy types - f EBang = s_Bang -- the sort of boxed strict types - f EHash = s_Hash -- the sort of unboxed types - f ETuple = s_Tuple -- the sort of unboxed tuples - f EHashHash = s_HashHash -- the supersort of unboxed types - f EStarStar = s_StarStar -- the supersort of boxed types - f (ESortNamed n) = n -- user defined sorts - -sortConstructor name ss = emptyConstructor { - conName = name, - conType = ESort ss, - conExpr = ESort (ESortNamed name), - conInhabits = sortName ss -} - -typesCompatable :: forall m . Monad m => E -> E -> m () -typesCompatable a b = f etherealIds a b where - f :: [Id] -> E -> E -> m () - f _ (ESort a) (ESort b) = when (a /= b) $ fail $ "Sorts don't match: " ++ pprint (ESort a,ESort b) - f _ (EVar a) (EVar b) = when (a /= b) $ fail $ "Vars don't match: " ++ pprint (a,b) - -- we expand aliases first, because the newtype might have phantom types as arguments - f c (ELit (LitCons { litAliasFor = Just af, litArgs = as })) b = do - f c (foldl eAp af as) b - f c a (ELit (LitCons { litAliasFor = Just af, litArgs = as })) = do - f c a (foldl eAp af as) - f c (ELit LitCons { litName = n, litArgs = xs, litType = t }) (ELit LitCons { litName = n', litArgs = xs', litType = t' }) | n == n' = do - f c t t' - when (not $ sameShape1 xs xs') $ fail "Arg lists don't match" - zipWithM_ (f c) xs xs' - f c (EAp a b) (EAp a' b') = do - f c a a' - f c b b' - f c (ELam va ea) (ELam vb eb) = lam va ea vb eb c - f c (EPi va ea) (EPi vb eb) = lam va ea vb eb c - f c (EPi (TVr { tvrIdent = eid, tvrType = a}) b) (ELit (LitCons { litName = n, litArgs = [a',b'], litType = t })) | eid == emptyId, conName tarrow == n, t == eStar = do - f c a a' - f c b b' - f c (ELit (LitCons { litName = n, litArgs = [a',b'], litType = t })) (EPi (TVr { tvrIdent = eid, tvrType = a}) b) | eid == emptyId, conName tarrow == n, t == eStar = do - f c a a' - f c b b' - f _ a b | boxCompat a b || boxCompat b a = return () - f _ a b = fail $ "Types don't match:" ++ pprint (a,b) - - lam :: TVr -> E -> TVr -> E -> [Id] -> m () - lam va ea vb eb ~(c:cs) = do - f (c:cs) (tvrType va) (tvrType vb) - f cs (subst va (EVar va { tvrIdent = c }) ea) (subst vb (EVar vb { tvrIdent = c }) eb) - boxCompat (ELit (LitCons { litName = n })) t | Just e <- fromConjured modBox n = e == getType t - boxCompat _ _ = False - -extractPrimitive :: Monad m => DataTable -> E -> m (E,(ExtType,E)) -extractPrimitive dataTable e = case followAliases dataTable (getType e) of - st@(ELit LitCons { litName = c, litArgs = [], litType = t }) - | t == eHash -> return (e,(ExtType (packString $show c),st)) - | otherwise -> do - Constructor { conChildren = DataNormal [cn] } <- getConstructor c dataTable - Constructor { conOrigSlots = [SlotNormal st] } <- getConstructor cn dataTable - (ELit LitCons { litName = n, litArgs = []}) <- return $ followAliases dataTable st - let tvra = tVr vn st - (vn:_) = newIds (freeIds e) - return (eCase e [Alt (litCons { litName = cn, litArgs = [tvra], - litType = (getType e) }) (EVar tvra)] Unknown,(ExtType (packString $ show n),st)) - e' -> fail $ "extractPrimitive: " ++ show (e,e') - -boxPrimitive :: - Monad m - => DataTable - -> E -- primitive to box - -> E -- what type we want it to have - -> m (E,(ExtType,E)) -boxPrimitive dataTable e et = case followAliases dataTable et of - st@(ELit LitCons { litName = c, litArgs = [], litType = t }) - | t == eHash -> return (e,(ExtType . packString $ show c,st)) - | otherwise -> do - Constructor { conChildren = DataNormal [cn] } <- getConstructor c dataTable - Constructor { conOrigSlots = [SlotNormal st] } <- getConstructor cn dataTable - (ELit LitCons { litName = n, litArgs = []}) <- return $ followAliases dataTable st - let tvra = tVr vn st - (vn:_) = newIds (freeVars (e,et)) - if isManifestAtomic e then - return $ (ELit litCons { litName = cn, litArgs = [e], litType = et },(ExtType . packString $ show n,st)) - else - return $ (eStrictLet tvra e $ ELit litCons { litName = cn, litArgs = [EVar tvra], litType = et },(ExtType . packString $ show n,st)) - e' -> fail $ "boxPrimitive: " ++ show (e,e') - -extractIO :: Monad m => E -> m E -extractIO e = f e where - f (ELit LitCons { litName = c, litArgs = [x] }) | c == tc_IO = return x - f (ELit LitCons { litAliasFor = Just af, litArgs = as }) = f (foldl eAp af as) - f _ = fail "extractIO: not an IO type" - --- extract IO or an unboxed version of it, (ST, World -> (# Wold, a #)) -extractIO' :: E -> ([E],Bool,E) -extractIO' e = f e [] where - f (ELit LitCons { litName = c, litArgs = [x] }) rs | c == tc_IO = (reverse rs, True,x) - f (ELit LitCons { litName = c, litArgs = [_,x] }) rs | c == tc_ST = (reverse rs, True,x) - f (expandAlias -> Just t) rs = f t rs - f (fromPi -> (fromUnboxedTuple -> Just [s',x],[getType -> s''])) rs - | isState_ s' && isState_ s'' = (reverse rs, True,x) - f (EPi v e) rs = f e (getType v:rs) - f e rs = (reverse rs, False,e) --- f (fromPi -> (getType -> s',[getType -> s''])) | isState_ s' && isState_ s'' = (True,tUnit) - -data ExtTypeInfo - = ExtTypeVoid -- maps to 'void' - | ExtTypeRaw ExtType -- value is an unboxed type suitable for passing with the argument calling convention - | ExtTypeBoxed Name E ExtType -- boxed type, name is constructor of box, E is type of the slice, and ExtType is the calling convention to use - -extTypeInfoExtType (ExtTypeRaw et) = et -extTypeInfoExtType (ExtTypeBoxed _ _ et) = et -extTypeInfoExtType ExtTypeVoid = "void" - -lookupExtTypeInfo :: Monad m => DataTable -> E -> m ExtTypeInfo -lookupExtTypeInfo dataTable oe = f Set.empty oe where - f :: Monad m => Set.Set Name -> E -> m ExtTypeInfo - -- handle the void context ones first - f _ e@(ELit LitCons { litName = c }) | c == tc_Unit || c == tc_State_ = return ExtTypeVoid - -- if the constructor is in the external type map, replace its external - -- type with the one in the map - f seen e@(ELit LitCons { litName = c, litArgs = [ta] }) | c == tc_Ptr = do - ExtTypeBoxed b t _ <- g seen e -- we know a pointer is a boxed BitsPtr - case f seen ta of - Just (ExtTypeBoxed _ _ (ExtType et)) -> return $ ExtTypeBoxed b t (ExtType $ et `mappend` "*") - Just (ExtTypeRaw (ExtType et)) -> return $ ExtTypeBoxed b t (ExtType $ et `mappend` "*") - _ -> return $ ExtTypeBoxed b t "HsPtr" - f seen e@(ELit LitCons { litName = c, litArgs = [ta] }) | c == tc_Complex = do - case f seen ta of - Just (ExtTypeRaw (ExtType et)) -> return $ ExtTypeRaw (ExtType $ "_Complex " `mappend` et) - _ -> fail "invalid _Complex type" - f seen e@(ELit LitCons { litName = c }) | Just (conCTYPE -> Just et) <- getConstructor c dataTable = do - return $ case g seen e of - Just (ExtTypeBoxed b t _) -> ExtTypeBoxed b t et - Just ExtTypeVoid -> ExtTypeVoid - _ -> ExtTypeRaw et - f seen e = g seen e - -- if we are a raw type, we can be foreigned - g _ (ELit LitCons { litName = c }) - | Just et <- Map.lookup c rawExtTypeMap = return (ExtTypeRaw et) - -- if we are a single constructor data type with a single foreignable unboxed - -- slot, we are foreiginable - g _ (ELit LitCons { litName = c, litAliasFor = Nothing }) - | Just Constructor { conChildren = DataNormal [cn] } <- getConstructor c dataTable, - Just Constructor { conOrigSlots = [SlotNormal st] } <- getConstructor cn dataTable, - Just (ExtTypeRaw et) <- lookupExtTypeInfo dataTable st = return $ ExtTypeBoxed cn st et - g seen e@(ELit LitCons { litName = n }) | Just e' <- followAlias dataTable e, - n `Set.notMember` seen = f (Set.insert n seen) e' - g _ e = fail $ "lookupExtTypeInfo: " ++ show (oe,e) - -expandAlias :: Monad m => E -> m E -expandAlias (ELit LitCons { litAliasFor = Just af, litArgs = as }) = return (foldl eAp af as) -expandAlias _ = fail "expandAlias: not alias" - -followAlias :: Monad m => DataTable -> E -> m E -followAlias _ (ELit LitCons { litAliasFor = Just af, litArgs = as }) = return (foldl eAp af as) -followAlias _ _ = fail "followAlias: not alias" - -followAliases :: DataTable -> E -> E -followAliases _dataTable e = f e where - f (ELit LitCons { litAliasFor = Just af, litArgs = as }) = f (foldl eAp af as) - f e = e - -dataTablePrims = DataTable $ Map.fromList ([ (conName x,x) | x <- [tarrow] ]) - -deriveClasses :: IdMap Comb -> DataTable -> [(SrcLoc,Name,Name)] -> [(TVr,E)] -deriveClasses cmap dt@(DataTable mp) ctd = concatMap f ctd where - f (_,cd,t) | Just c <- getConstructor t dt, TypeConstructor == nameType (conName c), Just is <- conVirtual c = g is c cd - f _ = [] - g is c cl = h cl where - lupvar v = EVar (combHead comb) where - Just comb = mlookup (toId v) cmap - typ = conExpr c - DataNormal [con] = conChildren c - Just conr = getConstructor con (DataTable mp) - [it@(ELit LitCons { litName = it_name })] = conSlots conr - Just itr = getConstructor it_name (DataTable mp) - DataEnum mv = conChildren itr - v1 = tvr { tvrIdent = anonymous 1, tvrType = typ } - v2 = tvr { tvrIdent = anonymous 2, tvrType = typ } - i1 = tvr { tvrIdent = anonymous 3, tvrType = it } - i2 = tvr { tvrIdent = anonymous 4, tvrType = it } - b3 = tvr { tvrIdent = anonymous 5, tvrType = tBoolzh } - val1 = tvr { tvrIdent = anonymous 7, tvrType = typ } - unbox e = ELam v1 (ELam v2 (ec (EVar v1) i1 (ec (EVar v2) i2 e))) where - ec v i e = eCase v [Alt (litCons { litName = con, litArgs = [i], litType = typ }) e] Unknown - h cl | cl == class_Eq = [mkCmpFunc v_equals Op.Eq] - h cl | cl == class_Ord = [ - mkCmpFunc v_geq Op.UGte, - mkCmpFunc v_leq Op.ULte, - mkCmpFunc v_lt Op.ULt, - mkCmpFunc v_gt Op.UGt] - h cl | Just ans <- lookup cl mthds = ans where - mthds = [(class_Enum,[ - (iv_te,ib_te), - (iv_fe,ib_fe), - iv v_succ succ_body, - iv v_pred pred_body, - iv v_enumFrom from_body, - iv v_enumFromTo fromTo_body, - iv v_enumFromThen fromThen_body, - iv v_enumFromThenTo fromThenTo_body - ]), - (class_Ix,[ - iv v_range range_body, --- iv v_inRange inRange_body, - iv v_index index_body - ])] - iv_te = setProperty prop_INSTANCE tvr { tvrIdent = toId $ instanceName v_toEnum (nameName $ conName c), tvrType = getType ib_te } - iv_fe = setProperty prop_INSTANCE tvr { tvrIdent = toId $ instanceName v_fromEnum (nameName $ conName c), tvrType = getType ib_fe } - iv fname body = (setProperty prop_INSTANCE tvr { tvrIdent = toId $ instanceName fname (nameName $ conName c), tvrType = getType body },body) - succ_body = foldl EAp (lupvar v_enum_succ) [typ, box, debox, max] - pred_body = foldl EAp (lupvar v_enum_pred) [typ, box, debox] - from_body = foldl EAp (lupvar v_enum_from) [typ, box, debox, max] - fromTo_body = foldl EAp (lupvar v_enum_fromTo) [typ, box, debox] - fromThen_body = foldl EAp (lupvar v_enum_fromThen) [typ, box, debox, max] - fromThenTo_body = foldl EAp (lupvar v_enum_fromThenTo) [typ, box, debox] - range_body = foldl EAp (lupvar v_ix_range) [typ, box, debox] - --inRange_body = foldl EAp (lupvar v_ix_inRange) [typ, box, debox] - index_body = foldl EAp (lupvar v_ix_index) [typ, box, debox] - - ib_te = foldl EAp (lupvar v_enum_toEnum) [typ, box, toEzh (mv - 1)] - ib_fe = ELam val1 (create_uintegralCast_toInt con tEnumzh (EVar val1)) - - max = ELit (LitInt (fromIntegral $ mv - 1) tEnumzh) - - box = ELam i1 (ELit (litCons { litName = con, litArgs = [EVar i1], litType = typ })) - debox = ELam v1 (ec (EVar v1) i1 (EVar i1)) where - ec v i e = eCase v [Alt (litCons { litName = con, litArgs = [i], litType = typ }) e] Unknown - - h _ = [] - mkCmpFunc fname op = (iv_eq,ib_eq) where - ib_eq = unbox (eStrictLet b3 (oper_IIB op (EVar i1) (EVar i2)) (ELit (litCons { litName = dc_Boolzh, litArgs = [EVar b3], litType = tBool }))) - iv_eq = setProperty prop_INSTANCE tvr { tvrIdent = toId $ instanceName fname (nameName $ conName c), tvrType = getType ib_eq } - oper_IIB op a b = EPrim (Op (Op.BinOp op Op.bits16 Op.bits16) Op.bits16) [a,b] tBoolzh - -create_integralCast conv c1 t1 c2 t2 e t = eCase e [Alt (litCons { litName = c1, litArgs = [tvra], litType = te }) cc] Unknown where - te = getType e - ELit LitCons { litName = n1, litArgs = [] } = t1 - ELit LitCons { litName = n2, litArgs = [] } = t2 - Just n1' = nameToOpTy n1 - Just n2' = nameToOpTy n2 - tvra = tVr va2 t1 - tvrb = tVr va3 t2 - cc = if n1 == n2 then ELit (litCons { litName = c2, litArgs = [EVar tvra], litType = t }) else - eStrictLet tvrb (EPrim (Op (Op.ConvOp conv n1') n2') [EVar tvra] t2) (ELit (litCons { litName = c2, litArgs = [EVar tvrb], litType = t })) - -nameToOpTy n = do RawType <- return $ nameType n; Op.readTy (show n) - -create_uintegralCast_toInt c1 t1 e = create_integralCast Op.U2U c1 t1 dc_Int tIntzh e tInt - -updateLit :: DataTable -> Lit e t -> Lit e t -updateLit _ l@LitInt {} = l -updateLit dataTable lc@LitCons { litAliasFor = Just {} } = lc -updateLit dataTable lc@LitCons { litName = n } = lc { litAliasFor = af } where - af = do - Constructor { conChildren = DataNormal [x], conOrigSlots = cs } <- getConstructor n dataTable - Constructor { conChildren = DataAlias ErasedAlias, conOrigSlots = [SlotNormal sl] } <- getConstructor x dataTable - return (foldr ELam sl [ tVr i s | s <- getSlots cs | i <- anonymousIds]) - -removeNewtypes :: DataTable -> E -> E -removeNewtypes dataTable e = runIdentity (f e) where - f ec@ECase {} = emapEGH f f return ec { eCaseAlts = map g (eCaseAlts ec) } where - g (Alt l e) = Alt (gl $ updateLit dataTable l) e - f (ELit l) = emapEGH f f return (ELit (gl $ updateLit dataTable l)) - f e = emapEGH f f return e - gl lc@LitCons { litAliasFor = Just e } = lc { litAliasFor = Just $ removeNewtypes dataTable e } - gl l = l - -collectDeriving :: [HsDecl] -> [(SrcLoc,Name,Name)] -collectDeriving ds = concatMap f ds where - f decl@HsDataDecl {} = g decl - f decl@HsDeclDeriving {} = h decl - f _ = [] - g decl = [(hsDeclSrcLoc decl, toName ClassName c, - toName TypeConstructor (hsDeclName decl)) | c <- hsDeclDerives decl ] - h decl@(hsDeclClassHead -> ch) | [(ltc -> Just t)] <- hsClassHeadArgs ch = [(hsDeclSrcLoc decl,toName ClassName (hsClassHead ch), t)] where - ltc (HsTyApp t1 _) = ltc t1 - ltc (HsTyCon n) = Just (toName TypeConstructor n) - ltc x = Nothing - h _ = [] - -{-# NOINLINE toDataTable #-} -toDataTable :: (Map.Map Name Kind) -> (Map.Map Name Type) -> [HsDecl] -> DataTable -> DataTable -toDataTable km cm ds currentDataTable = newDataTable where - newDataTable = DataTable (Map.mapWithKey fixupMap $ - Map.fromList [ (conName x,procNewTypes x) | x <- ds', conName x `notElem` keys primitiveAliases ]) - fullDataTable = (newDataTable `mappend` currentDataTable) - procNewTypes c = c { conExpr = f (conExpr c), conType = f (conType c), conOrigSlots = map (mapESlot f) (conOrigSlots c) } where - f = removeNewtypes fullDataTable - fixupMap k _ | Just n <- getConstructor k dataTablePrims = n - fixupMap _ n = n - ds' = Seq.toList $ execWriter (mapM_ f ds) - newtypeLoopBreakers = map fst $ fst $ G.findLoopBreakers (const 0) (const True) (G.newGraph newtypeDeps fst snd) where - newtypeDeps = [ (n,concatMap (fm . hsBangType) $ hsConDeclArgs c) | - HsDataDecl { hsDeclDeclType = DeclTypeNewtype, hsDeclName = n, hsDeclCons = (head -> c) } <- ds ] - fm t = execWriter $ f t - f HsTyCon { hsTypeName = n } = tell [n] - f t = traverseHsType_ f t - f decl@HsDataDecl { hsDeclDeclType = DeclTypeNewtype, hsDeclName = nn, hsDeclCons = cs } = - dt decl (if nn `elem` newtypeLoopBreakers then DataAlias RecursiveAlias else DataAlias ErasedAlias) cs - f decl@HsDataDecl { hsDeclDeclType = DeclTypeKind } = dkind decl - f decl@HsDataDecl { hsDeclCons = cs } = dt decl DataNone cs - f _ = return () - dt decl DataNone cs@(_:_:_) | all null (map hsConDeclArgs cs) = do - let virtualCons'@(fc:_) = map (makeData DataNone typeInfo) cs - typeInfo@(theType,_,_) = makeType decl (hsDeclCTYPE decl) - virt = Just (map conName virtualCons') - f (n,vc) = vc { conExpr = ELit (litCons { litName = consName, litArgs = [ELit (LitInt (fromIntegral n) rtype)], litType = conType vc }), conVirtual = virt } - virtualCons = map f (zip [(0 :: Int) ..] virtualCons') - consName = mapName (id,(++ "#")) $ toName DataConstructor (nameName (conName theType)) - rtypeName = mapName (id,(++ "#")) $ toName TypeConstructor (nameName (conName theType)) - rtype = ELit litCons { litName = rtypeName, litType = eHash, litAliasFor = Just tEnumzh } - dataCons = fc { conName = consName, conType = getType (conExpr dataCons), conOrigSlots = [SlotNormal rtype], conExpr = ELam (tVr (anonymous 3) rtype) (ELit (litCons { litName = consName, litArgs = [EVar (tVr (anonymous 6) rtype)], litType = conExpr theType })) } - rtypeCons = emptyConstructor { - conName = rtypeName, - conType = eHash, - conExpr = rtype, - conInhabits = s_Hash, - conChildren = DataEnum (length virtualCons) - } - tell (Seq.fromList virtualCons) - tell (Seq.singleton dataCons) - tell (Seq.singleton rtypeCons) - tell $ Seq.singleton theType { conChildren = DataNormal [consName], conVirtual = virt } - return () - - dt decl alias cs = do - let dataCons = map (makeData alias typeInfo) cs - typeInfo@(theType,_,_) = makeType decl (hsDeclCTYPE decl) - tell (Seq.fromList dataCons) - tell $ Seq.singleton theType { conChildren = DataNormal (map conName dataCons) } - - dkind HsDataDecl { .. } = do - tell $ Seq.singleton $ (sortConstructor hsDeclName EHashHash) { - conChildren = DataNormal (map hsConDeclName hsDeclCons) } - flip mapM_ hsDeclCons $ \ HsConDecl { .. } -> do - let Just theKind = kind `fmap` (Map.lookup hsConDeclName km) - (theTypeFKind,theTypeKArgs') = fromPi theKind - theTypeArgs = [ tvr { tvrIdent = x } | tvr <- theTypeKArgs' | x <- anonymousIds ] - theTypeExpr = ELit litCons { - litName = hsConDeclName, - litArgs = map EVar theTypeArgs, - litType = theTypeFKind } - tell $ Seq.singleton emptyConstructor { - conName = hsConDeclName, - conType = theKind, - conOrigSlots = map (SlotNormal . tvrType) theTypeArgs, - conExpr = foldr ($) theTypeExpr (map ELam theTypeArgs), - conInhabits = hsDeclName - } - dkind _ = error "dkind passed bad decl" - - makeData alias (theType,theTypeArgs,theTypeExpr) x = theData where - theData = emptyConstructor { - conName = dataConsName, - conType =foldr ($) (getType theExpr) (map EPi theTypeArgs), - conOrigSlots = origSlots, - conExpr = theExpr, - conInhabits = conName theType, - conChildren = alias - } - dataConsName = toName Name.DataConstructor (hsConDeclName x) - - theExpr = foldr ELam (strictize tslots $ ELit litCons { litName = dataConsName, litArgs = map EVar dvars, litType = theTypeExpr }) hsvars - - strictize tslots con = E.Subst.subst tvr { tvrIdent = sillyId } Unknown $ f tslots con where - f (Left (v,False):rs) con = f rs con - f (Left (v,True):rs) con = eStrictLet v (EVar v) (f rs con) - f (Right (v,dc,rcs):rs) con = eCase (EVar v) [Alt pat (f rs con)] Unknown where - pat = litCons { litName = dc, litArgs = rcs, litType = (getType v) } - f [] con = con - - -- substitution is only about substituting type variables - (ELit LitCons { litArgs = thisTypeArgs }, origArgs) = fromPi $ runVarName $ do - let (vs,ty) = case Map.lookup dataConsName cm of Just (TForAll vs (_ :=> ty)) -> (vs,ty); ~(Just ty) -> ([],ty) - mapM_ (newName anonymousIds ()) vs - tipe' ty - subst = substMap $ fromList [ (tvrIdent tv ,EVar $ tv { tvrIdent = p }) | EVar tv <- thisTypeArgs | p <- anonymousIds ] - - origSlots = map SlotExistential existentials ++ map f tslots where - f (Left (e,_)) = SlotNormal (getType e) - f (Right (e,n,es)) = SlotUnpacked (getType e) n (map getType es) - hsvars = existentials ++ map f tslots where - f (Left (e,_)) = e - f (Right (e,_,_)) = e - dvars = existentials ++ concatMap f tslots where - f (Left (e,_)) = [e] - f (Right (_,_,es)) = es - tslots = f (newIds fvset) (map isHsBangedTy (hsConDeclArgs x)) origArgs where - f (i:is) (False:bs) (e:es) = Left (e { tvrIdent = i, tvrType = subst (tvrType e) },False):f is bs es - f (i:j:is) (True:bs) (e:es) = maybe (Left (e { tvrIdent = i, tvrType = subst (tvrType e) },True):f is bs es) id $ g e (tvrType e) where - g e te = do - ELit LitCons { litName = n } <- return $ followAliases fullDataTable te - Constructor { conChildren = DataNormal [dc] } <- getConstructor n fullDataTable - con <- getConstructor dc fullDataTable - case (conChildren con,slotTypes fullDataTable dc te) of - (DataAlias ErasedAlias,[nt]) -> g e nt - (_,[st]) -> do - let nv = tvr { tvrIdent = j, tvrType = st } - return $ Right (e { tvrIdent = i, tvrType = subst (tvrType e)},dc,[nv]):f is bs es - _ -> fail "not unboxable" - f _ [] [] = [] - f _ _ _ = error "DataConstructors.tslots" - fvset = freeVars (thisTypeArgs,origArgs) `mappend` fromList (take (length theTypeArgs + 2) anonymousIds) - - -- existentials are free variables in the arguments, that arn't bound in the type - existentials = values $ freeVars (map getType origArgs) S.\\ (freeVars thisTypeArgs :: IdMap TVr) - - -- arguments that the front end passes or pulls out of this constructor - --hsArgs = existentials ++ [ tvr {tvrIdent = x} | tvr <- origArgs | x <- drop (5 + length theTypeArgs) [2,4..] ] - - makeType decl ct = (theType,theTypeArgs,theTypeExpr) where - theTypeName = toName Name.TypeConstructor (hsDeclName decl) - Just theKind = kind `fmap` (Map.lookup theTypeName km) - (theTypeFKind,theTypeKArgs') = fromPi theKind - theTypeArgs = [ tvr { tvrIdent = x } | tvr <- theTypeKArgs' | x <- anonymousIds ] - theTypeExpr = ELit litCons { litName = theTypeName, litArgs = map EVar theTypeArgs, litType = theTypeFKind } - theType = emptyConstructor { - conCTYPE = fmap (ExtType . packString) ct, - conExpr = foldr ($) theTypeExpr (map ELam theTypeArgs), - conInhabits = if theTypeFKind == eStar then s_Star else s_Hash, - conName = theTypeName, - conOrigSlots = map (SlotNormal . tvrType) theTypeArgs, - conType = theKind, - conVirtual = Nothing - } - -isHsBangedTy HsBangedTy {} = True -isHsBangedTy _ = False - -getConstructorArities :: DataTable -> [(Name,Int)] -getConstructorArities (DataTable dt) = [ (n,length $ conSlots c) | (n,c) <- Map.toList dt] - -constructionExpression :: - DataTable -- ^ table of data constructors - -> Name -- ^ name of said constructor - -> E -- ^ type of eventual constructor - -> E -- ^ saturated lambda calculus term -constructionExpression dataTable n typ@(ELit LitCons { litName = pn, litArgs = xs }) - | DataAlias ErasedAlias <- conChildren mc = ELam var (EVar var) - | DataAlias RecursiveAlias <- conChildren mc = let var' = var { tvrType = st } in ELam var' (prim_unsafeCoerce (EVar var') typ) - | pn == conName pc = sub (conExpr mc) where - ~[st] = slotTypes dataTable n typ - var = tvr { tvrIdent = vid, tvrType = typ } - (vid:_) = newIds (freeVars typ) - Just mc = getConstructor n dataTable - Just pc = getConstructor (conInhabits mc) dataTable - sub = substMap $ fromDistinctAscList [ (i,sl) | sl <- xs | i <- anonymousIds ] -constructionExpression wdt n e | Just fa <- followAlias wdt e = constructionExpression wdt n fa -constructionExpression _ n e = error $ "constructionExpression: error in " ++ show n ++ ": " ++ show e - -deconstructionExpression :: - UniqueProducer m - => DataTable -- ^ table of data constructors - -> Name -- ^ name of said constructor - -> E -- ^ type of pattern - -> [TVr] -- ^ variables to be bound - -> E -- ^ body of alt - -> m (Alt E) -- ^ resulting alternative -deconstructionExpression dataTable name typ@(ELit LitCons { litName = pn, litArgs = xs }) vs e | pn == conName pc = ans where - Just mc = getConstructor name dataTable - Just pc = getConstructor (conInhabits mc) dataTable - sub = substMap $ fromDistinctAscList [ (i,sl) | sl <- xs | i <- anonymousIds ] - ans = case conVirtual mc of - Just _ -> return $ let ELit LitCons { litArgs = [ELit (LitInt n t)] } = conExpr mc in Alt (LitInt n t) e - Nothing -> do - let f vs (SlotExistential t:ss) rs ls = f vs ss (t:rs) ls - f (v:vs) (SlotNormal _:ss) rs ls = f vs ss (v:rs) ls - f (v:vs) (SlotUnpacked e n es:ss) rs ls = do - let g t = do - s <- newUniq - return $ tVr (anonymous s) t - as <- mapM g (map sub es) - f vs ss (reverse as ++ rs) ((v,ELit litCons { litName = n, litArgs = map EVar as, litType = sub e }):ls) - f [] [] rs ls = return $ Alt (litCons { litName = name, litArgs = reverse rs, litType = typ }) (eLetRec ls e) - f _ _ _ _ = error "DataConstructors.deconstructuonExpression.f" - f vs (conOrigSlots mc) [] [] -deconstructionExpression wdt n ty vs e | Just fa <- followAlias wdt ty = deconstructionExpression wdt n fa vs e -deconstructionExpression _ n e _ _ = error $ "deconstructionExpression: error in " ++ show n ++ ": " ++ show e - -slotTypes :: - DataTable -- ^ table of data constructors - -> Name -- ^ name of constructor - -> E -- ^ type of value - -> [E] -- ^ type of each slot -slotTypes wdt n (ELit LitCons { litName = pn, litArgs = xs, litType = _ }) - | pn == conName pc = [sub x | x <- conSlots mc ] - where - Identity mc = getConstructor n wdt - Identity pc = getConstructor (conInhabits mc) wdt - sub = substMap $ fromDistinctAscList [ (i,sl) | sl <- xs | i <- anonymousIds ] -slotTypes wdt n kind - | sortKindLike kind, (e,ts) <- fromPi kind = take (length (conSlots mc) - length ts) (conSlots mc) - ---- | sortKindLike kind, (e,ts) <- fromPi kind = (conSlots mc) - where Identity mc = getConstructor n wdt -slotTypes wdt n e | Just fa <- followAlias wdt e = slotTypes wdt n fa -slotTypes _ n e = error $ "slotTypes: error in " ++ show n ++ ": " ++ show e - -slotTypesHs :: - DataTable -- ^ table of data constructors - -> Name -- ^ name of constructor - -> E -- ^ type of value - -> [E] -- ^ type of each slot -slotTypesHs wdt n (ELit LitCons { litName = pn, litArgs = xs, litType = _ }) - | pn == conName pc = [sub x | x <- getHsSlots $ conOrigSlots mc ] - where - Identity mc = getConstructor n wdt - Identity pc = getConstructor (conInhabits mc) wdt - sub = substMap $ fromDistinctAscList [ (i,sl) | sl <- xs | i <- anonymousIds ] -slotTypesHs wdt n kind - | sortKindLike kind, (e,ts) <- fromPi kind = take (length (conSlots mc) - length ts) (conSlots mc) - where Identity mc = getConstructor n wdt -slotTypesHs wdt n e | Just fa <- followAlias wdt e = slotTypes wdt n fa -slotTypesHs _ n e = error $ "slotTypesHs: error in " ++ show n ++ ": " ++ show e - -{-# NOINLINE showDataTable #-} -showDataTable (DataTable mp) = vcat xs where - c con = vcat [t,e,cs,vt,ih,ch,mc] where - t = text "::" <+> ePretty conType - e = text "=" <+> ePretty conExpr - cs = text "slots:" <+> tupled (map ePretty (conSlots con)) - vt = text "virtual:" <+> tshow conVirtual - ih = text "inhabits:" <+> tshow conInhabits - ch = text "children:" <+> tshow conChildren - mc = text "CTYPE:" <+> tshow conCTYPE - Constructor { .. } = con - xs = [text x <+> hang 0 (c y) | (x,y) <- ds ] - ds = sortBy (\(x,_) (y,_) -> compare x y) [(show x,y) | (x,y) <- Map.toList mp] - -{-# NOINLINE samplePrimitiveDataTable #-} -samplePrimitiveDataTable :: DataTable -samplePrimitiveDataTable = DataTable $ Map.fromList [ (x,c) | x <- xs, c <- getConstructor x mempty] where - nt v = map (flip unboxedNameTuple (v::Int)) [DataConstructor, TypeConstructor] - xs = nt 0 ++ nt 3 ++ [nameConjured modAbsurd eStar,nameConjured modBox hs, nameConjured modAbsurd hs', nameConjured modBox hs',rt_bits16,rt_bits_ptr_] - hs = EPi (tVr emptyId eHash) eStar - hs' = tFunc eStar (tFunc (tFunc eStar eHash) eStar) - -getSiblings :: DataTable -> Name -> Maybe [Name] -getSiblings dt n - | Just c <- getConstructor n dt, Just Constructor { conChildren = DataNormal cs } <- getConstructor (conInhabits c) dt = Just cs - | otherwise = Nothing - -numberSiblings :: DataTable -> Name -> Maybe Int -numberSiblings dt n - | Just c <- getConstructor n dt, Just Constructor { conChildren = cc } <- getConstructor (conInhabits c) dt = case cc of - DataNormal ds -> Just $ length ds - DataEnum n -> Just n - _ -> Nothing - | otherwise = Nothing - --- whether the type has a single slot -onlyChild :: DataTable -> Name -> Bool -onlyChild dt n = isJust ans where - ans = do - c <- getConstructor n dt - case conChildren c of - DataNormal [_] -> return () - _ -> do - c <- getConstructor (conInhabits c) dt - case conChildren c of - DataNormal [_] -> return () - _ -> fail "not cpr" - -pprintTypeOfCons :: (Monad m,DocLike a) => DataTable -> Name -> m a -pprintTypeOfCons dataTable name = do - c <- getConstructor name dataTable - return $ pprintTypeAsHs (conType c) - -pprintTypeAsHs :: DocLike a => E -> a -pprintTypeAsHs e = unparse $ runVarName (f e) where - f e | e == eStar = return $ atom $ text "*" - | e == eHash = return $ atom $ text "#" - f (EPi (TVr { tvrIdent = eid, tvrType = t1 }) t2) | eid == emptyId = do - t1 <- f t1 - t2 <- f t2 - return $ t1 `arr` t2 - f (ELit LitCons { litName = n, litArgs = as }) | (a:as') <- reverse as = f $ EAp (ELit litCons { litName = n, litArgs = reverse as' }) a - f (ELit LitCons { litName = n, litArgs = [] }) = return $ atom $ text $ show n - f (EAp a b) = do - a <- f a - b <- f b - return $ a `app` b - f (EVar v) = do - vo <- newLookupName ['a' .. ] () (tvrIdent v) - return $ atom $ char vo - f v | (e,ts@(_:_)) <- fromPi v = do - ts' <- mapM (newLookupName ['a'..] () . tvrIdent) ts - r <- f e - return $ fixitize (N,-3) $ pop (text "forall" <+> hsep (map char ts') <+> text ". ") (atomize r) - f e = error $ "printTypeAsHs: " ++ show e - arr = bop (R,0) (space D.<> text "->" D.<> space) - app = bop (L,100) (text " ") - -class Monad m => DataTableMonad m where - getDataTable :: m DataTable - getDataTable = return mempty - -instance DataTableMonad Identity - --- | list of declared data types that map --- directly to primitive real types - -primitiveAliases :: Map.Map Name Name -primitiveAliases = Map.fromList [ - (tc_Bits1, rt_bool), - (tc_Bits8, rt_bits8), - (tc_Bits16, rt_bits16), - (tc_Bits32, rt_bits32), - (tc_Bits64, rt_bits64), - (tc_Bits128, rt_bits128), - (tc_BitsPtr, rt_bits_ptr_), - (tc_BitsMax, rt_bits_max_), - (tc_Float32, rt_float32), - (tc_Float64, rt_float64), - (tc_Float80, rt_float80), - (tc_Float128, rt_float128) - ] - --- mapping of primitive types to the C calling convention used --- when passing to/from foreign functions - -rawExtTypeMap :: Map.Map Name ExtType -rawExtTypeMap = Map.fromList [ - (rt_bool, "bool"), - (rt_bits8, "uint8_t"), - (rt_bits16, "uint16_t"), - (rt_bits32, "uint32_t"), - (rt_bits64, "uint64_t"), - (rt_bits128, "uint128_t"), - (rt_bits_ptr_, "uintptr_t" ), - (rt_bits_max_, "uintmax_t"), - (rt_float32, "float"), - (rt_float64, "double"), - (rt_float80, "long double"), - (rt_float128, "__float128") - ] -{-* Generated by DrIFT : Look, but Don't Touch. *-} -instance Data.Binary.Binary AliasType where - put ErasedAlias = do - Data.Binary.putWord8 0 - put RecursiveAlias = do - Data.Binary.putWord8 1 - get = do - h <- Data.Binary.getWord8 - case h of - 0 -> do - return ErasedAlias - 1 -> do - return RecursiveAlias - _ -> fail "invalid binary data found" - -instance Data.Binary.Binary DataFamily where - put DataAbstract = do - Data.Binary.putWord8 0 - put DataNone = do - Data.Binary.putWord8 1 - put DataPrimitive = do - Data.Binary.putWord8 2 - put (DataEnum aa) = do - Data.Binary.putWord8 3 - Data.Binary.put aa - put (DataNormal ab) = do - Data.Binary.putWord8 4 - Data.Binary.put ab - put (DataAlias ac) = do - Data.Binary.putWord8 5 - Data.Binary.put ac - get = do - h <- Data.Binary.getWord8 - case h of - 0 -> do - return DataAbstract - 1 -> do - return DataNone - 2 -> do - return DataPrimitive - 3 -> do - aa <- Data.Binary.get - return (DataEnum aa) - 4 -> do - ab <- Data.Binary.get - return (DataNormal ab) - 5 -> do - ac <- Data.Binary.get - return (DataAlias ac) - _ -> fail "invalid binary data found" - -instance Data.Binary.Binary Constructor where - put (Constructor aa ab ac ad ae af ag ah) = do - Data.Binary.put aa - Data.Binary.put ab - Data.Binary.put ac - Data.Binary.put ad - Data.Binary.put ae - Data.Binary.put af - Data.Binary.put ag - Data.Binary.put ah - get = do - aa <- get - ab <- get - ac <- get - ad <- get - ae <- get - af <- get - ag <- get - ah <- get - return (Constructor aa ab ac ad ae af ag ah) - -instance Data.Binary.Binary Slot where - put (SlotNormal aa) = do - Data.Binary.putWord8 0 - Data.Binary.put aa - put (SlotUnpacked ab ac ad) = do - Data.Binary.putWord8 1 - Data.Binary.put ab - Data.Binary.put ac - Data.Binary.put ad - put (SlotExistential ae) = do - Data.Binary.putWord8 2 - Data.Binary.put ae - get = do - h <- Data.Binary.getWord8 - case h of - 0 -> do - aa <- Data.Binary.get - return (SlotNormal aa) - 1 -> do - ab <- Data.Binary.get - ac <- Data.Binary.get - ad <- Data.Binary.get - return (SlotUnpacked ab ac ad) - 2 -> do - ae <- Data.Binary.get - return (SlotExistential ae) - _ -> fail "invalid binary data found" - --- Imported from other files :- diff --git a/drift_processed/DataConstructors.hs-boot b/drift_processed/DataConstructors.hs-boot deleted file mode 100644 --- a/drift_processed/DataConstructors.hs-boot +++ /dev/null @@ -1,17 +0,0 @@ -{- Generated by DrIFT (Automatic class derivations for Haskell) -} -{-# LINE 1 "src/DataConstructors.hs-boot" #-} -module DataConstructors where - - -import E.E -import Name.Name - -data DataTable -followAliases :: DataTable -> E -> E -followAlias :: Monad m => DataTable -> E -> m E -typesCompatable :: Monad m => E -> E -> m () -updateLit :: DataTable -> Lit e t -> Lit e t -slotTypes :: DataTable -> Name -> E -> [E] -mktBox :: E -> E -{-* Generated by DrIFT : Look, but Don't Touch. *-} --- Imported from other files :- diff --git a/drift_processed/E/CPR.hs b/drift_processed/E/CPR.hs deleted file mode 100644 --- a/drift_processed/E/CPR.hs +++ /dev/null @@ -1,182 +0,0 @@ -{- Generated by DrIFT (Automatic class derivations for Haskell) -} -{-# LINE 1 "src/E/CPR.hs" #-} -module E.CPR(Val(..), cprAnalyzeDs, cprAnalyzeProgram) where - -import Control.Monad.Writer(runWriter,tell,Monoid(..)) -import Data.Binary -import Data.Monoid() -import Data.Typeable -import qualified Data.Map as Map - -import Cmm.Number -import DataConstructors -import Doc.DocLike -import E.E -import E.Program -import GenUtil -import Name.Name -import Name.Names -import Name.VConsts -import Util.SameShape -import qualified Doc.Chars as C -import qualified E.Demand as Demand -import qualified Info.Info as Info - -newtype Env = Env (Map.Map TVr Val) - deriving(Monoid) - -data Val = - Top -- the top. - | Fun Val -- function taking an arg - | Tup Name [Val] -- A constructed product - | VInt Number -- A number - | Tag [Name] -- A nullary constructor, like True, False - | Bot -- the bottom - deriving(Eq,Ord,Typeable) - {-! derive: Binary !-} - -trimVal v = f (0::Int) v where - f !n Tup {} | n > 5 = Top - f n (Tup x vs) = Tup x (map (f (n + 1)) vs) - f n (Fun v) = Fun (f n v) - f _ x = x - -toVal c = case conSlots c of - [] -> Tag [conName c] - ss -> Tup (conName c) [ Top | _ <- ss] - -instance Show Val where - showsPrec _ Top = C.top - showsPrec _ Bot = C.bot - showsPrec n (Fun v) = C.lambda <> showsPrec n v - showsPrec _ (Tup n [x,xs]) | n == dc_Cons = shows x <> showChar ':' <> shows xs - showsPrec _ (Tup n xs) | Just _ <- fromTupname n = tupled (map shows xs) - showsPrec _ (Tup n xs) = shows n <> tupled (map shows xs) - showsPrec _ (VInt n) = shows n - showsPrec _ (Tag [n]) | n == dc_EmptyList = showString "[]" - showsPrec _ (Tag [n]) = shows n - showsPrec _ (Tag ns) = shows ns - -lub :: Val -> Val -> Val -lub Bot a = a -lub a Bot = a -lub Top a = Top -lub a Top = Top -lub (Tup a xs) (Tup b ys) - | a == b, sameShape1 xs ys = Tup a (zipWith lub xs ys) - | a == b = error "CPR.lub this shouldn't happen" - | otherwise = Top -lub (Fun l) (Fun r) = Fun (lub l r) -lub (VInt n) (VInt n') | n == n' = VInt n -lub (Tag xs) (Tag ys) = Tag (smerge xs ys) -lub (Tag _) (Tup _ _) = Top -lub (Tup _ _) (Tag _) = Top -lub _ _ = Top ---lub a b = error $ "CPR.lub: " ++ show (a,b) - -instance Monoid Val where - mempty = Bot - mappend = lub - -{-# NOINLINE cprAnalyzeProgram #-} -cprAnalyzeProgram :: Program -> Program -cprAnalyzeProgram prog = ans where - nds = cprAnalyzeDs (progDataTable prog) (programDs prog) - ans = programSetDs' nds prog -- { progStats = progStats prog `mappend` stats } - -cprAnalyzeDs :: DataTable -> [(TVr,E)] -> [(TVr,E)] -cprAnalyzeDs dataTable ds = fst $ cprAnalyzeBinds dataTable mempty ds - -cprAnalyzeBinds :: DataTable -> Env -> [(TVr,E)] -> ([(TVr,E)],Env) -cprAnalyzeBinds dataTable env bs = f env (decomposeDs bs) [] where - f env (Left (t,e):rs) zs = case cprAnalyze dataTable env e of - (e',v) -> f (envInsert t v env) rs ((tvrInfo_u (Info.insert $ trimVal v) t,e'):zs) - f env (Right xs:rs) zs = g (length xs + 2) ([ (t,(e,Bot)) | (t,e) <- xs]) where - g 0 mp = f nenv rs ([ (tvrInfo_u (Info.insert $ trimVal b) t,e) | (t,(e,b)) <- mp] ++ zs) where - nenv = Env (Map.fromList [ (t,b) | (t,(e,b)) <- mp]) `mappend` env - g n mp = g (n - 1) [ (t,cprAnalyze dataTable nenv e) | (t,e) <- xs] where - nenv = Env (Map.fromList [ (t,b) | (t,(e,b)) <- mp]) `mappend` env - f env [] zs = (reverse zs,env) - -envInsert :: TVr -> Val -> Env -> Env -envInsert tvr val (Env mp) = Env $ Map.insert tvr val mp - -cprAnalyze :: DataTable -> Env -> E -> (E,Val) -cprAnalyze dataTable env e = cprAnalyze' env e where - cprAnalyze' (Env mp) (EVar v) - | Just t <- Map.lookup v mp = (EVar v,t) - | Just t <- Info.lookup (tvrInfo v) = (EVar v,t) - | otherwise = (EVar v,Top) - cprAnalyze' env ELetRec { eDefs = ds, eBody = e } = (ELetRec ds' e',val) where - (ds',env') = cprAnalyzeBinds dataTable env ds - (e',val) = cprAnalyze' (env' `mappend` env) e - - cprAnalyze' env (ELam t e) - | Just (Demand.S _) <- Info.lookup (tvrInfo t), Just c <- getProduct dataTable (tvrType t) = let - (e',val) = cprAnalyze' (envInsert t (toVal c) env) e - in (ELam t e',Fun val) - cprAnalyze' env (ELam t e) = (ELam t e',Fun val) where - (e',val) = cprAnalyze' (envInsert t Top env) e - cprAnalyze' env ec@(ECase {}) = runWriter (caseBodiesMapM f ec) where - f e = do - (e',v) <- return $ cprAnalyze' env e - tell v - return e' - cprAnalyze' env (EAp fun arg) = (EAp fun_cpr arg,res_res) where - (fun_cpr, fun_res) = cprAnalyze' env fun - res_res = case fun_res of - Fun x -> x - Top -> Top - Bot -> Bot - v -> error $ "cprAnalyze'.res_res: " ++ show v - cprAnalyze' env e = (e,f e) where - f (ELit (LitInt n _)) = VInt n - f (ELit LitCons { litName = n, litArgs = [], litType = _ }) = Tag [n] - f (ELit LitCons { litName = n, litArgs = xs, litType = _ }) = Tup n (map g xs) - f (EPi t e) = Tup tc_Arrow [g $ tvrType t, g e] - f (EPrim {}) = Top -- TODO fix primitives - f (EError {}) = Bot - f e = error $ "cprAnalyze'.f: " ++ show e - g = snd . cprAnalyze' env -{-* Generated by DrIFT : Look, but Don't Touch. *-} -instance Data.Binary.Binary Val where - put Top = do - Data.Binary.putWord8 0 - put (Fun aa) = do - Data.Binary.putWord8 1 - Data.Binary.put aa - put (Tup ab ac) = do - Data.Binary.putWord8 2 - Data.Binary.put ab - Data.Binary.put ac - put (VInt ad) = do - Data.Binary.putWord8 3 - Data.Binary.put ad - put (Tag ae) = do - Data.Binary.putWord8 4 - Data.Binary.put ae - put Bot = do - Data.Binary.putWord8 5 - get = do - h <- Data.Binary.getWord8 - case h of - 0 -> do - return Top - 1 -> do - aa <- Data.Binary.get - return (Fun aa) - 2 -> do - ab <- Data.Binary.get - ac <- Data.Binary.get - return (Tup ab ac) - 3 -> do - ad <- Data.Binary.get - return (VInt ad) - 4 -> do - ae <- Data.Binary.get - return (Tag ae) - 5 -> do - return Bot - _ -> fail "invalid binary data found" - --- Imported from other files :- diff --git a/drift_processed/E/Demand.hs b/drift_processed/E/Demand.hs deleted file mode 100644 --- a/drift_processed/E/Demand.hs +++ /dev/null @@ -1,486 +0,0 @@ -{- Generated by DrIFT (Automatic class derivations for Haskell) -} -{-# LINE 1 "src/E/Demand.hs" #-} -module E.Demand( - Demand(..), - DemandSignature(..), - DemandType(..), - SubDemand(..), - analyzeProgram, - absSig, - lazy - ) where - -import Control.Monad.Reader -import Control.Monad.Writer hiding(Product(..)) -import Data.Binary -import Data.List hiding(union,delete) -import Data.Typeable - ---import Debug.Trace -import DataConstructors -import Doc.DocLike -import Doc.PPrint -import E.E -import E.Program -import GenUtil -import Info.Types -import Name.Id -import Util.HasSize -import Util.SetLike -import qualified Info.Info as Info - -trace _ x = x - -data Demand = - Bottom -- always diverges - | L !SubDemand -- lazy - | S !SubDemand -- strict - | Error !SubDemand -- diverges, might use arguments - | Absent -- Not used - deriving(Eq,Ord,Typeable) - {-! derive: Binary !-} - -data SubDemand = None | Product ![Demand] - deriving(Eq,Ord) - {-! derive: Binary !-} - -data DemandEnv = DemandEnv !(IdMap Demand) !Demand - deriving(Eq,Ord) - {-! derive: Binary !-} - -data DemandType = (:=>) !DemandEnv ![Demand] - deriving(Eq,Ord) - {-! derive: Binary !-} - -data DemandSignature = DemandSignature {-# UNPACK #-} !Int !DemandType - deriving(Eq,Ord,Typeable) - {-! derive: Binary !-} - -idGlb = Absent - -absType = (DemandEnv mempty idGlb) :=> [] ---botType = (DemandEnv mempty Bottom) :=> [] -botType = (DemandEnv mempty Bottom) :=> [] - ---lazyType = (DemandEnv mempty lazy) :=> [] ---lazySig = DemandSignature 0 lazyType -absSig = DemandSignature 0 absType - -class Lattice a where - glb :: a -> a -> a - lub :: a -> a -> a - --- Sp [L .. L] = S --- Sp [.. _|_ ..] = _|_ - -sp [] = S None -sp xs = S (allLazy xs) -- None - -l None = L None -l (Product xs) = lp xs - -s None = S None -s (Product xs) = sp xs - -allLazy xs | all (== lazy) xs = None -allLazy xs = Product xs - -lp [] = L None -lp xs = L (allLazy (map f xs)) where - f (S None) = lazy - f (S (Product ys)) = lp ys - f Bottom = Absent - f (Error None) = lazy - f (Error (Product xs)) = lp xs - f x = x - -{- -sp s = sp' True s where - sp' True [] = S None - sp' False [] = S (Product s) - sp' allLazy (L _:rs) = sp' allLazy rs - sp' _ (Bottom:_) = Error (Product s) - sp' _ (_:rs) = sp' False rs --} - -instance Lattice DemandType where - lub (env :=> ts) (env' :=> ts') | length ts < length ts' = (env `lub` env') :=> strictList (zipWith lub (ts ++ repeat lazy) ts') - | otherwise = (env `lub` env') :=> strictList (zipWith lub ts (ts' ++ repeat lazy)) - glb (env :=> ts) (env' :=> ts') | length ts < length ts' = (env `glb` env') :=> strictList (zipWith glb (ts ++ repeat lazy) ts') - | otherwise = (env `glb` env') :=> strictList (zipWith glb ts (ts' ++ repeat lazy)) - -lazy = L None -strict = S None -err = Error None - -strictList (x:xs) = x `seq` xs' `seq` (x:xs') where - xs' = strictList xs -strictList [] = [] - -comb _ None None = None -comb f None (Product xs) = Product $ zipWith f (repeat lazy) xs -comb f (Product xs) None = Product $ zipWith f xs (repeat lazy) -comb f (Product xs) (Product ys) = Product $ zipWith f xs ys - -instance Lattice Demand where - lub Bottom s = s - lub s Bottom = s - lub Absent Absent = Absent - lub (S x) Absent = l x - lub Absent (S x) = l x - lub (L x) Absent = l x - lub Absent (L x) = l x - lub Absent sa = lazy - lub sa Absent = lazy - - lub (S x) (S y) = s (comb lub x y) - lub (L x) (L y) = l (comb lub x y) - lub (Error x) (Error y) = Error (comb lub x y) - - lub (S x) (L y) = l (comb lub x y) - lub (L x) (S y) = l (comb lub x y) - - lub (S x) (Error y) = s (comb lub x y) - lub (Error x) (S y) = s (comb lub x y) - - lub (L x) (Error y) = lazy - lub (Error x) (L y) = lazy - - glb Bottom Bottom = Bottom - glb Absent sa = sa - glb sa Absent = sa - - glb Bottom _ = err - glb _ Bottom = err - - glb (S x) (S y) = s (comb glb x y) - glb (L x) (L y) = l (comb glb x y) - glb (Error x) (Error y) = Error (comb glb x y) - - glb (S _) (Error _) = err - glb (Error _) (S _) = err - - glb (S x) (L y) = s (comb glb x y) - glb (L x) (S y) = s (comb glb x y) - - glb (L _) (Error _) = err - glb (Error _) (L _) = err - -lenv e (DemandEnv m r) = case mlookup e m of - Nothing -> r - Just x -> x - -demandEnvSingleton :: TVr -> Demand -> DemandEnv -demandEnvSingleton _ Absent = DemandEnv mempty idGlb -demandEnvSingleton t d = DemandEnv (msingleton (tvrIdent t) d) idGlb - -demandEnvMinus :: DemandEnv -> TVr -> DemandEnv -demandEnvMinus (DemandEnv m r) x = DemandEnv (delete (tvrIdent x) m) r - -instance Lattice DemandEnv where - lub d1@(DemandEnv m1 r1) d2@(DemandEnv m2 r2) = DemandEnv m (r1 `lub` r2) where - m = fromList [ (x,lenv x d1 `lub` lenv x d2) | x <- keys (m1 `union` m2)] - glb d1@(DemandEnv m1 r1) d2@(DemandEnv m2 r2) = DemandEnv m (r1 `glb` r2) where - m = fromList [ (x,lenv x d1 `glb` lenv x d2) | x <- keys (m1 `union` m2)] - -newtype IM a = IM (Reader (Env,DataTable) a) - deriving(Monad,Functor,MonadReader (Env,DataTable)) - -type Env = IdMap (Either DemandSignature E) - -getEnv :: IM Env -getEnv = asks fst - -extEnv TVr { tvrIdent = i } _ | isEmptyId i = id -extEnv t e = local (\ (env,dt) -> (minsert (tvrIdent t) (Left e) env,dt)) - -extEnvE TVr { tvrIdent = i } _ | isEmptyId i = id -extEnvE t e = local (\ (env,dt) -> (minsert (tvrIdent t) (Right e) env,dt)) - -instance DataTableMonad IM where - getDataTable = asks snd - -runIM :: Monad m => IM a -> DataTable -> m a -runIM (IM im) dt = return $ runReader im (mempty,dt) - --- returns the demand type and whether it was found in the local environment or guessed -determineDemandType :: TVr -> Demand -> IM (Either DemandType E) -determineDemandType tvr demand = do - let g (DemandSignature n dt@(DemandEnv phi _ :=> _)) = f n demand where - f 0 (S _) = dt - f n (S (Product [s])) = f (n - 1) s - f _ _ = lazify (DemandEnv phi Absent) :=> [] - env <- getEnv - case mlookup (tvrIdent tvr) env of - Just (Left ds) -> return (Left $ g ds) - Just (Right e) -> return (Right e) - Nothing -> case Info.lookup (tvrInfo tvr) of - Nothing -> return (Left absType) - Just ds -> return (Left $ g ds) - -extendSig (DemandSignature n1 t1) (DemandSignature n2 t2) = DemandSignature (max n1 n2) (glb t1 t2) - -splitSigma [] = (lazy,[]) -splitSigma (x:xs) = (x,xs) - -analyze :: E -> Demand -> IM (E,DemandType) -analyze e Absent = return (e,absType) -analyze (EVar v) s = do - ddt <- determineDemandType v s - (phi :=> sigma) <- case ddt of - Left dt -> return dt - Right e -> liftM snd $ analyze e s - return (EVar v,(phi `glb` (demandEnvSingleton v s)) :=> sigma) -analyze (EAp e1 e2) s = do - (e1',phi1 :=> sigma1') <- analyze e1 (sp [s]) - let (sa,sigma1) = splitSigma sigma1' - (e2',phi2 :=> sigma2) <- analyze e2 sa - return $ (EAp e1' e2',(phi1 `glb` phi2) :=> sigma1) -analyze el@(ELit lc@LitCons { litName = h, litArgs = ts@(_:_) }) (S (Product ss)) | length ss == length ts = do - dataTable <- getDataTable - case onlyChild dataTable h of - True -> do -- product type - envs <- flip mapM (zip ts ss) $ \(a,s) -> do - (_,env :=> _) <- analyze a s - return env - return (el,foldr1 glb envs :=> []) - _ -> do - rts <- mapM (\e -> analyze e lazy) ts - return (ELit lc { litArgs = fsts rts }, foldr glb absType (snds rts)) - -analyze (ELit lc@LitCons { litArgs = ts }) _s = do - rts <- mapM (\e -> analyze e lazy) ts - return (ELit lc { litArgs = fsts rts }, foldr glb absType (snds rts)) -analyze e s | Just (t1,t2,pt) <- from_dependingOn e = do - (t1',dt1) <- analyze t1 s - (t2',dt2) <- analyze t2 lazy - return (EPrim p_dependingOn [t1',t2'] pt,dt1 `glb` dt2) -analyze (EPrim ap ts pt) _s = do - rts <- mapM (\e -> analyze e lazy) ts - return (EPrim ap (fsts rts) pt, foldr glb absType (snds rts)) -analyze (EPi tvr@TVr { tvrType = t1 } t2) _s = do - (t1',dt1) <- analyze t1 lazy - (t2',dt2) <- analyze t2 lazy - return (EPi tvr { tvrType = t1' } t2',dt1 `glb` dt2) - -analyze (ELam x@TVr { tvrIdent = eid } e) (S (Product [s])) | eid == emptyId = do - (e',phi :=> sigma) <- analyze e s - let sx = Absent - return (ELam (tvrInfo_u (Info.insert $! sx) x) e',demandEnvMinus phi x :=> (sx:sigma)) -analyze (ELam x e) (S (Product [s])) = do - (e',phi :=> sigma) <- analyze e s - let sx = lenv (tvrIdent x) phi - return (ELam (tvrInfo_u (Info.insert $! sx) x) e',demandEnvMinus phi x :=> (sx:sigma)) - -analyze (ELam x e) (L (Product [s])) = do - (e',phi :=> sigma) <- analyze e s - let sx = lenv (tvrIdent x) phi - return (ELam (tvrInfo_u (Info.insert $! sx) x) e',lazify (demandEnvMinus phi x) :=> (sx:sigma)) -analyze (ELam x e) (S None) = analyze (ELam x e) (S (Product [lazy])) -- simply to ensure binder is annotated -analyze (ELam x e) (L None) = analyze (ELam x e) (L (Product [lazy])) -- simply to ensure binder is annotated -analyze (ELam x e) (Error None) = analyze (ELam x e) (Error (Product [lazy])) -- simply to ensure binder is annotated -analyze e@EError {} (S _) = return (e,botType) -analyze e@EError {} (L _) = return (e,absType) -analyze ec@ECase { eCaseBind = b, eCaseAlts = [Alt lc@LitCons { litName = h, litArgs = ts } alt], eCaseDefault = Nothing } s = do - dataTable <- getDataTable - case onlyChild dataTable h of - True -> do -- product type - (alt',enva :=> siga) <- extEnvE b (eCaseScrutinee ec) $ analyze alt s - (e',enve :=> []) <- analyze (eCaseScrutinee ec) (sp [ lenv (tvrIdent t) enva | t <- ts]) - let nenv = enve `glb` foldr denvDelete enva (b:ts) - return (caseUpdate $ ec { eCaseScrutinee = e', eCaseAlts = [Alt lc alt'] }, nenv :=> siga) - _ -> analyzeCase ec s -analyze ec@ECase {} s = analyzeCase ec s -analyze ELetRec { eDefs = ds, eBody = b } s = f (decomposeDs ds) [] where - f [] ds' = do - (b',phi :=> sig) <- analyze b s - let g (t,e) = (tvrInfo_u (Info.insert $! (lenv (tvrIdent t) phi)) t,e) - return (ELetRec (map g ds') b', foldr denvDelete phi (fsts ds) :=> sig) - f (Left (t,e):rs) fs = - solveDs' (Just False) [(t,e)] fixupDemandSignature (\nn -> f rs (nn ++ fs)) - f (Right rg:rs) fs = do - solveDs' (Just True) rg fixupDemandSignature (\nn -> f rs (nn ++ fs)) -analyze Unknown _ = return (Unknown,absType) -analyze es@ESort {} _ = return (es,absType) -analyze es@(ELit LitInt {}) _ = return (es,absType) -analyze e x = fail $ "analyze: " ++ show (e,x) - -from_dependingOn (EPrim don [t1,t2] pt) | don == p_dependingOn = return (t1,t2,pt) -from_dependingOn _ = fail "not dependingOn" - -lazify (DemandEnv x r) = DemandEnv (fmap f x) Absent where - f (S xs) = l xs - f Absent = Absent - f (L xs) = l xs - f Bottom = Absent - f (Error xs) = l xs - -analyzeCase ec s = do - (ec',dts) <- extEnvE (eCaseBind ec) (eCaseScrutinee ec) $ runWriterT $ flip caseBodiesMapM ec $ \e -> do - (ne,dt) <- lift $ analyze e s - tell [dt] - return ne - (ecs,env :=> _) <- analyze (eCaseScrutinee ec') strict - let enva :=> siga = foldr1 lub dts - let nenv = foldr denvDelete (glb enva env) (caseBinds ec') - return (caseUpdate $ ec' {eCaseScrutinee = ecs},nenv :=> siga) - -denvDelete x (DemandEnv m r) = DemandEnv (delete (tvrIdent x) m) r - -topAnalyze :: TVr -> E -> IM (E,DemandSignature) -topAnalyze tvr e | getProperty prop_PLACEHOLDER tvr = return (e,DemandSignature 0 absType) -topAnalyze _tvr e = clam e strict 0 where - clam (ELam _ x) s n = clam x (sp [s]) (n + 1) - clam _ s n = do - (e,dt) <- analyze e s - return (e,DemandSignature n dt) - -fixupDemandSignature (DemandSignature n (DemandEnv _ r :=> dt)) = DemandSignature n (DemandEnv mempty r :=> dt) - -shouldBind ELit {} = True -shouldBind EVar {} = True -shouldBind EPi {} = True -shouldBind _ = False - -solveDs' :: (Maybe Bool) -> [(TVr,E)] -> (DemandSignature -> DemandSignature) -> ([(TVr,E)] -> IM a) -> IM a -solveDs' Nothing ds fixup wdone = do - let f (Left d:rs) xs = solveDs' (Just False) [d] fixup (\nds -> f rs (nds ++ xs)) - f (Right ds:rs) xs = solveDs' (Just True) ds fixup (\nds -> f rs (nds ++ xs)) - f [] xs = wdone xs - f (decomposeDs ds) [] -solveDs' (Just False) [(t,e)] fixup wdone | shouldBind e = do - (ne,ds) <- topAnalyze t e - extEnvE t e $ wdone [(tvrInfo_u (Info.insert (fixup ds)) t,ne)] -solveDs' (Just False) [(t,e)] fixup wdone = do - (ne,ds) <- topAnalyze t e - extEnv t ds $ wdone [(tvrInfo_u (Info.insert (fixup ds)) t,ne)] ---solveDs' (Just False) ds fixup wdone = solveDs' Nothing ds fixup wdone -solveDs' (Just False) ds fixup wdone = error "solveDs' (Just False) called with more than one definition" -solveDs' (Just True) ds fixup wdone = trace "solveDs': jt" $ do - let ds' = [ ((t,e),sig) | (t,e) <- ds, let sig = maybe absSig id (Info.lookup (tvrInfo t))] - g 0 _ [] ds = trace "gdonetout" $ wdone [ (tvrInfo_u (Info.insert $! (fixup sig)) t,e) | ((t,e),sig) <- ds ] - g _ False [] ds = trace "gdone1" $ wdone [ (tvrInfo_u (Info.insert $! (fixup sig)) t,e) | ((t,e),sig) <- ds ] - g n True [] ds = do - (oe,dt) <- ask - let nenv = fromList [ (tvrIdent t,Left s) | ((t,_),s) <- ds, not (isEmptyId (tvrIdent t))] `Util.SetLike.union` oe - local (const (nenv,dt)) $ trace ("grepeating: " ++ show (length ds)) $ g (n - 1) False ds [] - g n ch (((t,e),sig):rs) fs = do - (ne,sig') <- topAnalyze t e - let sig'' = sig `extendSig` sig' - --(if sig'' /= sig then trace ("signe: " ++ show(tvrIdent t,sig)) else id) $ - g n (ch || (sig'' /= sig)) rs (((t,ne),sig''):fs) - g (5::Int) True [] ds' - -{-# NOINLINE analyzeProgram #-} -analyzeProgram prog = do - let ds = programDs prog - nds <- runIM (solveDs' Nothing ds fixupDemandSignature return) (progDataTable prog) - --flip mapM_ nds $ \ (t,_) -> - -- putStrLn $ "strictness: " ++ pprint t ++ ": " ++ show (maybe absSig id $ Info.lookup (tvrInfo t)) - return $ programSetDs' nds prog - ----------------------------- --- show and pprint instances ----------------------------- - -instance Show Demand where - showsPrec _ Bottom = ("_|_" ++) - showsPrec _ Absent = ('A':) - showsPrec _ (L None) = ('L':) - showsPrec _ (L (Product ds)) = showString "L(" . foldr (.) id (map shows ds) . showString ")" - showsPrec _ (S None) = ('S':) - showsPrec _ (S (Product ds)) = showString "S(" . foldr (.) id (map shows ds) . showString ")" - showsPrec _ (Error None) = showString "Err" - showsPrec _ (Error (Product ds)) = showString "Err(" . foldr (.) id (map shows ds) . showString ")" - -instance DocLike d => PPrint d Demand where - pprint demand = tshow demand - -instance Show DemandType where - showsPrec _ (DemandEnv e Absent :=> d) | isEmpty e = shows d - showsPrec _ (env :=> ds) = shows env . showString " :=> " . shows ds - -instance Show DemandEnv where - showsPrec _ (DemandEnv m Absent) = showString "{" . foldr (.) id (intersperse (showString ",") [ showString (pprint t) . showString " -> " . shows v | (t,v) <- idMapToList m]) . showString "}" - showsPrec _ (DemandEnv _ Bottom) = showString "_|_" - showsPrec _ (DemandEnv m demand) = showString "{" . shows demand . showString " - " . foldr (.) id (intersperse (showString ",") [ showString (pprint t) . showString " -> " . shows v | (t,v) <- idMapToList m]) . showString "}" - -instance Show DemandSignature where - showsPrec _ (DemandSignature n dt) = showString "<" . shows n . showString "," . shows dt . showString ">" -{-* Generated by DrIFT : Look, but Don't Touch. *-} -instance Data.Binary.Binary Demand where - put Bottom = do - Data.Binary.putWord8 0 - put (L aa) = do - Data.Binary.putWord8 1 - Data.Binary.put aa - put (S ab) = do - Data.Binary.putWord8 2 - Data.Binary.put ab - put (Error ac) = do - Data.Binary.putWord8 3 - Data.Binary.put ac - put Absent = do - Data.Binary.putWord8 4 - get = do - h <- Data.Binary.getWord8 - case h of - 0 -> do - return Bottom - 1 -> do - aa <- Data.Binary.get - return (L aa) - 2 -> do - ab <- Data.Binary.get - return (S ab) - 3 -> do - ac <- Data.Binary.get - return (Error ac) - 4 -> do - return Absent - _ -> fail "invalid binary data found" - -instance Data.Binary.Binary SubDemand where - put None = do - Data.Binary.putWord8 0 - put (Product aa) = do - Data.Binary.putWord8 1 - Data.Binary.put aa - get = do - h <- Data.Binary.getWord8 - case h of - 0 -> do - return None - 1 -> do - aa <- Data.Binary.get - return (Product aa) - _ -> fail "invalid binary data found" - -instance Data.Binary.Binary DemandEnv where - put (DemandEnv aa ab) = do - Data.Binary.put aa - Data.Binary.put ab - get = do - aa <- get - ab <- get - return (DemandEnv aa ab) - -instance Data.Binary.Binary DemandType where - put ((:=>) aa ab) = do - Data.Binary.put aa - Data.Binary.put ab - get = do - aa <- get - ab <- get - return ((:=>) aa ab) - -instance Data.Binary.Binary DemandSignature where - put (DemandSignature aa ab) = do - Data.Binary.put aa - Data.Binary.put ab - get = do - aa <- get - ab <- get - return (DemandSignature aa ab) - --- Imported from other files :- diff --git a/drift_processed/E/LambdaLift.hs b/drift_processed/E/LambdaLift.hs deleted file mode 100644 --- a/drift_processed/E/LambdaLift.hs +++ /dev/null @@ -1,349 +0,0 @@ -{- Generated by DrIFT (Automatic class derivations for Haskell) -} -{-# LINE 1 "src/E/LambdaLift.hs" #-} -module E.LambdaLift(lambdaLift,staticArgumentTransform) where - -import Control.Monad.Reader -import Control.Monad.Writer -import Data.IORef -import Data.Maybe -import Text.Printf - -import Doc.PPrint -import E.Annotate -import E.E -import E.Inline -import E.Program -import E.Subst -import E.Traverse -import E.TypeCheck -import E.Values -import Fixer.Fixer -import Fixer.Supply -import GenUtil -import Name.Id -import Name.Name -import Options (verbose) -import Stats(mtick,runStatM,runStatT) -import StringTable.Atom -import Support.CanType -import Support.FreeVars -import Util.Graph as G -import Util.HasSize -import Util.SetLike hiding(Value) -import Util.UniqueMonad - -annotateId mn x = case fromId x of - Just y -> toId (toName Val (mn,'f':show y)) - Nothing -> toId (toName Val (mn,'f':show x)) - --- | transform simple recursive functions into non-recursive variants --- this is exactly the opposite of lambda lifting, but is a big win if the function ends up inlined --- and is conducive to other optimizations --- --- in particular, the type arguments can almost always be transformed away from the recursive inner function --- --- this has potentially exponential behavior. beware - -staticArgumentTransform :: Program -> Program -staticArgumentTransform prog = ans where - ans = progCombinators_s (concat ds') prog { progStats = progStats prog `mappend` nstat } - (ds',nstat) = runStatM $ mapM h (programDecomposedCombs prog) - h (True,[comb]) = do [(_,nb)] <- f True (Right [(combHead comb, combBody comb)]); return [combBody_s nb comb] - h (_,cs) = do - forM cs $ \ c -> do - e' <- g (combBody c) - return (combBody_s e' c) - f _ (Left (t,e)) = gds [(t,e)] - f always (Right [(t,v@ELam {})]) | not (null collectApps), always || dropArgs > 0 = ans where - nname = annotateId "R@" (tvrIdent t) - dropArgs = minimum [ countCommon args aps | aps <- collectApps ] where - args = map EVar $ snd $ fromLam v - countCommon (x:xs) (y:ys) | x == y = 1 + countCommon xs ys - countCommon _ _ = 0 - collectApps = execWriter (ca v) where - ca e | (EVar v,as) <- fromAp e, tvrIdent v == tvrIdent t = tell [as] >> mapM_ ca as >> return e - ca e = emapE ca e - (body,args) = fromLam v - (droppedAs,keptAs) = splitAt dropArgs args - rbody = foldr ELam (subst t newV body) keptAs - newV = foldr ELam (EVar tvr') [ t { tvrIdent = emptyId } | t <- droppedAs ] - tvr' = tvr { tvrIdent = nname, tvrType = getType rbody } - ne' = foldr ELam (ELetRec [(tvr',rbody)] (foldl EAp (EVar tvr') (map EVar keptAs))) args - ans = do - mtick $ "SimpleRecursive.{" ++ pprint t - ne' <- g ne' - return [(t,ne')] - f _ (Right ts) = gds ts - gds ts = mapM g' ts >>= return where - g' (t,e) = g e >>= return . (,) t - g elet@ELetRec { eDefs = ds } = do - ds'' <- mapM (f False) (decomposeDs ds) - e' <- g $ eBody elet - return elet { eDefs = concat ds'', eBody = e' } - g e = emapE g e - -data S = S { - funcName :: Name, - topVars :: IdSet, - isStrict :: Bool, - declEnv :: [(TVr,E)] - } - -isStrict_u f r@S{isStrict = x} = r{isStrict = f x} -topVars_u f r@S{topVars = x} = r{topVars = f x} -isStrict_s v = isStrict_u (const v) - -{- -etaReduce :: E -> (E,Int) -etaReduce e = case f e 0 of - (ELam {},_) -> (e,0) - x -> x - where - f (ELam t (EAp x (EVar t'))) n | n `seq` True, t == t' && not (tvrIdent t `member` (freeVars x :: IdSet)) = f x (n + 1) - f e n = (e,n) --} - --- | we do not lift functions that only appear in saturated strict contexts, --- as these functions will never have an escaping thunk or partial app --- built and can be turned into local functions in grin. --- --- Although grin is only able to take advantage of groups of possibily --- mutually recursive local functions that only tail-call each other, we leave --- all candidate functions local, as further grin transformations can expose --- tail-calls that arn't evident in core. --- --- A final lambda-lifting needs to be done in grin to get rid of these local --- functions that cannot be turned into loops - -calculateLiftees :: Program -> IO IdSet -calculateLiftees prog = do - fixer <- newFixer - sup <- newSupply fixer - - let f v env ELetRec { eDefs = ds, eBody = e } = do - let nenv = fromList [ (tvrIdent t,length (snd (fromLam e))) | (t,e) <- ds ] `mappend` env - nenv :: IdMap Int - g (t,e@ELam {}) = do - v <- supplyValue sup (tvrIdent t) - let (a,_as) = fromLam e - f v nenv a - g (t,e) = do - f (value True) nenv e - mapM_ g ds - f v nenv e - f v env e@ESort {} = return () - f v env e@Unknown {} = return () - f v env e@EError {} = return () - f v env (EVar TVr { tvrIdent = vv }) = do - nv <- supplyValue sup vv - assert nv - f v env e | (EVar TVr { tvrIdent = vv }, as@(_:_)) <- fromAp e, Just n <- mlookup vv env = do - nv <- supplyValue sup vv - if length as >= n then v `implies` nv else assert nv - mapM_ (f (value True) env) as - f v env e | (a, as@(_:_)) <- fromAp e = do - mapM_ (f (value True) env) as - f v env a - f v env (ELit LitCons { litArgs = as }) = mapM_ (f (value True) env) as - f v env ELit {} = return () - f v env (EPi TVr { tvrType = a } b) = f (value True) env a >> f (value True) env b - f v env (EPrim _ as _) = mapM_ (f (value True) env) as - f v env ec@ECase {} = do - f v env (eCaseScrutinee ec) - mapM_ (f v env) (caseBodies ec) - f v env (ELam _ e) = f (value True) env e - f _ _ EAp {} = error "this should not happen" - mapM_ (f (value False) mempty) [ fst (fromLam e) | (_,e) <- programDs prog] - - findFixpoint Nothing {-"Liftees"-} fixer - vs <- supplyReadValues sup - let nlset = (fromList [ x | (x,False) <- vs]) - when verbose $ printf "%d lambdas not lifted\n" (size nlset) - return nlset - -implies :: Value Bool -> Value Bool -> IO () -implies x y = addRule $ y `isSuperSetOf` x - -assert x = value True `implies` x - -lambdaLift :: Program -> IO Program -lambdaLift prog@Program { progDataTable = dataTable, progCombinators = cs } = do - noLift <- calculateLiftees prog - let wp = fromList [ combIdent x | x <- cs ] :: IdSet - fc <- newIORef [] - fm <- newIORef mempty - statRef <- newIORef mempty - let z comb = do - (n,as,v) <- return $ combTriple comb - let ((v',(cs',rm)),stat) = runReader (runStatT $ execUniqT 1 $ runWriterT (f v)) S { funcName = mkFuncName (tvrIdent n), topVars = wp,isStrict = True, declEnv = [] } - modifyIORef statRef (mappend stat) - modifyIORef fc (\xs -> combTriple_s (n,as,v') comb:cs' ++ xs) - modifyIORef fm (rm `mappend`) - shouldLift t _ | tvrIdent t `member` noLift = False - shouldLift _ ECase {} = True - shouldLift _ ELam {} = True - shouldLift _ _ = False - f e@(ELetRec ds _) = do - let (ds',e') = decomposeLet e - h ds' e' [] - f e = do - st <- asks isStrict - if ((tvrIdent tvr `notMember` noLift && isELam e) || (shouldLift tvr e && not st)) then do - (e,fvs'') <- pLift e - doBigLift e fvs'' return - else g e - -- This ensures there are no 'orphaned type terms' when something is - -- lifted out. The problem occurs when a type is subsituted in some - -- places and not others, the type as free variable will not be the - -- same as its substituted instances if the variable is bound by a - -- lambda, Although the program is still typesafe, it is no longer - -- easily proven so, so we avoid the whole mess by subtituting known - -- type variables within lifted expressions. This can not duplicate work - -- since types are unpointed, but might change space usage slightly. --- g ec@ECase { eCaseScrutinee = (EVar v), eCaseAlts = as, eCaseDefault = d} | sortKindLike (tvrType v) = do --- True <- asks isStrict --- d' <- fmapM f d --- let z (Alt l e) = do --- e' <- local (declEnv_u ((v,followAliases dataTable $ patToLitEE l):)) $ f e --- return $ Alt l e' --- as' <- mapM z as --- return $ caseUpdate ec { eCaseAlts = as', eCaseDefault = d'} - g (ELam t e) = do - e' <- local (isStrict_s True) (g e) - return (ELam t e') - g e = emapE' f e - pLift e = do - gs <- asks topVars - ds <- asks declEnv - let fvs = freeVars e - fvs' = filter (not . (`member` gs) . tvrIdent) fvs - --ss = filter (sortKindLike . tvrType) fvs' - ss = [] - f [] e False = return (e,fvs'') - f [] e True = pLift e - f (s:ss) e x - | Just v <- lookup s ds = f ss (removeType s v e) True -- TODO subst - | otherwise = f ss e x - fvs'' = reverse $ topSort $ newGraph fvs' tvrIdent freeVars - f ss e False - h (Left (t,e):ds) rest ds' | shouldLift t e = do - (e,fvs'') <- pLift e - case fvs'' of - [] -> doLift t e (h ds rest ds') - fs -> doBigLift e fs (\e'' -> h ds rest ((t,e''):ds')) - h (Left (t,e@ELam {}):ds) rest ds' = do - let (a,as) = fromLam e - a' <- local (isStrict_s True) (f a) - h ds rest ((t,foldr ELam a' as):ds') - - h (Left (t,e):ds) rest ds' = do - let fvs = freeVars e :: [Id] - gs <- asks topVars - let fvs' = filter (not . (`member` gs) ) fvs - case fvs' of - [] -> doLift t e (h ds rest ds') -- We always lift CAFS to the top level for now. (GC?) - _ -> local (isStrict_s False) (f e) >>= \e'' -> h ds rest ((t,e''):ds') - --h (Left (t,e):ds) e' ds' = local (isStrict_s False) (f e) >>= \e'' -> h ds e' ((t,e''):ds') - h (Right rs:ds) rest ds' | any (uncurry shouldLift) rs = do - gs <- asks topVars - let fvs = freeVars (snds rs)-- (Set.fromList (map tvrIdent $ fsts rs) `Set.union` gs) - let fvs' = filter (not . (`member` (fromList (map tvrIdent $ fsts rs) `mappend` gs) ) . tvrIdent) fvs - fvs'' = reverse $ topSort $ newGraph fvs' tvrIdent freeVars - case fvs'' of - [] -> doLiftR rs (h ds rest ds') -- We always lift CAFS to the top level for now. (GC?) - fs -> doBigLiftR rs fs (\rs' -> h ds rest (rs' ++ ds')) - h (Right rs:ds) e' ds' = do - rs' <- local (isStrict_s False) $ do - flip mapM rs $ \te -> case te of - (t,e@ELam {}) -> do - let (a,as) = fromLam e - a' <- local (isStrict_s True) (f a) - return (t,foldr ELam a' as) - (t,e) -> do - e'' <- f e - return (t,e'') - h ds e' (rs' ++ ds') - h [] e ds = f e >>= return . eLetRec ds - tellCombinator c = tell ([combTriple_s c emptyComb],mempty) - tellCombinators c = tell (map (`combTriple_s` emptyComb) c,mempty) - doLift t e r = local (topVars_u (insert (tvrIdent t)) ) $ do - --(e,tn) <- return $ etaReduce e - let (e',ls) = fromLam e - mtick (toAtom $ "E.LambdaLift.doLift." ++ typeLift e ++ "." ++ show (length ls)) - --mticks tn (toAtom $ "E.LambdaLift.doLift.etaReduce") - e'' <- local (isStrict_s True) $ f e' - t <- globalName t - tellCombinator (t,ls,e'') - r - doLiftR rs r = local (topVars_u (mappend (fromList (map (tvrIdent . fst) rs)) )) $ do - flip mapM_ rs $ \ (t,e) -> do - --(e,tn) <- return $ etaReduce e - let (e',ls) = fromLam e - mtick (toAtom $ "E.LambdaLift.doLiftR." ++ typeLift e ++ "." ++ show (length ls)) - --mticks tn (toAtom $ "E.LambdaLift.doLift.etaReduce") - e'' <- local (isStrict_s True) $ f e' - t <- globalName t - tellCombinator (t,ls,e'') - r - globalName tvr | isNothing $ fromId (tvrIdent tvr) = do - TVr { tvrIdent = t } <- newName Unknown - let ntvr = tvr { tvrIdent = t } - tell ([],msingleton (tvrIdent tvr) (Just $ EVar ntvr)) - return ntvr - globalName tvr = return tvr - newName tt = do - un <- newUniq - n <- asks funcName - return $ tVr (toId $ mapName (id,(++ ('$':show un))) n) tt - doBigLift e fs dr = do - mtick (toAtom $ "E.LambdaLift.doBigLift." ++ typeLift e ++ "." ++ show (length fs)) - ds <- asks declEnv - let tt = typeInfer' dataTable ds (foldr ELam e fs) - tvr <- newName tt - let (e',ls) = fromLam e - e'' <- local (isStrict_s True) $ f e' - tellCombinator (tvr,fs ++ ls,e'') - let e'' = foldl EAp (EVar tvr) (map EVar fs) - dr e'' - doBigLiftR rs fs dr = do - ds <- asks declEnv - rst <- flip mapM rs $ \ (t,e) -> do - case shouldLift t e of - True -> do - mtick (toAtom $ "E.LambdaLift.doBigLiftR." ++ typeLift e ++ "." ++ show (length fs)) - let tt = typeInfer' dataTable ds (foldr ELam e fs) - tvr <- newName tt - let (e',ls) = fromLam e - e'' <- local (isStrict_s True) $ f e' - --tell [(tvr,fs ++ ls,e'')] - let e''' = foldl EAp (EVar tvr) (map EVar fs) - return ((t,e'''),[(tvr,fs ++ ls,e'')]) - False -> do - mtick (toAtom $ "E.LambdaLift.skipBigLiftR." ++ show (length fs)) - return ((t,e),[]) - let (rs',ts) = unzip rst - tellCombinators [ (t,ls,substLet rs' e) | (t,ls,e) <- concat ts] - dr rs' - - mkFuncName x = case fromId x of - Just y -> y - Nothing -> toName Val ("LL@",'f':show x) - mapM_ z cs - ncs <- readIORef fc - nstat <- readIORef statRef - nz <- readIORef fm - annotateProgram nz (\_ nfo -> return nfo) (\_ nfo -> return nfo) (\_ nfo -> return nfo) prog { progCombinators = ncs, progStats = progStats prog `mappend` nstat } - -typeLift ECase {} = "Case" -typeLift ELam {} = "Lambda" -typeLift _ = "Other" - -removeType t v e = subst' t v e -{- -removeType t v e = ans where - (b,ls) = fromLam e - ans = foldr f (substLet [(t,v)] e) ls - f tv@(TVr { tvrType = ty} ) e = ELam nt (subst tv (EVar nt) e) where nt = tv { tvrType = (subst t v ty) } --} -{-* Generated by DrIFT : Look, but Don't Touch. *-} --- Imported from other files :- diff --git a/drift_processed/E/SSimplify.hs b/drift_processed/E/SSimplify.hs deleted file mode 100644 --- a/drift_processed/E/SSimplify.hs +++ /dev/null @@ -1,1090 +0,0 @@ -{- Generated by DrIFT (Automatic class derivations for Haskell) -} -{-# LINE 1 "src/E/SSimplify.hs" #-} -module E.SSimplify( - Occurance(..), - cacheSimpOpts, - simplifyE, - collectOccurance', - programPruneOccurance, - programSSimplify, - programSSimplifyPStat, - SimplifyOpts(..), - emptySimplifyOpts - ) where - -import Control.Monad.Identity -import Data.Maybe -import Data.Typeable -import Debug.Trace -import Data.List hiding(delete,union,insert) -import qualified Data.Set as Set -import qualified Data.Traversable as T - -import C.Prims -import Cmm.Number -import DataConstructors -import Doc.PPrint -import E.E -import E.Eta -import E.Inline -import E.PrimOpt -import E.Program -import E.Rules -import E.Subst ---import E.Traverse(runRename) -import E.TypeCheck -import E.Values -import GenUtil hiding (split) -import Info.Types -import Name.Id -import Name.Name -import Name.Names -import Name.VConsts -import Options -import Stats hiding(null,new,print,Stats,singleton) -import StringTable.Atom -import Support.CanType -import Support.FreeVars -import Util.Graph -import Util.HasSize -import Util.NameMonad -import Util.RWS -import Util.ReaderWriter -import Util.SetLike as S -import qualified E.Demand as Demand -import qualified FlagDump as FD -import qualified FlagOpts as FO -import qualified Info.Info as Info - ---type Bind = (TVr,E) - -data Occurance = - Unused -- ^ unused means a var is not used at the term level, but might be at the type level - | Once -- ^ Used at most once not inside a lambda or as an argument - | OnceInLam -- ^ used once inside a lambda - | ManyBranch -- ^ used once in several branches - | Many -- ^ used many or an unknown number of times - | LoopBreaker -- ^ chosen as a loopbreaker, never inline - deriving(Show,Eq,Ord) - -data UseInfo = UseInfo { - useOccurance :: !Occurance, -- ^ occurance Info - minimumArgs :: {-# UNPACK #-} !Int -- ^ minimum number of args that are ever passed to this function (if used) - } - deriving(Show,Eq,Ord,Typeable) - -noUseInfo = UseInfo { useOccurance = Many, minimumArgs = 0 } -notUsedInfo = UseInfo { useOccurance = Unused, minimumArgs = maxBound } - -programPruneOccurance :: Program -> Program -programPruneOccurance prog = - let dsIn = progCombinators prog -- (runIdentity $ programMapBodies (return . subst (tVr (-1) Unknown) Unknown) prog) - (dsIn',(OMap fvs,uids)) = runReaderWriter (unOM $ collectDs dsIn mempty) (progEntry prog) - in --trace ("dsIn: "++show (length dsIn)) $ - (progCombinators_s dsIn' prog) { progFreeIds = idMapToIdSet fvs, progUsedIds = uids } - -newtype OM a = OM (ReaderWriter IdSet (OMap,IdSet) a) - deriving(Monad,Functor,MonadWriter (OMap,IdSet),MonadReader IdSet) - -unOM (OM a) = a - -newtype OMap = OMap (IdMap UseInfo) - deriving(HasSize,Collection,Unionize,SetLike,MapLike,Show,IsEmpty,Eq,Ord) - -type instance Value OMap = UseInfo -type instance Key OMap = Id -type instance Elem OMap = (Key OMap,Value OMap) - -instance Monoid OMap where - mempty = OMap mempty - mappend (OMap a) (OMap b) = OMap (andOM a b) - -maybeLetRec [] e = e -maybeLetRec ds e = ELetRec ds e - --- | occurance analysis - -grump :: OM a -> OM (a,OMap) -grump m = fmap ( \ (x, (y,z)) -> (x,y) ) $ censor (\ (_,y) -> (mempty,y)) (listen m) - -collectOccurance' :: E -> (E,IdMap UseInfo) -collectOccurance' e = (fe,omap) where - (fe,(OMap omap,_)) = runReaderWriter (unOM $ collectOccurance e) mempty - -collectOccurance :: E -> OM E -- ^ (annotated expression, free variables mapped to their occurance info) -collectOccurance e = f e where - f e@ESort {} = return e - f e@Unknown {} = return e - f (EPi tvr@TVr { tvrIdent = eid, tvrType = a} b) | isEmptyId eid = arg $ do - a <- f a - b <- f b - return (EPi tvr { tvrType = a } b) - f (EPi tvr@(TVr { tvrIdent = n, tvrType = a}) b) = arg $ do - a <- f a - (b,tfvs) <- grump (f b) - case mlookup n tfvs of - Nothing -> tell (tfvs,mempty) >> return (EPi tvr { tvrIdent = emptyId, tvrType = a } b) - Just occ -> tell (delete n tfvs,singleton n) >> return (EPi (annb' tvr { tvrType = a }) b) - f (ELit lc@LitCons { litArgs = as, litType = t }) = arg $ do - t <- f t - as <- mapM f as - return (ELit lc { litArgs = as, litType = t }) - f (ELit (LitInt i t)) = do - t <- arg (f t) - return $ ELit (LitInt i t) - f (EPrim p as t) = arg $ do - t <- f t - as <- mapM f as - return (EPrim p as t) - f (EError err t) = do - t <- arg (f t) - return $ EError err t - f e | (b,as@(_:_)) <- fromLam e = do - (b',bvs) <- grump (f b) - (as',asfv) <- grump (arg $ mapM ftvr as) - let avs = bvs `andOM` asfv - as'' = map (annbind' avs) as' - case all (getProperty prop_ONESHOT) as of - True -> tell $ (foldr delete avs (map tvrIdent as),fromList $ map tvrIdent as) - False -> tell $ (inLam $ foldr delete avs (map tvrIdent as),fromList $ map tvrIdent as) - return (foldr ELam b' as'') - f e | Just (x,t) <- from_unsafeCoerce e = do x <- f x ; t <- (arg (f t)); return (prim_unsafeCoerce x t) - f (EVar tvr@TVr { tvrIdent = n, tvrType = t}) = do - tell $ (msingleton n UseInfo { useOccurance = Once, minimumArgs = 0 },mempty) - t <- arg (f t) - return $ EVar tvr { tvrType = t } - f e | (EVar tvr@TVr { tvrIdent = n, tvrType = t},xs@(_:_)) <- fromAp e = do - tell $ (msingleton n UseInfo { useOccurance = Once, minimumArgs = length xs },mempty) - t <- arg (f t) - xs <- arg (mapM f xs) - return (foldl EAp (EVar tvr { tvrType = t}) xs) - f e | (x,xs@(_:_)) <- fromAp e = do - x <- f x - xs <- arg (mapM f xs) - return (foldl EAp x xs) - f ec@ECase { eCaseScrutinee = e, eCaseBind = b, eCaseAlts = as, eCaseDefault = d} = do - scrut' <- f e - (d',fvb) <- grump (T.mapM f d) - (as',fvas) <- mapAndUnzipM (grump . alt) as - let fidm = orMaps (fvb:fvas) - ct <- arg $ f (eCaseType ec) - b <- arg (ftvr b) - tell $ (delete (tvrIdent b) fidm,singleton (tvrIdent b)) - return $ caseUpdate ec { eCaseScrutinee = scrut', eCaseAlts = as', - eCaseBind = annbind' fidm b, eCaseType = ct, eCaseDefault = d'} - f ELetRec { eDefs = ds, eBody = e } = do - (e',fve) <- grump (f e) - ds''' <- collectDs (map bindComb ds) fve - return (maybeLetRec (map combBind ds''') e') - f e = error $ "SSimplify.collectOcc.f: " ++ show e - alt (Alt l e) = do - (e',fvs) <- grump (f e) - l <- arg (mapLitBindsM ftvr l) - l <- arg (T.mapM f l) - let fvs' = foldr delete fvs (map tvrIdent $ litBinds l) - l' = mapLitBinds (annbind' fvs) l - tell (fvs',fromList $ map tvrIdent (litBinds l')) - return (Alt l' e') - arg m = do - let mm (OMap mp,y) = (OMap $ fmap (const noUseInfo) mp,y) - censor mm m - ftvr tvr = do - tt <- f (tvrType tvr) - return tvr { tvrType = tt } - --- delete any occurance info for non-let-bound vars to be safe -annb' tvr = tvrInfo_u (Info.delete noUseInfo) tvr -annbind' idm tvr = case mlookup (tvrIdent tvr) idm of - Nothing | sortTermLike (getType tvr) -> annb' tvr { tvrIdent = emptyId } - _ -> annb' tvr - --- add ocucrance info -annbind idm tvr = case mlookup (tvrIdent tvr) idm of - Nothing -> annb notUsedInfo tvr { tvrIdent = emptyId } - Just x -> annb x tvr -annb x tvr = tvrInfo_u (Info.insert x) tvr - -mapLitBinds f lc@LitCons { litArgs = es } = lc { litArgs = map f es } -mapLitBinds f (LitInt e t) = LitInt e t -mapLitBindsM f lc@LitCons { litArgs = es } = do - es <- mapM f es - return lc { litArgs = es } -mapLitBindsM f (LitInt e t) = return $ LitInt e t - -collectBinding :: Comb -> OM (Comb,OMap) -collectBinding comb = do - e' <- collectOccurance $ combBody comb - let rvars = freeVars (combRules comb) :: IdSet - romap = OMap (idSetToIdMap (const noUseInfo) rvars) - return (combBody_s e' comb,romap) - -unOMap (OMap x) = x - ---collectCombs :: [Comb] -> OMap -> OM [Comb] ---collectCombs cs _ = return cs - -collectDs :: [Comb] -> OMap -> OM [Comb] -collectDs ds (OMap fve) = do - ds' <- mapM (grump . collectBinding) ds - exp <- ask - let (reachable',_) = newGraphReachable ds' (\ ((comb,_),_) -> combIdent comb) (\ ((_,rv),fv) -> keys (fv `mappend` rv)) - rds = reachable' (keys fve ++ [ combIdent t | t <- ds, (combIdent t `member` exp)]) - -- ignore rules when calculating loopbreakers - -- we must not simplify the expanded body of a rule without recalculating occurance info. - graph' = newGraph rds (\ ((comb,_),_) -> combIdent comb) (\ (_,fv) -> keys fv) - (lb,lbds) = findLoopBreakers (\ ((comb,_),_) -> loopFunc (combHead comb) (combBody comb)) canBeLoopBreaker graph' - canBeLoopBreaker n = not $ getProperty prop_WRAPPER (fst $ fst $ n) - ds'' = map ( \ ((t,rv),rv') -> (t,rv `mappend` rv') ) lbds - fids = foldl andOM mempty (fve:map unOMap (snds ds'')) - ffids = fromList [ (tvrIdent t,lup t) | (Comb { combHead = t },_) <- ds'' ] - cycNodes = (fromList $ [ combIdent c | ((c,_),_) <- cyclicNodes graph'] :: IdSet) - calcStrictInfo :: TVr -> TVr - calcStrictInfo t - | tvrIdent t `member` cycNodes = setProperty prop_CYCLIC t - | otherwise = t - lup t = case tvrIdent t `elem` [ combIdent c | ((c,_),_) <- lb] of - True -> noUseInfo { useOccurance = LoopBreaker } - False -> case (tvrIdent t `member` exp) of - True -> noUseInfo - False | Just r <- mlookup (tvrIdent t) fids -> r - _ -> error "SSimplify.collectDs: bad." - ds''' = [ combHead_s (calcStrictInfo $ annbind ffids (combHead comb)) comb | (comb,_) <- ds''] - froo comb = (combHead_s (combHead comb) {tvrType = t' } comb,fvs) where - (t',fvs) = collectOccurance' (tvrType $ combHead comb) - (ds'''',nfids) = unzip $ map froo ds''' - nfid' = fmap (const noUseInfo) (mconcat nfids) - tell $ ((OMap $ nfid' `andOM` fids) S.\\ ffids,fromList (map combIdent ds'''')) - return (ds'''') - --- TODO this should use the occurance info --- loopFunc t _ | getProperty prop_PLACEHOLDER t = -100 -- we must not choose the placeholder as the loopbreaker -loopFunc t e = negate (baseInlinability t e) - -inLam (OMap om) = OMap (fmap il om) where - il ui@UseInfo { useOccurance = Once } = ui { useOccurance = OnceInLam } - il ui = ui { useOccurance = Many } - ---andOM :: IdMap UseInfo -> IdMap UseInfo -> IdMap UseInfo -andOM x y = unionWith andOcc x y -andOcc UseInfo { useOccurance = Unused } x = x -andOcc x UseInfo { useOccurance = Unused } = x -andOcc x y = UseInfo { useOccurance = Many, - minimumArgs = min (minimumArgs x) (minimumArgs y) } - -orMaps ms = OMap $ fmap orMany $ foldl (unionWith (++)) mempty (map (fmap (:[])) - (map unOMap ms)) where unOMap (OMap m) = m - -orMany [] = error "empty orMany" -orMany xs = f (filter ((/= Unused) . useOccurance) xs) where - f [] = notUsedInfo - f [x] = x - f xs = if all good (map useOccurance xs) then ui ManyBranch else ui Many where - good Once = True - good ManyBranch = True - good _ = False - ui x = UseInfo { minimumArgs = minimum (map minimumArgs xs), useOccurance = x } - -data SimplifyOpts = SimpOpts { - so_noInlining :: !Bool, -- ^ this inhibits all inlining inside functions which will always be inlined - so_finalPhase :: !Bool, -- ^ no rules and don't inhibit inlining - so_postLift :: !Bool, -- ^ don't inline anything that was lifted out - so_boundVars :: IdMap Comb, -- ^ bound variables - so_forwardVars :: IdSet, -- ^ variables that we know will exist, but might not yet. - - so_boundVarsCache :: IdSet, - so_cachedScope :: Env - } - -emptySimplifyOpts = SimpOpts { so_noInlining = False - , so_finalPhase = False - , so_boundVars = mempty - , so_forwardVars = mempty - , so_postLift = False - , so_boundVarsCache = mempty - , so_cachedScope = mempty } - -cacheSimpOpts opts = opts { - so_boundVarsCache = idMapToIdSet (so_boundVars opts), - so_cachedScope = cacheSubst (extendScope initScope mempty { - envSubst = mapMaybeIdMap bb (so_boundVars opts), envRules = rules }) - } where - bb Comb { combBody = e } | isFullyConst e = Just (Done e) - bb _ = Nothing - initScope = fmap (\ c -> isBoundTo opts (combHead c) noUseInfo (combBody c)) (so_boundVars opts) - rules = mapMaybeIdMap f (so_boundVars opts) - f Comb { combRules = rs } = if null rs then Nothing else Just $ arules rs - -data Range = Done OutE | Susp InE Subst - deriving(Show,Eq,Ord) -type Subst = IdMap Range - -data Forced = ForceInline | ForceNoinline | NotForced - deriving(Eq,Ord,Show) - -data Binding - = NotAmong [Name] - | IsBoundTo { - bindingOccurance :: !Occurance, - bindingE :: OutE, - bindingCheap :: !Bool, - inlineForced :: !Forced, - bindingAtomic :: !Bool - } - | NotKnown - deriving(Ord,Eq,Show) - -isBoundTo opt v o e = fixInline (so_finalPhase opt) v $ IsBoundTo { - bindingOccurance = useOccurance o, - bindingE = e, - bindingCheap = isCheap e, - inlineForced = case () of - _ | useOccurance o == LoopBreaker -> ForceNoinline - | otherwise -> NotForced, - bindingAtomic = atomic - } where - atomic = isAtomic e - -instance Monoid Forced where - mempty = NotForced - mappend NotForced x = x - mappend x NotForced = x - mappend _ ForceNoinline = ForceNoinline - mappend ForceNoinline _ = ForceNoinline - mappend ForceInline ForceInline = ForceInline - -fixInline finalPhase v bt@IsBoundTo {} = bt { - inlineForced = inlineForced bt `mappend` calcForced finalPhase v } -fixInline _ _ _ = error "SSimplify.fixInline: bad." - -calcForced finalPhase v = - let props = getProperties v in - case (forceNoinline props,finalPhase,forceInline props) of - (True,_,_) -> ForceNoinline - (False,_,True) -> ForceInline - (False,True,_) -> NotForced - (False,False,False) -> NotForced - -data Env = Env { - envCachedSubst :: IdMap E, - envSubst :: Subst, - envRules :: IdMap ARules, - envInScope :: IdMap Binding, - envInScopeCache :: IdMap E - } - {-! derive: Monoid !-} - -envSubst_u f r@Env{envSubst = x} = r{envSubst = f x} -envSubst_s v = envSubst_u (const v) - -susp:: E -> Subst -> Range -susp e sub = Susp e sub - ---insertSuspSubst :: TVr -> InE -> Env -> Env ---insertSuspSubst t e env = insertSuspSubst' (tvrIdent t) e env - ---insertSuspSubst' :: Id -> InE -> Env -> Env ---insertSuspSubst' z _e env | isEmptyId z = env ---insertSuspSubst' t e env = cacheSubst env { --- envSubst = minsert t (susp e (envSubst env)) (envSubst env) } - -insertRange :: Id -> Range -> Env -> Env -insertRange z e env | isEmptyId z = env -insertRange t e env = cacheSubst env { envSubst = minsert t e (envSubst env) } - -insertDoneSubst :: TVr -> OutE -> Env -> Env -insertDoneSubst t e env = insertDoneSubst' (tvrIdent t) e env - -insertDoneSubst' :: Id -> OutE -> Env -> Env -insertDoneSubst' z _e env | isEmptyId z = env -insertDoneSubst' t e env = insertRange t (Done e) env - -insertInScope :: Id -> Binding -> Env -> Env -insertInScope z _b env | isEmptyId z = env -insertInScope t b env = extendScope (msingleton t b) env - -extendScope :: IdMap Binding -> Env -> Env -extendScope m env = cacheSubst env { envInScope = m `union` envInScope env - , envInScopeCache = cachedM `union` envInScopeCache env } - where cachedM = mapMaybeIdMap fromBinding m - fromBinding (IsBoundTo {bindingE = e}) = Just e - fromBinding _ = Nothing - -changeScope :: (Binding -> Binding) -> Env -> Env -changeScope fn env = cacheScope $ cacheSubst env { envInScope = fmap fn (envInScope env) } - -cacheScope :: Env -> Env -cacheScope env = env { envInScopeCache = mapMaybeIdMap fromBinding (envInScope env) } - where fromBinding (IsBoundTo {bindingE = e}) = Just e - fromBinding _ = Nothing - -substLookup :: Id -> SM (Maybe Range) -substLookup id = SM $ ask >>= return . mlookup id . envSubst - -substAddList ls env = cacheSubst env { envSubst = fromList ls `union` envSubst env } - -applySubst :: Subst -> IdMap a -> IdMap OutE -applySubst s nn = applySubst' s where - check n = n `member` s || n `member` nn - applySubst' s = fmap g s - g (Done e) = e - g (Susp e s') = doSubst' False False (applySubst' s') check e - -evalRange :: Range -> SM OutE -evalRange (Done e) = return e -evalRange (Susp e s) = localEnv (envSubst_s s) $ dosub e - -cacheSubst env = env { envCachedSubst = applySubst (envSubst env) (envInScope env) } - -dosub :: InE -> SM OutE -dosub e = ask >>= \inb -> coerceOpt return (doSubst' False False (envCachedSubst inb) (`member` envCachedSubst inb) e) - -simplifyE :: SimplifyOpts -> InE -> (Stat,OutE) -simplifyE sopts e = (stat,e') where - Identity ([Comb { combBody = e' }],stat) = runStatT $ simplifyDs program sopts [bindComb (tvrSilly,e)] - -programSSimplify :: SimplifyOpts -> Program -> Program -programSSimplify sopts prog = let - Identity (dsIn,stats) = runStatT $ simplifyDs prog sopts (progCombinators prog) - in (progCombinators_s dsIn prog) { progStats = progStats prog `mappend` stats } - -programSSimplifyPStat :: SimplifyOpts -> Program -> IO Program -programSSimplifyPStat sopts prog = do - setPrintStats True - dsIn <- simplifyDs prog sopts (progCombinators prog) - return (progCombinators_s dsIn prog) - -type InE = E -type OutE = E -type InTVr = TVr -type OutTVr = TVr - -data Cont = - ApplyTo { - contArg :: Range, - contNext :: Cont - } - | LazyContext TVr -- the RHS of a let statement - | StartContext --- | ArgContext - | Coerce Range Cont -{- | Scrutinee { - contExamined :: Bool -- ^ whether the result is actually examined, or just bound to a variable - }-} - deriving(Show) - ---isApplyTo ApplyTo {} = True ---isApplyTo _ = False - -simplifyDs :: forall m . MonadStats m => Program -> SimplifyOpts -> [Comb] -> m [Comb] -simplifyDs prog sopts dsIn = ans where - finalPhase = so_finalPhase sopts - ans = do - let ((dsOut,_),stats) = runSM (so_cachedScope sopts) doit - mtickStat stats - let lupRules t = concat [ combRules c | c <- dsIn, combIdent c == t] - return [ combRules_s (lupRules (tvrIdent t)) $ bindComb (t,e) | (t,e) <- dsOut ] - - getType e = infertype (progDataTable prog) e - doit = do - smAddNamesIdSet (progUsedIds prog) - smAddBoundNamesIdSet (progFreeIds prog) - smAddBoundNamesIdSet (sfilter (`notElem` map combIdent dsIn) $ so_forwardVars sopts) - smAddBoundNamesIdSet (so_boundVarsCache sopts) - doDs (map combBind dsIn) - makeRange b = do - sub <- asks envSubst - return $ susp b sub - f :: Cont -> InE -> SM OutE - --f cont e | trace (take 20 (show cont) ++ " - " ++ take 40 (show e)) False = undefined --- f ArgContext e = dosub e - f c (EAp a b) = do - b' <- makeRange b - f ApplyTo { contArg = b', contNext = c } a - f (ApplyTo rng cont) (ELam t b) = do - addBoundNames [tvrIdent t] - mtick (toAtom $ "E.Simplify.f-beta-reduce/{" ++ pprint t) - localEnv (insertRange (tvrIdent t) rng) $ f cont b - f (ApplyTo rng cont) (EPi t b) = do - addBoundNames [tvrIdent t] - mtick (toAtom $ "E.Simplify.f-pi-reduce/{" ++ pprint t) - localEnv (insertRange (tvrIdent t) rng) $ f cont b - f cont (EVar v) = do - z <- substLookup (tvrIdent v) - case z of - Just (Done e) -> done cont e - Just (Susp e s) -> localEnv (envSubst_s s) $ f cont e - Nothing -> done cont (EVar v) - f (Coerce t cont) (EError s _) = evalRange t >>= \t' -> done cont (EError s t') - f (Coerce t cont) (ELit (LitInt n _)) = evalRange t >>= \t' -> done cont (ELit (LitInt n t')) - f cont v | Just (e,t) <- from_unsafeCoerce v = - makeRange t >>= \t' -> f (g t' cont) e where g t' (Coerce _ cont) = Coerce t' cont ; g t' cont = Coerce t' cont - f cont ep@EPrim {} = do - ep' <- performPrimOpt ep - ep'' <- dosub ep' - done cont ep'' - f cont (ELit lc@LitCons { litArgs = xs }) = do - xs' <- mapM performPrimOpt xs - dosub (ELit lc { litArgs = xs' }) >>= done cont - f cont e@ELit {} = dosub e >>= done cont - f cont (ELam v e) = do - addNames [tvrIdent v] - v' <- nname v - e' <- localEnv (insertDoneSubst v (EVar v') . insertInScope (tvrIdent v') NotKnown) $ f StartContext e - done cont $ ELam v' e' - f cont e@(EPi (TVr { tvrIdent = n }) _) = do - addNames [n] - e' <- dosub e - done cont e' - f cont (EError s t) = (EError s `fmap` dosub t) >>= done cont - f cont ec@ECase { eCaseScrutinee = e, eCaseBind = b, eCaseAlts = as, eCaseDefault = d} = do - addNames (map tvrIdent $ caseBinds ec) --- e' <- f (Scrutinee (not $ null as)) e - e' <- f StartContext e - ec' <- doCaseCont cont e' (eCaseType ec) b as d - done StartContext ec' - f cont ELetRec { eDefs = [], eBody = e } = f cont e - f cont ELetRec { eDefs = ds@(_:_), eBody = e } = do - tickCont cont "let" - (ds',inb') <- doDs ds - e' <- localEnv (const inb') $ f cont e - res <- case ds' of - [(t,e)] | worthStricting e, Just (Demand.S _) <- Info.lookup (tvrInfo t), not (getProperty prop_CYCLIC t) -> do - mtick $ "E.Simplify.strictness.let-to-case/{" ++ pprint t - return $ eStrictLet t e e' - [(t,ec@ECase { eCaseScrutinee = sc@(EPrim p _ _), eCaseAlts = [], eCaseDefault = Just def })] | primEagerSafe p && not (getProperty prop_CYCLIC t) -> do - mtick $ "E.Simplify.strictness.cheap-eagerness.def/{" ++ pprint t - return $ caseUpdate ec { eCaseDefault = Just $ ELetRec [(t,def)] e', eCaseType = getType e' } - [(t,ec@ECase { eCaseScrutinee = sc@(EPrim p _ _), eCaseAlts = [Alt c def], eCaseDefault = Nothing })] | primEagerSafe p && not (getProperty prop_CYCLIC t) -> do - mtick $ "E.Simplify.strictness.cheap-eagerness.con/{" ++ pprint t - return $ caseUpdate ec { eCaseAlts = [Alt c (ELetRec [(t,def)] e')], eCaseType = getType e' } - _ -> do - let fn ds (ELetRec { eDefs = ds', eBody = e}) | not (hasRepeatUnder fst (ds ++ ds')) = fn (ds' ++ ds) e - fn ds e = f ds (Set.fromList $ fsts ds) [] False where - f ((t,ELetRec { eDefs = ds', eBody = e}):rs) us ds b | all (not . (`Set.member` us)) (fsts ds') = f ((t,e):rs) (Set.fromList (fsts ds') `Set.union` us) (ds':ds) True - f (te:rs) us ds b = f rs us ([te]:ds) b - f [] _ ds True = fn (concat ds) e - f [] _ ds False = (concat ds,e) - let (ds'',e'') = fn ds' e' - when (flint && hasRepeatUnder fst ds'') $ fail "hasRepeats!" - mticks (length ds'' - length ds') (toAtom $ "E.Simplify.let-coalesce") - return $ eLetRec ds'' e'' - done StartContext res - f cont e = trace ("Fall through: " ++ show (cont,e)) $ dosub e >>= done cont - - showName t | isJust (fromId t) || dump FD.EVerbose = tvrShowName (tVr t Unknown) - | otherwise = "(epheremal)" - - -- Rename a if necessary. We always have to substitute all occurrences because we update the type. - nname tvr@(TVr { tvrIdent = n, tvrType = t}) = do - t' <- dosub t - inb <- ask - let t'' = substMap' (envInScopeCache inb) t' - n' <- if n == emptyId then return emptyId else uniqueName n - return $ tvr { tvrIdent = n', tvrType = t'' } - -- TODO - case simplification - tickCont (ApplyTo _ cont) cs = mtick ("E.Simplify.application-push." ++ cs) >> tickCont cont cs - tickCont (Coerce _ cont) cs = mtick ("E.Simplify.coerce-push." ++ cs) >> tickCont cont cs - tickCont _ _ = return () - contType (ApplyTo z cont) t = contType cont t >>= \t' -> evalRange z >>= \z' -> return (eAp t' z') - contType (Coerce t cont) _ = evalRange t - contType _ t = return t - doCaseCont :: Cont -> OutE -> InE -> InTVr -> [Alt InE] -> (Maybe InE) -> SM OutE - doCaseCont cont e t b as d = do - inb <- ask - let - varval = do EVar v <- return e; mlookup (tvrIdent v) (envInScope inb) - doCase ELetRec { eDefs = ds, eBody = e} t b as d = do - mtick "E.Simplify.let-from-case" - e' <- doCaseCont cont e t b as d - done StartContext (substLet' ds e') - - doCase _ t b as d | Just IsBoundTo { bindingE = ELit l } <- varval = doConstCase cont l t b as d - doCase (EPi TVr { tvrType = x} y) t b as d = doConstCase cont litCons { litName = tc_Arrow, litArgs = [x,y], litType = eStar} t b as d - doCase (ELit l) t b as d = doConstCase cont l t b as d - doCase (EVar v) t b as d | Just IsBoundTo { bindingE = e } <- varval , isBottom e = do - mtick "E.Simplify.case-of-bottom'" - t' <- makeRange t - done (Coerce t' cont) (EVar v) - doCase e t b as d | isBottom e = do - mtick "E.Simplify.case-of-bottom" - t' <- makeRange t - done (Coerce t' cont) e - - doCase ic@ECase { eCaseScrutinee = e, eCaseBind = b, eCaseAlts = as, eCaseDefault = d } t b' as' d' - | length (filter (not . isBottom) (caseBodies ic)) <= 1 || - all whnfOrBot (caseBodies ic) || - all whnfOrBot (caseBodies emptyCase { eCaseAlts = as', eCaseDefault = d'} ) = do - mtick (toAtom "E.Simplify.case-of-case") - let f (Alt l e) = do - e' <- localEnv (extendScope (fromList [ (n,NotKnown) | TVr { tvrIdent = n } <- litBinds l ])) - $ doCaseCont StartContext e t b' as' d' - return (Alt l e') - --g e >>= return . Alt l - g x = localEnv (insertInScope (tvrIdent b) NotKnown) $ doCaseCont StartContext x t b' as' d' - as'' <- mapM f as - d'' <- T.mapM g d - t' <- dosub t - done cont $ caseUpdate ECase { - eCaseAllFV = error "eCaseAllFV", - eCaseScrutinee = e, - eCaseType = t', - eCaseBind = b, - eCaseAlts = as'', - eCaseDefault = d''} -- XXX -- we duplicate code so continue for next renaming pass before going further. - doCase ic@ECase { eCaseType = it, eCaseScrutinee = e, eCaseBind = b, eCaseAlts = as, eCaseDefault = d } t b' as' d' | not (isUnboxedTuple it) = do - mtick (toAtom "E.Simplify.case-of-case-join") - n1 <- newName - n2 <- newName - let cvar = setProperty prop_ONESHOT $ tVr n1 it - rcc <- doCaseCont StartContext (EVar cvar) t b' as' d' - let fbody = ELam cvar rcc - zvar = setProperties [prop_JOINPOINT,prop_ONESHOT] $ tVr n2 (EPi tvr { tvrType = it } (getType rcc)) - nic <- flip caseBodiesMapM ic $ \body -> return $ eLet cvar body (eAp (EVar zvar) (EVar cvar)) - done cont $ eLet zvar fbody nic { eCaseType = getType rcc } - doCase e t b as@(Alt LitCons { litName = n } _:_) (Just d) | Just nsib <- numberSiblings (progDataTable prog) n, nsib <= length as = do - mtick "E.Simplify.case-no-default" - doCase e t b as Nothing - doCase e t b (a@(Alt LitCons { litName = n } _):_) (Just d) | Just _ <- fromUnboxedNameTuple n = do - mtick "E.Simplify.case-unboxed-no-default" - doCase e t b [a] Nothing -{- - Remove the default case if possible. - case lst of [] -> True; _ -> False - ==> - case lst of [] -> True; (:) _ _ -> False --} - doCase e t b as (Just d) | te /= tWorld__, (ELit LitCons { litName = cn }) <- followAliases dt te - , Just Constructor { conChildren = DataNormal cs } <- getConstructor cn dt - , length as == length cs - 1 || (False && length as < length cs && isAtomic d) = do - let ns = [ n | Alt ~LitCons { litName = n } _ <- as ] - ls = filter (`notElem` ns) cs - ff n = do - con <- getConstructor n dt - let g t = do - n <- newName - return $ tVr n t - ts <- mapM g (slotTypes (progDataTable prog) n te) - let wtd = ELit $ updateLit (progDataTable prog) litCons { litName = n, litArgs = map EVar ts, litType = te } - return $ Alt (updateLit (progDataTable prog) litCons { litName = n, litArgs = ts, litType = te }) (eLet b wtd d) - mtick $ "E.Simplify.case-improve-default.{" ++ show (sort ls) ++ "}" - ls' <- mapM ff ls - --ec <- dosub $ caseUpdate emptyCase { eCaseScrutinee = e, eCaseType = t, eCaseBind = b, eCaseAlts = as ++ ls' } - --localEnv (envSubst_s mempty) $ f StartContext (caseUpdate ec { eCaseScrutinee = e }) - doCase e t b (as ++ ls') Nothing - where - te = getType b - dt = (progDataTable prog) - doCase e _ b [] (Just d) | not (isLifted e || isUnboxed (getType e)) = do - mtick "E.Simplify.case-unlifted" - b' <- nname b - d' <- localEnv (insertDoneSubst b (EVar b') . (insertInScope (tvrIdent b') (isBoundTo sopts b' noUseInfo e))) $ f cont d - done StartContext $ eLet b' e d' - doCase e@ELam {} _ b [] (Just d) = do - mtick "E.Simplify.case-lambda" - b' <- nname b - d' <- localEnv (insertDoneSubst b (EVar b') . (insertInScope (tvrIdent b') (isBoundTo sopts b' noUseInfo e))) $ f cont d - done StartContext $ eLet b' e d' - -- atomic unboxed values may be substituted or discarded without replicating work or affecting program semantics. - doCase e _ b [] (Just d) | isUnboxed (getType e), isAtomic e = do - mtick "E.Simplify.case-atomic-unboxed" - localEnv (insertDoneSubst b e) $ f cont d - doCase e _ TVr { tvrIdent = z } [] (Just d) | isEmptyId z, isOmittable inb e = do - mtick "E.Simplify.case-omittable" - f cont d - doCase (EVar v) _ b [] (Just d) | Just (NotAmong _) <- varval = do - mtick $ "E.Simplify.case-evaled/{" ++ pprint v - localEnv (insertDoneSubst b (EVar v)) $ f cont d - doCase e _ b [] (Just (EVar v')) | b == v' = do - mtick $ "E.Simplify.case-trailing/{" ++ pprint b - done cont e - doCase scrut _ v [] (Just sc@ECase { eCaseScrutinee = EVar v'} ) | v == v', tvrIdent v `notMember` (freeVars (caseBodies sc) :: IdSet) = do - mtick "E.Simplify.case-default-case" - doCase scrut (eCaseType sc) (eCaseBind sc) (eCaseAlts sc) (eCaseDefault sc) - doCase e t b as d = do - tickCont cont "case" - b' <- nname b - (ids,b') <- case (e,tvrIdent b') of - (EVar v,z) | isEmptyId z -> do - nn <- newName - b' <- return b' { tvrIdent = nn } - return $ (insertInScope (tvrIdent v) (isBoundTo sopts v noUseInfo (EVar b')),b') - (EVar v,_) -> return $ (insertDoneSubst b (EVar b') . insertInScope (tvrIdent v) (isBoundTo sopts v noUseInfo (EVar b')),b') - _ -> return $ (insertDoneSubst b (EVar b'),b') - inb <- ask - let dd e' = localEnv (const $ ids $ extendScope newinb inb) $ f cont e' where - na = NotAmong [ n | Alt LitCons { litName = n } _ <- as] - newinb = fromList [ (n,na) | EVar (TVr { tvrIdent = n }) <- [EVar b']] - da (Alt (LitInt n t) ae) = do - t' <- dosub t - let p' = LitInt n t' - e' <- localEnv (ids . mins e (patToLitEE p')) $ f cont ae - return $ Alt p' e' - da (Alt lc@LitCons { litName = n, litArgs = ns, litType = t } ae) = do - t' <- dosub t - ns' <- mapM nname ns - let p' = lc { litArgs = ns', litType = t' } - nsub = [ (n,Done (EVar t)) | TVr { tvrIdent = n } <- ns | t <- ns' ] - ninb = fromList [ (n,NotKnown) | TVr { tvrIdent = n } <- ns' ] - e' <- localEnv (const $ ids $ substAddList nsub (extendScope ninb $ mins e (patToLitEE p') inb)) $ f cont ae - return $ Alt p' e' - mins _ e | emptyId `notMember` (freeVars e :: IdSet) = insertInScope (tvrIdent b') (isBoundTo sopts b' noUseInfo e) - mins _ _ = id - - d' <- T.mapM dd d - as' <- mapM da as - t' <- dosub t - t' <- contType cont t' - done StartContext $ caseUpdate ECase { - eCaseAllFV = error "eCaseAllFV", - eCaseScrutinee = e, - eCaseType = t', - eCaseBind = b', - eCaseAlts = as', - eCaseDefault = d'} - doCase e t b as d - - isOmittable _ ELit {} = True - isOmittable _ EPi {} = True - isOmittable _ ELam {} = True - isOmittable _ (EPrim p _ _) = primIsConstant p - isOmittable inb (EVar v) = case mlookup (tvrIdent v) (envInScope inb) of - Just IsBoundTo { bindingE = e } | not (isEVar e) -> isOmittable inb e - Just (NotAmong _) -> True - _ -> False - isOmittable _ _ = False - - doConstCase :: Cont -> {- Out -} Lit E E -> InE -> InTVr -> [Alt E] -> Maybe InE -> SM OutE - doConstCase cont l t b as d = do - t' <- dosub t - mr <- match l as (b,d) - inb <- ask - case mr of - Just (bs,e) -> do - let bs' = [ x | x@(TVr { tvrIdent = n },_) <- bs, n /= emptyId] - binds <- mapM (\ (v,e) -> nname v >>= return . (,,) e v) bs' - e' <- localEnv (substAddList [ (n,Done $ EVar nt) | (_,TVr { tvrIdent = n },nt) <- binds] . extendScope (fromList [ (n,isBoundTo sopts t noUseInfo e) | (e,_,t@TVr { tvrIdent = n }) <- binds])) $ f StartContext e - done cont $ eLetRec [ (v,e) | (e,_,v) <- binds ] e' - Nothing -> do - done cont $ EError ("match falls off bottom: " ++ pprint l) t' - - match m@LitCons { litName = c, litArgs = xs } ((Alt LitCons { litName = c', litArgs = bs } e):rs) d@(b,_) | c == c' = do - mtick (toAtom $ "E.Simplify.known-case." ++ show c ) - return $ Just ((b,ELit m):(zip bs xs),e) - | otherwise = match m rs d - match m@(LitInt x _) ((Alt (LitInt y _) e):rs) d@(b,_) | x == y = do - mtick (toAtom $ "E.Simplify.known-case." ++ show x) - return $ Just ([(b,ELit m)],e) - | otherwise = match m rs d - match m@LitCons { litName = c } [] (_,Just e) | Just _ <- fromUnboxedNameTuple c = do - mtick (toAtom $ "E.Simplify.known-case._#" ++ show c ) - return (Just ([],e)) - match l [] (b,Just e) = do - mtick (toAtom "E.Simplify.known-case._") - return $ Just ([(b,ELit l)],e) - match m [] (_,Nothing) = do - mtick (toAtom "E.Simplify.known-case.unmatch") - return Nothing - match m as d = error $ "Odd Match: " ++ show ((m,getType m),as,d) - - applyRule :: OutTVr -> [OutE] -> SM (Maybe (OutE,[OutE])) - applyRule v xs = do - inb <- ask - z <- builtinRule v xs - let lup x = case mlookup x (envInScope inb) of - Just IsBoundTo { bindingE = e } -> Just e - _ -> Nothing - case z of - Nothing | fopts FO.Rules -> applyRules lup (findWithDefault mempty (tvrIdent v) $ envRules inb) xs - x -> return x - done cont e = z cont [] where - z (ApplyTo r cont') rs = evalRange r >>= \a -> z cont' (a:rs) - z (Coerce t cont) rs = do - t' <- evalRange t - z <- hFunc e (reverse rs) - done cont (prim_unsafeCoerce z t') - z _ rs = hFunc e (reverse rs) - hFunc :: OutE -> [OutE] -> SM OutE - hFunc (EVar v) xs' = do - inb <- ask - z <- applyRule v xs' - let txs = map tx xs' where - tx (ELit l) = knowLit l - tx EPi {} = KnowSomething - tx (EVar v) = case mlookup (tvrIdent v) (envInScope inb) of - Just (NotAmong xs) -> KnowNotOneOf xs - Just IsBoundTo { bindingE = ELit l } -> knowLit l - Just IsBoundTo {} -> KnowSomething - _ -> KnowNothing - tx _ = KnowNothing - knowLit LitCons { litName = c } = KnowIsCon c - knowLit (LitInt n _) = KnowIsNum n - case z of - (Just (x,xs)) -> didInline x xs - _ -> case mlookup (tvrIdent v) (envInScope inb) of - Just IsBoundTo { inlineForced = ForceNoinline } -> appVar v xs' - Just IsBoundTo { bindingOccurance = Once } -> error "IsBoundTo: Once" - Just IsBoundTo { bindingE = e, bindingAtomic = True } -> do - mtick (toAtom $ "E.Simplify.inline.atomic/{" ++ tvrShowName v ++ "}") - didInline e xs' - Just IsBoundTo { bindingE = e, inlineForced = ForceInline } | someBenefit v e txs -> do - mtick (toAtom $ "E.Simplify.inline.Forced/{" ++ tvrShowName v ++ "}") - didInline e xs' --- Just ibt@IsBoundTo { bindingE = e } | False && someBenefit v e txs && getProperty prop_WRAPPER v -> do --- mtick (toAtom $ "E.Simplify.inline.Wrapper/{" ++ tvrShowName v ++ "}") --- trace (show (v,e,ibt,tvrInfo v)) didInline e xs' - Just IsBoundTo { bindingOccurance = OnceInLam, bindingE = e, bindingCheap = True } | someBenefit v e txs -> do - mtick (toAtom $ "E.Simplify.inline.OnceInLam/{" ++ showName (tvrIdent v) ++ "}") - didInline e xs' - Just IsBoundTo { bindingOccurance = ManyBranch, bindingE = e } | multiInline v e txs -> do - mtick (toAtom $ "E.Simplify.inline.ManyBranch/{" ++ showName (tvrIdent v) ++ "}") - didInline e xs' - Just IsBoundTo { bindingOccurance = Many, bindingE = e, bindingCheap = True } | multiInline v e txs -> do - mtick (toAtom $ "E.Simplify.inline.Many/{" ++ showName (tvrIdent v) ++ "}") - didInline e xs' - Just _ -> appVar v xs' - Nothing -> appVar v xs' - -- Nothing | tvrIdent v `Set.member` exports -> app (EVar v,xs') - -- Nothing -> error $ "Var not in scope: " ++ show v - hFunc e xs' = do app (e,xs') - didInline ::OutE -> [OutE] -> SM OutE - didInline z zs = return (foldl EAp z zs) - --didInline z zs = do - -- used <- smUsedNames - -- let (ne,nn) = runRename used (foldl EAp z zs) - -- smAddNamesIdSet nn - -- return ne - appVar v xs | so_postLift sopts = app (EVar v,xs) - appVar v xs = do - me <- etaExpandAp (progDataTable prog) v xs - case me of - Just e -> return e - Nothing -> app (EVar v,xs) - - app (e,[]) = return e - app (e,xs) = app' e xs - - app' (ELit lc@LitCons { litName = n, litArgs = xs, litType = EPi ta tt }) (a:as) = do - mtick (toAtom $ "E.Simplify.typecon-reduce.{" ++ show n ++ "}" ) - app' (ELit lc { litArgs = xs ++ [a], litType = subst ta a tt }) as - app' (ELit LitCons { litName = n, litArgs = es, litAliasFor = Just af }) bs@(_:_) = do - mtick (toAtom $ "E.Simplify.newtype-reduce.{" ++ show n ++ "}" ) - app' (foldl eAp af (es ++ bs)) [] - app' (EError s t) xs = do - mticks (length xs) (toAtom "E.Simplify.error-application") - return $ EError s (foldl eAp t xs) - app' e as = do - return $ foldl EAp e as - doDs ds = do - addNames $ map (tvrIdent . fst) ds - let z :: (InTVr,InE) -> SM (Id,UseInfo,OutTVr,InE) - z (t,EVar t') | t == t' = do -- look for simple loops and replace them with errors. - t'' <- nname t - mtick $ "E.Simplify.<>.{" ++ showName (tvrIdent t) ++ "}" - return (tvrIdent t,noUseInfo,t'',EError "<>" (getType t)) - z (t,e) = do - t' <- nname t - case Info.lookup (tvrInfo t) of - _ | forceNoinline t -> return (tvrIdent t,noUseInfo { useOccurance = LoopBreaker },t',e) - | so_postLift sopts && (isELam e || isECase e) -> return (tvrIdent t,noUseInfo { useOccurance = LoopBreaker },t',e) - Just ui@UseInfo { useOccurance = Once } -> return (tvrIdent t,ui,error $ "Once: " ++ show t,e) - Just n -> return (tvrIdent t,n,t',e) - -- We don't want to inline things we don't have occurance info for because they might lead to an infinite loop. hopefully the next pass will fix it. - Nothing -> return (tvrIdent t,noUseInfo { useOccurance = LoopBreaker },t',e) - -- Nothing -> error $ "No Occurance info for " ++ show t - w :: [(Id,UseInfo,OutTVr,InE)] -> [(OutTVr,OutE)] -> SM ([(OutTVr,OutE)],Env) - w ((t,UseInfo { useOccurance = Once },t',e):rs) ds = do - mtick $ "E.Simplify.inline.Once/{" ++ showName t ++ "}" - w rs ds -- (minsert t (Susp e sub) sub) inb ds - w ((t,n,t',e):rs) ds = do - let inb = case isForced of - ForceInline -> cacheSubst . changeScope nogrowth - _ -> id - isForced = calcForced finalPhase t' - nogrowth IsBoundTo { bindingAtomic = False } = NotKnown - nogrowth x = x - e' <- localEnv inb $ f (LazyContext t') e - let ibt = isBoundTo sopts t' n e' - case (bindingAtomic ibt,inlineForced ibt) of - (True,f) | f /= ForceNoinline -> do - --when (n /= Unused) $ mtick $ "E.Simplify.inline.Atomic.{" ++ showName t ++ "}" - localEnv (insertDoneSubst' t e' . insertInScope (tvrIdent t') ibt) $ w rs ((t',e'):ds) - _ -> localEnv (insertInScope (tvrIdent t') ibt) $ w rs ((t',e'):ds) - w [] ds = ask >>= \inb -> return (ds,inb) - s' <- mapM z ds - inb <- ask - let sub'' = fromList [ (t,susp e sub'') | (t, UseInfo { useOccurance = Once },_,e) <- s'] `union` fromList [ (t,Done (EVar t')) | (t,n,t',_) <- s', useOccurance n /= Once] `union` envSubst inb - (ds',inb') <- localEnv (envSubst_s sub'' . extendScope (fromList [ (tvrIdent t',NotKnown) | (_,n,t',_) <- s', useOccurance n /= Once])) $ w s' [] - let minArgs t = case Info.lookup (tvrInfo t) of - Just (UseInfo { minimumArgs = min }) -> min - Nothing -> 0 - - ds' <- if so_postLift sopts then return ds' else sequence [ etaExpandDef' (progDataTable prog) (minArgs t) t e | (t,e) <- ds'] - return (ds',inb') - -data KnowSomething = KnowNothing | KnowNotOneOf [Name] | KnowIsCon Name | KnowIsNum Number | KnowSomething - deriving(Eq) - -someBenefit _ e _ | isAtomic e = True -someBenefit _ ELit {} _ = True -someBenefit _ EPi {} _ = True -someBenefit _ EPrim {} _ = True -someBenefit v ELetRec { eDefs = ds, eBody = e } xs | someBenefit v e xs = True ---someBenefit _v ECase {} (_:_) = True -someBenefit _ e xs | f e xs = True where - f (ELam _ e) (_:xs) = f e xs - f ELam {} [] = any (/= KnowNothing) xs - f _ _ = not (null xs) -someBenefit v e xs = any (/= KnowNothing) xs - -exprSize :: - Int -- ^ maximum size before bailing out - -> E -- ^ expression - -> Int -- ^ discount for case of something known - -> [(Id,KnowSomething)] -- ^ things that are known - -> Maybe Int -exprSize max e discount known = f max e >>= \n -> return (max - n) where - f n _ | n <= 0 = fail "exprSize: expression too big" - f n EVar {} = return $! n - 1 - f n (EAp x@(EVar v) y) | Just _ <- lookup (tvrIdent v) known = do - v <- f (n + discount) x - f v x - f n (EAp x y) = do - v <- f n x - f v x - f n (ELam t x) = f (n - 1) x - f n EPi {} = return $! n - 1 - f n ELit {} = return $! n - 1 - f n ESort {} = return $! n - 1 - f n EPrim {} = return $! n - 1 - f n EError {} = return $! n - 1 - f n ec@ECase { eCaseScrutinee = EVar tv } | Just l <- lookup (tvrIdent tv) known = do - n <- f (n + discount) (EVar tv) - let g n [] | Just d <- eCaseDefault ec = f n d - | otherwise = return n - g n (Alt LitCons { litName = c' } e:rs) | KnowIsCon c <- l = if c == c' then f n e else g n rs - g n (Alt (LitInt c' _) e:rs) | KnowIsNum c <- l = if c == c' then f n e else g n rs - g n (Alt LitCons { litName = c } e:rs) | KnowNotOneOf na <- l = if c `elem` na then g n rs else f n e >>= \n' -> g n' rs - g n (Alt _ e:rs) = f n e >>= \n' -> g n' rs - g n (eCaseAlts ec) - f n ec@ECase {} = do - n <- f n (eCaseScrutinee ec) - foldM f n (caseBodies ec) - f n ELetRec {eDefs = ds, eBody = e } = do - n <- foldM f n (snds ds) - f n e - f _ Unknown = error "SSimplify.exprSize: bad." - -noSizeIncrease e xs = f e xs where - currentSize = 1 + length xs - f (ELam t e) (x:xs) = f e xs - f ELam {} [] = False -- abort if we will create a lambda - f e [] = isJust $ exprSize currentSize e 3 [] - f e xs = isJust $ exprSize (currentSize - length xs) e 3 [] - ---multiInline _ e xs | isSmall (f e xs) = True where -- should be noSizeIncrease --- f e [] = e --- f (ELam _ e) (_:xs) = f e xs --- f e xs = foldl EAp e xs --- --- - -scrutineeDiscount = 4 -extraArgDiscount = 1 -knowSomethingDiscount = 2 - -multiInline _ e xs | noSizeIncrease e xs = True -multiInline v e xs | not (someBenefit v e xs) = False -multiInline v e xs = f e xs [] where - currentSize = 1 + length xs - f (ELam t e) (KnowNothing:xs) rs = f e xs rs - f (ELam t e) (x:xs) rs = f e xs ((tvrIdent t,x):rs) - f e xs rs = isJust $ exprSize (knowSomethingDiscount*(length rs) + discount + currentSize + (if null xs then 0 else extraArgDiscount)) e scrutineeDiscount rs where - discount = if safeToDup e then 4 else 0 - -worthStricting EError {} = True -worthStricting ELit {} = False -worthStricting ELam {} = False -worthStricting x = sortTermLike x - -coerceOpt :: MonadStats m => (E -> m E) -> E -> m E -coerceOpt fn e = do - let (n,e',p) = unsafeCoerceOpt e - n `seq` stat_unsafeCoerce `seq` mticks n stat_unsafeCoerce - e'' <- fn e' - return (p e'') - -stat_unsafeCoerce = toAtom "E.Simplify.unsafeCoerce" - ------------------------ --- simplification Monad ------------------------ - -data SmState = SmState { - idsSeed :: {-# UNPACK #-} !Int, - idsUsed :: !IdSet, - idsBound :: !IdSet - } - -smState = SmState { idsSeed = 1, idsUsed = mempty, idsBound = mempty } - -newtype SM a = SM (RWS Env Stats.Stat SmState a) - deriving(Monad,Functor,MonadReader Env, MonadState SmState) - -localEnv f (SM action) = SM $ local (cacheSubst . f) action - -runSM :: Env -> SM a -> (a,Stat) -runSM env (SM x) = (r,s) where - (r,_,s) = runRWS x (cacheSubst env) smState - -instance MonadStats SM where - mticks' n k = SM $ tell (Stats.singleStat n k) >> return () - mtickStat = error "MonadStats.mtickStat: not impl." - -modifyIds fn = SM $ modify f where - f s@SmState { idsUsed = used, idsBound = bound } = case fn (used,bound) of (used',bound') -> s { idsUsed = used', idsBound = bound' } -getIds = SM $ liftM f get where - f s@SmState { idsUsed = used, idsBound = bound } = (used,bound) -putIds x = SM $ modify (f x) where - f (used,bound) = \s -> s { idsUsed = used, idsBound = bound } - -instance NameMonad Id SM where - addNames ns = do - modifyIds (\ (used,bound) -> -- trace ("AddNames: " ++ show (size used,size bound)) $ - (fromList ns `union` used, bound) ) - addBoundNames ns = do - let nset = fromList ns - modifyIds (\ (used,bound) -> --trace ("AddBoundNames: " ++ show (size used, size bound)) - (nset `union` used, nset `union` bound) ) - uniqueName n = do - (used,bound) <- getIds - if n `member` bound then newName else putIds (insert n used,insert n bound) >> return n - newNameFrom vs = do - (used,bound) <- getIds - let f (x:xs) - | x `member` used = f xs - | otherwise = x - f [] = error "newNameFrom: finite list!" - nn = f vs - putIds (insert nn used, insert nn bound) - return nn - newName = do - seed <- gets idsSeed - modify (\e -> e { idsSeed = seed + 1 }) --- (used,bound) <- getIds - newNameFrom $ candidateIds seed -- (size used + 10000*size bound) - ---smUsedNames = SM $ gets idsUsed ---smBoundNames = SM $ gets idsBound - -smAddNamesIdSet nset = --trace ("addNamesIdSet: "++ show (size nset)) $ - do modifyIds (\ (used,bound) -> (nset `union` used, bound) ) -smAddBoundNamesIdSet nset = --trace ("addBoundNamesIdSet: "++show (size nset)) $ - do modifyIds (\ (used,bound) -> (nset `union` used, nset `union` bound) ) - ---smAddBoundNamesIdMap = smAddNamesIdSet . idMapToIdSet -{-* Generated by DrIFT : Look, but Don't Touch. *-} -instance Monoid Env where - mempty = Env mempty mempty mempty mempty mempty - mappend (Env aa ab ac ad ae) (Env aa' ab' ac' ad' ae') = Env (mappend aa aa')(mappend ab ab')(mappend ac ac')(mappend ad ad')(mappend ae ae') - --- Imported from other files :- diff --git a/drift_processed/E/Type.hs b/drift_processed/E/Type.hs deleted file mode 100644 --- a/drift_processed/E/Type.hs +++ /dev/null @@ -1,333 +0,0 @@ -{- Generated by DrIFT (Automatic class derivations for Haskell) -} -{-# LINE 1 "src/E/Type.hs" #-} --- | The definitions related to jhc core - -module E.Type where - -import Data.Foldable hiding(concat) -import Data.Traversable - -import C.Prims -import Cmm.Number -import Doc.DocLike hiding((<$>)) -import Info.Types -import Name.Id -import Name.Name -import Name.Names -import StringTable.Atom -import Util.Gen -import qualified Info.Info as Info - -{- @Internals - -# Jhc core normalized forms - -Jhc core has a number of 'normalized forms' in which certain invarients are -met. many routines expect code to be in a certain form, and guarentee theier -output is also in a given form. The type system also can change with each form -by adding/removing terms from the PTS axioms and rules. - -normalized form alpha -: There are basically no restrictions other than the code is typesafe, but -certain constructs that are checked by the type checker are okay when they -wouldn't otherwise be. In particular, 'newtype' casts still exist at the data -level. 'enum' scrutinizations are creations may be in terms of the virtual -constructors rather than the internal representations. let may bind unboxed -values, which is normaly not allowed. - -normalized form beta -: This is like alpha except all data type constructors and case scrutinizations -are in their final form. As in, newtype coercions are removed, Enums are -desugared etc. also, 'let' bindings of unboxed values are translated to the -appropriate 'case' statements. The output of E.FromHs is in this form. - -normalized form blue -: This is the form that most routines work on. - -normalized form larry -: post lambda-lifting - -normalized form mangled -: All polymorphism has been replaced with subtyping - --} - --- the type of a supercombinator -data Comb = Comb { - combHead :: TVr, - combBody :: E, - combRules :: [Rule] - } - -instance HasProperties Comb where - modifyProperties f comb = combHead_u (modifyProperties f) comb - getProperties comb = getProperties $ combHead comb - putProperties p comb = combHead_u (putProperties p) comb - -instance HasProperties TVr where - modifyProperties f = tvrInfo_u (modifyProperties f) - getProperties = getProperties . tvrInfo - putProperties prop = tvrInfo_u (putProperties prop) - -combBody_u f r@Comb{combBody = x} = r{combBody = f x} -combHead_u f r@Comb{combHead = x} = r{combHead = f x} -combRules_u f r@Comb{combRules = x} = cp r{combRules = fx} where - cp = if null fx then unsetProperty PROP_HASRULE else setProperty PROP_HASRULE - fx = f x - -combBody_s v = combBody_u (const v) -combHead_s v = combHead_u (const v) -combRules_s v = combRules_u (const v) - -emptyComb = Comb { combHead = tvr, combBody = Unknown, combRules = [] } -combIdent = tvrIdent . combHead -combArgs = snd . fromLam . combBody -combABody = fst . fromLam . combBody -combBind b = (combHead b,combBody b) -bindComb (t,e) = combHead_s t . combBody_s e $ emptyComb -combTriple comb = (combHead comb,combArgs comb,combABody comb) -combTriple_s (t,as,e) comb = comb { combHead = t, combBody = Prelude.foldr ELam e as } - -data RuleType = RuleSpecialization | RuleUser | RuleCatalyst - deriving(Eq) - --- a rule in its user visible form - -data Rule = Rule { - ruleHead :: TVr, - ruleBinds :: [TVr], - ruleArgs :: [E], - ruleNArgs :: {-# UNPACK #-} !Int, - ruleBody :: E, - ruleType :: RuleType, - ruleUniq :: (Module,Int), - ruleName :: Atom - } - -data ARules = ARules { - aruleFreeVars :: IdSet, - aruleRules :: [Rule] - } - -data Lit e t = LitInt { litNumber :: Number, litType :: t } - | LitCons { litName :: Name, litArgs :: [e], litType :: t, litAliasFor :: Maybe E } - deriving(Eq,Ord,Functor,Foldable,Traversable) - {-!derive: is !-} - --------------------------------------- --- Lambda Cube (it's just fun to say.) --- We are now based on a PTS, which is --- a generalization of the lambda cube --- see E.TypeCheck for a description --- of the type system. --------------------------------------- - -data ESort = - EStar -- ^ the sort of boxed lazy types - | EBang -- ^ the sort of boxed strict types - | EHash -- ^ the sort of unboxed types - | ETuple -- ^ the sort of unboxed tuples - | EHashHash -- ^ the supersort of unboxed types - | EStarStar -- ^ the supersort of boxed types - | ESortNamed Name -- ^ user defined sorts - deriving(Eq, Ord) - {-! derive: is !-} - -data E = EAp E E - | ELam TVr E - | EPi TVr E - | EVar TVr - | Unknown - | ESort ESort - | ELit !(Lit E E) - | ELetRec { eDefs :: [(TVr, E)], eBody :: E } - | EPrim Prim [E] E - | EError String E - | ECase { - eCaseScrutinee :: E, - eCaseType :: E, -- due to GADTs and typecases, the final type of the expression might not be so obvious, so we include it here. - eCaseBind :: TVr, - eCaseAlts :: [Alt E], - eCaseDefault :: (Maybe E), - eCaseAllFV :: IdSet - } - deriving(Eq, Ord) - {-! derive: is, from !-} - ---instance Functor (Lit e) where --- fmap f x = runIdentity $ fmapM (return . f) x - ---instance FunctorM (Lit e) where --- fmapM f x = case x of --- LitCons { litName = a, litArgs = es, litType = e, litAliasFor = af } -> do e <- f e; return LitCons { litName = a, litArgs = es, litType = e, litAliasFor = af } --- LitInt i t -> do t <- f t; return $ LitInt i t - -instance Show ESort where - showsPrec _ EStar = showString "*" - showsPrec _ EHash = showString "#" - showsPrec _ EStarStar = showString "**" - showsPrec _ EHashHash = showString "##" - showsPrec _ ETuple = showString "(#)" - showsPrec _ EBang = showString "!" - showsPrec _ (ESortNamed n) = shows n - -instance (Show e,Show t) => Show (Lit e t) where - showsPrec p (LitInt x t) = showParen (p > 10) $ shows x <> showString "::" <> shows t - showsPrec p LitCons { litName = n, litArgs = es, litType = t } = showParen (p > 10) $ hsep (shows n:map (showsPrec 11) es) <> showString "::" <> shows t - -instance Show a => Show (TVr' a) where - showsPrec n TVr { tvrIdent = eid, tvrType = e} | eid == emptyId = showParen (n > 10) $ showString "_::" . shows e - showsPrec n TVr { tvrIdent = x, tvrType = e} = showParen (n > 10) $ case fromId x of - Just n -> shows n . showString "::" . shows e - Nothing -> shows x . showString "::" . shows e - -type TVr = TVr' E -data TVr' e = TVr { tvrIdent :: !Id, tvrType :: e, tvrInfo :: Info.Info } - deriving(Functor,Foldable,Traversable) - {-!derive: update !-} - -data Alt e = Alt (Lit TVr e) e - deriving(Eq,Ord) - -instance Eq TVr where - (==) (TVr { tvrIdent = i }) (TVr { tvrIdent = i' }) = i == i' - (/=) (TVr { tvrIdent = i }) (TVr { tvrIdent = i' }) = i /= i' - -instance Ord TVr where - compare (TVr { tvrIdent = x }) (TVr { tvrIdent = y }) = compare x y - x < y = tvrIdent x < tvrIdent y - x > y = tvrIdent x > tvrIdent y - x >= y = tvrIdent x >= tvrIdent y - x <= y = tvrIdent x <= tvrIdent y - --- simple querying routines -altHead :: Alt E -> Lit () () -altHead (Alt l _) = litHead l - -litHead :: Lit a b -> Lit () () -litHead (LitInt x _) = LitInt x () -litHead LitCons { litName = s, litAliasFor = af } = litCons { litName = s, litType = (), litAliasFor = af } - -litBinds (LitCons { litArgs = xs } ) = xs -litBinds _ = [] - -patToLitEE LitCons { litName = n, litArgs = [a,b], litType = t } | t == eStar, n == tc_Arrow = EPi (tVr emptyId (EVar a)) (EVar b) -patToLitEE LitCons { litName = n, litArgs = xs, litType = t, litAliasFor = af } = ELit $ LitCons { litName = n, litArgs = (map EVar xs), litType = t, litAliasFor = af } -patToLitEE (LitInt x t) = ELit $ LitInt x t - -caseBodies :: E -> [E] -caseBodies ec = [ b | Alt _ b <- eCaseAlts ec] ++ maybeToMonad (eCaseDefault ec) -casePats ec = [ p | Alt p _ <- eCaseAlts ec] -caseBinds ec = eCaseBind ec : concat [ xs | LitCons { litArgs = xs } <- casePats ec] - --- | extract out EAp nodes a value and the arguments it is applied to. -fromAp :: E -> (E,[E]) -fromAp e = f [] e where - f as (EAp e a) = f (a:as) e - f as e = (e,as) - --- | deconstruct EPi terms, getting function argument types. - -fromPi :: E -> (E,[TVr]) -fromPi e = f [] e where - f as (EPi v e) = f (v:as) e - f as e = (e,reverse as) - --- | deconstruct ELam term. - -fromLam :: E -> (E,[TVr]) -fromLam e = f [] e where - f as (ELam v e) = f (v:as) e - f as e = (e,reverse as) - -litCons = LitCons { litName = error "litName: name not set", litArgs = [], litType = error "litCons: type not set", litAliasFor = Nothing } - ------------------ --- E constructors ------------------ - -eStar :: E -eStar = ESort EStar - -eHash :: E -eHash = ESort EHash - -tVr x y = tvr { tvrIdent = x, tvrType = y } -tvr = TVr { tvrIdent = emptyId, tvrType = Unknown, tvrInfo = Info.empty } - --- Imported from other files :- -{-* Generated by DrIFT : Look, but Don't Touch. *-} -isLitInt (LitInt _ _) = True -isLitInt _ = False -isLitCons (LitCons _ _ _ _) = True -isLitCons _ = False - -isEStar (EStar) = True -isEStar _ = False -isEBang (EBang) = True -isEBang _ = False -isEHash (EHash) = True -isEHash _ = False -isETuple (ETuple) = True -isETuple _ = False -isEHashHash (EHashHash) = True -isEHashHash _ = False -isEStarStar (EStarStar) = True -isEStarStar _ = False -isESortNamed (ESortNamed _) = True -isESortNamed _ = False - -isEAp (EAp _ _) = True -isEAp _ = False -isELam (ELam _ _) = True -isELam _ = False -isEPi (EPi _ _) = True -isEPi _ = False -isEVar (EVar _) = True -isEVar _ = False -isUnknown (Unknown) = True -isUnknown _ = False -isESort (ESort _) = True -isESort _ = False -isELit (ELit _) = True -isELit _ = False -isELetRec (ELetRec _ _) = True -isELetRec _ = False -isEPrim (EPrim _ _ _) = True -isEPrim _ = False -isEError (EError _ _) = True -isEError _ = False -isECase (ECase _ _ _ _ _ _) = True -isECase _ = False - -fromEAp (EAp aa ab) = return (aa,ab) -fromEAp _ = fail "fromEAp" -fromELam (ELam aa ab) = return (aa,ab) -fromELam _ = fail "fromELam" -fromEPi (EPi aa ab) = return (aa,ab) -fromEPi _ = fail "fromEPi" -fromEVar (EVar aa) = return (aa) -fromEVar _ = fail "fromEVar" -fromUnknown (Unknown) = return () -fromUnknown _ = fail "fromUnknown" -fromESort (ESort aa) = return (aa) -fromESort _ = fail "fromESort" -fromELit (ELit aa) = return (aa) -fromELit _ = fail "fromELit" -fromELetRec (ELetRec aa ab) = return (aa,ab) -fromELetRec _ = fail "fromELetRec" -fromEPrim (EPrim aa ab ac) = return (aa,ab,ac) -fromEPrim _ = fail "fromEPrim" -fromEError (EError aa ab) = return (aa,ab) -fromEError _ = fail "fromEError" -fromECase (ECase aa ab ac ad ae af) = return (aa,ab,ac,ad,ae,af) -fromECase _ = fail "fromECase" - -tvrIdent_u f r@TVr{tvrIdent = x} = r{tvrIdent = f x} -tvrInfo_u f r@TVr{tvrInfo = x} = r{tvrInfo = f x} -tvrType_u f r@TVr{tvrType = x} = r{tvrType = f x} -tvrIdent_s v = tvrIdent_u (const v) -tvrInfo_s v = tvrInfo_u (const v) -tvrType_s v = tvrType_u (const v) - --- Imported from other files :- diff --git a/drift_processed/E/TypeCheck.hs b/drift_processed/E/TypeCheck.hs deleted file mode 100644 --- a/drift_processed/E/TypeCheck.hs +++ /dev/null @@ -1,566 +0,0 @@ -{- Generated by DrIFT (Automatic class derivations for Haskell) -} -{-# LINE 1 "src/E/TypeCheck.hs" #-} -module E.TypeCheck( - canBeBox, - eAp, - inferType, - infertype, - typecheck, - match, - sortSortLike, - sortKindLike, - sortTermLike, - sortTypeLike, - typeInfer, - typeInfer' - ) where - -import Control.Monad.Reader -import Control.Monad.Writer -import qualified Data.Map as Map - -import Doc.DocLike -import Doc.PPrint -import Doc.Pretty -import E.E -import E.Eval(strong) -import E.Subst -import GenUtil -import Name.Id -import Name.Name -import Name.Names -import Support.CanType -import Util.ContextMonad -import Util.SetLike -import qualified Util.Seq as Seq -import {-# SOURCE #-} DataConstructors -import {-# SOURCE #-} E.Show - -{-@Internals - -# Ajhc Core Type System - -Ajhc's core is based on a pure type system. A pure type system (also called a -PTS) is actually a parameterized set of type systems. Ajhc's version is -described by the following. - - Sorts = (*, !, **, #, (#), ##, □) - Axioms = (*:**, #:##, !:**, **:□, ##:□) - - -- sort kind - * is the kind of boxed values - ! is the kind of boxed strict values - # is the kind of unboxed values - (#) is the kind of unboxed tuples - -- sort superkind - ** is the superkind of all boxed value - ## is the superkind of all unboxed values - -- sort box - □ superkinds inhabit this - - in addition there exist user defined kinds, which are always of supersort ## - -The following Rules table shows what sort of abstractions are allowed, a rule -of the form (A,B,C) means you can have functions of things of sort A to things -of sort B and the result is something of sort C. _Function_ in this context -subsumes both term and type level abstractions. - -Notice that functions are always boxed, but may be strict if they take an -unboxed tuple as an argument. When a function is strict it means that it is -represented by a pointer to code directly, it cannot be a suspended value that -evaluates to a function. - -These type system rules apply to lambda abstractions. It is possible that data -constructors might exist that cannot be given a type on their own with these -rules, even though when fully applied it has a well formed type. An example -would be unboxed tuples. This presents no difficulty as one concludes correctly -that it is a type error for these constructors to ever appear when not fully -saturated with arguments. - - as a shortcut we will use *# to mean every combination involving * and #, and so forth. - for instance, (*#,*#,*) means the set (*,*,*) (#,*,*) (*,#,*) (#,#,*) - - Rules = - (*#!,*#!,*) -- functions from values to values are boxed and lazy - (*#!,(#),*) -- functions from values to unboxed tuples are boxed and lazy - ((#),*#!,!) -- functions from unboxed tuples to values are boxed and strict - ((#),(#),!) -- functions from unboxed tuples to unboxed tuples are boxed and strict - (**,*,*) -- may have a function from an unboxed type to a value - (**,#,*) - (**,!,*) - (**,**,**) -- we have functions from types to types - (**,##,##) -- MutArray_ :: * -> # - (##,##,##) -- Complex_ :: # -> # - - The defining feature of boxed values is - - _|_ :: t iff t::* - - This PTS is functional but not injective - -The PTS can be considered stratified into the following levels - - □ - sort box - **,##, - sort superkind - *,#,(#),! - sort kind - Int,Bits32_,Char - sort type - 3,True,"bob" - sort value - -## On boxed kinds - -The boxed kinds (* and !) represent types that have a uniform run time -representation. Due to this, functions may be written that are polymorphic in types of these kinds. -Hence the rules of the form (**,?,?), allowing taking types of boxed kinds as arguments. - -the unboxed kind # is inhabited with types that have their own specific run -time representation. Hence you cannot write functions that are polymorphic in -unboxed types - -## On sort box, the unboxed tuple, and friends - -Although sort box does not appear in the code, it is useful from a theoretical -point of view to talk about certain types such as the types of unboxed tuples. -Unboxed tuples may have boxed and unboxed arguments, without sort box it would -be impossible to express this since it must be superkind polymorphic. sort box -allows one to express this as (in the case of the unboxed 2-tuple) - - ∀s1:□ ∀s2:□ ∀k1:s1 ∀k2:s2 ∀t1:k1 ∀t2:k2 . (# t1, t2 #) - -However, although this is a valid typing of what it would mean if a unboxed -tuple were not fully applied, since we do not have any rules of form (##,?,?) or -(□,?,?) this type obviously does not typecheck. Which is what enforces the -invarient that unboxed tuples are always fully applied, and is also why we do -not need a code representation of sort box. - -### Do we need a superbox? - -You will notice that if you look at the axioms involving the sorts, you end up -with a disjoint graph - - □ - the box - / \ - ** ## - superkind - /\ \ - * ! # (#) - kind - -This is simply due to the fact that nothing is polymorphic in unboxed tuples of -kind (#) so we never need to refer to any super-sorts of them. We can add sorts -(##),(□) and □□ to fill in the gaps, but since these sorts will never appear in -code or discourse, we will ignore them from now on. - - □□ - sort superbox - / \ - □ (□) - sort box - / \ \ - ** ## (##) - sort superkind - /\ \ | - * ! # (#) - sort kind - --} - -ptsAxioms :: Map.Map ESort ESort -ptsAxioms = Map.fromList [ - (EStar,EStarStar), - (EBang,EStarStar), - (EHash,EHashHash), - (ETuple,EHashHash) - ] - -ptsRulesMap :: Map.Map (ESort,ESort) ESort -ptsRulesMap = Map.fromList [ ((a,b),c) | (as,bs,c) <- ptsRules, a <- as, b <- bs ] where - starHashBang = [EStar,EHash,EBang] - ptsRules = [ - (starHashBang,ETuple:starHashBang,EStar), - ([ETuple],ETuple:starHashBang,EBang), - ([EStarStar],starHashBang,EStar), - ([EStarStar],[EStarStar],EStarStar), - ([EStarStar],[EHashHash],EHashHash), - ([EHashHash],[EHashHash],EHashHash) - ] - -canBeBox x | getType (getType x) == ESort EStarStar = True -canBeBox _ = False - -tBox = mktBox eStar - -monadicLookup key m = case Map.lookup key m of - Just x -> return x - Nothing -> fail "Key not found" - --- Fast (and lazy, and perhaps unsafe) typeof -instance CanType E where - type TypeOf E = E - getType (ESort s) = ESort $ getType s - getType (ELit l) = getType l - getType (EVar v) = getType v - getType e@(EPi TVr { tvrType = a } b) - | isUnknown typa || isUnknown typb = Unknown - | otherwise = maybe (error $ "E.TypeCheck.getType: " ++ show (e,getType a,getType b)) ESort $ do - ESort s1 <- return $ getType a - ESort s2 <- return $ getType b - monadicLookup (s1,s2) ptsRulesMap - where typa = getType a; typb = getType b - getType (EAp (ELit LitCons { litType = EPi tvr a }) b) = getType (subst tvr b a) - getType (EAp (ELit lc@LitCons { litAliasFor = Just af }) b) = getType (foldl eAp af (litArgs lc ++ [b])) - getType (EAp (EPi tvr a) b) = getType (subst tvr b a) - getType e@(EAp a b) = ans where - ans = if isUnknown typa then Unknown else if a == tBox || typa == tBox then tBox else (case a of - (ELit LitCons {}) -> error $ "getType: application of type alias " ++ (render $ parens $ ePretty e) - _ -> eAp typa b) - typa = getType a - getType (ELam (TVr { tvrIdent = x, tvrType = a}) b) = EPi (tVr x a) (getType b) - getType (ELetRec _ e) = getType e - getType ECase {eCaseType = ty} = ty - getType (EError _ e) = e - getType (EPrim _ _ t) = t - getType Unknown = Unknown - -instance CanType ESort where - type TypeOf ESort = ESort - getType (ESortNamed _) = EHashHash - getType s = case Map.lookup s ptsAxioms of - Just s -> s - Nothing -> error $ "getType: " ++ show s -instance CanType TVr where - type TypeOf TVr = E - getType = tvrType -instance CanType (Lit x t) where - type TypeOf (Lit x t) = t - getType l = litType l -instance CanType e => CanType (Alt e) where - type TypeOf (Alt e) = TypeOf e - getType (Alt _ e) = getType e - -sortSortLike (ESort s) = isEHashHash s || isEStarStar s -sortSortLike _ = False - -sortKindLike (ESort s) = not (isEHashHash s) && not (isEStarStar s) -sortKindLike e = sortSortLike (getType e) - -sortTypeLike ESort {} = False -sortTypeLike e = sortKindLike (getType e) - -sortTermLike ESort {} = False -sortTermLike e = sortTypeLike (getType e) - -withContextDoc s a = withContext (render s) a - --- | Perform a full typecheck, evaluating type terms as necessary. - -inferType :: (ContextMonad m, ContextOf m ~ String) => DataTable -> [(TVr,E)] -> E -> m E -inferType dataTable ds e = rfc e where - inferType' ds e = inferType dataTable ds e - prettyE = ePretty - rfc e = withContextDoc (text "fullCheck:" prettyE e) (fc e >>= strong') - rfc' nds e = withContextDoc (text "fullCheck':" prettyE e) (inferType' nds e) - strong' e = withContextDoc (parens $ text "Strong:" prettyE e) $ strong ds e - fc s@(ESort _) = return $ getType s - fc (ELit lc@LitCons {}) | let lc' = updateLit dataTable lc, litAliasFor lc /= litAliasFor lc' = fail $ "Alias not correct: " ++ show (lc, litAliasFor lc') - fc (ELit LitCons { litName = n, litArgs = es, litType = t}) | nameType n == TypeConstructor, Just _ <- fromUnboxedNameTuple n = do - withContext ("Checking Unboxed Tuple: " ++ show n) $ do - -- we omit kind checking for unboxed tuples - valid t - es' <- mapM rfc es - strong' t - fc e@(ELit LitCons { litName = n, litArgs = es, litType = t}) = do - withContext ("Checking Constructor: " ++ show e) $ do - valid t - es' <- mapM rfc es - t' <- strong' t - let sts = slotTypes dataTable n t - les = length es - lsts = length sts - withContext ("Checking Args: " ++ show (sts,es')) $ do - unless (les == lsts || (les < lsts && isEPi t')) $ do - fail "constructor with wrong number of arguments" - zipWithM_ eq sts es' - return t' - fc e@(ELit _) = let t = getType e in valid t >> return t - fc (EVar (TVr { tvrIdent = eid })) | eid == emptyId = fail "variable with nothing!" - fc (EVar (TVr { tvrType = t})) = valid t >> strong' t - fc (EPi (TVr { tvrIdent = n, tvrType = at}) b) = do - ESort a <- rfc at - ESort b <- rfc' [ d | d@(v,_) <- ds, tvrIdent v /= n ] b - liftM ESort $ monadicLookup (a,b) ptsRulesMap - --valid at >> rfc' [ d | d@(v,_) <- ds, tvrIdent v /= n ] b - --fc (ELam tvr@(TVr n at) b) = valid at >> rfc' [ d | d@(v,_) <- ds, tvrIdent v /= n ] b >>= \b' -> (strong' $ EPi tvr b') - fc (ELam tvr@(TVr { tvrIdent = n, tvrType = at}) b) = do - withContext "Checking Lambda" $ do - valid at - b' <- withContext "Checking Lambda Body" $ rfc' [ d | d@(v,_) <- ds, tvrIdent v /= n ] b - withContext "Checking lambda pi" $ strong' $ EPi tvr b' - fc (EAp (EPi tvr e) b) = rfc (subst tvr b e) - fc (EAp (ELit lc@LitCons { litAliasFor = Just af }) b) = rfc (EAp (foldl eAp af (litArgs lc)) b) - fc (EAp a b) = do - withContextDoc (text "EAp:" parens (prettyE a) parens (prettyE b)) $ do - a' <- rfc a - if a' == tBox then return tBox else strong' (eAp a' b) - fc (ELetRec vs e) = do - let ck (TVr { tvrIdent = eid },_) | eid == emptyId = fail "binding of empty var" - ck (tv@(TVr { tvrType = t}),e) = withContextDoc (hsep [text "Checking Let: ", parens (pprint tv),text " = ", parens $ prettyE e ]) $ do - when (getType t == eHash && not (isEPi t)) $ fail $ "Let binding unboxed value: " ++ show (tv,e) - valid' nds t - fceq nds e t - nds = vs ++ ds - mapM_ ck vs - when (hasRepeatUnder (tvrIdent . fst) vs) $ fail "Repeat Variable in ELetRec" - inferType' nds e - --et <- inferType' nds e - --strong nds et - fc (EError _ e) = valid e >> (strong' e) - fc (EPrim _ ts t) = mapM_ valid ts >> valid t >> ( strong' t) - fc ec@ECase { eCaseScrutinee = e@ELit {}, eCaseBind = b, eCaseAlts = as, eCaseType = dt } | sortTypeLike e = do -- TODO - this is a hack to get around case of constants. - withContext "Checking typelike pattern binding case" $ do - et <- rfc e - withContext "Checking typelike default binding" $ eq et (getType b) - verifyPats (casePats ec) - -- skip checking alternatives - ps <- mapM (strong' . getType) $ casePats ec - withContext "Checking typelike pattern equality" $ eqAll (et:ps) - strong' dt - fc ec@ECase {eCaseScrutinee = e, eCaseBind = b, eCaseAlts = as, eCaseType = dt } | sortTypeLike e = do -- TODO - we should substitute the tested for value into the default type. - withContext "Checking typelike binding case" $ do - et <- rfc e - withContext "Checking typelike default binding" $ eq et (getType b) - --dt <- rfc d - --bs <- mapM rfc (caseBodies ec) -- these should be specializations of dt - withContext "Checking typelike alternatives" $ mapM_ (calt e) as - --eqAll bs - verifyPats (casePats ec) - ps <- withContext "Getting pattern types" $ mapM (strong' . getType) $ casePats ec - withContext "checking typelike pattern equality" $ eqAll (et:ps) - withContext "Evaluating Case Type" $ strong' dt - fc ec@ECase { eCaseScrutinee =e, eCaseBind = b } = do - withContext "Checking plain case" $ do - et <- rfc e - withContext "Checking default binding" $ eq et (getType b) - bs <- withContext "Checking case bodies" $ mapM rfc (caseBodies ec) - ect <- strong' (eCaseType ec) - withContext "Checking case bodies have equal types" $ eqAll (ect:bs) - verifyPats (casePats ec) - ps <- mapM (strong' . getType) $ casePats ec - withContext "checking pattern equality" $ eqAll (et:ps) - return ect - fc Unknown = return Unknown - --fc e = failDoc $ text "what's this? " (prettyE e) - calt (EVar v) (Alt l e) = do - let nv = followAliases undefined (patToLitEE l) - rfc (subst' v nv e) - calt _ (Alt _ e) = rfc e - verifyPats xs = do - mapM_ verifyPats' xs - when (hasRepeatUnder litHead xs) $ fail "Duplicate case alternatives" - - verifyPats' LitCons { litArgs = xs } = when (hasRepeatUnder id (filter (/= emptyId) $ map tvrIdent xs)) $ fail "Case pattern is non-linear" - verifyPats' _ = return () - - eqAll ts = withContextDoc (text "eqAll" list (map prettyE ts)) $ foldl1M_ eq ts - valid s = valid' ds s - valid' nds ESort {} = return () - valid' nds s - | Unknown <- s = return () - | otherwise = withContextDoc (text "valid:" <+> prettyE s) (do t <- inferType' nds s; valid' nds t) - eq box t2 | boxCompat box t2 = return t2 - eq t1 box | boxCompat box t1 = return t1 - -- box == tBox, canBeBox t2 = return t2 - -- eq t1 box | box == tBox, canBeBox t1 = return t1 - eq Unknown t2 = return t2 - eq t1 Unknown = return t1 - eq t1 t2 = eq' ds t1 t2 - eq' nds t1 t2 = do - e1 <- strong nds (t1) - e2 <- strong nds (t2) - case typesCompatable e1 e2 of - Just () -> return (e1) - Nothing -> failDoc $ text "eq:" <+> align $ vcat [ prettyE (e1), prettyE (e2) ] - fceq nds e1 t2 = do - withContextDoc (hsep [text "fceq:", align $ vcat [parens $ prettyE e1, parens $ prettyE t2]]) $ do - t1 <- inferType' nds e1 - eq' nds t1 t2 - boxCompat (ELit (LitCons { litName = n })) t | Just e <- fromConjured modBox n = e == getType t - boxCompat _ _ = False - --- This should perform a full typecheck and may take any extra information needed as an extra parameter -class CanTypeCheck a where - typecheck :: Monad m => DataTable -> a -> m E - -infertype :: CanTypeCheck a => DataTable -> a -> E -infertype env a = case typecheck env a of - Left s -> error $ "infertype: " ++ s - Right x -> x - -instance CanTypeCheck E where - typecheck dataTable e = case runContextEither $ typeInfer'' dataTable [] e of - Left ss -> fail $ "\n>>> internal error:\n" ++ unlines ss - Right v -> return v - -instance CanTypeCheck TVr where - typecheck dt tvr = do - typecheck dt (getType tvr) - return $ getType tvr - -instance CanTypeCheck (Lit a E) where - typecheck dt LitCons { litType = t } = typecheck dt t >> return t - typecheck dt LitInt { litType = t } = typecheck dt t >> return t - --- TODO, types might be bound in scrutinization -instance CanTypeCheck (Alt E) where - typecheck dt (Alt l e) = typecheck dt l >> typecheck dt e - --- | Determine type of term using full algorithm with substitutions. This --- should be used instead of 'typ' when let-bound type variables exist or you --- wish a more thorough checking of types. - -typeInfer :: DataTable -> E -> E -typeInfer dataTable e = case runContextEither $ typeInfer'' dataTable [] e of - Left ss -> error $ "\n>>> internal error:\n" ++ unlines (tail ss) - Right v -> v - -typeInfer' :: DataTable -> [(TVr,E)] -> E -> E -typeInfer' dataTable ds e = case runContextEither $ typeInfer'' dataTable ds e of - Left ss -> error $ "\n>>> internal error:\n" ++ unlines (tail ss) - Right v -> v - -data TcEnv = TcEnv { - --tcDefns :: [(TVr,E)], - tcContext :: [String] - --tcDataTable :: DataTable - } - -tcContext_u f r@TcEnv{tcContext = x} = r{tcContext = f x} - -newtype Tc a = Tc (Reader TcEnv a) - deriving(Monad,Functor,MonadReader TcEnv) - -instance ContextMonad Tc where - type ContextOf Tc = String - withContext s = local (tcContext_u (s:)) - -{- -tcE :: E -> Tc E -tcE e = rfc e where - rfc e = withContextDoc (text "tcE:" ePretty e) (fc e >>= strong') - strong' e = do - ds <- asks tcDefns - withContextDoc (text "tcE.strong:" ePretty e) $ strong ds e - - fc s@ESort {} = return $ getType s - fc (ELit LitCons { litType = t }) = strong' t - fc e@ELit {} = strong' (getType e) - fc (EVar TVr { tvrIdent = eid }) | eid == emptyId = fail "variable with nothing!" - fc (EVar TVr { tvrType = t}) = strong' t - fc (EPi TVr { tvrIdent = n, tvrType = at} b) = do - ESort a <- rfc at - ESort b <- local (tcDefns_u (\ds -> [ d | d@(v,_) <- ds, tvrIdent v /= n ])) $ rfc b - liftM ESort $ monadicLookup (a,b) ptsRulesMap - fc (ELam tvr@TVr { tvrIdent = n, tvrType = at} b) = do - at' <- strong' at - b' <- local (tcDefns_u (\ds -> [ d | d@(v,_) <- ds, tvrIdent v /= n ])) $ rfc b - return (EPi (tVr n at') b') - fc (EAp (EPi tvr e) b) = do - b <- strong' b - rfc (subst tvr b e) - fc (EAp (ELit lc@LitCons { litAliasFor = Just af }) b) = fc (EAp (foldl eAp af (litArgs lc)) b) - fc (EAp a b) = do - a' <- rfc a - if a' == tBox then return tBox else strong' (eAp a' b) - fc (ELetRec vs e) = local (tcDefns_u (vs ++)) $ rfc e - fc (EError _ e) = strong' e - fc (EPrim _ ts t) = strong' t - fc ECase { eCaseType = ty } = do - strong' ty - fc Unknown = return Unknown - fc e = failDoc $ text "what's this? " (ePretty e) --} - -typeInfer'' :: (ContextMonad m, ContextOf m ~ String) => DataTable -> [(TVr,E)] -> E -> m E -typeInfer'' dataTable ds e = rfc e where - inferType' ds e = typeInfer'' dataTable ds e - rfc e = withContextDoc (text "fullCheck':" ePretty e) (fc e >>= strong') - rfc' nds e = withContextDoc (text "fullCheck':" ePretty e) (inferType' nds e) - strong' e = withContextDoc (text "Strong':" ePretty e) $ strong ds e - fc s@ESort {} = return $ getType s - fc (ELit LitCons { litType = t }) = strong' t - fc e@ELit {} = strong' (getType e) - fc (EVar TVr { tvrIdent = eid }) | eid == emptyId = fail "variable with nothing!" - fc (EVar TVr { tvrType = t}) = strong' t - fc (EPi TVr { tvrIdent = n, tvrType = at} b) = do - ESort a <- rfc at - ESort b <- rfc' [ d | d@(v,_) <- ds, tvrIdent v /= n ] b - liftM ESort $ monadicLookup (a,b) ptsRulesMap - fc (ELam tvr@TVr { tvrIdent = n, tvrType = at} b) = do - at' <- strong' at - b' <- rfc' [ d | d@(v,_) <- ds, tvrIdent v /= n ] b - return (EPi (tVr n at') b') - fc (EAp (EPi tvr e) b) = do - b <- strong' b - rfc (subst tvr b e) - fc (EAp (ELit lc@LitCons { litAliasFor = Just af }) b) = fc (EAp (foldl eAp af (litArgs lc)) b) - fc (EAp a b) = do - a' <- rfc a - if a' == tBox then return tBox else strong' (eAp a' b) - fc (ELetRec vs e) = do - let nds = vs ++ ds - --et <- inferType' nds e - --strong nds et - inferType' nds e - fc (EError _ e) = strong' e - fc (EPrim _ ts t) = strong' t - fc ECase { eCaseType = ty } = do - strong' ty - fc Unknown = return Unknown - --fc e = failDoc $ text "what's this? " (ePretty e) - --- | find substitution that will transform the left term into the right one, --- only substituting for the vars in the list - -match :: Monad m => - (Id -> Maybe E) -- ^ function to look up values in the environment - -> [TVr] -- ^ vars which may be substituted - -> E -- ^ pattern to match - -> E -- ^ input expression - -> m [(TVr,E)] -match lup vs = \e1 e2 -> liftM Seq.toList $ execWriterT (un e1 e2 etherealIds) where - bvs :: IdSet - bvs = fromList (map tvrIdent vs) - - un (EAp a b) (EAp a' b') c = do - un a a' c - un b b' c - un (ELam va ea) (ELam vb eb) c = lam va ea vb eb c - un (EPi va ea) (EPi vb eb) c = lam va ea vb eb c - un (EPi va ea) (ELit LitCons { litName = ar, litArgs = [x,y], litType = lt}) c | ar == tc_Arrow = do - un (tvrType va) x c - un ea y c - un (EPrim s xs t) (EPrim s' ys t') c | length xs == length ys = do - sequence_ [ un x y c | x <- xs | y <- ys] - un t t' c - un (ESort x) (ESort y) c | x == y = return () - un (ELit (LitInt x t1)) (ELit (LitInt y t2)) c | x == y = un t1 t2 c - un (ELit LitCons { litName = n, litArgs = xs, litType = t }) (ELit LitCons { litName = n', litArgs = ys, litType = t'}) c | n == n' && length xs == length ys = do - sequence_ [ un x y c | x <- xs | y <- ys] - un t t' c - - un (EVar TVr { tvrIdent = i, tvrType = t}) (EVar TVr {tvrIdent = j, tvrType = u}) c | i == j = un t u c - un (EVar TVr { tvrIdent = i, tvrType = t}) (EVar TVr {tvrIdent = j, tvrType = u}) c | isEtherealId i || isEtherealId j = fail "Expressions don't match" - un (EAp a b) (ELit lc@LitCons { litArgs = bas@(_:_), litType = t }) c = do - let (al:as) = reverse bas - un a (ELit lc { litArgs = reverse as, litType = ePi tvr { tvrType = getType al } t }) c - un b al c - un (EAp a b) (EPi TVr { tvrType = a1 } a2) c = do - un a (ELit litCons { litArgs = [a1], litName = tc_Arrow, litType = EPi tvr { tvrType = getType a2 } (getType a1) }) c - un b a2 c - un (EVar tvr@TVr { tvrIdent = i, tvrType = t}) b c - | i `member` bvs = tell (Seq.single (tvr,b)) - | otherwise = fail $ "Expressions do not unify: " ++ show tvr ++ show b - un a (EVar tvr) c | Just b <- lup (tvrIdent tvr), not $ isEVar b = un a b c - --un a b c | Just a' <- followAlias undefined a = un a' b c - un a b c | Just b' <- followAlias undefined b = un a b' c - - un a b _ = fail $ "Expressions do not unify: " ++ show a ++ show b - lam va ea vb eb (c:cs) = do - un (tvrType va) (tvrType vb) (c:cs) - un (subst va (EVar va { tvrIdent = c }) ea) (subst vb (EVar vb { tvrIdent = c }) eb) cs - lam _ _ _ _ _ = error "TypeCheck.match: bad." -{-* Generated by DrIFT : Look, but Don't Touch. *-} --- Imported from other files :- diff --git a/drift_processed/FrontEnd/Class.hs b/drift_processed/FrontEnd/Class.hs deleted file mode 100644 --- a/drift_processed/FrontEnd/Class.hs +++ /dev/null @@ -1,586 +0,0 @@ -{- Generated by DrIFT (Automatic class derivations for Haskell) -} -{-# LINE 1 "src/FrontEnd/Class.hs" #-} -{-# LANGUAGE NoMonoLocalBinds, NamedFieldPuns #-} -module FrontEnd.Class( - printClassHierarchy, - instanceToTopDecls, - ClassHierarchy(), - augmentClassHierarchy, - chToClassHead, - ClassRecord(..), - ClassType(..), - instanceName, - defaultInstanceName, - checkForDuplicateInstaces, - printClassSummary, - findClassInsts, - findClassRecord, - asksClassRecord, - classRecords, - addInstanceToHierarchy, - makeClassHierarchy, - scatterAliasInstances, - derivableClasses, - enumDerivableClasses, - noNewtypeDerivable, - makeInstanceEnv, - emptyInstance, - InstanceEnv(..), - Inst(..) - ) where - -import Control.Monad.Identity -import Control.Monad.Writer(Monoid(..)) -import Data.Generics(mkQ,something) -import Data.List(nub) -import Data.Maybe -import Debug.Trace -import Text.PrettyPrint.HughesPJ(render,Doc()) -import Text.Printf -import qualified Data.List -import qualified Data.Map as Map -import qualified Text.PrettyPrint.HughesPJ as PPrint - -import Data.Binary -import Doc.DocLike -import Doc.PPrint -import FrontEnd.HsSyn -import FrontEnd.KindInfer -import FrontEnd.SrcLoc -import FrontEnd.Tc.Kind -import FrontEnd.Tc.Type -import FrontEnd.Utils -import FrontEnd.Warning -import Name.Name -import Name.Names -import Options (verbose) -import Support.FreeVars -import Support.MapBinaryInstance -import Support.Tickle -import Util.Gen -import Util.Inst() - -type Assump = (Name,Sigma) - -data Inst = Inst { - instSrcLoc :: SrcLoc, - instDerived :: !Bool, -- ^ whether this instance was derived - instHead :: Qual Pred, - instAssocs :: [(Tycon,[Tyvar],[Tyvar],Sigma)] - } deriving(Eq,Ord,Show) - {-! derive: Binary !-} - -instance PPrint a (Qual Pred) => PPrint a Inst where - pprint Inst { instHead = h, instAssocs = [], instDerived = d } = (if d then text "*" else text " ") <> pprint h - pprint Inst { instHead = h, instAssocs = as, instDerived = d } = (if d then text "*" else text " ") <> pprint h <+> text "where" <$> vcat [ text " type" <+> pprint n <+> text "_" <+> hsep (map pprint ts) <+> text "=" <+> pprint sigma | (n,_,ts,sigma) <- as] - -emptyInstance = Inst { instDerived = False, instSrcLoc = bogusASrcLoc, instHead = error "emptyInstance", instAssocs = [] } - --- augment heirarchy with just instances with full class definitions -augmentClassHierarchy :: ClassHierarchy -> ClassHierarchy -> ClassHierarchy -augmentClassHierarchy (CH full _) (CH res is) = ans where - ans = CH (Map.mapWithKey f is) is - f cn _ = r where Just r = Map.lookup cn (Map.union res full) - -data ClassType = ClassNormal | ClassTypeFamily | ClassDataFamily | ClassAlias - deriving(Eq,Ord) - --- Bool is true if data declaration instead of type declaration -data AssociatedType = Assoc !Tycon !Bool [Tyvar] Kind - deriving(Eq,Show) - {-! derive: Binary !-} - -data ClassRecord = ClassRecord { - className :: !Class, -- ^ can be a TypeConstructor if we are a type or data family - classSrcLoc :: !SrcLoc, - classArgs :: [Tyvar], - classSupers :: [Class], -- TODO: should be Pred - classAlias :: Maybe (Qual [Pred]), - classAssumps :: [(Name,Sigma)], -- ^ method signatures - classAssocs :: [AssociatedType] - } deriving (Show,Eq) - {-! derive: Binary !-} - -newtype InstanceEnv = InstanceEnv { - instanceEnv :: Map.Map (Name,Name) ([Tyvar],[Tyvar],Type) } - -makeInstanceEnv :: ClassHierarchy -> InstanceEnv -makeInstanceEnv (CH _ is) = InstanceEnv $ Map.fromList (concatMap f (Map.toList is)) where - f (cr,is) = concatMap (g cr) is - g cr Inst { instHead = _ :=> IsIn _cname tt, instAssocs = as } | _cname == cr = ans where - ans = [ ((tyconName tc,getTypeHead tt),(is,rs,e)) | (tc,is,rs,e) <- as] - g cr x = error $ "makeInstanceEnv: " ++ show (cr,x) - -getTypeHead th = case fromTAp th of - (TArrow {},_) -> tc_Arrow - (TCon c,_) -> tyconName c - _ -> error $ "getTypeHead: " ++ show th - -data ClassHierarchy = CH (Map.Map Class ClassRecord) (Map.Map Class [Inst]) - -instance Binary ClassHierarchy where - get = do - m1 <- getMap - m2 <- getMap - return (CH m1 m2) - put (CH m1 m2) = do - putMap m1 - putMap m2 - -instance Monoid ClassHierarchy where - mempty = CH mempty mempty - mappend (CH a b) (CH c d) = - CH (Map.union a c) (Map.unionWith Data.List.union b d) - -classRecords :: ClassHierarchy -> [ClassRecord] -classRecords (CH ch _) = Map.elems ch - -findClassRecord (CH ch _) cn = case Map.lookup cn ch of - Nothing -> error $ "findClassRecord: " ++ show cn - Just n -> n - -asksClassRecord (CH ch _) cn f = case Map.lookup cn ch of - Nothing -> error $ "asksClassRecord: " ++ show cn - Just n -> f n -findClassInsts (CH _ is) cn = fromMaybe [] (Map.lookup cn is) - -showInst :: Inst -> String -showInst = PPrint.render . pprint - -aHsTypeSigToAssumps :: KindEnv -> HsDecl -> [(Name,Type)] -aHsTypeSigToAssumps kt ~sig@(HsTypeSig _ names qualType) = [ (toName Val n,typ) | n <- names] where - Identity typ = hsQualTypeToSigma kt qualType - -qualifyMethod :: [HsAsst] -> HsDecl -> HsDecl -qualifyMethod ~[HsAsst c [n]] ~(HsTypeSig sloc names (HsQualType oc t)) - = HsTypeSig sloc names (HsQualType (HsAsst c [n']:oc) t) where - Just n' = (something (mkQ mzero f)) t - f (HsTyVar n') | hsNameToOrig n' == hsNameToOrig n = return n' - f _ = mzero - -printClassSummary :: ClassHierarchy -> IO () -printClassSummary (CH h is) = mapM_ f (Map.toList h) where - --h' = [ (n,fromJust $ Map.lookup n h) | n <- (map fst [ (cn, classSupers ss) | (cn,ss) <- Map.toList h]) ] - f (cname, ClassRecord { .. }) = do - putStrLn $ "-- class: " ++ show cname - let insts = fromMaybe [] (Map.lookup cname is) - unless (null classSupers) $ putStrLn $ "super classes:" ++ unwords (map show classSupers) - unless (null insts) $ putStrLn $ "instances: " ++ (intercalate ", " (map showInst insts)) --- putStrLn "" --- f (cname, (ClassAliasRecord { classSupers = supers, classInsts = insts, classClasses = classes })) = do --- putStrLn $ "-- class: " ++ show cname --- unless (null supers) $ putStrLn $ "super classes:" ++ unwords (map show supers) --- unless (null insts) $ putStrLn $ "instances: " ++ (intercalate ", " (map showInst insts)) --- unless (null classes) $ putStrLn $ "alias for: " ++ unwords (map show classes) --- putStrLn "" - -printClassHierarchy :: ClassHierarchy -> IO () -printClassHierarchy (CH h is) = mapM_ printClassDetails $ Map.toList h where - printClassDetails :: (Name, ClassRecord) -> IO () - printClassDetails (cname, cr) = do - let args = classArgs cr; supers = classSupers cr; - methodAssumps = classAssumps cr - assocs = classAssocs cr - let insts = fromMaybe [] (Map.lookup cname is) - putStrLn "..........." - putStrLn $ "class: " ++ hsep (pprint cname:map pprintParen args) - putStr $ "super classes:" - pnone supers $ do putStrLn $ " " ++ (intercalate " " (map show supers)) - putStr $ "instances:" - pnone insts $ putStr $ "\n" ++ (showListAndSepInWidth showInst 80 ", " insts) - when True $ do - putStr $ "method signatures:" - pnone methodAssumps $ putStr $ "\n" ++ (unlines $ map pretty methodAssumps) - putStr $ "associated types:" - pnone assocs $ putStrLn $ "\n" ++ (unlines $ map (render . passoc) assocs) - when (isJust (classAlias cr)) $ do - let Just x = classAlias cr - putStr $ "alias for:" - putStrLn (pprint x) - --Just $ --pnone classes $ do putStrLn $ " " ++ (intercalate " " (map show classes)) - putStr "\n" - pnone [] f = putStrLn " none" - pnone xs f = f - passoc (Assoc nk isData as kt) = text (if isData then "data" else "type") <+> - pprint nk <+> hsep (map pprint as) <+> text "::" <+> pprint kt - --- this does not check for duplicates, use checkForDuplicateInstaces after all --- instances have been added to do so. -addInstanceToHierarchy :: Inst -> ClassHierarchy -> ClassHierarchy -addInstanceToHierarchy inst@Inst { instHead = cntxt :=> ~(IsIn className _) } (CH r i) = - CH r (Map.insertWith Data.List.union className [inst] i) - --- Kind inference has already been done so we don't need to check for kind --- errors here. -hsInstDeclToInst :: Monad m => KindEnv -> HsDecl -> m [Inst] -hsInstDeclToInst kt (HsInstDecl sloc qType decls) - = return [emptyInstance { instSrcLoc = sloc, instDerived = False, - instHead = cntxt :=> IsIn className convertedArgType, instAssocs = assocs }] - where - (cntxt, (className, [convertedArgType])) = chToClassHead kt qType - assocs = [ (tc,as,bs,s) | (tc,as,bs,~(Just s)) <- createInstAssocs kt decls ] -hsInstDeclToInst kt (HsDeclDeriving sloc qType) - = return [emptyInstance { instSrcLoc = sloc, instDerived = True, - instHead = cntxt :=> IsIn className convertedArgType }] - where (cntxt, (className, [convertedArgType])) = chToClassHead kt qType -hsInstDeclToInst _ _ = return [] - -vtrace s v | False && verbose = trace s v -vtrace s v | otherwise = v - -chToClassHead :: KindEnv -> HsClassHead -> ([Pred],(Name,[Type])) -chToClassHead kt qt@HsClassHead { .. } = - vtrace ("chToClassHead" <+> show qt) $ - let res = (map (hsAsstToPred kt) hsClassHeadContext,(hsClassHead, - map (runIdentity . hsTypeToType (kiHsQualType kt (HsQualType hsClassHeadContext (HsTyTuple [])))) hsClassHeadArgs)) - in vtrace ("=" <+> show res) res - -createClassAssocs kt decls = [ Assoc (ctc n) False (map ct as) (ctype t) | HsTypeDecl { hsDeclName = n, hsDeclTArgs = as, hsDeclType = t } <- decls ] where - ctc n = let nn = toName TypeConstructor n in Tycon nn (kindOf nn kt) - ct (HsTyVar n) = let nn = toName TypeVal n in tyvar nn (kindOf nn kt) - ct _ = error "Class.createClassAssocs: bad1." - ctype HsTyAssoc = kindStar - ctype _ = error "Class.createClassAssocs: bad2." --- ctype t = Just $ runIdentity $ hsTypeToType kt t - -createInstAssocs kt decls = [ (ctc n,map ct (czas ca),map ct as,ctype t) | HsTypeDecl { hsDeclName = n, hsDeclTArgs = (ca:as), hsDeclType = t } <- decls ] where - ctc n = let nn = toName TypeConstructor n in Tycon nn (kindOf nn kt) - ct (HsTyVar n) = let nn = toName TypeVal n in tyvar nn (kindOf nn kt) - ct _ = error "Class.createInstAssocs: bad." - czas ca = let (HsTyCon {},zas) = fromHsTypeApp ca in zas - ctype HsTyAssoc = Nothing - ctype t = Just $ runIdentity $ hsTypeToType kt t - -fromHsTypeApp t = f t [] where - f (HsTyApp a b) rs = f a (b:rs) - f t rs = (t,rs) - -instanceToTopDecls :: KindEnv -> ClassHierarchy -> HsDecl -> (([HsDecl],[Assump])) -instanceToTopDecls kt ch@(CH classHierarchy _) (HsInstDecl _ qualType methods) - = unzip $ concatMap (methodToTopDecls kt [] crecord qualType) $ methodGroups where - methodGroups = groupEquations (filter (not . isHsPragmaProps) methods) - (_,(className,_)) = chToClassHead kt qualType - crecord = case Map.lookup className classHierarchy of - Nothing -> error $ "instanceToTopDecls: could not find class " ++ show className ++ "in class hierarchy" - Just crecord -> crecord -instanceToTopDecls kt ch@(CH classHierarchy _) (HsClassDecl _ chead methods) - = unzip $ map (defaultMethodToTopDecls kt methodSigs chead) $ methodGroups where - className = hsClassHead chead - --HsQualType _ (HsTyApp (HsTyCon className) _) = qualType - methodGroups = groupEquations (filter (\x -> isHsPatBind x || isHsFunBind x) methods) - methodSigs = case Map.lookup (toName ClassName className) classHierarchy of - Nothing -> error $ "defaultInstanceToTopDecls: could not find class " ++ show className ++ "in class hierarchy" - Just sigs -> classAssumps sigs -instanceToTopDecls _ _ _ = mempty - -instanceName n t = toName Val ("Instance@",'i':show n ++ "." ++ show t) -defaultInstanceName n = toName Val ("Instance@",'i':show n ++ ".default") --- aliasDefaultInstanceName :: Name -> Class -> Name --- aliasDefaultInstanceName n ca = toName Val ("Instance@",'i':show n ++ ".default."++show ca) - -methodToTopDecls :: Monad m - => KindEnv -- ^ the kindenv - -> [Pred] -- ^ random extra predicates to add - -> ClassRecord -- ^ the class we are lifting methods from - -> HsClassHead - -> (Name, HsDecl) - -> m (HsDecl,Assump) -methodToTopDecls kt preds crecord qt (methodName, methodDecls) = do - let (cntxt,(className,[argType])) = chToClassHead kt qt - newMethodName = instanceName methodName (getTypeHead argType) - sigFromClass <- case [ s | (n, s) <- classAssumps crecord, n == methodName] of - [x] -> return x - _ -> fail $ "sigFromClass: " ++ (pprint className <+> pprint (classAssumps crecord)) - ++ " " ++ show methodName - let instantiatedSig = newMethodSig' kt methodName (preds ++ cntxt) sigFromClass argType - renamedMethodDecls = renameOneDecl newMethodName methodDecls - return (renamedMethodDecls,(newMethodName, instantiatedSig)) - -defaultMethodToTopDecls :: KindEnv -> [Assump] -> HsClassHead -> (Name, HsDecl) -> (HsDecl,Assump) -defaultMethodToTopDecls kt methodSigs HsClassHead { .. } (methodName, methodDecls) - = (renamedMethodDecls,(newMethodName,sigFromClass)) where - newMethodName = defaultInstanceName methodName - sigFromClass = case [ s | (n, s) <- methodSigs, n == methodName] of - [x] -> x - _ -> error $ "sigFromClass: " ++ show methodSigs ++ " " ++ show methodName - -- = newMethodSig cntxt newMethodName sigFromClass argType - renamedMethodDecls = renameOneDecl newMethodName methodDecls - -{- -aliasDefaultMethodToTopDecls :: KindEnv -> [Assump] -> Class -> (Name, HsDecl) -> (HsDecl,Assump) -aliasDefaultMethodToTopDecls kt methodSigs aliasName (methodName, methodDecls) - = (renamedMethodDecls,(newMethodName,sigFromClass)) where - newMethodName = aliasDefaultInstanceName methodName aliasName - sigFromClass = case [ s | (n, s) <- methodSigs, n == methodName] of - [x] -> x - _ -> error $ "sigFromClass: " ++ show methodSigs ++ " " ++ show methodName - -- = newMethodSig cntxt newMethodName sigFromClass argType - renamedMethodDecls = renameOneDecl newMethodName methodDecls --} - -renameOneDecl :: Name -> HsDecl -> HsDecl -renameOneDecl newName (HsFunBind matches) - = HsFunBind (map (renameOneMatch newName) matches) --- all pattern bindings are simple by this stage --- (ie no compound patterns) -renameOneDecl newName (HsPatBind sloc (HsPVar patName) rhs wheres) - = HsPatBind sloc (HsPVar (nameName newName)) rhs wheres -renameOneDecl _ _ = error "Class.renameOneDecl" - -renameOneMatch :: Name -> HsMatch -> HsMatch -renameOneMatch newName (HsMatch sloc oldName pats rhs wheres) - = HsMatch sloc (nameName newName) pats rhs wheres - -newMethodSig' :: KindEnv -> Name -> [Pred] -> Sigma -> Type -> Sigma -newMethodSig' kt methodName newCntxt qt' instanceType = newQualType where - TForAll _ ((IsIn _ classArg:restContext) :=> t) = qt' - -- the assumption is that the context is non-empty and that - -- the class and variable that we are interested in are at the - -- front of the old context - the method of inserting instance types into - -- the class hierarchy should ensure this - --((className, classArg):restContxt) = cntxt - foo = "_" ++ (show methodName ++ show (getTypeHead instanceType)) ++ "@@" --- newQualType = everywhere (mkT at) $ tForAll (nub $ freeVars qt) qt - - newQualType = tForAll vs nqt where - vs = nub $ freeVars nqt - nqt = map (tickle f) (newCntxt ++ restContext) :=> f t - f t | t == classArg = f instanceType - f (TVar t) = TVar (at t) - f (TForAll ta (ps :=> t)) = tickle f (TForAll (map at ta) (ps :=> t)) - f (TExists ta (ps :=> t)) = tickle f (TExists (map at ta) (ps :=> t)) - f t = tickle f t - - at (Tyvar n k) = tyvar (updateName (++ foo) n) k - updateName f n = toName nt (md,f nm) where - (nt,(md::String,nm)) = fromName n --- qt = (newCntxt ++ restContext) :=> t - {- - qt = (newCntxt ++ restContext) :=> (everywhere (mkT ct) t) - ct n | n == classArg = instanceType - ct n = n - -} - --- collect assumptions of all class methods - ---classMethodAssumps :: ClassHierarchy -> [Assump] ---classMethodAssumps hierarchy = concatMap classAssumps $ classRecords hierarchy - --------------------------------------------------------------------------------- - -scatterAliasInstances :: ClassHierarchy -> ClassHierarchy -scatterAliasInstances = id -{- -scatterAliasInstances ch = - let cas = [cr | cr@(ClassAliasRecord {}) <- classRecords ch] - --ch `seq` liftIO $ putStrLn ("scatterAliasInstances: " ++ show cas) - instances = concatMap scatterInstancesOf cas - ret = foldr (modifyClassRecord $ \cr -> cr - { classInsts = [], - classMethodMap = Map.fromList [(meth, cls) | cls <- classClasses cr, - (meth,_) <- classAssumps (findClassRecord ch cls)] - }) - (ch `mappend` classHierarchyFromRecords instances) - (map className cas) - -- liftIO $ mapM_ print (classRecords ret) - in ret - -scatterInstancesOf :: ClassRecord -> [ClassRecord] -scatterInstancesOf cr = map extract (classClasses cr) - where - extract c = - (newClassRecord c) { classInsts = - [Inst sl d ((cxt ++ [IsIn c2 xs | c2 <- classClasses cr, c2 /= c]) :=> IsIn c xs) [] - | Inst sl d (cxt :=> IsIn _ xs) [] <- classInsts cr] } - --} --------------------------------------------------------------------------------- - ---failSl sl m = fail $ show sl ++ ": " ++ m - -classHierarchyFromRecords rs = - CH (Map.fromList [ (className x,x)| x <- rs ]) mempty - -fromHsTyVar (HsTyVar v) = return v -fromHsTyVar (HsTyExpKind (Located _ t) _) = fromHsTyVar t -fromHsTyVar _ = fail "fromHsTyVar" - --- We give all instance declarations the benefit of the doubt here, assuming --- they are correct. It is up to the typechecking pass to find any errors. -makeClassHierarchy :: MonadWarn m => ClassHierarchy -> KindEnv -> [HsDecl] -> m ClassHierarchy -makeClassHierarchy (CH ch _is) kt ds = mconcat `liftM` mapM f ds where - f (HsClassDecl sl chead decls) = do - let qualifiedMethodAssumps = concatMap (aHsTypeSigToAssumps kt . qualifyMethod newClassContext) (filter isHsTypeSig decls) - newClassContext = [HsAsst className args] - className = hsClassHead chead - args = [ a | ~(Just a) <- map fromHsTyVar (hsClassHeadArgs chead) ] - return $ classHierarchyFromRecords [ClassRecord { - classArgs, - classAssocs, - classAlias = Nothing, - className = toName ClassName className, - classSrcLoc = sl, - classSupers = [ toName ClassName x | ~(HsAsst x _) <- cntxt], - classAssumps = qualifiedMethodAssumps }] - where - cntxt = hsClassHeadContext chead - classAssocs = createClassAssocs kt decls - (_,(_,classArgs')) = chToClassHead kt chead - classArgs = [ v | ~(TVar v) <- classArgs' ] --- f decl@(HsClassAliasDecl {}) = trace ("makeClassHierarchy: "++show decl) $ do --- tell [ClassAliasRecord { className = toName ClassName (hsDeclName decl), --- classArgs = [v | ~(TVar v) <- map (runIdentity . hsTypeToType kt) (hsDeclTypeArgs decl)], --- classSrcLoc = hsDeclSrcLoc decl, --- classSupers = [toName ClassName n | HsAsst n _ <- (hsDeclContext decl)], --- classClasses = [toName ClassName n | HsAsst n _ <- (hsDeclClasses decl)], --- classInsts = [], --- classMethodMap = Map.empty --- }] - - f decl@(HsInstDecl {}) = hsInstDeclToInst kt decl >>= \insts -> do - return $ foldl (flip addInstanceToHierarchy) mempty insts - f decl@(HsDeclDeriving {}) = hsInstDeclToInst kt decl >>= \insts -> do - return $ foldl (flip addInstanceToHierarchy) mempty insts - f _ = return mempty - -checkForDuplicateInstaces :: MonadWarn m - => ClassHierarchy -- ^ imported class hierarchy - -> ClassHierarchy -- ^ locally defined hierarchy - -> m ClassHierarchy -- ^ possibly simplified local hierarchy -checkForDuplicateInstaces iCh (CH ch is) = mapM_ f (Map.toList is) >> return (CH ch is) where - f (className,is) = do - let is' = findClassInsts iCh className ++ is - sgu = sortGroupUnderFG fst snd [ ((cn,getTypeHead tt), i) | - i@Inst { instSrcLoc = sl, instHead = _ :=> IsIn cn tt } <- is' ] - mapM_ g sgu - g (_,[_]) = return () - g (_,sls) | all instDerived sls = return () - g ((ch,th),sls) = warn (instSrcLoc $ head sls) DuplicateInstances $ - printf "instance (%s (%s ..)) defined multiple times: %s" - (show ch) (show th) (show $ map instSrcLoc sls) - -accLen :: Int -> [[a]] -> [(Int, [a])] -accLen width [] = [] -accLen width (x:xs) = let newWidth = length x + width in (newWidth, x) : accLen newWidth xs - -groupStringsToWidth :: Int -> [String] -> [String] -groupStringsToWidth width ss = groupStringsToWidth' width (accLen 0 ss) where - groupStringsToWidth' :: Int -> [(Int,String)] -> [String] - groupStringsToWidth' width [] = [] - groupStringsToWidth' width xs - = headString : groupStringsToWidth' width (accLen 0 $ map snd rest) - where - (headSegments, rest) - = case span ((<=width).fst) xs of - ([], ss) -> ([head ss], tail ss) - anythingElse -> anythingElse - headString = concatMap snd headSegments - -showListAndSepInWidth :: (a -> String) -> Int -> String -> [a] -> String -showListAndSepInWidth _ _ _ [] = [] -showListAndSepInWidth f width sep things = unlines $ groupStringsToWidth width newThings where - newThings = (map ((\t -> t ++ sep).f) (init things)) ++ [f (last things)] - -pretty :: PPrint Doc a => a -> String -pretty = render . pprint - -{- -nameOfTyCon :: NameType -> HsType -> Name -nameOfTyCon t (HsTyCon n) = toName t n -nameOfTyCon t (HsTyTuple xs) = nameTuple t (length xs) -nameOfTyCon t (HsTyFun _ _) = tc_Arrow -nameOfTyCon _ t = error $ "nameOfTyCon: " ++ show t --} - -groupEquations :: [HsDecl] -> [(Name, HsDecl)] -groupEquations [] = [] -groupEquations (HsTypeDecl {}:ds) = groupEquations ds -groupEquations (d:ds) = (getDeclName d, d) : groupEquations ds - -derivableClasses :: [Name] -derivableClasses = [ - class_Eq, - class_Ord, - class_Enum, - class_Bounded, - class_Show, - class_Read, - class_Ix - ] - --- can be automatically derived when --- the class is an enumeration -enumDerivableClasses :: [Name] -enumDerivableClasses = [ - class_Eq, - class_Ord, - class_Enum, - class_Ix - ] - --- classes that cannot be derived by the generalized --- newtype deriving mechanism. -noNewtypeDerivable :: [Name] -noNewtypeDerivable = [ - class_Show, - class_Read - ] - --- classes that behave identically to their component when they have a single --- unary constructor but are not newtypes -{- -unaryPassDerivable :: [Name] -unaryPassDerivable = [ - class_Ix, - class_Eq, - class_Ord, - class_Bounded - ] --} -{-* Generated by DrIFT : Look, but Don't Touch. *-} -instance Data.Binary.Binary Inst where - put (Inst aa ab ac ad) = do - Data.Binary.put aa - Data.Binary.put ab - Data.Binary.put ac - Data.Binary.put ad - get = do - aa <- get - ab <- get - ac <- get - ad <- get - return (Inst aa ab ac ad) - -instance Data.Binary.Binary AssociatedType where - put (Assoc aa ab ac ad) = do - Data.Binary.put aa - Data.Binary.put ab - Data.Binary.put ac - Data.Binary.put ad - get = do - aa <- get - ab <- get - ac <- get - ad <- get - return (Assoc aa ab ac ad) - -instance Data.Binary.Binary ClassRecord where - put (ClassRecord aa ab ac ad ae af ag) = do - Data.Binary.put aa - Data.Binary.put ab - Data.Binary.put ac - Data.Binary.put ad - Data.Binary.put ae - Data.Binary.put af - Data.Binary.put ag - get = do - aa <- get - ab <- get - ac <- get - ad <- get - ae <- get - af <- get - ag <- get - return (ClassRecord aa ab ac ad ae af ag) - --- Imported from other files :- diff --git a/drift_processed/FrontEnd/HsSyn.hs b/drift_processed/FrontEnd/HsSyn.hs deleted file mode 100644 --- a/drift_processed/FrontEnd/HsSyn.hs +++ /dev/null @@ -1,877 +0,0 @@ -{- Generated by DrIFT (Automatic class derivations for Haskell) -} -{-# LINE 1 "src/FrontEnd/HsSyn.hs" #-} -module FrontEnd.HsSyn where - -import Data.Binary -import Data.Generics - -import C.FFI -import FrontEnd.SrcLoc -import Name.Name -import Name.Names -import Options -import StringTable.Atom -import StringTable.Atom() - -instance HasLocation HsAlt where - srcLoc (HsAlt sl _ _ _) = sl - -instance HasLocation HsExp where - srcLoc (HsCase _ xs) = srcLoc xs - srcLoc (HsExpTypeSig sl _ _) = sl - srcLoc (HsLambda sl _ _) = sl - srcLoc HsError { hsExpSrcLoc = sl } = sl - srcLoc _ = bogusASrcLoc - -hsNameIdent_u f n = mapName (id,f) n -hsIdentString_u f x = f x - -type HsName = Name - -instance Binary Module where - get = do - ps <- get - return (Module $ fromAtom ps) - put (Module n) = put (toAtom n) - -instance HasLocation HsModule where - srcLoc x = hsModuleSrcLoc x - -data HsModule = HsModule { - hsModuleName :: Module, - hsModuleSrcLoc :: SrcLoc, - hsModuleExports :: (Maybe [HsExportSpec]), - hsModuleImports :: [HsImportDecl], - hsModuleDecls :: [HsDecl], - hsModuleOptions :: [String], - hsModuleOpt :: Opt - } - {-! derive: update !-} - --- Export/Import Specifications - -data HsExportSpec - = HsEVar HsName -- variable - | HsEAbs HsName -- T - | HsEThingAll HsName -- T(..) - | HsEThingWith HsName [HsName] -- T(C_1,...,C_n) - | HsEModuleContents Module -- module M (not for imports) - | HsEQualified NameType HsExportSpec -- class Foo, type Bar, kind ANY - deriving(Eq,Show) - -instance HasLocation HsImportDecl where - srcLoc x = hsImportDeclSrcLoc x - -data HsImportDecl = HsImportDecl { - hsImportDeclSrcLoc :: SrcLoc, - hsImportDeclModule :: Module, - hsImportDeclQualified :: !Bool, - hsImportDeclAs :: (Maybe Module), - hsImportDeclSpec :: (Maybe (Bool,[HsExportSpec])) - } - deriving(Eq,Show) - -data HsAssoc = HsAssocNone | HsAssocLeft | HsAssocRight - deriving(Eq,Show) - {-! derive: Binary !-} - -instance HasLocation HsDecl where - srcLoc HsTypeDecl { hsDeclSrcLoc = sl } = sl - srcLoc HsTypeFamilyDecl { hsDeclSrcLoc = sl } = sl - srcLoc HsDeclDeriving { hsDeclSrcLoc = sl } = sl - srcLoc HsSpaceDecl { hsDeclSrcLoc = sl } = sl - srcLoc HsDataDecl { hsDeclSrcLoc = sl } = sl - srcLoc HsInfixDecl { hsDeclSrcLoc = sl } = sl - srcLoc HsPragmaSpecialize { hsDeclSrcLoc = sl } = sl - srcLoc (HsPragmaRules rs) = srcLoc rs - srcLoc HsForeignDecl { hsDeclSrcLoc = sl } = sl - srcLoc HsActionDecl { hsDeclSrcLoc = sl } = sl - srcLoc (HsForeignExport sl _ _ _) = sl - srcLoc (HsClassDecl sl _ _) = sl - srcLoc HsClassAliasDecl { hsDeclSrcLoc = sl } = sl - srcLoc (HsInstDecl sl _ _) = sl - srcLoc (HsDefaultDecl sl _) = sl - srcLoc (HsTypeSig sl _ _) = sl - srcLoc (HsFunBind ms) = srcLoc ms - srcLoc (HsPatBind sl _ _ _) = sl - srcLoc (HsPragmaProps sl _ _) = sl - -instance HasLocation HsRule where - srcLoc HsRule { hsRuleSrcLoc = sl } = sl - -hsDataDecl = HsDataDecl { - hsDeclDeclType = DeclTypeData, - hsDeclSrcLoc = bogusASrcLoc, - hsDeclContext = [], - hsDeclName = error "hsDataDecl.hsDeclName", - hsDeclArgs = [], - hsDeclCons = [], - hsDeclHasKind = Nothing, - hsDeclCTYPE = Nothing, - hsDeclDerives = [] - } - -hsNewTypeDecl = hsDataDecl { - hsDeclDeclType = DeclTypeNewtype, - hsDeclName = error "hsNewTypeDecl.hsDeclName" - } - -data DeclType = DeclTypeData | DeclTypeNewtype | DeclTypeKind - deriving(Eq,Show) - -data HsDecl - = HsTypeFamilyDecl { - hsDeclSrcLoc :: SrcLoc, - hsDeclData :: !Bool, - hsDeclName :: HsName, - hsDeclTArgs :: [HsType], - hsDeclHasKind :: Maybe HsKind - } - | HsTypeDecl { - hsDeclSrcLoc :: SrcLoc, - hsDeclName :: HsName, - hsDeclTArgs :: [HsType], - hsDeclType :: HsType - } - | HsDataDecl { - hsDeclDeclType :: !DeclType, - hsDeclSrcLoc :: SrcLoc, - hsDeclContext :: HsContext, - hsDeclName :: HsName, - hsDeclArgs :: [Name], - hsDeclCons :: [HsConDecl], - hsDeclHasKind :: Maybe HsKind, - hsDeclCTYPE :: Maybe String, - {- deriving -} hsDeclDerives :: [HsName] - } - | HsInfixDecl { - hsDeclSrcLoc :: SrcLoc, - hsDeclAssoc :: HsAssoc, - hsDeclInt :: !Int, - hsDeclNames :: [HsName] - } - | HsClassDecl { - hsDeclSrcLoc :: SrcLoc, - hsDeclClassHead :: HsClassHead, - hsDeclDecls :: [HsDecl] - } - | HsClassAliasDecl { - hsDeclSrcLoc :: SrcLoc, - hsDeclName :: HsName, - hsDeclTypeArgs :: [HsType], - {- rhs -} hsDeclContext :: HsContext, - hsDeclClasses :: HsContext, - hsDeclDecls :: [HsDecl] - } - | HsInstDecl { - hsDeclSrcLoc :: SrcLoc, - hsDeclClassHead :: HsClassHead, - hsDeclDecls :: [HsDecl] - } - | HsDefaultDecl SrcLoc HsType - | HsTypeSig SrcLoc [HsName] HsQualType - | HsFunBind [HsMatch] - | HsPatBind SrcLoc HsPat HsRhs {-where-} [HsDecl] - | HsActionDecl { - hsDeclSrcLoc :: SrcLoc, - hsDeclPat :: HsPat, - hsDeclExp :: HsExp - } - | HsSpaceDecl { - hsDeclSrcLoc :: SrcLoc, - hsDeclName :: HsName, - hsDeclExp :: HsExp, - hsDeclCName :: Maybe String, - hsDeclCount :: Int, - hsDeclQualType :: HsQualType - } - | HsForeignDecl { - hsDeclSrcLoc :: SrcLoc, - hsDeclForeign :: FfiSpec, - hsDeclName :: HsName, - hsDeclQualType :: HsQualType - } - | HsForeignExport { - hsDeclSrcLoc :: SrcLoc, - hsDeclFFIExport :: FfiExport, - hsDeclName :: HsName, - hsDeclQualType ::HsQualType - } - | HsPragmaProps SrcLoc String [HsName] - | HsPragmaRules [HsRule] - | HsPragmaSpecialize { - hsDeclUniq :: (Module,Int), - hsDeclSrcLoc :: SrcLoc, - hsDeclBool :: Bool, - hsDeclName :: HsName, - hsDeclType :: HsType - } - | HsDeclDeriving { - hsDeclSrcLoc :: SrcLoc, - hsDeclClassHead :: HsClassHead - } - deriving(Eq,Show) - {-! derive: is !-} - -data HsRule = HsRule { - hsRuleUniq :: (Module,Int), - hsRuleSrcLoc :: SrcLoc, - hsRuleIsMeta :: Bool, - hsRuleString :: String, - hsRuleFreeVars :: [(HsName,Maybe HsType)], - hsRuleLeftExpr :: HsExp, - hsRuleRightExpr :: HsExp - } - deriving(Eq,Show) - -data HsPragmaExp = HsPragmaExp String [HsExp] - -instance HasLocation HsMatch where - srcLoc (HsMatch sl _ _ _ _) = sl - -data HsMatch = HsMatch { - hsMatchSrcLoc :: SrcLoc, - hsMatchName :: HsName, - hsMatchPats :: [HsPat], - hsMatchRhs :: HsRhs, - {-where-} hsMatchDecls :: [HsDecl] - } - deriving(Eq,Show) - -data HsConDecl - = HsConDecl { - hsConDeclSrcLoc :: SrcLoc, - hsConDeclExists :: [HsTyVarBind], - hsConDeclName :: HsName, - hsConDeclConArg :: [HsBangType] - } - | HsRecDecl { - hsConDeclSrcLoc :: SrcLoc, - hsConDeclExists :: [HsTyVarBind], - hsConDeclName :: HsName, - hsConDeclRecArg :: [([HsName],HsBangType)] - } - deriving(Eq,Show) - {-! derive: is, update !-} - -hsConDeclArgs HsConDecl { hsConDeclConArg = as } = as -hsConDeclArgs HsRecDecl { hsConDeclRecArg = as } = concat [ replicate (length ns) t | (ns,t) <- as] - -data HsBangType - = HsBangedTy { hsBangType :: HsType } - | HsUnBangedTy { hsBangType :: HsType } - deriving(Eq,Show) - -data HsRhs - = HsUnGuardedRhs HsExp - | HsGuardedRhss [HsGuardedRhs] - deriving(Eq,Show) - -data HsGuardedRhs = HsGuardedRhs SrcLoc HsExp HsExp - deriving(Eq,Show) - -data HsQualType = HsQualType { - hsQualTypeContext :: HsContext, - hsQualTypeType :: HsType - } deriving(Data,Typeable,Eq,Ord,Show) - {-! derive: Binary !-} - -type LHsType = Located HsType - -data HsType - = HsTyFun HsType HsType - | HsTyTuple [HsType] - | HsTyUnboxedTuple [HsType] - | HsTyApp HsType HsType - | HsTyVar { hsTypeName :: HsName } - | HsTyCon { hsTypeName :: HsName } - | HsTyForall { - hsTypeVars :: [HsTyVarBind], - hsTypeType :: HsQualType } - | HsTyExists { - hsTypeVars :: [HsTyVarBind], - hsTypeType :: HsQualType } - | HsTyExpKind { - hsTyLType :: LHsType, - hsTyKind :: HsKind } - | HsTyStrictType { - hsTyStrict :: !Bool, - hsTyLType :: LHsType - } - -- the following is used internally - | HsTyAssoc - | HsTyEq HsType HsType - deriving(Data,Typeable,Eq,Ord,Show) - {-! derive: Binary, is !-} - -data HsTyVarBind = HsTyVarBind { - hsTyVarBindSrcLoc :: SrcLoc, - hsTyVarBindName :: HsName, - hsTyVarBindKind :: Maybe HsKind } - deriving(Data,Typeable,Eq,Ord,Show) - {-! derive: Binary, update !-} - -hsTyVarBind = HsTyVarBind { - hsTyVarBindSrcLoc = bogusASrcLoc, - hsTyVarBindName = undefined, - hsTyVarBindKind = Nothing - } - -instance HasLocation HsTyVarBind where - srcLoc = hsTyVarBindSrcLoc - -type HsContext = [HsAsst] - -data HsAsst = HsAsst HsName [HsName] | HsAsstEq HsType HsType - deriving(Data,Typeable,Eq,Ord, Show) - {-! derive: Binary !-} - -data HsLiteral - = HsInt !Integer - | HsChar !Char - | HsString String - | HsFrac Rational - -- GHC unboxed literals: - | HsCharPrim Char - | HsStringPrim String - | HsIntPrim Integer - | HsFloatPrim Rational - | HsDoublePrim Rational - -- GHC extension: - | HsLitLit String - deriving(Eq,Ord, Show) - {-! derive: is !-} - -hsParen x@HsVar {} = x -hsParen x@HsCon {} = x -hsParen x@HsParen {} = x -hsParen x@HsLit {} = x -hsParen x@HsTuple {} = x -hsParen x@HsUnboxedTuple {} = x -hsParen x = HsParen x - -data HsErrorType - = HsErrorPatternFailure - | HsErrorSource - | HsErrorFieldSelect - | HsErrorUnderscore - | HsErrorUninitializedField - | HsErrorRecordUpdate - deriving(Eq,Show) - -type LHsExp = Located HsExp - -data HsExp - = HsVar { {-hsExpSrcSpan :: SrcSpan,-} hsExpName :: HsName } - | HsCon { {-hsExpSrcSpan :: SrcSpan,-} hsExpName :: HsName } - | HsLit HsLiteral - | HsInfixApp HsExp HsExp HsExp - | HsApp HsExp HsExp - | HsNegApp HsExp - | HsLambda SrcLoc [HsPat] HsExp - | HsLet [HsDecl] HsExp - | HsIf HsExp HsExp HsExp - | HsCase HsExp [HsAlt] - | HsDo { hsExpStatements :: [HsStmt] } - | HsTuple [HsExp] - | HsUnboxedTuple [HsExp] - | HsList [HsExp] - | HsParen HsExp - | HsLeftSection HsExp HsExp - | HsRightSection HsExp HsExp - | HsRecConstr HsName [HsFieldUpdate] - | HsRecUpdate HsExp [HsFieldUpdate] - | HsEnumFrom HsExp - | HsEnumFromTo HsExp HsExp - | HsEnumFromThen HsExp HsExp - | HsEnumFromThenTo HsExp HsExp HsExp - | HsListComp HsExp [HsStmt] - | HsExpTypeSig SrcLoc HsExp HsQualType - | HsAsPat { hsExpName :: HsName, hsExpExp :: HsExp } - | HsError { hsExpSrcLoc :: SrcLoc, hsExpErrorType :: HsErrorType, hsExpString :: String } - | HsWildCard SrcLoc - | HsIrrPat { hsExpLExp :: LHsExp } - | HsBangPat { hsExpLExp :: LHsExp } - | HsLocatedExp LHsExp - deriving(Eq,Show) - {-! derive: is, update !-} - -data HsClassHead = HsClassHead { - hsClassHeadContext :: HsContext, - hsClassHead :: HsName, - hsClassHeadArgs :: [HsType] } - deriving(Eq,Show) - {-! derive: update !-} - -type LHsPat = Located HsPat - -data HsPat - = HsPVar { hsPatName :: HsName } - | HsPLit { hsPatLit :: HsLiteral } - | HsPNeg HsPat - | HsPInfixApp HsPat HsName HsPat - | HsPApp { hsPatName :: HsName, hsPatPats :: [HsPat] } - | HsPTuple [HsPat] - | HsPUnboxedTuple [HsPat] - | HsPList [HsPat] - | HsPParen HsPat - | HsPRec HsName [HsPatField] - | HsPAsPat { hsPatName :: HsName, hsPatPat :: HsPat } - | HsPWildCard - | HsPIrrPat { hsPatLPat :: LHsPat } - | HsPBangPat { hsPatLPat :: LHsPat } - | HsPTypeSig SrcLoc HsPat HsQualType -- scoped type variable extension - deriving(Eq,Ord,Show) - {-! derive: is !-} - -data HsPatField = HsPFieldPat HsName HsPat - deriving(Eq,Ord,Show) - -data HsStmt - = HsGenerator SrcLoc HsPat HsExp -- srcloc added by bernie - | HsQualifier HsExp - | HsLetStmt [HsDecl] - deriving(Eq,Show) - -data HsFieldUpdate = HsFieldUpdate HsName HsExp - deriving(Eq,Show) - -data HsAlt = HsAlt SrcLoc HsPat HsRhs [HsDecl] - deriving(Eq,Show) - -data HsKind = HsKind HsName | HsKindFn HsKind HsKind - deriving(Data,Typeable,Eq,Ord,Show) - {-! derive: Binary !-} - -hsKindStar = HsKind s_Star -hsKindHash = HsKind s_Hash -hsKindBang = HsKind s_Bang -hsKindQuest = HsKind s_Quest -hsKindQuestQuest = HsKind s_QuestQuest -hsKindStarBang = HsKind s_StarBang -{-* Generated by DrIFT : Look, but Don't Touch. *-} -hsModuleDecls_u f r@HsModule{hsModuleDecls = x} = r{hsModuleDecls = f x} -hsModuleExports_u f r@HsModule{hsModuleExports = x} = r{hsModuleExports = f x} -hsModuleImports_u f r@HsModule{hsModuleImports = x} = r{hsModuleImports = f x} -hsModuleName_u f r@HsModule{hsModuleName = x} = r{hsModuleName = f x} -hsModuleOpt_u f r@HsModule{hsModuleOpt = x} = r{hsModuleOpt = f x} -hsModuleOptions_u f r@HsModule{hsModuleOptions = x} = r{hsModuleOptions = f x} -hsModuleSrcLoc_u f r@HsModule{hsModuleSrcLoc = x} = r{hsModuleSrcLoc = f x} -hsModuleDecls_s v = hsModuleDecls_u (const v) -hsModuleExports_s v = hsModuleExports_u (const v) -hsModuleImports_s v = hsModuleImports_u (const v) -hsModuleName_s v = hsModuleName_u (const v) -hsModuleOpt_s v = hsModuleOpt_u (const v) -hsModuleOptions_s v = hsModuleOptions_u (const v) -hsModuleSrcLoc_s v = hsModuleSrcLoc_u (const v) - -instance Data.Binary.Binary HsAssoc where - put HsAssocNone = do - Data.Binary.putWord8 0 - put HsAssocLeft = do - Data.Binary.putWord8 1 - put HsAssocRight = do - Data.Binary.putWord8 2 - get = do - h <- Data.Binary.getWord8 - case h of - 0 -> do - return HsAssocNone - 1 -> do - return HsAssocLeft - 2 -> do - return HsAssocRight - _ -> fail "invalid binary data found" - -isHsTypeFamilyDecl (HsTypeFamilyDecl _ _ _ _ _) = True -isHsTypeFamilyDecl _ = False -isHsTypeDecl (HsTypeDecl _ _ _ _) = True -isHsTypeDecl _ = False -isHsDataDecl (HsDataDecl _ _ _ _ _ _ _ _ _) = True -isHsDataDecl _ = False -isHsInfixDecl (HsInfixDecl _ _ _ _) = True -isHsInfixDecl _ = False -isHsClassDecl (HsClassDecl _ _ _) = True -isHsClassDecl _ = False -isHsClassAliasDecl (HsClassAliasDecl _ _ _ _ _ _) = True -isHsClassAliasDecl _ = False -isHsInstDecl (HsInstDecl _ _ _) = True -isHsInstDecl _ = False -isHsDefaultDecl (HsDefaultDecl _ _) = True -isHsDefaultDecl _ = False -isHsTypeSig (HsTypeSig _ _ _) = True -isHsTypeSig _ = False -isHsFunBind (HsFunBind _) = True -isHsFunBind _ = False -isHsPatBind (HsPatBind _ _ _ _) = True -isHsPatBind _ = False -isHsActionDecl (HsActionDecl _ _ _) = True -isHsActionDecl _ = False -isHsSpaceDecl (HsSpaceDecl _ _ _ _ _ _) = True -isHsSpaceDecl _ = False -isHsForeignDecl (HsForeignDecl _ _ _ _) = True -isHsForeignDecl _ = False -isHsForeignExport (HsForeignExport _ _ _ _) = True -isHsForeignExport _ = False -isHsPragmaProps (HsPragmaProps _ _ _) = True -isHsPragmaProps _ = False -isHsPragmaRules (HsPragmaRules _) = True -isHsPragmaRules _ = False -isHsPragmaSpecialize (HsPragmaSpecialize _ _ _ _ _) = True -isHsPragmaSpecialize _ = False -isHsDeclDeriving (HsDeclDeriving _ _) = True -isHsDeclDeriving _ = False - -isHsConDecl (HsConDecl _ _ _ _) = True -isHsConDecl _ = False -isHsRecDecl (HsRecDecl _ _ _ _) = True -isHsRecDecl _ = False - -hsConDeclConArg_u f r@HsConDecl{hsConDeclConArg = x} = r{hsConDeclConArg = f x} -hsConDeclConArg_u _ x = x -hsConDeclExists_u f r@HsConDecl{hsConDeclExists = x} = r{hsConDeclExists = f x} -hsConDeclExists_u f r@HsRecDecl{hsConDeclExists = x} = r{hsConDeclExists = f x} -hsConDeclName_u f r@HsConDecl{hsConDeclName = x} = r{hsConDeclName = f x} -hsConDeclName_u f r@HsRecDecl{hsConDeclName = x} = r{hsConDeclName = f x} -hsConDeclRecArg_u f r@HsRecDecl{hsConDeclRecArg = x} = r{hsConDeclRecArg = f x} -hsConDeclRecArg_u _ x = x -hsConDeclSrcLoc_u f r@HsConDecl{hsConDeclSrcLoc = x} = r{hsConDeclSrcLoc = f x} -hsConDeclSrcLoc_u f r@HsRecDecl{hsConDeclSrcLoc = x} = r{hsConDeclSrcLoc = f x} -hsConDeclConArg_s v = hsConDeclConArg_u (const v) -hsConDeclExists_s v = hsConDeclExists_u (const v) -hsConDeclName_s v = hsConDeclName_u (const v) -hsConDeclRecArg_s v = hsConDeclRecArg_u (const v) -hsConDeclSrcLoc_s v = hsConDeclSrcLoc_u (const v) - -instance Data.Binary.Binary HsQualType where - put (HsQualType aa ab) = do - Data.Binary.put aa - Data.Binary.put ab - get = do - aa <- get - ab <- get - return (HsQualType aa ab) - -instance Data.Binary.Binary HsType where - put (HsTyFun aa ab) = do - Data.Binary.putWord8 0 - Data.Binary.put aa - Data.Binary.put ab - put (HsTyTuple ac) = do - Data.Binary.putWord8 1 - Data.Binary.put ac - put (HsTyUnboxedTuple ad) = do - Data.Binary.putWord8 2 - Data.Binary.put ad - put (HsTyApp ae af) = do - Data.Binary.putWord8 3 - Data.Binary.put ae - Data.Binary.put af - put (HsTyVar ag) = do - Data.Binary.putWord8 4 - Data.Binary.put ag - put (HsTyCon ah) = do - Data.Binary.putWord8 5 - Data.Binary.put ah - put (HsTyForall ai aj) = do - Data.Binary.putWord8 6 - Data.Binary.put ai - Data.Binary.put aj - put (HsTyExists ak al) = do - Data.Binary.putWord8 7 - Data.Binary.put ak - Data.Binary.put al - put (HsTyExpKind am an) = do - Data.Binary.putWord8 8 - Data.Binary.put am - Data.Binary.put an - put (HsTyStrictType ao ap) = do - Data.Binary.putWord8 9 - Data.Binary.put ao - Data.Binary.put ap - put HsTyAssoc = do - Data.Binary.putWord8 10 - put (HsTyEq aq ar) = do - Data.Binary.putWord8 11 - Data.Binary.put aq - Data.Binary.put ar - get = do - h <- Data.Binary.getWord8 - case h of - 0 -> do - aa <- Data.Binary.get - ab <- Data.Binary.get - return (HsTyFun aa ab) - 1 -> do - ac <- Data.Binary.get - return (HsTyTuple ac) - 2 -> do - ad <- Data.Binary.get - return (HsTyUnboxedTuple ad) - 3 -> do - ae <- Data.Binary.get - af <- Data.Binary.get - return (HsTyApp ae af) - 4 -> do - ag <- Data.Binary.get - return (HsTyVar ag) - 5 -> do - ah <- Data.Binary.get - return (HsTyCon ah) - 6 -> do - ai <- Data.Binary.get - aj <- Data.Binary.get - return (HsTyForall ai aj) - 7 -> do - ak <- Data.Binary.get - al <- Data.Binary.get - return (HsTyExists ak al) - 8 -> do - am <- Data.Binary.get - an <- Data.Binary.get - return (HsTyExpKind am an) - 9 -> do - ao <- Data.Binary.get - ap <- Data.Binary.get - return (HsTyStrictType ao ap) - 10 -> do - return HsTyAssoc - 11 -> do - aq <- Data.Binary.get - ar <- Data.Binary.get - return (HsTyEq aq ar) - _ -> fail "invalid binary data found" - -isHsTyFun (HsTyFun _ _) = True -isHsTyFun _ = False -isHsTyTuple (HsTyTuple _) = True -isHsTyTuple _ = False -isHsTyUnboxedTuple (HsTyUnboxedTuple _) = True -isHsTyUnboxedTuple _ = False -isHsTyApp (HsTyApp _ _) = True -isHsTyApp _ = False -isHsTyVar (HsTyVar _) = True -isHsTyVar _ = False -isHsTyCon (HsTyCon _) = True -isHsTyCon _ = False -isHsTyForall (HsTyForall _ _) = True -isHsTyForall _ = False -isHsTyExists (HsTyExists _ _) = True -isHsTyExists _ = False -isHsTyExpKind (HsTyExpKind _ _) = True -isHsTyExpKind _ = False -isHsTyStrictType (HsTyStrictType _ _) = True -isHsTyStrictType _ = False -isHsTyAssoc (HsTyAssoc) = True -isHsTyAssoc _ = False -isHsTyEq (HsTyEq _ _) = True -isHsTyEq _ = False - -instance Data.Binary.Binary HsTyVarBind where - put (HsTyVarBind aa ab ac) = do - Data.Binary.put aa - Data.Binary.put ab - Data.Binary.put ac - get = do - aa <- get - ab <- get - ac <- get - return (HsTyVarBind aa ab ac) - -hsTyVarBindKind_u f r@HsTyVarBind{hsTyVarBindKind = x} = r{hsTyVarBindKind = f x} -hsTyVarBindName_u f r@HsTyVarBind{hsTyVarBindName = x} = r{hsTyVarBindName = f x} -hsTyVarBindSrcLoc_u f r@HsTyVarBind{hsTyVarBindSrcLoc = x} = r{hsTyVarBindSrcLoc = f x} -hsTyVarBindKind_s v = hsTyVarBindKind_u (const v) -hsTyVarBindName_s v = hsTyVarBindName_u (const v) -hsTyVarBindSrcLoc_s v = hsTyVarBindSrcLoc_u (const v) - -instance Data.Binary.Binary HsAsst where - put (HsAsst aa ab) = do - Data.Binary.putWord8 0 - Data.Binary.put aa - Data.Binary.put ab - put (HsAsstEq ac ad) = do - Data.Binary.putWord8 1 - Data.Binary.put ac - Data.Binary.put ad - get = do - h <- Data.Binary.getWord8 - case h of - 0 -> do - aa <- Data.Binary.get - ab <- Data.Binary.get - return (HsAsst aa ab) - 1 -> do - ac <- Data.Binary.get - ad <- Data.Binary.get - return (HsAsstEq ac ad) - _ -> fail "invalid binary data found" - -isHsInt (HsInt _) = True -isHsInt _ = False -isHsChar (HsChar _) = True -isHsChar _ = False -isHsString (HsString _) = True -isHsString _ = False -isHsFrac (HsFrac _) = True -isHsFrac _ = False -isHsCharPrim (HsCharPrim _) = True -isHsCharPrim _ = False -isHsStringPrim (HsStringPrim _) = True -isHsStringPrim _ = False -isHsIntPrim (HsIntPrim _) = True -isHsIntPrim _ = False -isHsFloatPrim (HsFloatPrim _) = True -isHsFloatPrim _ = False -isHsDoublePrim (HsDoublePrim _) = True -isHsDoublePrim _ = False -isHsLitLit (HsLitLit _) = True -isHsLitLit _ = False - -isHsVar (HsVar _) = True -isHsVar _ = False -isHsCon (HsCon _) = True -isHsCon _ = False -isHsLit (HsLit _) = True -isHsLit _ = False -isHsInfixApp (HsInfixApp _ _ _) = True -isHsInfixApp _ = False -isHsApp (HsApp _ _) = True -isHsApp _ = False -isHsNegApp (HsNegApp _) = True -isHsNegApp _ = False -isHsLambda (HsLambda _ _ _) = True -isHsLambda _ = False -isHsLet (HsLet _ _) = True -isHsLet _ = False -isHsIf (HsIf _ _ _) = True -isHsIf _ = False -isHsCase (HsCase _ _) = True -isHsCase _ = False -isHsDo (HsDo _) = True -isHsDo _ = False -isHsTuple (HsTuple _) = True -isHsTuple _ = False -isHsUnboxedTuple (HsUnboxedTuple _) = True -isHsUnboxedTuple _ = False -isHsList (HsList _) = True -isHsList _ = False -isHsParen (HsParen _) = True -isHsParen _ = False -isHsLeftSection (HsLeftSection _ _) = True -isHsLeftSection _ = False -isHsRightSection (HsRightSection _ _) = True -isHsRightSection _ = False -isHsRecConstr (HsRecConstr _ _) = True -isHsRecConstr _ = False -isHsRecUpdate (HsRecUpdate _ _) = True -isHsRecUpdate _ = False -isHsEnumFrom (HsEnumFrom _) = True -isHsEnumFrom _ = False -isHsEnumFromTo (HsEnumFromTo _ _) = True -isHsEnumFromTo _ = False -isHsEnumFromThen (HsEnumFromThen _ _) = True -isHsEnumFromThen _ = False -isHsEnumFromThenTo (HsEnumFromThenTo _ _ _) = True -isHsEnumFromThenTo _ = False -isHsListComp (HsListComp _ _) = True -isHsListComp _ = False -isHsExpTypeSig (HsExpTypeSig _ _ _) = True -isHsExpTypeSig _ = False -isHsAsPat (HsAsPat _ _) = True -isHsAsPat _ = False -isHsError (HsError _ _ _) = True -isHsError _ = False -isHsWildCard (HsWildCard _) = True -isHsWildCard _ = False -isHsIrrPat (HsIrrPat _) = True -isHsIrrPat _ = False -isHsBangPat (HsBangPat _) = True -isHsBangPat _ = False -isHsLocatedExp (HsLocatedExp _) = True -isHsLocatedExp _ = False - -hsExpErrorType_u f r@HsError{hsExpErrorType = x} = r{hsExpErrorType = f x} -hsExpErrorType_u _ x = x -hsExpExp_u f r@HsAsPat{hsExpExp = x} = r{hsExpExp = f x} -hsExpExp_u _ x = x -hsExpLExp_u f r@HsBangPat{hsExpLExp = x} = r{hsExpLExp = f x} -hsExpLExp_u f r@HsIrrPat{hsExpLExp = x} = r{hsExpLExp = f x} -hsExpLExp_u _ x = x -hsExpName_u f r@HsAsPat{hsExpName = x} = r{hsExpName = f x} -hsExpName_u f r@HsCon{hsExpName = x} = r{hsExpName = f x} -hsExpName_u f r@HsVar{hsExpName = x} = r{hsExpName = f x} -hsExpName_u _ x = x -hsExpSrcLoc_u f r@HsError{hsExpSrcLoc = x} = r{hsExpSrcLoc = f x} -hsExpSrcLoc_u _ x = x -hsExpStatements_u f r@HsDo{hsExpStatements = x} = r{hsExpStatements = f x} -hsExpStatements_u _ x = x -hsExpString_u f r@HsError{hsExpString = x} = r{hsExpString = f x} -hsExpString_u _ x = x -hsExpErrorType_s v = hsExpErrorType_u (const v) -hsExpExp_s v = hsExpExp_u (const v) -hsExpLExp_s v = hsExpLExp_u (const v) -hsExpName_s v = hsExpName_u (const v) -hsExpSrcLoc_s v = hsExpSrcLoc_u (const v) -hsExpStatements_s v = hsExpStatements_u (const v) -hsExpString_s v = hsExpString_u (const v) - -hsClassHead_u f r@HsClassHead{hsClassHead = x} = r{hsClassHead = f x} -hsClassHeadArgs_u f r@HsClassHead{hsClassHeadArgs = x} = r{hsClassHeadArgs = f x} -hsClassHeadContext_u f r@HsClassHead{hsClassHeadContext = x} = r{hsClassHeadContext = f x} -hsClassHead_s v = hsClassHead_u (const v) -hsClassHeadArgs_s v = hsClassHeadArgs_u (const v) -hsClassHeadContext_s v = hsClassHeadContext_u (const v) - -isHsPVar (HsPVar _) = True -isHsPVar _ = False -isHsPLit (HsPLit _) = True -isHsPLit _ = False -isHsPNeg (HsPNeg _) = True -isHsPNeg _ = False -isHsPInfixApp (HsPInfixApp _ _ _) = True -isHsPInfixApp _ = False -isHsPApp (HsPApp _ _) = True -isHsPApp _ = False -isHsPTuple (HsPTuple _) = True -isHsPTuple _ = False -isHsPUnboxedTuple (HsPUnboxedTuple _) = True -isHsPUnboxedTuple _ = False -isHsPList (HsPList _) = True -isHsPList _ = False -isHsPParen (HsPParen _) = True -isHsPParen _ = False -isHsPRec (HsPRec _ _) = True -isHsPRec _ = False -isHsPAsPat (HsPAsPat _ _) = True -isHsPAsPat _ = False -isHsPWildCard (HsPWildCard) = True -isHsPWildCard _ = False -isHsPIrrPat (HsPIrrPat _) = True -isHsPIrrPat _ = False -isHsPBangPat (HsPBangPat _) = True -isHsPBangPat _ = False -isHsPTypeSig (HsPTypeSig _ _ _) = True -isHsPTypeSig _ = False - -instance Data.Binary.Binary HsKind where - put (HsKind aa) = do - Data.Binary.putWord8 0 - Data.Binary.put aa - put (HsKindFn ab ac) = do - Data.Binary.putWord8 1 - Data.Binary.put ab - Data.Binary.put ac - get = do - h <- Data.Binary.getWord8 - case h of - 0 -> do - aa <- Data.Binary.get - return (HsKind aa) - 1 -> do - ab <- Data.Binary.get - ac <- Data.Binary.get - return (HsKindFn ab ac) - _ -> fail "invalid binary data found" - --- Imported from other files :- diff --git a/drift_processed/FrontEnd/KindInfer.hs b/drift_processed/FrontEnd/KindInfer.hs deleted file mode 100644 --- a/drift_processed/FrontEnd/KindInfer.hs +++ /dev/null @@ -1,633 +0,0 @@ -{- Generated by DrIFT (Automatic class derivations for Haskell) -} -{-# LINE 1 "src/FrontEnd/KindInfer.hs" #-} -{-# OPTIONS -funbox-strict-fields #-} --- | --- This module implements the Kind Inference algorithm, and the routines which --- use the product of kind inference to convert haskell source types into the --- simplified kind annotated types used by the rest of the FrontEnd. - -module FrontEnd.KindInfer ( - kiDecls, - KindEnv(), - hsQualTypeToSigma, - hsAsstToPred, - kiHsQualType, - kindOfClass, - kindOf, - restrictKindEnv, - hsTypeToType, - getConstructorKinds - ) where - -import Control.Monad.Identity -import Control.Monad.Reader -import Control.Monad.Writer -import Data.Binary -import Data.Generics(Typeable, everything, mkQ) -import Data.IORef -import Data.List -import System.IO.Unsafe -import Util.Inst() -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.Traversable as T - -import Doc.DocLike -import Doc.PPrint -import FrontEnd.HsSyn -import FrontEnd.SrcLoc -import FrontEnd.Tc.Kind -import FrontEnd.Tc.Type -import FrontEnd.Utils -import FrontEnd.Warning -import Name.Name -import Options -import Support.FreeVars -import Support.MapBinaryInstance -import Util.ContextMonad -import Util.HasSize -import qualified FlagDump as FD -import qualified Util.Seq as Seq - -data KindEnv = KindEnv { - kindEnv :: Map.Map Name Kind, - kindEnvAssocs :: Map.Map Name (Int,Int), - kindEnvClasses :: Map.Map Name [Kind] - } deriving(Typeable,Show) - {-!derive: Monoid !-} - -instance Binary KindEnv where - put KindEnv { kindEnv = a, kindEnvAssocs = b, kindEnvClasses = c } = - putMap a >> putMap b >> putMap c - get = do - a <- getMap - b <- getMap - c <- getMap - return KindEnv { kindEnv = a, kindEnvAssocs = b, kindEnvClasses = c } - -instance HasSize KindEnv where - size KindEnv { kindEnv = env } = size env - -instance FreeVars Kind (Set.Set Kindvar) where - freeVars (KVar kindvar) = Set.singleton kindvar - freeVars (kind1 `Kfun` kind2) = freeVars kind1 `Set.union` freeVars kind2 - freeVars KBase {} = mempty - -instance DocLike d => PPrint d KindEnv where - pprint KindEnv { kindEnv = m, kindEnvAssocs = ev, kindEnvClasses = cs } = vcat $ - [ pprint x <+> text "=>" <+> pprint y | (x,y) <- Map.toList m] ++ - [ text "associated type" <+> pprint n <+> pprint ab | (n,ab) <- Map.toList ev] ++ - [ text "class" <+> pprint n <+> pprint ab | (n,ab) <- Map.toList cs] ++ - [empty] - --------------------------------------------------------------------------------- - --- The kind inference monad - -data KiWhere = InClass | InInstance | Other - deriving(Eq) - -data KiEnv = KiEnv { - kiSrcLoc :: SrcLoc, - kiContext :: [String], - kiEnv :: !(IORef KindEnv), - kiWhere :: !KiWhere, - kiVarnum :: !(IORef Int) - } - -newtype Ki a = Ki (ReaderT KiEnv IO a) - deriving(Monad,MonadReader KiEnv,MonadIO,Functor,MonadWarn) - -instance MonadSrcLoc Ki where - getSrcLoc = asks kiSrcLoc -instance MonadSetSrcLoc Ki where - withSrcLoc sl = local (\s -> s { kiSrcLoc = sl }) - -restrictKindEnv :: (Name -> Bool) -> KindEnv -> KindEnv -restrictKindEnv f ke = ke { kindEnv = Map.filterWithKey (\k _ -> f k) (kindEnv ke) } - -findKind :: MonadIO m => Kind -> m Kind -findKind tv@(KVar Kindvar {kvarRef = r, kvarConstraint = con }) = liftIO $ do - rt <- readIORef r - case rt of - Nothing - | con == KindStar -> writeIORef r (Just kindStar) >> return kindStar - | otherwise -> return tv - Just t -> do - t' <- findKind t - writeIORef r (Just t') - return t' -findKind tv = return tv - --- useful operations in the inference monad - -runKI :: KindEnv -> Ki a -> IO a -runKI env (Ki ki) = (kienv >>= ki') where - kienv = do - env <- newIORef env - varnum <- newIORef 0 - return KiEnv { - kiSrcLoc = bogusASrcLoc, - kiContext = [], - kiEnv = env, - kiVarnum = varnum, - kiWhere = Other } - ki' e = runReaderT ki e - -instance ContextMonad Ki where - type ContextOf Ki = String - withContext nc x = local (\s -> s { kiContext = nc :kiContext s }) x - -getEnv :: Ki KindEnv -getEnv = do asks kiEnv >>= liftIO . readIORef - -unify :: Kind -> Kind -> Ki () -unify k1 k2 = do - k1 <- flattenKind k1 - k2 <- flattenKind k2 - printRule $ "unify:" <+> pprint k1 <+> text "<->" <+> pprint k2 - mgu k1 k2 - -mgu :: Kind -> Kind -> Ki () -mgu (KBase a) (KBase b) | a == b = return () -mgu (Kfun a b) (Kfun a' b') = do - unify a a' - unify b b' -mgu (KVar u) k = varBind u k -mgu k (KVar u) = varBind u k -mgu k1 k2 = addWarn UnificationError $ - "kind unification error, attempt to unify (" ++ show k1 ++ ") with (" ++ show k2 ++ ")" - -varBind :: Kindvar -> Kind -> Ki () -varBind u k = do - k <- flattenKind k - printRule $ "varBind:" <+> pprint u <+> text ":=" <+> pprint k - if k == KVar u then return () else do - when (u `Set.member` freeVars k) $ addWarn OccursCheck $ "occurs check failed in kind inference: " ++ show u ++ " := " ++ show k - v <- liftIO $ readIORef (kvarRef u) - case v of - Just v -> fail $ "varBind unfree" - Nothing -> do - liftIO $ writeIORef (kvarRef u) (Just k) - constrain (kvarConstraint u) k - -zonkConstraint :: KindConstraint -> Kindvar -> Ki () -zonkConstraint nk mv = do - let fk = mappend nk (kvarConstraint mv) - if fk == kvarConstraint mv then return () else do - nref <- liftIO $ newIORef Nothing - let nmv = mv { kvarConstraint = fk, kvarRef = nref } - liftIO $ modifyIORef (kvarRef mv) (\Nothing -> Just $ KVar nmv) - -constrain KindAny k = return () -constrain KindStar (KBase Star) = return () -constrain KindQuest k@KBase {} = kindCombine kindFunRet k >> return () -constrain KindQuestQuest (KBase KQuest) = fail "cannot constrain ? to be ??" -constrain KindQuestQuest k@KBase {} = kindCombine kindArg k >> return () -constrain KindSimple (KBase Star) = return () -constrain KindSimple (a `Kfun` b) = do - a <- findKind a - b <- findKind b - constrain KindSimple a - constrain KindSimple b -constrain con (KVar v) = zonkConstraint con v -constrain con k = fail $ "constraining kind: " ++ show (con,k) - -flattenKind :: Kind -> Ki Kind -flattenKind k = f' k where - f (a `Kfun` b) = return Kfun `ap` f' a `ap` f' b - f k = return k - f' k = findKind k >>= f - -newKindVar :: KindConstraint -> Ki Kindvar -newKindVar con = do - KiEnv { kiVarnum = vr } <- ask - liftIO $ do - n <- readIORef vr - writeIORef vr $! (n + 1) - nr <- newIORef Nothing - return Kindvar { kvarUniq = n, kvarRef = nr, kvarConstraint = con } - -lookupKind :: KindConstraint -> Name -> Ki Kind -lookupKind con name = do - KindEnv { kindEnv = env } <- getEnv - case Map.lookup name env of - Just k -> do - k <- f k - k <- findKind k - constrain con k - findKind k - Nothing -> do - kv <- newKindVar con - extendEnv mempty { kindEnv = Map.singleton name (KVar kv) } - return (KVar kv) - where - -- ?? and ? aren't *really* kinds - f (KBase KQuestQuest) = liftM KVar $ newKindVar KindQuestQuest - f (KBase KQuest) = liftM KVar $ newKindVar KindQuest - f k@(KBase _) = return k - f (Kfun k1 k2) = liftM2 Kfun (f k1) (f k2) - f k@(KVar _) = return k - -extendEnv :: KindEnv -> Ki () -extendEnv newEnv = do - ref <- asks kiEnv - liftIO $ modifyIORef ref (mappend newEnv) -- (\ (KindEnv env x) -> KindEnv (env `Map.union` newEnv) (nx `mappend` x)) - -getConstructorKinds :: KindEnv -> Map.Map Name Kind -getConstructorKinds ke = kindEnv ke -- Map.fromList [ (toName TypeConstructor x,y) | (x,y)<- Map.toList m] - --------------------------------------------------------------------------------- - --- kind inference proper --- this is what gets called from outside of this module - -printRule :: String -> Ki () -printRule s - | dump FD.KindSteps = liftIO $ putStrLn s - | otherwise = return () - -{-# NOINLINE kiDecls #-} -kiDecls :: KindEnv -> [HsDecl] -> IO KindEnv -kiDecls inputEnv classAndDataDecls = ans where - ans = do - ke <- run - return ke -- TODO (Map.fromList (concatMap kgAssocs kindGroups) `mappend` as)) - run = runKI inputEnv $ withContext ("kiDecls: " ++ show (map getDeclName classAndDataDecls)) $ do - kiInitClasses classAndDataDecls - mapM_ kiDecl classAndDataDecls - getEnv >>= postProcess - -postProcess ke = do - kindEnv <- T.mapM flattenKind (kindEnv ke) - kindEnvClasses <- T.mapM (mapM flattenKind) (kindEnvClasses ke) - let defs = Set.toList (freeVars (Map.elems kindEnv,Map.elems kindEnvClasses)) - printRule $ "defaulting the following kinds: " ++ pprint defs - mapM_ (flip varBind kindStar) defs - kindEnv <- T.mapM flattenKind kindEnv - kindEnvClasses <- T.mapM (mapM flattenKind) kindEnvClasses - return ke { kindEnvClasses = kindEnvClasses, kindEnv = kindEnv } - -kiType,kiType' :: Kind -> HsType -> Ki () -kiType' k t = do - k <- findKind k - kiType k t - -kiType k (HsTyTuple ts) = do - unify kindStar k - mapM_ (kiType' kindStar) ts -kiType k (HsTyUnboxedTuple ts) = do - unify kindUTuple k - flip mapM_ ts $ \t -> do - kt <- newKindVar KindQuestQuest - kiType (KVar kt) t -kiType k (HsTyFun a b) = do - unify kindStar k - ka <- newKindVar KindQuestQuest - kb <- newKindVar KindQuest - kiType (KVar ka) a - kiType (KVar kb) b -kiType k (HsTyApp a b) = do - kv <- newKindVar KindAny - kiType (KVar kv `Kfun` k) a - kiType' (KVar kv) b -kiType k (HsTyVar v) = do - kv <- lookupKind KindAny (toName TypeVal v) - unify k kv -kiType k (HsTyCon v) = do - kv <- lookupKind KindAny (toName TypeConstructor v) - unify k kv -kiType k HsTyAssoc = do - constrain KindSimple k -kiType _ HsTyEq {} = error "kiType.HsTyEq" -kiType k HsTyForall { hsTypeVars = vs, hsTypeType = HsQualType con t } = do - mapM_ initTyVarBind vs - mapM_ kiPred con - kiType' k t -kiType k HsTyExpKind { hsTyLType = Located _ t, hsTyKind = ek } = do - unify (hsKindToKind ek) k - kiType' k t -kiType k HsTyExists { hsTypeVars = vs, hsTypeType = HsQualType con t } = do - mapM_ initTyVarBind vs - mapM_ kiPred con - kiType' k t -kiType _ _ = error "KindInfer.kiType: bad." - -initTyVarBind HsTyVarBind { hsTyVarBindName = name, hsTyVarBindKind = kk } = do - nk <- lookupKind KindSimple (toName TypeVal name) - case kk of - Nothing -> return () - Just kk -> unify nk (hsKindToKind kk) - -hsKindToKind (HsKindFn a b) = hsKindToKind a `Kfun` hsKindToKind b -hsKindToKind a | a == hsKindStar = kindStar - | a == hsKindHash = kindHash - | a == hsKindQuest = kindFunRet - | a == hsKindQuestQuest = kindArg -hsKindToKind (HsKind n) = KBase (KNamed (toName SortName n)) --- hsKindToKind (HsKind n) = toName SortName n - -kiApps :: Kind -> [HsType] -> Kind -> Ki () -kiApps ca args fk = f ca args fk where - f ca [] fk = unify ca fk - f (x `Kfun` y) (a:as) fk = do - kiType' x a - y <- findKind y - f y as fk - f (KVar var) as fk = do - x <- newKindVar KindAny - y <- newKindVar KindAny - let nv = (KVar x `Kfun` KVar y) - varBind var nv - f nv as fk - f _ _ _ = error "KindInfer.kiApps: bad." - -kiApps' :: Kind -> [Kind] -> Kind -> Ki () -kiApps' ca args fk = f ca args fk where - f ca [] fk = unify ca fk - f (x `Kfun` y) (a:as) fk = do - unify a x - y <- findKind y - f y as fk - f (KVar var) as fk = do - x <- newKindVar KindAny - y <- newKindVar KindAny - let nv = (KVar x `Kfun` KVar y) - varBind var nv - f nv as fk - f _ _ _ = error "KindInfer.kiApps': bad." - -kiPred :: HsAsst -> Ki () -kiPred asst@(HsAsst n ns) = do - env <- getEnv - let f k n = do - k' <- lookupKind KindAny (toName TypeVal n) - unify k k' - case Map.lookup n (kindEnvClasses env) of - Nothing -> do - addWarn (UndefinedName n) ("Incorrect number of class parameters for " ++ show asst) --- ,fail $ "unknown class: " ++ show asst - Just ks -> do - when (length ks /= length ns) $ - addWarn InvalidDecl ("Incorrect number of class parameters for " ++ show n) - zipWithM_ f ks ns -kiPred (HsAsstEq a b) = do - mv <- newKindVar KindSimple - kiType (KVar mv) a - kiType' (KVar mv) b - --- first pass over declarations adds classes to environment. -kiInitClasses :: [HsDecl] -> Ki () -kiInitClasses ds = do mapM_ kiInitDecl ds - -kiInitDecl :: HsDecl -> Ki () -kiInitDecl d = withSrcLoc (srcLoc d) (f d) where - f HsClassDecl { .. } = do - args <- mapM (\_ -> newKindVar KindAny) (hsClassHeadArgs hsDeclClassHead) - extendEnv mempty { kindEnvClasses = - Map.singleton (hsClassHead hsDeclClassHead) (map KVar args) } - f _ = return () -kiDecl :: HsDecl -> Ki () -kiDecl d = withSrcLoc (srcLoc d) (f d) where - varLike HsTyVar {} = True - varLike HsTyExpKind { hsTyLType = Located _ t } = varLike t - varLike _ = False - consLike (HsTyFun a b) = varLike a && varLike b - consLike (HsTyTuple ts) = all varLike ts - consLike t = case fromHsTypeApp t of - (HsTyCon {},as) -> all varLike as - _ -> False - f HsTypeFamilyDecl { .. } = do - kc <- lookupKind KindSimple (toName TypeConstructor hsDeclName) - kiApps kc hsDeclTArgs (maybe kindStar hsKindToKind hsDeclHasKind) - f HsDataDecl { hsDeclDeclType = DeclTypeKind, .. } = kiDataKind hsDeclName hsDeclCons - f HsDataDecl { - hsDeclContext = context, - hsDeclName = tyconName, - hsDeclArgs = args, - hsDeclCons = [], - hsDeclHasKind = Just kk } = do - args <- mapM (lookupKind KindSimple . toName TypeVal) args - kc <- lookupKind KindAny (toName TypeConstructor tyconName) - kiApps' kc args (hsKindToKind kk) - mapM_ kiPred context - f HsDataDecl { hsDeclDeclType = DeclTypeNewtype, .. } = kiAlias hsDeclContext hsDeclName hsDeclArgs (head hsDeclCons) - f HsDataDecl { .. } = kiData hsDeclContext hsDeclName hsDeclArgs hsDeclCons - f HsTypeDecl { hsDeclName = name, hsDeclTArgs = args, hsDeclType = ty } = do - wh <- asks kiWhere - let theconstraint = if wh == Other then KindAny else KindSimple - kc <- lookupKind theconstraint (toName TypeConstructor name) - mv <- newKindVar theconstraint - kiApps kc args (KVar mv) - kiType' (KVar mv) ty - f (HsTypeSig _ _ (HsQualType ps t)) = do - mapM_ kiPred ps - kiType kindStar t - f (HsClassDecl _sloc HsClassHead { .. } sigsAndDefaults) = do - when (length hsClassHeadArgs /= 1) $ - addWarn UnsupportedFeature "Multi-parameter type classes not supported" - unless (all varLike hsClassHeadArgs) $ - addWarn InvalidDecl "Class parameters must be variables" - env <- getEnv - let ks = kindOfClass hsClassHead env - [fromHsTyVar -> Just classArg] = hsClassHeadArgs - zipWithM_ kiType' ks hsClassHeadArgs - mapM_ kiPred hsClassHeadContext - let rn = Seq.toList $ everything (Seq.<>) (mkQ Seq.empty g) newClassBodies - newClassBodies = map typeFromSig $ filter isHsTypeSig sigsAndDefaults - typeFromSig (HsTypeSig _sloc _names qualType) = qualType - typeFromSig _ = error "KindInfer.typeFromSig: bad." - g (HsTyVar n') | hsNameToOrig n' == hsNameToOrig classArg = Seq.single (toName TypeVal n') - g _ = Seq.empty - carg <- lookupKind KindSimple (toName TypeVal classArg) - mapM_ (\n -> lookupKind KindSimple n >>= unify carg ) rn - local (\e -> e { kiWhere = InClass }) $ mapM_ kiDecl sigsAndDefaults - f HsDeclDeriving { hsDeclClassHead = ch } = checkInstance ch - f HsInstDecl { hsDeclClassHead = ch } = checkInstance ch - f _ = return () - checkInstance HsClassHead { .. } = do - unless (all consLike hsClassHeadArgs) $ - addWarn InvalidDecl "Instance parameters must be of the form 'C v1 v2'" - mapM_ kiPred hsClassHeadContext - env <- getEnv - let ks = kindOfClass hsClassHead env - when (length ks /= length hsClassHeadArgs) $ - addWarn InvalidDecl "Incorrect number of class parameters in instance head" - zipWithM_ kiType' ks hsClassHeadArgs - -- HsQualType contxt (HsTyApp (HsTyCon _className) (HsTyVar classArg)) = qualType - -- ans = do - -- carg <- lookupKind KindSimple (toName TypeVal classArg) - -- mapM_ kiPred contxt --- extendEnv mempty { kindEnvAssocs = Map.fromList assocs } --- mapM_ (\n -> lookupKind KindSimple n >>= unify carg ) rn --- local (\e -> e { kiWhere = InClass }) $ mapM_ kiDecl sigsAndDefaults - --- numClassArgs = 1 --- newAssocs = [ (name,[ n | ~(HsTyVar n) <- names],t,names) | HsTypeDecl _sloc name names t <- sigsAndDefaults ] --- assocs = [ (toName TypeConstructor n,(numClassArgs,length names - numClassArgs)) | (n,names,_,_) <- newAssocs ] --- rn = Seq.toList $ everything (Seq.<>) (mkQ Seq.empty f) (newClassBodies,newAssocs) --- newClassBodies = map typeFromSig $ filter isHsTypeSig sigsAndDefaults --- f (HsTyVar n') | hsNameToOrig n' == hsNameToOrig classArg = Seq.single (toName TypeVal n') --- f _ = Seq.empty --- typeFromSig :: HsDecl -> HsQualType --- typeFromSig (HsTypeSig _sloc _names qualType) = qualType - -fromHsTypeApp t = f t [] where - f (HsTyApp a b) rs = f a (b:rs) - f t rs = (t,rs) - -kiAlias context tyconName args condecl = do - args <- mapM (lookupKind KindSimple . toName TypeVal) args - kc <- lookupKind KindAny (toName TypeConstructor tyconName) - let [a] = hsConDeclArgs condecl - va <- newKindVar KindQuestQuest - kiApps' kc args (KVar va) - kiType (KVar va) (hsBangType a) - mapM_ kiPred context - -kiData context tyconName args condecls = do - args <- mapM (lookupKind KindSimple . toName TypeVal) args - kc <- lookupKind KindSimple (toName TypeConstructor tyconName) - kiApps' kc args kindStar - mapM_ kiPred context - flip mapM_ (concatMap (map hsBangType . hsConDeclArgs) condecls) $ \t -> do - v <- newKindVar KindQuestQuest - kiType (KVar v) t - -kiDataKind tyconName condecls = do - unless (nameType tyconName == SortName) $ fail "tycon isn't sort" - flip mapM_ condecls $ \ HsConDecl { .. } -> do - kc <- lookupKind KindAny (toName TypeConstructor hsConDeclName) - let args = [ KBase (KNamed t) | HsTyCon t <- map hsBangType hsConDeclConArg ] - kiApps' kc args (KBase (KNamed tyconName)) - -kiHsQualType :: KindEnv -> HsQualType -> KindEnv -kiHsQualType inputEnv qualType@(HsQualType ps t) = newState where - newState = unsafePerformIO $ runKI inputEnv $ withContext ("kiHsQualType: " ++ show qualType) $ do - kiType kindStar t - mapM_ kiPred ps - getEnv >>= postProcess - --------------------------------------------------------------------------------- - -kindOf :: Name -> KindEnv -> Kind -kindOf name KindEnv { kindEnv = env } = case Map.lookup name env of --- Nothing | nameType name `elem` [TypeConstructor,TypeVal] -> kindStar - Just k -> k - _ -> error $ "kindOf: could not find kind of : " ++ show (nameType name,name) - -kindOfClass :: Name -> KindEnv -> [Kind] -kindOfClass name KindEnv { kindEnvClasses = cs } = case Map.lookup name cs of - --Nothing -> Star - --Nothing -> error $ "kindOf: could not find kind of class : " ++ show (nameType name,name) - Nothing -> [] -- error $ "kindOf: could not find kind of class : " ++ show (nameType name,name) - Just k -> k - ----------------------- --- Conversion of Types ----------------------- - -fromTyApp t = f t [] where - f (HsTyApp a b) rs = f a (b:rs) - f t rs = (t,rs) - -aHsTypeToType :: KindEnv -> HsType -> Type -aHsTypeToType kt@KindEnv { kindEnvAssocs = at } t | (HsTyCon con,xs) <- fromTyApp t, let nn = toName TypeConstructor con, Just (n1,n2) <- Map.lookup nn at = - TAssoc { - typeCon = Tycon nn (kindOf nn kt), - typeClassArgs = map (aHsTypeToType kt) (take n1 xs), - typeExtraArgs = map (aHsTypeToType kt) (take n2 $ drop n1 xs) - } -aHsTypeToType kt (HsTyFun t1 t2) = aHsTypeToType kt t1 `fn` aHsTypeToType kt t2 -aHsTypeToType kt HsTyExpKind { hsTyLType = Located _ t } = aHsTypeToType kt t -aHsTypeToType kt tuple@(HsTyTuple types) = tTTuple $ map (aHsTypeToType kt) types -aHsTypeToType kt tuple@(HsTyUnboxedTuple types) = tTTuple' $ map (aHsTypeToType kt) types -aHsTypeToType kt (HsTyApp t1 t2) = tAp (aHsTypeToType kt t1) (aHsTypeToType kt t2) - --- variables, we must know the kind of the variable here! --- they are assumed to already exist in the kindInfoTable --- which was generated by the process of KindInference - -aHsTypeToType kt (HsTyVar name) = TVar $ toTyvar kt name -- tyvar name (kindOf name kt) Nothing - --- type constructors, we must know the kind of the constructor. --- here we also qualify the type constructor if it is --- currently unqualified - -aHsTypeToType kt (HsTyCon name) = TCon $ Tycon nn (kindOf nn kt) where - nn = (toName TypeConstructor name) - -aHsTypeToType kt (HsTyForall vs qt) = TForAll (map (toTyvar kt . hsTyVarBindName) vs) (aHsQualTypeToQualType kt qt) -aHsTypeToType kt (HsTyExists vs qt) = TExists (map (toTyvar kt . hsTyVarBindName) vs) (aHsQualTypeToQualType kt qt) - -aHsTypeToType _ t = error $ "aHsTypeToType: " ++ show t - -toTyvar kt name = tyvar nn (kindOf nn kt) where - nn = toName TypeVal name - -aHsQualTypeToQualType :: KindEnv -> HsQualType -> Qual Type -aHsQualTypeToQualType kt (HsQualType cntxt t) = map (hsAsstToPred kt) cntxt :=> aHsTypeToType kt t - -hsAsstToPred :: KindEnv -> HsAsst -> Pred -hsAsstToPred kt (HsAsst className [varName]) - -- = IsIn className (TVar $ Tyvar varName (kindOf varName kt)) - | isConstructorLike varName = IsIn (toName ClassName className) (TCon (Tycon (toName TypeConstructor varName) (head $ kindOfClass (toName ClassName className) kt))) - | otherwise = IsIn (toName ClassName className) (TVar $ tyvar (toName TypeVal varName) (head $ kindOfClass (toName ClassName className) kt)) -hsAsstToPred kt (HsAsstEq t1 t2) = IsEq (runIdentity $ hsTypeToType' kt t1) (runIdentity $ hsTypeToType' kt t2) -hsAsstToPred _ _ = error "KindInfer.hsAsstToPred: bad." - -hsQualTypeToSigma kt qualType = hsQualTypeToType kt (Just []) qualType - -hsTypeToType :: Monad m => KindEnv -> HsType -> m Type -hsTypeToType kt t = return $ unsafePerformIO $ runKI kt $ - do kv <- newKindVar KindAny - kiType (KVar kv) t - kt' <- postProcess =<< getEnv - hsTypeToType' kt' t - -hsTypeToType' :: Monad m => KindEnv -> HsType -> m Type -hsTypeToType' kt t = return $ hoistType $ aHsTypeToType kt t -- (forallHoist t) - -hsQualTypeToType :: Monad m => - KindEnv -- ^ the kind environment - -> Maybe [HsName] -- ^ universally quantify free variables excepting those in list. - -> HsQualType -- ^ the type to convert - -> m Sigma -hsQualTypeToType kindEnv qs qualType = return $ hoistType $ tForAll quantOver ( ps' :=> t') where - newEnv = kiHsQualType kindEnv qualType - --newEnv = kindEnv - Just t' = hsTypeToType' newEnv (hsQualTypeType qualType) - ps = hsQualTypeContext qualType - ps' = map (hsAsstToPred newEnv) ps - quantOver = nub $ freeVars ps' ++ fvs - fvs = case qs of - Nothing -> [] - Just xs -> [ v | v <- freeVars t', nameName (tyvarName v) `notElem` xs] - -hoistType :: Type -> Type -hoistType t = f t where - f t@TVar {} = t - f t@TCon {} = t - f t@TMetaVar {} = t - f t@TAssoc {} = t { typeClassArgs = map f (typeClassArgs t), typeExtraArgs = map f (typeExtraArgs t) } - f (TAp a b) = TAp (f a) (f b) - f (TForAll vs (ps :=> (f -> nt))) - | (TForAll vs' (ps' :=> t')) <- nt = f $ TForAll (vs ++ vs') ((ps ++ ps') :=> t') - | otherwise = TForAll vs (ps :=> nt) - f (TExists vs (ps :=> (f -> nt))) - | (TExists vs' (ps' :=> t')) <- nt = f $ TExists (vs ++ vs') ((ps ++ ps') :=> t') - | otherwise = TExists vs (ps :=> nt) - f (TArrow (f -> na) (f -> nb)) - | TForAll vs (ps :=> t) <- nb = f $ TForAll vs (ps :=> TArrow na t) - | TExists vs (ps :=> t) <- na = f $ TForAll vs (ps :=> TArrow t nb) - | otherwise = TArrow na nb - -fromHsTyVar (HsTyVar v) = return v -fromHsTyVar (HsTyExpKind (Located _ t) _) = fromHsTyVar t -fromHsTyVar _ = fail "fromHsTyVar" -{-* Generated by DrIFT : Look, but Don't Touch. *-} -instance Monoid KindEnv where - mempty = KindEnv mempty mempty mempty - mappend (KindEnv aa ab ac) (KindEnv aa' ab' ac') = KindEnv (mappend aa aa')(mappend ab ab')(mappend ac ac') - --- Imported from other files :- diff --git a/drift_processed/FrontEnd/Representation.hs b/drift_processed/FrontEnd/Representation.hs deleted file mode 100644 --- a/drift_processed/FrontEnd/Representation.hs +++ /dev/null @@ -1,459 +0,0 @@ -{- Generated by DrIFT (Automatic class derivations for Haskell) -} -{-# LINE 1 "src/FrontEnd/Representation.hs" #-} -module FrontEnd.Representation( - Type(..), - Tyvar(..), - tyvar, - Tycon(..), - fn, - Pred(..), - Qual(..), - Class, - tForAll, - tExists, - MetaVarType(..), - prettyPrintType, - fromTAp, - fromTArrow, - tassocToAp, - MetaVar(..), - tTTuple, - tTTuple', - tList, - tArrow, - tAp - )where - -import Control.Monad.Identity -import Data.IORef - -import Data.Binary -import Doc.DocLike -import Doc.PPrint -import FrontEnd.Tc.Kind -import Name.Name -import Name.Names -import Name.VConsts -import Support.CanType -import Support.Unparse -import Util.VarName - --- Types - -data MetaVarType = Tau | Rho | Sigma - deriving(Eq,Ord) - {-! derive: Binary !-} - -data Type = TVar { typeVar :: !Tyvar } - | TCon { typeCon :: !Tycon } - | TAp Type Type - | TArrow Type Type - | TForAll { typeArgs :: [Tyvar], typeBody :: (Qual Type) } - | TExists { typeArgs :: [Tyvar], typeBody :: (Qual Type) } - | TMetaVar { metaVar :: MetaVar } - | TAssoc { typeCon :: !Tycon, typeClassArgs :: [Type], typeExtraArgs :: [Type] } - deriving(Ord,Show) - {-! derive: Binary !-} - --- | metavars are used in type checking -data MetaVar = MetaVar { - metaUniq :: {-# UNPACK #-} !Int, - metaKind :: Kind, - metaRef :: {-# UNPACK #-} !(IORef (Maybe Type)), - metaType :: !MetaVarType - } - {-! derive: Binary !-} - -instance Eq MetaVar where - a == b = metaUniq a == metaUniq b - -instance Ord MetaVar where - compare a b = compare (metaUniq a) (metaUniq b) - -instance TypeNames Type where - tBool = TCon (Tycon tc_Bool kindStar) - tString = TAp tList tChar - tChar = TCon (Tycon tc_Char kindStar) - tUnit = TCon (Tycon tc_Unit kindStar) - tCharzh = TCon (Tycon tc_Char_ kindHash) - -instance Ord (IORef a) -instance Binary (IORef a) where - put = error "Binary.put: not impl." - get = error "Binary.get: not impl." - -tList :: Type -tList = TCon (Tycon tc_List (Kfun kindStar kindStar)) - --- | The @(->)@ type constructor. Invariant: @tArrow@ shall not be fully applied. To this end, see 'tAp'. -tArrow :: Type -tArrow = TCon (Tycon tc_Arrow (kindArg `Kfun` (kindFunRet `Kfun` kindStar))) - --- | Type application, enforcing the invariant that there be no fully-applied 'tArrow's -tAp :: Type -> Type -> Type -tAp (TAp c@TCon{} a) b | c == tArrow = TArrow a b -tAp a b = TAp a b - -instance Eq Type where - (TVar a) == (TVar b) = a == b - (TMetaVar a) == (TMetaVar b) = a == b - (TCon a) == (TCon b) = a == b - (TAp a' a) == (TAp b' b) = a' == b' && b == a - (TArrow a' a) == (TArrow b' b) = a' == b' && b == a - _ == _ = False - -tassocToAp TAssoc { typeCon = con, typeClassArgs = cas, typeExtraArgs = eas } = foldl tAp (TCon con) (cas ++ eas) -tassocToAp _ = error "Representation.tassocToAp: bad." - --- Unquantified type variables - -data Tyvar = Tyvar { tyvarName :: {-# UNPACK #-} !Name, tyvarKind :: Kind } - {- derive: Binary -} - -instance Show Tyvar where - showsPrec _ Tyvar { tyvarName = hn, tyvarKind = k } = shows hn . ("::" ++) . shows k - -tForAll [] ([] :=> t) = t -tForAll vs (ps :=> TForAll vs' (ps' :=> t)) = tForAll (vs ++ vs') ((ps ++ ps') :=> t) -tForAll x y = TForAll x y - -tExists [] ([] :=> t) = t -tExists vs (ps :=> TExists vs' (ps' :=> t)) = tExists (vs ++ vs') ((ps ++ ps') :=> t) -tExists x y = TExists x y - -tyvar n k = Tyvar n k - -instance Eq Tyvar where - Tyvar { tyvarName = x } == Tyvar { tyvarName = y } = x == y - Tyvar { tyvarName = x } /= Tyvar { tyvarName = y } = x /= y - -instance Ord Tyvar where - compare (Tyvar { tyvarName = x }) (Tyvar { tyvarName = y }) = compare x y - (Tyvar { tyvarName = x }) <= (Tyvar { tyvarName = y }) = x <= y - (Tyvar { tyvarName = x }) >= (Tyvar { tyvarName = y }) = x >= y - (Tyvar { tyvarName = x }) < (Tyvar { tyvarName = y }) = x < y - (Tyvar { tyvarName = x }) > (Tyvar { tyvarName = y }) = x > y - --- Type constructors - -data Tycon = Tycon { tyconName :: Name, tyconKind :: Kind } - deriving(Eq, Show,Ord) - {-! derive: Binary !-} - -instance ToTuple Tycon where - toTuple n = Tycon (nameTuple TypeConstructor n) (foldr Kfun kindStar $ replicate n kindStar) -instance ToTuple Type where - toTuple n = TCon $ toTuple n - -instance DocLike d => PPrint d Tycon where - pprint (Tycon i _) = pprint i - -infixr 4 `fn` -fn :: Type -> Type -> Type -a `fn` b = TArrow a b - --------------------------------------------------------------------------------- - --- Predicates -data Pred = IsIn Class Type | IsEq Type Type - deriving(Show, Eq,Ord) - {-! derive: Binary !-} - --- Qualified entities -data Qual t = [Pred] :=> t - deriving(Show, Eq,Ord) - {-! derive: Binary !-} - -instance (DocLike d,PPrint d t) => PPrint d (Qual t) where - pprint ([] :=> r) = pprint r - pprint ([x] :=> r) = pprint x <+> text "=>" <+> pprint r - pprint (xs :=> r) = tupled (map pprint xs) <+> text "=>" <+> pprint r - -instance DocLike d => PPrint d Tyvar where - pprint tv = tshow (tyvarName tv) - -instance Binary Tyvar where - put (Tyvar aa ab) = do - put aa - put ab - get = do - aa <- get - ab <- get - return (Tyvar aa ab) - -instance DocLike d => PPrint d Module where - pprint (Module s) = tshow s - -withNewNames ts action = subVarName $ do - ts' <- mapM newTyvarName ts - action ts' - -newTyvarName t = case tyvarKind t of - x@(KBase Star) -> newLookupName (map (:[]) ['a' ..]) x t - y@(KBase Star `Kfun` KBase Star) -> newLookupName (map (('f':) . show) [0 :: Int ..]) y t - z@(KBase KUTuple) -> newLookupName (map (('u':) . show) [0 :: Int ..]) z t - z@(KBase KQuest) -> newLookupName (map (('q':) . show) [0 :: Int ..]) z t - z@(KBase KQuestQuest) -> newLookupName (map (('q':) . ('q':) . show) [0 :: Int ..]) z t - z -> newLookupName (map (('t':) . show) [0 :: Int ..]) z t - -prettyPrintType :: DocLike d => Type -> d -prettyPrintType = pprint - -instance DocLike d => PPrint d Type where - pprintAssoc _ n t = prettyPrintTypePrec n t - -prettyPrintTypePrec :: DocLike d => Int -> Type -> d -prettyPrintTypePrec n t = unparse $ zup (runIdentity (runVarNameT (f t))) where - zup = if n >= 10 then pop empty else id - arr = bop (R,0) (space <> text "->" <> space) - app = bop (L,100) (text " ") - fp (IsIn cn t) = do - t' <- f t - return (atom (text $ show cn) `app` t') - fp (IsEq t1 t2) = do - t1' <- f t1 - t2' <- f t2 - return (atom (parens $ unparse t1' <+> text "=" <+> unparse t2')) - f (TForAll [] ([] :=> t)) = f t - f (TForAll vs (ps :=> t)) = do - withNewNames vs $ \ts' -> do - t' <- f t - ps' <- mapM fp ps - return $ case ps' of - [] -> fixitize (N,-3) $ pop (text "forall" <+> hsep (map text ts') <+> text ". ") (atomize t') - [p] -> fixitize (N,-3) $ pop (text "forall" <+> hsep (map text ts') <+> text "." <+> unparse p <+> text "=> ") (atomize t') - ps -> fixitize (N,-3) $ pop (text "forall" <+> hsep (map text ts') <+> text "." <+> tupled (map unparse ps) <+> text "=> ") (atomize t') - f (TExists [] ([] :=> t)) = f t - f (TExists vs (ps :=> t)) = do - withNewNames vs $ \ts' -> do - t' <- f t - ps' <- mapM fp ps - return $ case ps' of - [] -> fixitize (N,-3) $ pop (text "exists" <+> hsep (map text ts') <+> text ". ") (atomize t') - [p] -> fixitize (N,-3) $ pop (text "exists" <+> hsep (map text ts') <+> text "." <+> unparse p <+> text "=> ") (atomize t') - ps -> fixitize (N,-3) $ pop (text "exists" <+> hsep (map text ts') <+> text "." <+> tupled (map unparse ps) <+> text "=> ") (atomize t') - f (TCon tycon) = return $ atom (pprint tycon) - f (TVar tyvar) = do - vo <- maybeLookupName tyvar - case vo of - Just c -> return $ atom $ text c - Nothing -> return $ atom $ tshow (tyvarName tyvar) - f (TAp (TCon (Tycon n _)) x) | n == tc_List = do - x <- f x - return $ atom (char '[' <> unparse x <> char ']') - f TAssoc { typeCon = con, typeClassArgs = cas, typeExtraArgs = eas } = do - let x = atom (pprint con) - xs <- mapM f (cas ++ eas) - return $ foldl app x xs - f ta@(TAp {}) | (TCon (Tycon c _),xs) <- fromTAp ta, Just _ <- fromTupname c = do - xs <- mapM f xs - return $ atom (tupled (map unparse xs)) - f (TAp t1 t2) = do - t1 <- f t1 - t2 <- f t2 - return $ t1 `app` t2 - f (TArrow t1 t2) = do - t1 <- f t1 - t2 <- f t2 - return $ t1 `arr` t2 - f (TMetaVar mv) = return $ atom $ pprint mv - --f tv = return $ atom $ parens $ text ("FrontEnd.Tc.Type.pp: " ++ show tv) - -instance DocLike d => PPrint d MetaVarType where - pprint t = case t of - Tau -> char 't' - Rho -> char 'r' - Sigma -> char 's' - -instance DocLike d => PPrint d Pred where - pprint (IsIn c t) = tshow c <+> pprintParen t - pprint (IsEq t1 t2) = parens $ prettyPrintType t1 <+> text "=" <+> prettyPrintType t2 - -instance DocLike d => PPrint d MetaVar where - pprint MetaVar { metaUniq = u, metaKind = k, metaType = t } - | KBase Star <- k = pprint t <> tshow u - | otherwise = parens $ pprint t <> tshow u <> text " :: " <> pprint k - -instance Show MetaVarType where - show mv = pprint mv - -instance Show MetaVar where - show mv = pprint mv - -fromTAp t = f t [] where - f (TAp a b) rs = f a (b:rs) - f t rs = (t,rs) - -fromTArrow t = f t [] where - f (TArrow a b) rs = f b (a:rs) - f t rs = (reverse rs,t) - -instance CanType MetaVar where - type TypeOf MetaVar = Kind - getType mv = metaKind mv - -instance CanType Tycon where - type TypeOf Tycon = Kind - getType (Tycon _ k) = k - -instance CanType Tyvar where - type TypeOf Tyvar = Kind - getType = tyvarKind - -instance CanType Type where - type TypeOf Type = Kind - getType (TCon tc) = getType tc - getType (TVar u) = getType u - getType typ@(TAp t _) = case (getType t) of - (Kfun _ k) -> k - x -> error $ "Representation.getType: kind error in: " ++ (show typ) - getType (TArrow _l _r) = kindStar - getType (TForAll _ (_ :=> t)) = getType t - getType (TExists _ (_ :=> t)) = getType t - getType (TMetaVar mv) = getType mv - getType ta@TAssoc {} = getType (tassocToAp ta) - -tTTuple ts | length ts < 2 = error "tTTuple" -tTTuple ts = foldl TAp (toTuple (length ts)) ts - -tTTuple' ts = foldl TAp (TCon $ Tycon (unboxedNameTuple TypeConstructor n) (foldr Kfun kindUTuple $ replicate n kindStar)) ts where - n = length ts -{-* Generated by DrIFT : Look, but Don't Touch. *-} -instance Data.Binary.Binary MetaVarType where - put Tau = do - Data.Binary.putWord8 0 - put Rho = do - Data.Binary.putWord8 1 - put Sigma = do - Data.Binary.putWord8 2 - get = do - h <- Data.Binary.getWord8 - case h of - 0 -> do - return Tau - 1 -> do - return Rho - 2 -> do - return Sigma - _ -> fail "invalid binary data found" - -instance Data.Binary.Binary Type where - put (TVar aa) = do - Data.Binary.putWord8 0 - Data.Binary.put aa - put (TCon ab) = do - Data.Binary.putWord8 1 - Data.Binary.put ab - put (TAp ac ad) = do - Data.Binary.putWord8 2 - Data.Binary.put ac - Data.Binary.put ad - put (TArrow ae af) = do - Data.Binary.putWord8 3 - Data.Binary.put ae - Data.Binary.put af - put (TForAll ag ah) = do - Data.Binary.putWord8 4 - Data.Binary.put ag - Data.Binary.put ah - put (TExists ai aj) = do - Data.Binary.putWord8 5 - Data.Binary.put ai - Data.Binary.put aj - put (TMetaVar ak) = do - Data.Binary.putWord8 6 - Data.Binary.put ak - put (TAssoc al am an) = do - Data.Binary.putWord8 7 - Data.Binary.put al - Data.Binary.put am - Data.Binary.put an - get = do - h <- Data.Binary.getWord8 - case h of - 0 -> do - aa <- Data.Binary.get - return (TVar aa) - 1 -> do - ab <- Data.Binary.get - return (TCon ab) - 2 -> do - ac <- Data.Binary.get - ad <- Data.Binary.get - return (TAp ac ad) - 3 -> do - ae <- Data.Binary.get - af <- Data.Binary.get - return (TArrow ae af) - 4 -> do - ag <- Data.Binary.get - ah <- Data.Binary.get - return (TForAll ag ah) - 5 -> do - ai <- Data.Binary.get - aj <- Data.Binary.get - return (TExists ai aj) - 6 -> do - ak <- Data.Binary.get - return (TMetaVar ak) - 7 -> do - al <- Data.Binary.get - am <- Data.Binary.get - an <- Data.Binary.get - return (TAssoc al am an) - _ -> fail "invalid binary data found" - -instance Data.Binary.Binary MetaVar where - put (MetaVar aa ab ac ad) = do - Data.Binary.put aa - Data.Binary.put ab - Data.Binary.put ac - Data.Binary.put ad - get = do - aa <- get - ab <- get - ac <- get - ad <- get - return (MetaVar aa ab ac ad) - -instance Data.Binary.Binary Tycon where - put (Tycon aa ab) = do - Data.Binary.put aa - Data.Binary.put ab - get = do - aa <- get - ab <- get - return (Tycon aa ab) - -instance Data.Binary.Binary Pred where - put (IsIn aa ab) = do - Data.Binary.putWord8 0 - Data.Binary.put aa - Data.Binary.put ab - put (IsEq ac ad) = do - Data.Binary.putWord8 1 - Data.Binary.put ac - Data.Binary.put ad - get = do - h <- Data.Binary.getWord8 - case h of - 0 -> do - aa <- Data.Binary.get - ab <- Data.Binary.get - return (IsIn aa ab) - 1 -> do - ac <- Data.Binary.get - ad <- Data.Binary.get - return (IsEq ac ad) - _ -> fail "invalid binary data found" - -instance (Data.Binary.Binary t) => Data.Binary.Binary (Qual t) where - put ((:=>) aa ab) = do - Data.Binary.put aa - Data.Binary.put ab - get = do - aa <- get - ab <- get - return ((:=>) aa ab) - --- Imported from other files :- diff --git a/drift_processed/FrontEnd/SrcLoc.hs b/drift_processed/FrontEnd/SrcLoc.hs deleted file mode 100644 --- a/drift_processed/FrontEnd/SrcLoc.hs +++ /dev/null @@ -1,168 +0,0 @@ -{- Generated by DrIFT (Automatic class derivations for Haskell) -} -{-# LINE 1 "src/FrontEnd/SrcLoc.hs" #-} -module FrontEnd.SrcLoc where - -import Control.Applicative -import Control.Monad.Identity -import Control.Monad.Writer -import Data.Foldable -import Data.Traversable -import Data.Binary -import Data.Generics - -import PackedString - -data SrcLoc = SrcLoc { - srcLocFileName :: PackedString, - srcLocLine :: {-# UNPACK #-} !Int, - srcLocColumn :: {-# UNPACK #-} !Int - } - deriving(Data,Typeable,Eq,Ord) - {-! derive: update, Binary !-} - -data SrcSpan = SrcSpan { srcSpanBegin :: !SrcLoc, srcSpanEnd :: !SrcLoc } - deriving(Data,Typeable,Eq,Ord) - {-! derive: update, Binary !-} - --- Useful bogus file names used to indicate where non file based errors are. -fileNameCommandLine = packString "(command line)" -fileNameUnknown = packString "(unknown)" -fileNameGenerated = packString "(generated)" - -bogusASrcLoc = SrcLoc fileNameUnknown (-1) (-1) -bogusSrcSpan = SrcSpan bogusASrcLoc bogusASrcLoc - -instance Monoid SrcLoc where - mempty = bogusASrcLoc - mappend a b - | a == bogusASrcLoc = b - | otherwise = a - --------------------- --- haslocation class --------------------- - -class HasLocation a where - srcLoc :: a -> SrcLoc - srcSpan :: a -> SrcSpan - srcSpan x = bogusSrcSpan { srcSpanBegin = slx, srcSpanEnd = slx } where slx = srcLoc x - srcLoc x = srcSpanBegin (srcSpan x) - -instance HasLocation a => HasLocation [a] where - srcLoc xs = mconcat (map srcLoc xs) - -instance HasLocation SrcLoc where - srcLoc x = x - -instance HasLocation SrcSpan where - srcSpan x = x - -instance HasLocation (SrcLoc,SrcLoc) where - srcSpan (x,y) = SrcSpan x y - -instance HasLocation (Located a) where - srcSpan (Located x _) = x - -data Located x = Located SrcSpan x - deriving(Ord,Show,Data,Typeable,Eq) - {-! derive: Binary !-} - -fromLocated :: Located x -> x -fromLocated (Located _ x) = x - -instance Functor Located where - fmap f (Located l x) = Located l (f x) - -instance Foldable Located where - foldMap f (Located l x) = f x - -instance Traversable Located where - traverse f (Located l x) = Located l <$> f x - -located ss x = Located (srcSpan ss) x - ------------------------ --- srcloc monad classes ------------------------ - -class Monad m => MonadSrcLoc m where - getSrcLoc :: m SrcLoc - getSrcSpan :: m SrcSpan - getSrcSpan = getSrcLoc >>= return . srcSpan - getSrcLoc = getSrcSpan >>= return . srcLoc - -class MonadSrcLoc m => MonadSetSrcLoc m where - withSrcLoc :: SrcLoc -> m a -> m a - withSrcSpan :: SrcSpan -> m a -> m a - withSrcLoc sl a = withSrcSpan (srcSpan sl) a - withSrcSpan ss a = withSrcLoc (srcLoc ss) a - -withLocation :: (HasLocation l,MonadSetSrcLoc m) => l -> m a -> m a -withLocation l = withSrcSpan (srcSpan l) - -instance Monoid w => MonadSrcLoc (Writer w) where - getSrcLoc = return mempty -instance Monoid w => MonadSetSrcLoc (Writer w) where - withSrcLoc _ a = a - -instance MonadSrcLoc Identity where - getSrcLoc = return mempty -instance MonadSetSrcLoc Identity where - withSrcLoc _ a = a - ------------------ --- show instances ------------------ - -instance Show SrcLoc where - show (SrcLoc fn l c) = unpackPS fn ++ f l ++ f c where - f (-1) = "" - f n = ':':show n - -instance Show SrcSpan where - show SrcSpan { srcSpanBegin = sl1, srcSpanEnd = sl2 } - | sl1 == sl2 = show sl1 - | otherwise = show sl1 ++ "-" ++ show sl2 -{-* Generated by DrIFT : Look, but Don't Touch. *-} -srcLocColumn_u f r@SrcLoc{srcLocColumn = x} = r{srcLocColumn = f x} -srcLocFileName_u f r@SrcLoc{srcLocFileName = x} = r{srcLocFileName = f x} -srcLocLine_u f r@SrcLoc{srcLocLine = x} = r{srcLocLine = f x} -srcLocColumn_s v = srcLocColumn_u (const v) -srcLocFileName_s v = srcLocFileName_u (const v) -srcLocLine_s v = srcLocLine_u (const v) - -instance Data.Binary.Binary SrcLoc where - put (SrcLoc aa ab ac) = do - Data.Binary.put aa - Data.Binary.put ab - Data.Binary.put ac - get = do - aa <- get - ab <- get - ac <- get - return (SrcLoc aa ab ac) - -srcSpanBegin_u f r@SrcSpan{srcSpanBegin = x} = r{srcSpanBegin = f x} -srcSpanEnd_u f r@SrcSpan{srcSpanEnd = x} = r{srcSpanEnd = f x} -srcSpanBegin_s v = srcSpanBegin_u (const v) -srcSpanEnd_s v = srcSpanEnd_u (const v) - -instance Data.Binary.Binary SrcSpan where - put (SrcSpan aa ab) = do - Data.Binary.put aa - Data.Binary.put ab - get = do - aa <- get - ab <- get - return (SrcSpan aa ab) - -instance (Data.Binary.Binary x) => Data.Binary.Binary (Located x) where - put (Located aa ab) = do - Data.Binary.put aa - Data.Binary.put ab - get = do - aa <- get - ab <- get - return (Located aa ab) - --- Imported from other files :- diff --git a/drift_processed/FrontEnd/Tc/Kind.hs b/drift_processed/FrontEnd/Tc/Kind.hs deleted file mode 100644 --- a/drift_processed/FrontEnd/Tc/Kind.hs +++ /dev/null @@ -1,229 +0,0 @@ -{- Generated by DrIFT (Automatic class derivations for Haskell) -} -{-# LINE 1 "src/FrontEnd/Tc/Kind.hs" #-} -module FrontEnd.Tc.Kind( - Kind(..), - KBase(..), - Kindvar(..), - KindConstraint(..), - kindCombine, - kindStar, - kindUTuple, - kindFunRet, - kindHash, - kindArg, - isSubsumedBy, - unfoldKind - ) where - -import Control.Monad -import Data.IORef -import Data.Monoid - -import Data.Binary -import Doc.DocLike -import Doc.PPrint(pprint,pprintPrec,pprintAssoc,Assoc(..),PPrint,pprintBinary) -import Name.Name - -{- - - KQuest = ? star or hash or unboxed tuple - KQuestQuest = ?? star or hash - KUTuple = (#) unboxed tuple - Star = * boxed value - KHash = # unboxed value - Kfun = (->) - KNamed Foo = Foo named kind - - we have the following subkinding going on - - ? - / \ - ?? (#) - /\ - * # - -in addition, user defined named kinds are allowed. these can only occur via -kind annotations, and only unify with themselves - --} - -data KBase = - Star - | KHash - | KUTuple - | KQuestQuest - | KQuest - | KNamed Name - deriving(Eq, Ord) -- but we need them for kind inference - {-! derive: Binary !-} - -KNamed s1 `isSubsumedBy2` KNamed s2 = s1 == s2 -_ `isSubsumedBy2` KQuest = True -Star `isSubsumedBy2` KQuestQuest = True -KHash `isSubsumedBy2` KQuestQuest = True -k1 `isSubsumedBy2` k2 = k1 == k2 - -kindStar = KBase Star -kindHash = KBase KHash -kindUTuple = KBase KUTuple -kindFunRet = KBase KQuest -kindArg = KBase KQuestQuest - -infixr 5 `Kfun` - -data Kind = KBase KBase - | Kfun Kind Kind - | KVar Kindvar -- variables aren't really allowed in haskell in kinds - deriving(Eq, Ord) -- but we need them for kind inference - {-! derive: Binary !-} - -KBase kb `isSubsumedBy` KBase kb' = isSubsumedBy2 kb kb' -Kfun k1 k2 `isSubsumedBy` Kfun k1' k2' = isSubsumedBy k1 k1' && isSubsumedBy k2 k2' -_ `isSubsumedBy` _ = False - -kindCombine :: Monad m => Kind -> Kind -> m Kind -kindCombine x y = g x y where - f x y | x == y = return x - - f KQuest x = fquest x - f x KQuest = fquest x - f KQuestQuest x = fquest2 x - f x KQuestQuest = fquest2 x - f x y = fail $ "kindCombine: " ++ show (x,y) - fquest (KNamed n) = fail $ "Attempt to unify named kind" <+> tshow n <+> "with ?" - fquest x = return x - fquest2 (KNamed n) = fail $ "Attempt to unify named kind" <+> tshow n <+> "with ??" - fquest2 KUTuple = fail $ "Attempt to unify unboxed tuple with ??" - fquest2 KQuest = return KQuestQuest - fquest2 x = return x - g (KBase x) (KBase y) = f x y >>= return . KBase - g (Kfun a b) (Kfun a' b') = return Kfun `ap` g a a' `ap` g b b' - g x y = fail $ "kindCombine: " ++ show (x,y) - -data KindConstraint - = KindSimple -- ^ * | kindSimple -> kindSimple - | KindQuest -- ^ ?, so * or (#) or # - | KindQuestQuest -- ^ ??, * or # - | KindStar -- ^ must be * - | KindAny -- ^ may be anything - deriving(Eq,Ord,Show) - --- note that named kinds are never infered, so we don't need constraints --- mentioning them. - -instance Monoid KindConstraint where - mempty = KindAny - mappend a b | a == b = a - mappend KindAny k = k - mappend KindStar _ = KindStar - mappend KindSimple KindQuest = KindStar - mappend KindSimple KindQuestQuest = KindStar - mappend KindQuest KindQuestQuest = KindQuestQuest - mappend k1 k2 = mappend k2 k1 - -data Kindvar = Kindvar { - kvarUniq :: {-# UNPACK #-} !Int, - kvarRef :: {-# UNPACK #-} !(IORef (Maybe Kind)), - kvarConstraint :: !KindConstraint - } - -instance Binary Kindvar where - put _ = return () - get = return (error "Binary.Kindvar.get") - -instance Eq Kindvar where - a == b = kvarUniq a == kvarUniq b - -instance Ord Kindvar where - a `compare` b = kvarUniq a `compare` kvarUniq b - -instance Show Kind where - showsPrec n k = pprintPrec n k - -instance Show Kindvar where - showsPrec n k = pprintPrec n k - -instance Show KBase where - showsPrec _ Star = showString "*" - showsPrec _ KUTuple = showString "(#)" - showsPrec _ KHash = showString "#" - showsPrec _ KQuest = showString "?" - showsPrec _ KQuestQuest = showString "??" - showsPrec _ (KNamed n) = shows n - -instance DocLike d => PPrint d KBase where - pprint kb = text (show kb) - -instance DocLike d => PPrint d Kind where - pprintAssoc _ _ (KBase b) = pprint b - pprintAssoc _ _ (KVar kindVar) = pprint kindVar - pprintAssoc a n (Kfun k1 k2) = pprintBinary AssocRight 5 a n k1 (text "->") k2 -- checkAssoc AssocRight 5 a n $ pprintPrec 5 k1 <+> text "->" <+> pprintAssoc AssocRight 5 k2 - -instance DocLike d => PPrint d Kindvar where - pprint Kindvar { kvarUniq = s } = text $ 'k':show s - --- * -> * == [*,*] --- (*->*->*) -> * -> * == [(*->*->*), *, *] -unfoldKind :: Kind -> [Kind] -unfoldKind (Kfun k1 k2) = k1 : unfoldKind k2 -unfoldKind v = [v] -{-* Generated by DrIFT : Look, but Don't Touch. *-} -instance Data.Binary.Binary KBase where - put Star = do - Data.Binary.putWord8 0 - put KHash = do - Data.Binary.putWord8 1 - put KUTuple = do - Data.Binary.putWord8 2 - put KQuestQuest = do - Data.Binary.putWord8 3 - put KQuest = do - Data.Binary.putWord8 4 - put (KNamed aa) = do - Data.Binary.putWord8 5 - Data.Binary.put aa - get = do - h <- Data.Binary.getWord8 - case h of - 0 -> do - return Star - 1 -> do - return KHash - 2 -> do - return KUTuple - 3 -> do - return KQuestQuest - 4 -> do - return KQuest - 5 -> do - aa <- Data.Binary.get - return (KNamed aa) - _ -> fail "invalid binary data found" - -instance Data.Binary.Binary Kind where - put (KBase aa) = do - Data.Binary.putWord8 0 - Data.Binary.put aa - put (Kfun ab ac) = do - Data.Binary.putWord8 1 - Data.Binary.put ab - Data.Binary.put ac - put (KVar ad) = do - Data.Binary.putWord8 2 - Data.Binary.put ad - get = do - h <- Data.Binary.getWord8 - case h of - 0 -> do - aa <- Data.Binary.get - return (KBase aa) - 1 -> do - ab <- Data.Binary.get - ac <- Data.Binary.get - return (Kfun ab ac) - 2 -> do - ad <- Data.Binary.get - return (KVar ad) - _ -> fail "invalid binary data found" - --- Imported from other files :- diff --git a/drift_processed/FrontEnd/Tc/Monad.hs b/drift_processed/FrontEnd/Tc/Monad.hs deleted file mode 100644 --- a/drift_processed/FrontEnd/Tc/Monad.hs +++ /dev/null @@ -1,571 +0,0 @@ -{- Generated by DrIFT (Automatic class derivations for Haskell) -} -{-# LINE 1 "src/FrontEnd/Tc/Monad.hs" #-} -{-# LANGUAGE ImpredicativeTypes #-} -module FrontEnd.Tc.Monad( - CoerceTerm(..), - Tc(), - TcInfo(..), - TypeEnv(), - TcEnv(..), - tcRecursiveCalls_u, - Output(..), - addCoerce, - addPreds, - composeCoerce, - addRule, - addToCollectedEnv, - boxyInstantiate, - boxySpec, - deconstructorInstantiate, - freeMetaVarsEnv, - freshInstance, - freshSigma, - getClassHierarchy, - getCollectedEnv, - getCollectedCoerce, - getDeName, - getKindEnv, - getSigEnv, - evalFullType, - inst, - listenCheckedRules, - listenPreds, - listenCPreds, - localEnv, - lookupName, - newBox, - newMetaVar, - newVar, - quantify, - quantify_n, - runTc, - skolomize, - tcInfoEmpty, - toSigma, - unBox, - evalType, - unificationError, - varBind, - zonkKind, - withContext, - withMetaVars - ) where - -import Control.Monad.Error -import Control.Monad.Reader -import Control.Monad.Writer.Strict -import Data.IORef -import Data.List ---import Text.PrettyPrint.HughesPJ(Doc) -import qualified Data.Foldable as T -import qualified Data.Map as Map -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Traversable as T - -import Doc.DocLike -import Doc.PPrint -import FrontEnd.Class -import FrontEnd.Diagnostic -import FrontEnd.KindInfer -import FrontEnd.Rename(DeNameable(..)) -import FrontEnd.SrcLoc(bogusASrcLoc,MonadSrcLoc(..)) -import FrontEnd.Tc.Kind -import FrontEnd.Tc.Type -import FrontEnd.Warning -import GenUtil -import Name.Name -import Name.Names -import Options -import Support.CanType -import Support.FreeVars -import Support.Tickle -import qualified FlagDump as FD -import {-# SOURCE #-} FrontEnd.Tc.Class(simplify) - --- data BindingType = RecursiveInfered | Supplied -type TypeEnv = Map.Map Name Sigma - --- read only environment, set up before type checking. -data TcEnv = TcEnv { - tcInfo :: TcInfo, - tcDiagnostics :: [Diagnostic], -- list of information that might help diagnosis - tcVarnum :: {-# UNPACK #-} !(IORef Int), - tcCollectedEnv :: {-# UNPACK #-} !(IORef (Map.Map Name Sigma)), - tcCollectedCoerce :: {-# UNPACK #-} !(IORef (Map.Map Name CoerceTerm)), - tcConcreteEnv :: Map.Map Name Sigma, - tcMutableEnv :: Map.Map Name Sigma, - tcCurrentScope :: Set.Set MetaVar, - tcRecursiveCalls :: Set.Set Name, - tcInstanceEnv :: InstanceEnv, - tcOptions :: Opt -- module specific options - } - -tcConcreteEnv_u f r@TcEnv{tcConcreteEnv = x} = r{tcConcreteEnv = f x} -tcDiagnostics_u f r@TcEnv{tcDiagnostics = x} = r{tcDiagnostics = f x} -tcMutableEnv_u f r@TcEnv{tcMutableEnv = x} = r{tcMutableEnv = f x} -tcRecursiveCalls_u f r@TcEnv{tcRecursiveCalls = x} = r{tcRecursiveCalls = f x} - -data Output = Output { - collectedPreds :: !Preds, - existentialPreds :: !Preds, - constraints :: !(Seq.Seq Constraint), - checkedRules :: !(Seq.Seq Rule), - existentialVars :: [Tyvar], - tcWarnings :: !(Seq.Seq Warning), - outKnots :: [(Name,Name)] - } - {-! derive: Monoid !-} - -newtype Tc a = Tc (ReaderT TcEnv (WriterT Output IO) a) - deriving(MonadFix,MonadIO,MonadReader TcEnv,MonadWriter Output,Functor) - --- | information that is passed into the type checker. -data TcInfo = TcInfo { - tcInfoEnv :: TypeEnv, -- initial typeenv, data constructors, and previously infered types - tcInfoSigEnv :: TypeEnv, -- type signatures used for binding analysis - tcInfoModName :: Module, - tcInfoKindInfo :: KindEnv, - tcInfoClassHierarchy :: ClassHierarchy - } - -getDeName :: DeNameable n => Tc (n -> n) -getDeName = do - mn <- asks (tcInfoModName . tcInfo) - return (\n -> deName mn n) - --- | run a computation with a local environment -localEnv :: TypeEnv -> Tc a -> Tc a -localEnv te act = do - te' <- T.mapM flattenType te - let (cenv,menv) = Map.partition (Set.null . freeMetaVars) te' - --if any isBoxy (Map.elems te') then - -- fail $ "localEnv error!\n" ++ show te - local (tcConcreteEnv_u (cenv `Map.union`) . tcMutableEnv_u ((menv `Map.union`) . - Map.filterWithKey (\k _ -> k `Map.notMember` cenv))) act - --- | add to the collected environment which will be used to annotate uses of --- variables with their instantiated types. should contain @-aliases for each --- use of a polymorphic variable or pattern match. - -addToCollectedEnv :: TypeEnv -> Tc () -addToCollectedEnv te = do - v <- asks tcCollectedEnv - liftIO $ modifyIORef v (te `Map.union`) - -addCoerce :: Name -> CoerceTerm -> Tc () -addCoerce n te = do - v <- asks tcCollectedCoerce - liftIO $ modifyIORef v (Map.insert n te) - -getCollectedEnv :: Tc TypeEnv -getCollectedEnv = do - v <- asks tcCollectedEnv - r <- liftIO $ readIORef v - r <- T.mapM flattenType r - return r - -getCollectedCoerce :: Tc (Map.Map Name CoerceTerm) -getCollectedCoerce = do - v <- asks tcCollectedCoerce - r <- liftIO $ readIORef v - r <- T.mapM flattenType r - return r - -runTc :: (MonadIO m,OptionMonad m) => TcInfo -> Tc a -> m a -runTc tcInfo (Tc tim) = do - opt <- getOptions - liftIO $ do - vn <- newIORef 0 - ce <- newIORef mempty - cc <- newIORef mempty - (a,out) <- runWriterT $ runReaderT tim TcEnv { - tcCollectedEnv = ce, - tcCollectedCoerce = cc, - tcConcreteEnv = tcInfoEnv tcInfo `mappend` tcInfoSigEnv tcInfo, - tcMutableEnv = mempty, - tcVarnum = vn, - tcDiagnostics = [Msg Nothing $ - "Compilation of module: " ++ show (tcInfoModName tcInfo)], - tcInfo = tcInfo, - tcRecursiveCalls = mempty, - tcInstanceEnv = makeInstanceEnv (tcInfoClassHierarchy tcInfo), - tcCurrentScope = mempty, - tcOptions = opt - } - liftIO $ processErrors (T.toList $ tcWarnings out) - return a - -instance OptionMonad Tc where - getOptions = asks tcOptions - --- | given a diagnostic and a computation to take place inside the TI-monad, --- run the computation but during it have the diagnostic at the top of the --- stack - -withContext :: Diagnostic -> Tc a -> Tc a -withContext diagnostic comp = do - local (tcDiagnostics_u (diagnostic:)) comp - -addRule :: Rule -> Tc () -addRule r = tell mempty { checkedRules = Seq.singleton r } - -getErrorContext :: Tc [Diagnostic] -getErrorContext = asks tcDiagnostics - -getClassHierarchy :: Tc ClassHierarchy -getClassHierarchy = asks (tcInfoClassHierarchy . tcInfo) - -getKindEnv :: Tc KindEnv -getKindEnv = asks (tcInfoKindInfo . tcInfo) - -getSigEnv :: Tc TypeEnv -getSigEnv = asks (tcInfoSigEnv . tcInfo) - -askCurrentEnv = do - env1 <- asks tcConcreteEnv - env2 <- asks tcMutableEnv - return (env2 `Map.union` env1) - -{- -dConScheme :: Name -> Tc Sigma -dConScheme conName = do - env <- askCurrentEnv - case Map.lookup conName env of - Just s -> return s - Nothing -> error $ "dConScheme: constructor not found: " ++ show conName ++ - "\nin this environment:\n" ++ show env --} - --- | returns a new box and a function to read said box. - -newBox :: Kind -> Tc Type -newBox k = newMetaVar Sigma k - -unificationError t1 t2 = do - t1 <- evalFullType t1 - t2 <- evalFullType t2 - diagnosis <- getErrorContext - let Left msg = typeError (Unification $ "attempted to unify " ++ - prettyPrintType t1 ++ " with " ++ prettyPrintType t2) diagnosis - liftIO $ processIOErrors - liftIO $ putErrLn msg - liftIO $ exitFailure - -lookupName :: Name -> Tc Sigma -lookupName n = do - env <- askCurrentEnv - case Map.lookup n env of - Just x -> freshSigma x - Nothing | Just 0 <- fromUnboxedNameTuple n -> do - return (tTTuple' []) - Nothing | Just num <- fromUnboxedNameTuple n -> do - nvs <- mapM newVar (replicate num kindArg) - let nvs' = map TVar nvs - return (TForAll nvs $ [] :=> foldr TArrow (tTTuple' nvs') nvs') - Nothing -> fail $ "Could not find var in tcEnv:" ++ show (nameType n,n) - -newMetaVar :: MetaVarType -> Kind -> Tc Type -newMetaVar t k = do - te <- ask - n <- newUniq - r <- liftIO $ newIORef Nothing - return $ TMetaVar MetaVar { metaUniq = n, metaKind = k, metaRef = r, metaType = t } - -class Instantiate a where - inst:: Map.Map Int Type -> Map.Map Name Type -> a -> a - -instance Instantiate Type where - inst mm ts (TAp l r) = tAp (inst mm ts l) (inst mm ts r) - inst mm ts (TArrow l r) = TArrow (inst mm ts l) (inst mm ts r) - inst mm _ t@TCon {} = t - inst mm ts (TVar tv ) = case Map.lookup (tyvarName tv) ts of - Just t' -> t' - Nothing -> (TVar tv) - inst mm ts (TForAll as qt) = TForAll as (inst mm (foldr Map.delete ts (map tyvarName as)) qt) - inst mm ts (TExists as qt) = TExists as (inst mm (foldr Map.delete ts (map tyvarName as)) qt) - inst mm ts (TMetaVar mv) | Just t <- Map.lookup (metaUniq mv) mm = t - inst mm ts (TMetaVar mv) = TMetaVar mv - inst mm ts (TAssoc tc as bs) = TAssoc tc (map (inst mm ts) as) (map (inst mm ts) bs) - --inst mm _ t = error $ "inst: " ++ show t - -instance Instantiate a => Instantiate [a] where - inst mm ts = map (inst mm ts) - -instance Instantiate t => Instantiate (Qual t) where - inst mm ts (ps :=> t) = inst mm ts ps :=> inst mm ts t - -instance Instantiate Pred where - inst mm ts is = tickle (inst mm ts :: Type -> Type) is - -freshInstance :: MetaVarType -> Sigma -> Tc ([Type],Rho) -freshInstance typ (TForAll as qt) = do - ts <- mapM (newMetaVar typ) (map tyvarKind as) - let (ps :=> t) = (applyTyvarMapQT (zip as ts) qt) - addPreds ps - return (ts,t) -freshInstance _ x = return ([],x) - -addPreds :: Preds -> Tc () -addPreds ps = do - sl <- getSrcLoc - Tc $ tell mempty { collectedPreds = [ p | p@IsIn {} <- ps ], - constraints = Seq.fromList [ Equality { constraintSrcLoc = sl, - constraintType1 = a, constraintType2 = b } | IsEq a b <- ps ] } - ---addConstraints :: [Constraint] -> Tc () ---addConstraints ps = Tc $ tell mempty { constraints = Seq.fromList ps } - -listenPreds :: Tc a -> Tc (a,Preds) -listenPreds action = censor (\x -> x { collectedPreds = mempty }) $ - listens collectedPreds action - -listenCPreds :: Tc a -> Tc (a,(Preds,[Constraint])) -listenCPreds action = censor (\x -> x { constraints = mempty, collectedPreds = mempty }) $ - listens (\x -> (collectedPreds x,T.toList $ constraints x)) action - -listenCheckedRules :: Tc a -> Tc (a,[Rule]) -listenCheckedRules action = do - (a,r) <- censor (\x -> x { checkedRules = mempty }) $ listens checkedRules action - return (a,T.toList r) - -newVar :: Kind -> Tc Tyvar -newVar k = do - te <- ask - n <- newUniq - let ident = toName TypeVal (tcInfoModName $ tcInfo te,'v':show n) - v = tyvar ident k - return v - --- rename the bound variables of a sigma, just in case. -freshSigma :: Sigma -> Tc Sigma -freshSigma (TForAll [] ([] :=> t)) = return t -freshSigma (TForAll vs qt) = do - nvs <- mapM (newVar . tyvarKind) vs - return (TForAll nvs $ applyTyvarMapQT (zip vs (map TVar nvs)) qt) -freshSigma x = return x - -toSigma :: Sigma -> Sigma -toSigma t@TForAll {} = t -toSigma t = TForAll [] ([] :=> t) - --- | replace bound variables with arbitrary new ones and drop the binding --- TODO predicates? - -skolomize :: Sigma -> Tc ([Tyvar],[Pred],Type) -skolomize s = freshSigma s >>= return . fromType - -boxyInstantiate :: Sigma -> Tc ([Type],Rho') -boxyInstantiate = freshInstance Sigma - -deconstructorInstantiate :: Sigma -> Tc Rho' -deconstructorInstantiate tfa@TForAll {} = do - TForAll vs qt@(_ :=> t) <- freshSigma tfa - let f (_ `TArrow` b) = f b - f b = b - eqvs = vs Data.List.\\ freeVars (f t) - tell mempty { existentialVars = eqvs } - (_,t) <- freshInstance Sigma (TForAll (vs Data.List.\\ eqvs) qt) - return t -deconstructorInstantiate x = return x - -boxySpec :: Sigma -> Tc ([(BoundTV,[Sigma'])],Rho') -boxySpec (TForAll as qt@(ps :=> t)) = do - let f (TVar t) vs | t `elem` vs = do - b <- lift (newBox $ tyvarKind t) - tell [(t,b)] - return b - f e@TCon {} _ = return e - f (TAp a b) vs = liftM2 tAp (f a vs) (f b vs) - f (TArrow a b) vs = liftM2 TArrow (f a vs) (f b vs) - f (TForAll as (ps :=> t)) vs = do - t' <- f t (vs Data.List.\\ as) - return (TForAll as (ps :=> t')) - f t _ = return t - -- f t _ = error $ "boxySpec: " ++ show t - (t',vs) <- runWriterT (f t as) - addPreds $ inst mempty (Map.fromList [ (tyvarName bt,s) | (bt,s) <- vs ]) ps - return (sortGroupUnderFG fst snd vs,t') -boxySpec _ = error "boxySpec: bad." - -freeMetaVarsEnv :: Tc (Set.Set MetaVar) -freeMetaVarsEnv = do - env <- asks tcMutableEnv - xs <- flip mapM (Map.elems env) $ \ x -> do - x <- flattenType x - return $ freeMetaVars x - return (Set.unions xs) - -quantify_n :: [MetaVar] -> [Pred] -> [Rho] -> Tc [Sigma] -quantify_n vs ps rs | not $ any isBoxyMetaVar vs = do - -- we bind the quantified variables to fresh tvars - vs <- mapM groundKind vs - nvs <- mapM (newVar . fixKind . metaKind) vs - sequence_ [ varBind mv (TVar v) | v <- nvs | mv <- vs ] - - ps <- flattenType ps - rs <- flattenType rs - - ch <- getClassHierarchy - return $ [TForAll nvs (FrontEnd.Tc.Class.simplify ch ps :=> r) | r <- rs ] - | otherwise = error "quantify_n: bad." - -quantify :: [MetaVar] -> [Pred] -> Rho -> Tc Sigma -quantify vs ps r = do [s] <- quantify_n vs ps [r]; return s - --- turn all ?? into * types, as we can't abstract over unboxed types -fixKind :: Kind -> Kind -fixKind (KBase KQuestQuest) = KBase Star -fixKind (KBase KQuest) = KBase Star -fixKind (a `Kfun` b) = fixKind a `Kfun` fixKind b -fixKind x = x - -groundKind mv = zonkKind (fixKind $ metaKind mv) mv - --- this removes all boxes, replacing them with tau vars -unBox :: Type -> Tc Type -unBox tv = ft' tv where - ft t@(TMetaVar mv) - | isBoxyMetaVar mv = do - tmv <- newMetaVar Tau (getType mv) - varBind mv tmv - return tmv - | otherwise = return t - ft t = tickleM ft' t - ft' t = evalType t >>= ft - -evalType t = findType t >>= evalTAssoc >>= evalArrowApp -evalFullType t = f' t where - f t = tickleM f' t - f' t = evalType t >>= f - -evalTAssoc ta@TAssoc { typeCon = Tycon { tyconName = n1 }, typeClassArgs = ~[carg], typeExtraArgs = eas } = do - carg' <- evalType carg - case fromTAp carg' of - (TCon Tycon { tyconName = n2 }, as) -> do - InstanceEnv ie <- asks tcInstanceEnv - case Map.lookup (n1,n2) ie of - Just (aa,bb,tt) -> evalType (applyTyvarMap (zip aa as ++ zip bb eas) tt) - _ -> fail "no instance for associated type" - _ -> return ta { typeClassArgs = [carg'] } -evalTAssoc t = return t - -evalArrowApp (TAp (TAp (TCon tcon) ta) tb) - | tyconName tcon == tc_Arrow = return (TArrow ta tb) - -evalArrowApp t = return t - --- Bind mv to type, first filling in any boxes in type with tau vars -varBind :: MetaVar -> Type -> Tc () -varBind u t --- | getType u /= getType t = error $ "varBind: kinds do not match:" ++ show (u,t) - | otherwise = do - kindCombine (getType u) (getType t) - tt <- unBox t - --(t,be,_) <- unbox t - --when be $ error $ "binding boxy: " ++ tupled [pprint u,prettyPrintType t] - tt <- evalFullType tt - when (dump FD.BoxySteps) $ liftIO $ putStrLn $ "varBind: " ++ pprint u <+> - text ":=" <+> prettyPrintType tt - when (u `Set.member` freeMetaVars tt) $ do - unificationError (TMetaVar u) tt -- occurs check - let r = metaRef u - x <- liftIO $ readIORef r - case x of - Just r -> fail $ "varBind: binding unfree: " ++ - tupled [pprint u,prettyPrintType tt,prettyPrintType r] - Nothing -> liftIO $ do - --when (dump FD.BoxySteps) $ putStrLn $ "varBind: " ++ pprint u <+> text ":=" <+> prettyPrintType t - writeIORef r (Just tt) - -zonkKind :: Kind -> MetaVar -> Tc MetaVar -zonkKind nk mv = do - fk <- kindCombine nk (metaKind mv) - if fk == metaKind mv then return mv else do - nref <- liftIO $ newIORef Nothing - let nmv = mv { metaKind = fk, metaRef = nref } - liftIO $ modifyIORef (metaRef mv) (\Nothing -> Just $ TMetaVar nmv) - return nmv - -zonkBox :: MetaVar -> Tc Type -zonkBox mv | isBoxyMetaVar mv = findType (TMetaVar mv) -zonkBox mv = fail $ "zonkBox: nonboxy" ++ show mv - -readFilledBox :: MetaVar -> Tc Type -readFilledBox mv | isBoxyMetaVar mv = zonkBox mv >>= \v -> case v of - TMetaVar mv' | mv == mv' -> fail $ "readFilledBox: " ++ show mv - t -> return t -readFilledBox mv = error $ "readFilledBox: nonboxy" ++ show mv - -{- -elimBox :: MetaVar -> Tc Type -elimBox mv | isBoxyMetaVar mv = do - t <- readMetaVar mv - case t of - Just t -> return t - Nothing -> newMetaVar Tau (getType mv) - -elimBox mv = error $ "elimBox: nonboxy" ++ show mv --} - ----------------------------------------- --- Declaration of instances, boilerplate ----------------------------------------- - ---pretty :: PPrint Doc a => a -> String ---pretty x = show (pprint x :: Doc) - -instance Monad Tc where - return a = Tc $ return a - Tc comp >>= fun = Tc $ do x <- comp; case fun x of Tc m -> m - Tc a >> Tc b = Tc $ a >> b - fail s = Tc $ do - st <- ask - liftIO $ processIOErrors - Left x <- typeError (Failure s) (tcDiagnostics st) - liftIO $ fail x - -instance MonadWarn Tc where - addWarning w = tell mempty { tcWarnings = Seq.singleton w } - -instance MonadSrcLoc Tc where - getSrcLoc = do - xs <- asks tcDiagnostics - case xs of - (Msg (Just sl) _:_) -> return sl - _ -> return bogusASrcLoc - -instance UniqueProducer Tc where - newUniq = do - v <- asks tcVarnum - n <- liftIO $ do - n <- readIORef v - writeIORef v $! n + 1 - return n - return n - -tcInfoEmpty = TcInfo { - tcInfoEnv = mempty, - tcInfoModName = toModule "(unknown)", - tcInfoKindInfo = mempty, - tcInfoClassHierarchy = mempty, - tcInfoSigEnv = mempty -} - -withMetaVars :: MetaVar -> [Kind] -> ([Sigma] -> Sigma) -> ([Sigma'] -> Tc a) -> Tc a -withMetaVars mv ks sfunc bsfunc | isBoxyMetaVar mv = do - boxes <- mapM newBox ks - res <- bsfunc boxes - tys <- mapM readFilledBox [ mv | ~(TMetaVar mv) <- boxes] - varBind mv (sfunc tys) - return res -withMetaVars mv ks sfunc bsfunc = do - taus <- mapM (newMetaVar Tau) ks - varBind mv (sfunc taus) - bsfunc taus -{-* Generated by DrIFT : Look, but Don't Touch. *-} -instance Monoid Output where - mempty = Output mempty mempty mempty mempty mempty mempty mempty - mappend (Output aa ab ac ad ae af ag) (Output aa' ab' ac' ad' ae' af' ag') = Output (mappend aa aa')(mappend ab ab')(mappend ac ac')(mappend ad ad')(mappend ae ae')(mappend af af')(mappend ag ag') - --- Imported from other files :- diff --git a/drift_processed/Grin/SSimplify.hs b/drift_processed/Grin/SSimplify.hs deleted file mode 100644 --- a/drift_processed/Grin/SSimplify.hs +++ /dev/null @@ -1,443 +0,0 @@ -{- Generated by DrIFT (Automatic class derivations for Haskell) -} -{-# LINE 1 "src/Grin/SSimplify.hs" #-} -module Grin.SSimplify(simplify,explicitRecurse) where - -import Control.Monad.Identity -import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Writer -import Data.Maybe -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS -import qualified Data.Map as Map -import qualified Data.Set as Set - -import Grin.Grin -import Grin.Noodle -import Stats(mtick) -import StringTable.Atom -import Support.CanType -import Support.FreeVars -import Support.Tickle -import Util.GMap -import Util.Gen -import Util.HasSize -import Util.RWS -import Util.SetLike -import qualified Stats - --- This goes through and puts grin into a normal form, in addition, it carries out some straightforward --- simplifications. --- --- normalized form has the following properties --- --- :>>= only appears in trailing position --- Return [v0 .. vn] for n > 1 only appears in trailing position --- --- all variables and function names are unique in their scope. - -data SEnv = SEnv { - envSubst :: IM.IntMap Val, -- renaming substitution - envCSE :: Map.Map Exp (Atom,Exp), - envPapp :: IM.IntMap (Atom,[Val]) - --envPush :: IM.IntMap Exp - } - {-! derive: Monoid !-} - -newtype SState = SState { usedVars :: IS.IntSet } - -data SCol = SCol { - colStats :: Stats.Stat, - colFreeVars :: GSet Var - } - {-! derive: Monoid !-} - -{- -data ExpInfo = ExpInfo { - expFreeVars :: GSet Var, - expUnboxing :: UnboxingResult, - expType :: [Ty] - } --} - -newtype S a = S (RWS SEnv SCol SState a) - deriving(Monad,Functor,MonadWriter SCol, MonadReader SEnv,MonadState SState) - -instance Stats.MonadStats S where - mtickStat s = S (tell mempty { colStats = s }) - mticks' n a = S (tell mempty { colStats = Stats.singleStat n a }) - -tellFV v = tell mempty { colFreeVars = freeVars v } - -simplify :: Grin -> IO Grin -simplify grin = do - let (fs,_,SCol { colStats = stats}) = runRWS fun mempty SState { usedVars = mempty } - S fun = simpFuncs (grinFunctions grin) - return grin { grinFunctions = fs, grinStats = grinStats grin `mappend` stats } - -simpFuncs :: [FuncDef] -> S [FuncDef] -simpFuncs fd = do - let f fd@FuncDef { funcDefBody = body } = do - body' <- simpLam body - return $ updateFuncDefProps fd { funcDefBody = body' } - mapM f fd - -simpLam :: Lam -> S Lam -simpLam (ps :-> e) = do - (ps,env') <- renamePattern ps - let f col = col { colFreeVars = colFreeVars col \\ freeVars ps } - (e,col) <- censor f $ listen $ local (env' `mappend`) $ simpExp e - ps <- mapM (zeroVars (`member` colFreeVars col)) ps - return (ps :-> e) - -dstore x = BaseOp (StoreNode True) [x] - -simpDone :: Exp -> S Exp -simpDone e = do - pmap <- asks envPapp - case e of - (BaseOp (Apply ty) (Var (V vn) _:fs)) | Just (tl,gs) <- IM.lookup vn pmap -> do - (cl,fn) <- tagUnfunction tl - mtick $ if cl == 1 then "Simplify.Apply.Papp.{" ++ show tl else ("Simplify.Apply.App.{" ++ show fn) - return $ if cl == 1 - then App fn (gs ++ fs) ty - else dstore (NodeC (partialTag fn (cl - 1)) (gs ++ fs)) - (Case v ls) | isJust utypes -> ans where - utypes@(~(Just ts)) = unboxTypes ur - ur = foldr1 combineUnboxing [ getUnboxing e | _ :-> e <- ls ] - ans = do - mtick "Grin.Simplify.Unbox.case-return" - let vs = zipWith Var [v1 ..] ts - return (unboxModify ur (Case v ls) :>>= vs :-> (unboxRet ur vs)) - (Case v1 ls) | [v1'] :-> Case v2 ls' <- last ls, v1' == v2 || v1 == v2 -> do - let f (p :-> e) = p :-> Return [v1] :>>= [v1'] :-> e - mtick "Grin.Simplify.case-merge" - return $ Case v1 (init ls ++ map f ls') - --(e :>>= p :-> Return p') | p == p' -> do - -- mtick "Grin.Simplify.tail-return-omit" - -- return e - _ -> do - cmap <- asks envCSE - case Map.lookup e cmap of - Just (n,e') -> do mtick n; tellFV e'; return e' - Nothing -> return e - -simpBind :: [Val] -> Exp -> S Exp -> S Exp -simpBind p e cont = f p e where - cse name xs = do - (z,col) <- listen $ local (\s -> s { envCSE = Map.fromList [ (x,(toAtom name,y)) | (x,y) <- xs] `Map.union` envCSE s }) cont - e <- simpDone e - if isOmittable e && isEmpty (freeVars p `intersection` colFreeVars col) then do - mtick "Simplify.Omit.Bind" - return z - else return $ e :>>= (p :-> z) - cse' name xs = cse name ((e,Return p):xs) - f p app@(BaseOp Eval [v]) = cse' "Simplify.CSE.eval" [(BaseOp Promote [v],Return p)] - f p (BaseOp Promote [v@Var {}]) = cse' "Simplify.CSE.promote" [(gEval v,Return p)] - f [p] (BaseOp Demote [v@Var {}]) = cse' "Simplify.CSE.demote" [(BaseOp Promote [p],Return [v]),(gEval p,Return [v])] - f [p@(Var (V vn) _)] (BaseOp (StoreNode isD) [v@(NodeC t vs)]) | not (isHoly v) = case (isD,tagUnfunction t,tagIsWHNF t) of - (True,Nothing,_) -> cse' "Simplify.CSE.return-node" [] - (True,Just (n,fn),_) -> local (\s -> s { envPapp = IM.insert vn (t,vs) (envPapp s) }) $ cse' "Simplify.CSE.return-node-func" [] - --(False,_,True) -> local (\s -> s { envPush = IM.insert vn (Store v) (envPush s) }) $ cse "Simplify.CSE.store-whnf" [] - --(False,_,False) -> cse' "Simplify.CSE.store" [] - _ -> cse' "Simplify.CSE.store" [] --- f [p@(Var (V vn) _)] (Return [v@(NodeC t vs)]) | not (isHoly v) = case tagUnfunction t of --- Nothing -> cse "Simplify.CSE.return-node" [(Return [p],Return [v]),(Store p,Store v)] --- Just (n,fn) -> local (\s -> s { envPapp = IM.insert vn (t,vs) (envPapp s) }) $ cse' "Simplify.CSE.return-node" [(Return [p],Return [v]),(Store p,Store v)] --- f [p@(Var (V vn) _)] (Store v@(NodeC t vs)) | not (isHoly v) = case tagIsWHNF t of --- True -> local (\s -> s { envPush = IM.insert vn (Store v) (envPush s) }) $ cse "Simplify.CSE.store-whnf" [(BaseOp Promote [p],Return [v]),(gEval p,Return [v])] --- False -> cse' "Simplify.CSE.store" [] - f _ _ = cse "Simplify.CSE.NOT" [] - -extEnv :: Var -> Val -> SEnv -> SEnv -extEnv (V vn) v s = s { envSubst = IM.insert vn v (envSubst s) } - -simpExp :: Exp -> S Exp -simpExp e = f e [] where - f (e :>>= p :-> Return p') rs | p == p' = do - mtick "Grin.Simplify.tail-return-omit" - f e rs - f (a :>>= (v :-> b)) xs = do - env <- ask - f a ((env,v,b):xs) - - -- simple transforms - f (BaseOp Promote [Const x]) rs = do - mtick "Grin.Simplify.fetch-const" - f (Return [x]) rs --- f (Store x) rs | valIsNF x = do --- mtick "Grin.Simplify.store-normalform" --- f (Return [Const x]) rs - f (BaseOp Eval [Const n]) rs = do - mtick "Grin.Simplify.eval-const" - f (Return [n]) rs - f (Error s t) rs@(_:_) = do - mtick "Grin.Simplify.error-discard" - let (_,_,b) = last rs - f (Error s (getType b)) [] - f (Return [v]) ((senv,[Var vn _],b):rs) | valIsConstant v = do - mtick "Grin.Simplify.Subst.const" - fbind vn v senv b rs - f (Return [v@ValUnknown {}]) ((senv,[Var vn _],b):rs) = do - mtick "Grin.Simplify.Subst.unknown" - fbind vn v senv b rs - f (Return [v@Var {}]) ((senv,[Var vn _],b):rs) = do - mtick "Grin.Simplify.Subst.var" - fbind vn v senv b rs --- f a@(Return [NodeC t xs]) ((senv,[NodeC t' ys],b):rs) | t == t' = do --- mtick "Grin.Simplify.Assign.node-node" --- dtup xs ys senv b rs - f (Return []) ((senv,[],b):rs) = do - mtick "Grin.Simplify.Assign.unit-unit" - dtup [] [] senv b rs - f a@(Return (xs@(_:_:_))) ((senv,ys,b):rs) = do - mtick "Grin.Simplify.Assign.tuple-tuple" - dtup xs ys senv b rs - f (Case v@Var {} [l]) rs = do - f (Return [v] :>>= l) rs --- f e@(Case v ls) rs | isJust utypes = ans where --- utypes@(~(Just ts)) = unboxTypes ur --- ur = foldr1 combineUnboxing [ getUnboxing e | _ :-> e <- ls ] --- ans = do --- mtick "Grin.Simplify.Unbox.case-return" --- let vs = zipWith Var [v1 ..] ts --- f (unboxModify ur (Case v ls) :>>= vs :-> Return (unboxRet ur vs)) rs - f a ((senv,p,b):xs) = do - a <- g a - (p,env') <- renamePattern p - let env'' = env' `mappend` senv - local (const env'') $ simpBind p a (f b xs) - f x [] = do - e <- g x - simpDone e - fbind vn v senv b rs = do - v' <- applySubst v - local (\_ -> extEnv vn v' senv) $ f b rs - - dtup xs ys senv b rs | sameLength xs ys = do - xs <- mapM applySubst xs - (ys,env') <- renamePattern ys - let env'' = env' `mappend` senv - z <- local (const env'') $ f b rs - ts <- mapM (return . Just) [([y],Return [x]) | x <- xs | y <- ys ] - let h [] = z - h ((p,v):rs) = v :>>= p :-> h rs - return $ h [ (p,v) | Just (p,v) <- ts] - dtup _ _ _ _ _ = error "dtup: attempt to bind unequal lists" - g (Case v as) = do - v <- applySubst v - as <- mapM simpLam as - return $ Case v as - g lt@Let { expDefs = defs, expBody = body } = do - body <- f body [] - defs <- simpFuncs defs - let dnames = fromList $ map funcDefName defs :: GSet Atom - isInvalid e = isEmpty (freeVars e `intersection` dnames) - case body of - e :>>= l :-> r | isInvalid e -> do - mtick "Simplify.simplify.let-shrink-head" - return $ e :>>= l :-> updateLetProps lt { expBody = r, expDefs = defs } - e :>>= l :-> r | isInvalid r -> do - mtick "Simplify.simplify.let-shrink-tail" - return (updateLetProps lt { expBody = e, expDefs = defs } :>>= l :-> r) - App f as ts | f `elem` map funcDefName defs, f `Set.notMember` freeVars (map funcDefBody defs) -> do - mtick "Simplify.simplify.let-inline-body" - let [fbody] = [ funcDefBody fd | fd <- defs, funcDefName fd == f] - return $ updateLetProps lt { expDefs = defs, expBody = Return as :>>= fbody } - _ -> return $ updateLetProps lt { expBody = body, expDefs = defs } - g x = applySubstE x - -applySubstE :: Exp -> S Exp -applySubstE x = mapExpVal applySubst x - -applySubst x = f x where - f var@(Var (V v) _) = do - env <- asks envSubst - case IM.lookup v env of - Just n -> tellFV n >> return n - Nothing -> tellFV var >> return var - f x = mapValVal f x - -zeroVars fn x = f x where - f (Var v ty) | fn v || v == v0 = return (Var v ty) - | otherwise = do mtick $ "Simplify.ZeroVar.{" ++ show (Var v ty); return (Var v0 ty) - f x = mapValVal f x - -renamePattern :: [Val] -> S ([Val],SEnv) -renamePattern x = runWriterT (mapM f x) where - f :: Val -> WriterT SEnv S Val - f (Var v@(V vn) t) = do - v' <- lift $ newVarName v - let nv = Var v' t - tell (mempty { envSubst = IM.singleton vn nv }) - return nv - f x = mapValVal f x - -newVarName :: Var -> S Var -newVarName (V 0) = return (V 0) -newVarName (V sv) = do - s <- gets usedVars - let nv = v sv - v n | n `IS.member` s = v (1 + n + IS.size s) - | otherwise = n - modify (\e -> e { usedVars = IS.insert nv s }) - return (V nv) - -isHoly (NodeC _ as) | any isValUnknown as = True -isHoly n = False - -data UnboxingResult - = UnErr [Ty] - | UnStore !Bool !Atom [Unbox] - | UnDemote Unbox - | UnReturn [Unbox] - | UnTail (Set.Set Atom) [Ty] [Ty] - -data Unbox = UnConst Val | UnUnknown Ty | UnBaseOp BaseOp [Unbox] - deriving(Eq,Ord) - -isUnUnknown UnUnknown {} = True -isUnUnknown _ = False - -instance CanType UnboxingResult where - type TypeOf UnboxingResult = [Ty] - getType (UnErr tys) = tys - getType (UnReturn us) = map getType us - getType (UnStore b _ _) = [bool b tyDNode tyINode] - getType (UnDemote _) = [tyINode] - getType (UnTail _ tys _) = tys - -instance CanType Unbox where - type TypeOf Unbox = Ty - getType (UnConst v) = getType v - getType (UnUnknown t) = t - getType _ = error "getType: bad." - -unboxRet :: UnboxingResult -> [Val] -> Exp -unboxRet ur vs = f ur vs where - f (UnReturn xs) vs = Return $ let (r,[]) = g xs vs in r - f (UnStore b c xs) vs = let (xs',[]) = g xs vs in BaseOp (StoreNode b) [NodeC c xs'] - f (UnDemote u) vs = let ([u'],[]) = g [u] vs in BaseOp Demote [u'] - f (UnTail a _ tys) vs | [f] <- Set.toList a = App f vs tys - f UnErr {} _ = Return [] - f _ vs = Return vs - g [] vs = ([],vs) - g (UnUnknown _:xs) (v:vs) = let (r,y) = g xs vs in (v:r,y) - g (UnConst v:xs) vs = let (r,y) = g xs vs in (v:r,y) - g _ _ = error "SSimplify.unboxRet: bad." - -unboxTypes :: UnboxingResult -> Maybe [Ty] -unboxTypes ur = f ur where - f (UnTail ts tys _) | Set.size ts == 1 = Just tys - f (UnTail {}) = Nothing - f (UnErr []) = Nothing - f (UnErr (_:_)) = Just [] - f (UnReturn us) | all isUnUnknown us = Nothing - f (UnReturn xs) = Just $ concatMap h xs - f (UnStore _ _ ts) = Just $ concatMap h ts - f (UnDemote _) = Just [tyDNode] - h (UnUnknown t) = [t] - h (UnConst {}) = [] - h _ = error "SSimplify.unboxTypes: bad." - -unboxModify :: UnboxingResult -> Exp -> Exp -unboxModify ur = f ur where - Just nty = unboxTypes ur - f UnErr {} = id - f (UnTail a tys _) | [f] <- Set.toList a = runIdentity . editTail tys (mApp f) - f (UnReturn us) | all isUnUnknown us = id - f (UnReturn xs) = runIdentity . editTail nty (g xs) - f (UnStore _ _ us) =runIdentity . editTail nty (z us) - f (UnDemote _) =runIdentity . editTail nty y - f _ = error "SSimplify.unboxModify: bad1." - g xs (Return ys) = return $ Return (concat $ zipWith h xs ys) - g _ _ = error "SSimplify.unboxModify: bad2." - h (UnUnknown _) y = [y] - h (UnConst {}) _ = [] - h _ _ = error "SSimplify.unboxModify: bad3." - z xs (BaseOp (StoreNode _) [NodeC _ ts]) = return . Return . concat $ zipWith h xs ts - z _ _ = error "SSimplify.unboxModify: bad4." - y (BaseOp Demote [x]) = return $ Return [x] - y (Return [Const v]) = return $ Return [v] - y _ = error "SSimplify.unboxModify: bad5." - mApp f (App f' as tys) | f == f' = return $ Return as - mApp f e = error $ "mApp: " ++ show (f,e) - -combineUnboxing :: UnboxingResult -> UnboxingResult -> UnboxingResult -combineUnboxing ub1 ub2 = f ub1 ub2 where - f UnErr {} x = x - f x UnErr {} = x - f (UnTail t1 a1 u1) (UnTail t2 a2 u2) | u1 == u2, a1 == a2 = UnTail (t1 `union` t2) a1 u1 - f (UnReturn xs) (UnReturn ys) = UnReturn (zipWith g xs ys) - f (UnStore b1 a1 xs1) (UnStore b2 a2 xs2) | a1 == a2 = UnStore b1 a1 (zipWith g xs1 xs2) - | otherwise = UnReturn [UnUnknown (bool b1 tyDNode tyINode)] - f (UnDemote u1) (UnDemote u2) = UnDemote (g u1 u2) - f (UnDemote u1) (UnReturn [UnConst (Const v)]) = UnDemote (UnUnknown tyDNode) - f (UnReturn [UnConst (Const v)]) (UnDemote u1) = UnDemote (UnUnknown tyDNode) - f x _ = UnReturn (map UnUnknown (getType x)) - g (UnConst v1) (UnConst v2) | v1 == v2 = UnConst v1 - | otherwise = UnUnknown (getType v1) - g x _ = UnUnknown (getType x) - -getUnboxing :: Exp -> UnboxingResult -getUnboxing e = f e where - f (Return rs) = UnReturn (map g rs) - f (BaseOp (StoreNode b) [NodeC c xs]) = UnStore b c (map g xs) - f (BaseOp Demote [v]) = UnDemote (g v) - f (Error _ tys) = UnErr tys - f (App f vs ts) = UnTail (singleton f) (getType vs) ts - f (Case _ ls) = foldr1 combineUnboxing [ f e | _ :-> e <- ls ] - f Let { expDefs = defs, expBody = body, expIsNormal = False } = case f body of - UnTail fs _ ntys | not $ Set.null (fs `Set.intersection` (Set.fromList $ map funcDefName defs)) -> UnReturn (map UnUnknown ntys) - e -> e - f (_ :>>= _ :-> e) = f e - f e = UnReturn (map UnUnknown $ getType e) - g v | valIsConstant v = UnConst v - g v = UnUnknown (getType v) - -editTail :: Monad m => [Ty] -> (Exp -> m Exp) -> Exp -> m Exp -editTail nty mt te = f (sempty :: GSet Atom) te where - f _ (Error s ty) = return $ Error s nty - f lf (Case x ls) = return (Case x) `ap` mapM (g lf) ls - f lf lt@Let {expIsNormal = False, expBody = body } = do - body <- f lf body - return $ updateLetProps lt { expBody = body } - f lf lt@Let {expDefs = defs, expIsNormal = True } = do - let nlf = lf `union` fromList (map funcDefName defs) - mapExpExp (f nlf) lt - f lf lt@MkCont {expLam = lam, expCont = cont } = do - a <- g lf lam - b <- g lf cont - return $ lt { expLam = a, expCont = b } - f lf (e1 :>>= p :-> e2) = do - e2 <- f lf e2 - return $ e1 :>>= p :-> e2 - f lf e@(App a as t) | a `member` lf = return $ App a as nty - f lf e = mt e - g lf (p :-> e) = do e <- f lf e; return $ p :-> e - -bool b x y = if b then x else y - --- this finds top level functions that call themselves recursively and turns the recursive call into a --- local definition, allowing it to be compiled to a direct loop. - -explicitRecurse - :: Grin - -> IO Grin -explicitRecurse grin = mapGrinFuncsM f grin where - f name lam | name `notMember` (freeVars lam :: GSet Atom) = return lam - f name (as :-> e) = do - let nname = toAtom $ "bR" ++ fromAtom name - g (App n rs t) | n == name = App nname rs t - g e = tickle g e - return $ as :-> grinLet [createFuncDef True nname (as :-> g e) ] (App nname as (getType e)) -{-* Generated by DrIFT : Look, but Don't Touch. *-} -instance Monoid SEnv where - mempty = SEnv mempty mempty mempty - mappend (SEnv aa ab ac) (SEnv aa' ab' ac') = SEnv (mappend aa aa')(mappend ab ab')(mappend ac ac') - -instance Monoid SCol where - mempty = SCol mempty mempty - mappend (SCol aa ab) (SCol aa' ab') = SCol (mappend aa aa')(mappend ab ab') - --- Imported from other files :- diff --git a/drift_processed/Ho/Build.hs b/drift_processed/Ho/Build.hs deleted file mode 100644 --- a/drift_processed/Ho/Build.hs +++ /dev/null @@ -1,858 +0,0 @@ -{- Generated by DrIFT (Automatic class derivations for Haskell) -} -{-# LINE 1 "src/Ho/Build.hs" #-} -{-# LANGUAGE DoRec #-} -module Ho.Build ( - module Ho.Type, - dumpHoFile, - parseFiles, - preprocess, - preprocessHs, - buildLibrary - ) where - -import Control.Concurrent -import Control.Monad.Identity -import Data.IORef -import Data.List hiding(union) -import Data.Maybe -import Data.Monoid(Monoid(..)) -import Data.Tree -import Data.Version(Version,parseVersion,showVersion) -import System.FilePath as FP -import System.Mem -import Text.Printf -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Lazy.UTF8 as LBSU -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Text.PrettyPrint.HughesPJ as PPrint - -import DataConstructors -import Doc.DocLike -import Doc.PPrint -import Doc.Pretty -import E.E -import E.Rules -import E.Show -import E.Traverse(emapE) -import E.TypeCheck() -import FrontEnd.Class -import FrontEnd.FrontEnd -import FrontEnd.HsSyn -import FrontEnd.Infix -import FrontEnd.SrcLoc -import FrontEnd.Warning(warn,processIOErrors,WarnType(..)) -import Ho.Binary -import Ho.Collected() -import Ho.Library -import Ho.ReadSource -import Ho.Type -import Name.Name -import Options -import PackedString(PackedString,packString,unpackPS) -import Support.TempDir -import Util.Gen -import Util.SetLike -import Util.YAML -import Version.Config(version) -import Version.Version(versionString) -import qualified FlagDump as FD -import qualified FlagOpts as FO -import qualified Support.MD5 as MD5 -import qualified Util.Graph as G - --- Ho File Format --- --- ho files are standard CFF format files (PNG-like) as described in the Support.CFF modules. --- --- the CFF magic for the files is the string "JHC" --- --- JHDR - header info, contains a list of modules contained and dependencies that need to be checked to read the file --- LIBR - only present if this is a library, contains library metainfo --- IDEP - immutable import information, needed to tell if ho files are up to date --- LINK - redirect to another file for file systems without symlinks --- DEFS - definitions type checking information --- CORE - compiled core and associated data --- LDEF - library map of module group name to DEFS --- LCOR - library map of module group name to CORE --- GRIN - compiled grin code --- FILE - Extra file, such as embedded c code. - -{- - - We separate the data into various chunks for logical layout as well as the - - important property that each chunk is individually compressed and accessable. - - What this means is that we can skip chunks we don't need. for instance, - - during the final link we have no need of the haskell type checking - - information, we are only interested in the compiled code, so we can jump - - directly to it. If we relied on straight serialization, we would have to - - parse all preceding information just to discard it right away. We also lay - - them out so that we can generate error messages quickly. for instance, we can - - determine if a symbol is undefined quickly, before it has to load the - - typechecking data. - -} - -type LibraryName = PackedString - -findFirstFile :: [FilePath] -> IO (LBS.ByteString,FilePath) -findFirstFile [] = fail "findFirstFile: file not found" -findFirstFile (x:xs) = flip iocatch (\e -> findFirstFile xs) $ do - bs <- LBS.readFile x - return (bs,x) - -data ModDone - = ModNotFound - | ModLibrary !Bool ModuleGroup Library - | Found SourceCode - -data Done = Done { - hoCache :: Maybe FilePath, - knownSourceMap :: Map.Map SourceHash (Module,[(Module,SrcLoc)]), - validSources :: Set.Set SourceHash, - loadedLibraries :: Map.Map LibraryName Library, - hosEncountered :: Map.Map HoHash (FilePath,HoHeader,HoIDeps,Ho), - modEncountered :: Map.Map Module ModDone - } - -hosEncountered_u f r@Done{hosEncountered = x} = r{hosEncountered = f x} -knownSourceMap_u f r@Done{knownSourceMap = x} = r{knownSourceMap = f x} -loadedLibraries_u f r@Done{loadedLibraries = x} = r{loadedLibraries = f x} -modEncountered_u f r@Done{modEncountered = x} = r{modEncountered = f x} -validSources_u f r@Done{validSources = x} = r{validSources = f x} - -replaceSuffix suffix fp = reverse (dropWhile ('.' /=) (reverse fp)) ++ suffix - -hoFile :: Maybe FilePath -> FilePath -> Maybe Module -> SourceHash -> FilePath -hoFile cacheDir fp mm sh = case (cacheDir,optHoDir options) of - (Nothing,Nothing) -> replaceSuffix "ho" fp - (Nothing,Just hdir) -> case mm of - Nothing -> hdir ++ "/" ++ MD5.md5show32 sh ++ ".ho" - Just m -> hdir ++ "/" ++ map ft (show m) ++ ".ho" where - ft '/' = '.' - ft x = x - (Just hdir,_) -> hdir ++ "/" ++ MD5.md5show32 sh ++ ".ho" - -findHoFile :: IORef Done -> FilePath -> Maybe Module -> SourceHash -> IO (Bool,FilePath) -findHoFile done_ref fp mm sh = do - done <- readIORef done_ref - let honame = hoFile (hoCache done) fp mm sh - writeIORef done_ref (done { validSources = Set.insert sh (validSources done) }) - if sh `Set.member` validSources done || optIgnoreHo options then return (False,honame) else do - onErr (return (False,honame)) (readHoFile honame) $ \ (hoh,hidep,ho) -> - case hohHash hoh `Map.lookup` hosEncountered done of - Just (fn,_,_,a) -> return (True,fn) - Nothing -> do - modifyIORef done_ref (knownSourceMap_u $ (`mappend` (hoIDeps hidep))) - modifyIORef done_ref (validSources_u $ Set.union (Set.fromList . map snd $ hoDepends hidep)) - modifyIORef done_ref (hosEncountered_u $ Map.insert (hohHash hoh) (honame,hoh,hidep,ho)) - return (True,honame) - -onErr :: IO a -> IO b -> (b -> IO a) -> IO a -onErr err good cont = join $ iocatch (good >>= return . cont) (\_ -> return err) - -fetchSource :: Opt -> IORef Done -> [FilePath] -> Maybe (Module,SrcLoc) -> IO Module -fetchSource _ _ [] _ = fail "No files to load" -fetchSource modOpt done_ref fs mm = do - let killMod = case mm of - Nothing -> fail $ "Could not load file: " ++ show fs - Just (m,sloc) -> do - warn sloc (MissingModule m) $ printf "Module '%s' not found." (show m) - modifyIORef done_ref (modEncountered_u $ Map.insert m ModNotFound) >> return m - onErr killMod (findFirstFile fs) $ \ (lbs,fn) -> do - let hash = MD5.md5lazy $ (LBSU.fromString version) `mappend` lbs - (foundho,mho) <- findHoFile done_ref fn (fmap fst mm) hash - done <- readIORef done_ref - (mod,m,ds) <- case mlookup hash (knownSourceMap done) of - Just (m,ds) -> return (Left lbs,m,ds) - Nothing -> do - (hmod,_) <- parseHsSource modOpt fn lbs - let m = hsModuleName hmod - ds = hsModuleRequires hmod - writeIORef done_ref (knownSourceMap_u (Map.insert hash (m,ds)) done) - case optAnnotate options of - Just _ -> return (Left lbs,m,ds) - _ -> return (Right hmod,m,ds) - case mm of - Just (m',_) | m /= m' -> do - putErrLn $ "Skipping file" <+> fn <+> "because its module declaration of" <+> show m <+> "does not equal the expected" <+> show m' - killMod - _ -> do - let sc (Right mod) = SourceParsed sinfo mod - sc (Left lbs) = SourceRaw sinfo lbs - sinfo = SI { sourceHash = hash, sourceDeps = ds, sourceFP = fn, sourceHoName = mho, sourceModName = m } - modifyIORef done_ref (modEncountered_u $ Map.insert m (Found (sc mod))) - fn' <- shortenPath fn - mho' <- shortenPath mho - putProgressLn $ if foundho - then printf "%-23s [%s] <%s>" (show m) fn' mho' - else printf "%-23s [%s]" (show m) fn' - mapM_ (resolveDeps modOpt done_ref) ds - return m - -resolveDeps :: Opt -> IORef Done -> (Module,SrcLoc) -> IO () -resolveDeps modOpt done_ref (m,sloc) = do - done <- readIORef done_ref - case m `mlookup` modEncountered done of - Just (ModLibrary False _ lib) | not ("jhc-prim-" `isPrefixOf` libName lib) -> putErrDie $ printf "ERROR: Attempt to import module '%s' which is a member of the library '%s'.\nPerhaps you need to add '-p%s' to the command line?" (show m) (libName lib) (libName lib) - Just _ -> return () - Nothing -> fetchSource modOpt done_ref (map fst $ searchPaths modOpt (show m)) (Just (m,sloc)) >> return () - -type LibInfo = (Map.Map Module ModuleGroup, Map.Map ModuleGroup [ModuleGroup], Set.Set Module,Map.Map ModuleGroup HoBuild,Map.Map ModuleGroup HoTcInfo) - -data CompNode = CompNode !HoHash [CompNode] {-# UNPACK #-} !(IORef CompLink) -data CompLink - = CompLinkUnit CompUnit - | CompCollected CollectedHo CompUnit - | CompTcCollected HoTcInfo CompUnit - | CompLinkLib (ModuleGroup,LibInfo) CompUnit - -compLinkCompUnit (CompLinkUnit cu) = cu -compLinkCompUnit (CompCollected _ cu) = cu -compLinkCompUnit (CompTcCollected _ cu) = cu -compLinkCompUnit (CompLinkLib _ cu) = cu - -instance MapKey Module where - showMapKey = show -instance MapKey MD5.Hash where - showMapKey = show - -dumpDeps targets memap cug = case optDeps options of - Nothing -> return () - Just fp -> do - let (sfps,sdps,ls) = collectDeps memap cug - let yaml = Map.fromList [ - ("Target",toNode targets), - ("LibraryDesc",toNode [ fp | BuildHl fp <- [optMode options]]), - ("LibraryDeps",toNode ls), - ("ModuleSource",toNode sfps), - ("ModuleDeps",toNode sdps) - ] - writeFile fp (showYAML yaml) - -collectDeps memap cs = mconcatMap f [ cu | (_,(_,cu)) <- cs] where - f (CompSources ss) = mconcat [ (Map.singleton (sourceModName s) (sourceFP s),Map.singleton (sourceModName s) (fsts $ sourceDeps s),mempty) | s <- map sourceInfo ss ] - f (CompLibrary _ lib) = (mempty,mempty,Map.singleton (libHash lib) (libFileName lib)) - f (CompHo _hoh idep _ho) = (Map.fromList [ (sourceModName $ sourceInfo src, sourceFP $ sourceInfo src) | s <- fsts ss, Just (Found src) <- [Map.lookup s memap] ],Map.fromList [ (mms,fsts mms') | s <- snds ss, Just (mms,mms') <- [Map.lookup s (hoIDeps idep)] ],mempty) where - ss = [ s | s <- hoDepends idep ] - f _ = mempty - -type CompUnitGraph = [(HoHash,([HoHash],CompUnit))] - -data CompUnit - = CompHo HoHeader HoIDeps Ho - | CompSources [SourceCode] - | CompTCed ((HoTcInfo,TiData,[(HoHash,HsModule)],[String])) - | CompDummy - | CompLibrary Ho Library - -instance Show CompUnit where - showsPrec _ = shows . providesModules - -data SourceInfo = SI { - sourceHash :: SourceHash, - sourceDeps :: [(Module,SrcLoc)], - sourceFP :: FilePath, - sourceModName :: Module, - sourceHoName :: FilePath - } - -data SourceCode - = SourceParsed { sourceInfo :: !SourceInfo, sourceModule :: HsModule } - | SourceRaw { sourceInfo :: !SourceInfo, sourceLBS :: LBS.ByteString } - -sourceIdent = show . sourceModName . sourceInfo - -class ProvidesModules a where - providesModules :: a -> [Module] - providesModules _ = [] - -instance ProvidesModules HoIDeps where - providesModules = fsts . hoDepends - -instance ProvidesModules HoLib where - providesModules = Map.keys . hoModuleMap - -instance ProvidesModules CompUnit where - providesModules (CompHo _ hoh _) = providesModules hoh - providesModules (CompSources ss) = concatMap providesModules ss - providesModules (CompLibrary ho libr) = libProvides (hoModuleGroup ho) libr - providesModules CompDummy = [] - providesModules (CompTCed _) = error "providesModules: bad1." - -instance ProvidesModules CompLink where - providesModules (CompLinkUnit cu) = providesModules cu - providesModules (CompCollected _ cu) = providesModules cu - providesModules (CompTcCollected _ cu) = providesModules cu - providesModules (CompLinkLib _ _) = error "providesModules: bad2c." - -instance ProvidesModules SourceCode where - providesModules sp = [sourceModName (sourceInfo sp)] - --- | this walks the loaded modules and ho files, discarding out of --- date ho files and organizing modules into their binding groups. --- the result is an acyclic graph where the nodes are ho files, sets --- of mutually recursive modules, or libraries. --- there is a strict ordering of --- source >= ho >= library --- in terms of dependencies - -toCompUnitGraph :: Done -> [Module] -> IO (HoHash,CompUnitGraph) -toCompUnitGraph done roots = do - let fs m = map inject $ maybe (error $ "can't find deps for: " ++ show m) (fsts . snd) (Map.lookup m (knownSourceMap done)) - fs' m libr = fromMaybe (error $ "can't find deps for: " ++ show m) (Map.lookup m (hoModuleDeps $ libHoLib libr)) - foundMods = [ ((m,Left (sourceHash $ sourceInfo sc)),fs (sourceHash $ sourceInfo sc)) | (m,Found sc) <- Map.toList (modEncountered done)] - foundMods' = Map.elems $ Map.fromList [ (mg,((mg,Right lib),fs' mg lib)) | (_,ModLibrary _ mg lib) <- Map.toList (modEncountered done)] - fullModMap = Map.unions (map libModMap $ Map.elems (loadedLibraries done)) - inject m = Map.findWithDefault m m fullModMap - gr = G.newGraph (foundMods ++ foundMods') (fst . fst) snd - gr' = G.sccGroups gr - phomap = Map.fromListWith (++) (concat [ [ (m,[hh]) | (m,_) <- hoDepends idep ] | (hh,(_,_,idep,_)) <- Map.toList (hosEncountered done)]) - sources = Map.fromList [ (m,sourceHash $ sourceInfo sc) | (m,Found sc) <- Map.toList (modEncountered done)] - - when (dump FD.SccModules) $ do - mapM_ (putErrLn . show) $ map (map $ fst . fst) gr' - putErrLn $ drawForest (map (fmap (show . fst . fst)) (G.dff gr)) - - cug_ref <- newIORef [] - hom_ref <- newIORef (Map.map ((,) False) $ hosEncountered done) - ms <- forM gr' $ \ns -> do - r <- newIORef (Left ns) - return (Map.fromList [ (m,r) | ((m,_),_) <- ns ]) - let mods = Map.unions ms - lmods m = fromMaybe (error $ "modsLookup: " ++ show m) (Map.lookup m mods) - let f m = do - rr <- readIORef (lmods m) - case rr of - Right hh -> return hh - Left ns -> g ns - - g ms@(((m,Left _),_):_) = do - let amods = map (fst . fst) ms - pm (fromMaybe [] (Map.lookup m phomap)) $ do - let deps = Set.toList $ Set.fromList (concat $ snds ms) `Set.difference` (Set.fromList amods) - deps' <- snub `fmap` mapM f deps - let mhash = MD5.md5String (concatMap (show . fst) ms ++ show deps') - writeIORef (lmods m) (Right mhash) - modifyIORef cug_ref ((mhash,(deps',CompSources $ map fs amods)):) - return mhash - g [((mg,Right lib),ds)] = do - let Just hob = Map.lookup mg $ libBuildMap lib - Just hot = Map.lookup mg $ libTcMap lib - ho = Ho { hoModuleGroup = mg, hoBuild = hob, hoTcInfo = hot } - myHash = libMgHash mg lib - deps <- snub `fmap` mapM f ds - writeIORef (lmods mg) (Right myHash) - modifyIORef cug_ref ((myHash,(deps,CompLibrary ho lib)):) - return myHash - g _ = error "Build.toCompUnitGraph: bad." - pm :: [HoHash] -> IO HoHash -> IO HoHash - pm [] els = els - pm (h:hs) els = hvalid h `iocatch` (\_ -> pm hs els) - hvalid h = do - ll <- Map.lookup h `fmap` readIORef hom_ref - case ll of - Nothing -> fail "Don't know anything about this hash" - Just (True,_) -> return h - Just (False,af@(fp,hoh,idep,ho)) -> do - fp <- shortenPath fp - isGood <- iocatch ( mapM_ cdep (hoDepends idep) >> mapM_ hvalid (hoModDepends idep) >> return True) (\_ -> return False) - let isStale = not . null $ map (show . fst) (hoDepends idep) `intersect` optStale options - libsGood = all (\ (p,h) -> fmap (libHash) (Map.lookup p (loadedLibraries done)) == Just h) (hohLibDeps hoh) - noGood forced = do - putProgressLn $ printf "Stale: <%s>%s" fp forced - modifyIORef hom_ref (Map.delete h) - fail "stale file" - case (isStale,isGood && libsGood) of - (False,True) -> do - putProgressLn $ printf "Fresh: <%s>" fp - hs <- mapM f (hoModuleGroupNeeds idep) - modifyIORef cug_ref ((h,(hs ++ hoModDepends idep,CompHo hoh idep ho)):) - modifyIORef hom_ref (Map.insert h (True,af)) - return h - (True,_) -> noGood " (forced)" - (_,False) -> noGood "" - cdep (_,hash) | hash == MD5.emptyHash = return () - cdep (mod,hash) = case Map.lookup mod sources of - Just hash' | hash == hash' -> return () - _ -> fail "Can't verify module up to date" - fs m = case Map.lookup m (modEncountered done) of - Just (Found sc) -> sc - _ -> error $ "fs: " ++ show m - mapM_ f (map inject roots) - cug <- readIORef cug_ref - let (rhash,cug') = mkPhonyCompUnit roots cug - let gr = G.newGraph cug' fst (fst . snd) - gr' = G.transitiveReduction gr - when (dump FD.SccModules) $ do - putErrLn "ComponentsDeps:" - mapM_ (putErrLn . show) [ (snd $ snd v, map (snd . snd) vs) | (v,vs) <- G.fromGraph gr'] - return (rhash,[ (h,([ d | (d,_) <- ns ],cu)) | ((h,(_,cu)),ns) <- G.fromGraph gr' ]) - -parseFiles - :: Opt -- ^ Options to use when parsing files - -> [FilePath] -- ^ Targets we are building, used when dumping dependencies - -> [String] -- ^ Extra libraries to load - -> [Either Module FilePath] -- ^ Either a module or filename to find - -> (CollectedHo -> Ho -> IO CollectedHo) -- ^ Process initial ho loaded from file - -> (CollectedHo -> Ho -> TiData -> IO (CollectedHo,Ho)) -- ^ Process set of mutually recursive modules to produce final Ho - -> IO (CompNode,CollectedHo) -- ^ Final accumulated ho -parseFiles options targets elibs need ifunc func = do - putProgressLn "Finding Dependencies..." - (ksm,chash,cug) <- loadModules options targets (snub $ - if optNoAuto options then optHls options ++ elibs else - optAutoLoads options ++ optHls options ++ elibs) bogusASrcLoc need - cnode <- processCug cug chash - when (optStop options == StopParse) exitSuccess - performGC - putProgressLn "Typechecking..." - typeCheckGraph options cnode - if isJust (optAnnotate options) then exitSuccess else do - when (optStop options == StopTypeCheck) exitSuccess - performGC - putProgressLn "Compiling..." - cho <- compileCompNode ifunc func ksm cnode - return (cnode,cho) - --- this takes a list of modules or files to load, and produces a compunit graph -loadModules - :: Opt -- ^ Options to use when parsing files - -> [FilePath] -- ^ targets - -> [String] -- ^ libraries to load - -> SrcLoc -- ^ where these files are requsted from - -> [Either Module FilePath] -- ^ a list of modules or filenames - -> IO (Map.Map SourceHash (Module,[(Module,SrcLoc)]),HoHash,CompUnitGraph) -- ^ the resulting acyclic graph of compilation units -loadModules modOpt targets libs sloc need = do - theCache <- findHoCache - case theCache of - Just s -> putProgressLn $ printf "Using Ho Cache: '%s'" s - Nothing -> return () - done_ref <- newIORef Done { - hoCache = theCache, - knownSourceMap = Map.empty, - validSources = Set.empty, - loadedLibraries = Map.empty, - hosEncountered = Map.empty, - modEncountered = Map.empty - } - (es,is) <- collectLibraries libs - let combModMap es = Map.unions [ Map.map ((,) l) (hoModuleMap $ libHoLib l) | l <- es] - explicitModMap = combModMap es - implicitModMap = combModMap is - reexported = Set.fromList [ m | l <- es, (m,_) <- Map.toList $ hoReexports (libHoLib l) ] - modEnc exp emap = Map.fromList [ (m,ModLibrary (exp || Set.member m reexported) mg l) | (m,(l,mg)) <- Map.toList emap ] - - modifyIORef done_ref (loadedLibraries_u $ Map.union $ Map.fromList [ (libBaseName lib,lib) | lib <- es ++ is]) - modifyIORef done_ref (modEncountered_u $ Map.union (modEnc True explicitModMap)) - modifyIORef done_ref (modEncountered_u $ Map.union (modEnc False implicitModMap)) - - forM_ (concatMap libExtraFiles (es ++ is)) $ \ef -> do - fileInTempDir ("cbits/" ++ unpackPS (extraFileName ef)) $ \fn -> BS.writeFile fn (extraFileData ef) - - done <- readIORef done_ref - forM_ (Map.elems $ loadedLibraries done) $ \ lib -> do - let libsBad = filter (\ (p,h) -> fmap (libHash) (Map.lookup p (loadedLibraries done)) /= Just h) (hohLibDeps $ libHoHeader lib) - unless (null libsBad) $ do - putErr $ printf "Library Dependencies not met. %s needs\n" (libName lib) - forM_ libsBad $ \ (p,h) -> putErr $ printf " %s (hash:%s)\n" (unpackPS p) (show h) - putErrDie "\n" - ms1 <- forM (rights need) $ \fn -> do - fetchSource modOpt done_ref [fn] Nothing - forM_ (map (,sloc) $ lefts need) $ resolveDeps modOpt done_ref - processIOErrors - done <- readIORef done_ref - let needed = (ms1 ++ lefts need) - (chash,cug) <- toCompUnitGraph done needed - dumpDeps targets (modEncountered done) cug - return (Map.filterWithKey (\k _ -> k `Set.member` validSources done) (knownSourceMap done),chash,cug) - --- turn the list of CompUnits into a true mutable graph. -processCug :: CompUnitGraph -> HoHash -> IO CompNode -processCug cug root = mdo - let mmap = Map.fromList xs - lup x = maybe (error $ "processCug: " ++ show x) id (Map.lookup x mmap) - f (h,(ds,cu)) = do - cur <- newIORef (CompLinkUnit cu) - return $ (h,CompNode h (map lup ds) cur) - xs <- mapM f cug - Just x <- return $ Map.lookup root mmap - return $ x - -mkPhonyCompUnit :: [Module] -> CompUnitGraph -> (HoHash,CompUnitGraph) -mkPhonyCompUnit need cs = (fhash,(fhash,(fdeps,CompDummy)):cs) where - fhash = MD5.md5String $ show (sort fdeps) - fdeps = [ h | (h,(_,cu)) <- cs, not . null $ providesModules cu `intersect` need ] - -printModProgress :: Int -> Int -> IO Int -> [HsModule] -> IO () -printModProgress _ _ _ [] = return () -printModProgress _ _ tickProgress ms | not progress = mapM_ (const tickProgress) ms -printModProgress fmtLen maxModules tickProgress ms = f "[" ms where - f bl ms = do - curModule <- tickProgress - case ms of - [x] -> g curModule bl "]" x - (x:xs) -> do g curModule bl "-" x; putErrLn ""; f "-" xs - _ -> error "Build.printModProgress: bad." - g curModule bl el modName = putErr $ printf "%s%*d of %*d%s %-17s" bl fmtLen curModule fmtLen maxModules el (show $ hsModuleName modName) - -countNodes cn = do - seen <- newIORef Set.empty - let h (CompNode hh deps ref) = do - s <- readIORef seen - if hh `Set.member` s then return Set.empty else do - writeIORef seen (Set.insert hh s) - ds <- mapM h deps - cm <- readIORef ref >>= g - return (Set.unions (cm:ds)) - g cn = case cn of - CompLinkUnit cu -> return $ f cu - CompTcCollected _ cu -> return $ f cu - CompCollected _ cu -> return $ f cu - CompLinkLib _ _ -> error "Build.countNodes: bad." - f cu = case cu of - CompTCed (_,_,_,ss) -> Set.fromList ss - CompSources sc -> Set.fromList (map sourceIdent sc) - _ -> Set.empty - h cn - -typeCheckGraph :: Opt -> CompNode -> IO () -typeCheckGraph modOpt cn = do - cur <- newMVar (1::Int) - maxModules <- Set.size `fmap` countNodes cn - let f (CompNode hh deps ref) = readIORef ref >>= \cn -> case cn of - CompTcCollected ctc _ -> return ctc - CompLinkUnit lu -> do - deps' <- randomPermuteIO deps - ctc <- mconcat `fmap` mapM f deps' - case lu of - CompDummy -> do - writeIORef ref (CompTcCollected ctc CompDummy) - return ctc - CompHo hoh idep ho -> do - let ctc' = hoTcInfo ho `mappend` ctc - writeIORef ref (CompTcCollected ctc' lu) - return ctc' - CompLibrary ho _libr -> do - let ctc' = hoTcInfo ho `mappend` ctc - writeIORef ref (CompTcCollected ctc' lu) - return ctc' - CompSources sc -> do - let mods = sort $ map (sourceModName . sourceInfo) sc - modules <- forM sc $ \x -> case x of - SourceParsed { sourceInfo = si, sourceModule = sm } -> - return (sourceHash si, sm, error "SourceParsed in AnnotateSource") - SourceRaw { sourceInfo = si, sourceLBS = lbs } -> do - (mod,lbs') <- parseHsSource modOpt (sourceFP si) lbs - case optAnnotate modOpt of - Just fp -> do - let ann = LBSU.fromString $ unlines [ - "{- --ANNOTATE--", - "Module: " ++ show (sourceModName si), - "Deps: " ++ show (sort $ fsts $ sourceDeps si), - "Siblings: " ++ show mods, - "-}"] - LBS.writeFile (fp ++ "/" ++ show (hsModuleName mod) ++ ".hs") (ann `LBS.append` lbs') - _ -> return () - return (sourceHash si,mod,lbs') - showProgress (map snd3 modules) - (htc,tidata) <- doModules ctc (map snd3 modules) - let ctc' = htc `mappend` ctc - writeIORef ref (CompTcCollected ctc' (CompTCed ((htc,tidata,[ (x,y) | (x,y,_) <- modules],map (sourceHoName . sourceInfo) sc)))) - return ctc' - _ -> error "Build.typeCheckGraph: bad1." - _ -> error "Build.typeCheckGraph: bad2." - showProgress ms = printModProgress fmtLen maxModules tickProgress ms - fmtLen = ceiling (logBase 10 (fromIntegral maxModules+1) :: Double) :: Int - tickProgress = modifyMVar cur $ \val -> return (val+1,val) - f cn - return () - -compileCompNode :: (CollectedHo -> Ho -> IO CollectedHo) -- ^ Process initial ho loaded from file - -> (CollectedHo -> Ho -> TiData -> IO (CollectedHo,Ho)) -- ^ Process set of mutually recursive modules to produce final Ho - -> Map.Map SourceHash (Module,[(Module,SrcLoc)]) - -> CompNode - -> IO CollectedHo -compileCompNode ifunc func ksm cn = do - cur <- newMVar (1::Int) - ksm_r <- newIORef ksm - let tickProgress = modifyMVar cur $ \val -> return (val+1,val) - maxModules <- Set.size `fmap` countNodes cn - let showProgress ms = printModProgress fmtLen maxModules tickProgress ms - fmtLen = ceiling (logBase 10 (fromIntegral maxModules+1) :: Double) :: Int - let f (CompNode hh deps ref) = readIORef ref >>= g where - g cn = case cn of - CompCollected ch _ -> return ch - CompTcCollected _ cl -> h cl - CompLinkUnit cu -> h cu - _ -> error "Build.compileCompNode: bad." - h cu = do - deps' <- randomPermuteIO deps - cho <- mconcat `fmap` mapM f deps' - - case cu of - CompDummy -> do - writeIORef ref (CompCollected cho CompDummy) - return cho - (CompHo hoh idep ho) -> do - cho <- choLibDeps_u (Map.union $ Map.fromList (hohLibDeps hoh)) `fmap` ifunc cho ho - writeIORef ref (CompCollected cho cu) - return cho - (CompLibrary ho Library { libHoHeader = hoh }) -> do - cho <- ifunc cho ho - let Right (ln,_) = hohName hoh - lh = hohHash hoh - cho' = (choLibDeps_u (Map.insert ln lh) cho) - writeIORef ref (CompCollected cho' cu) - return cho' - CompTCed ((htc,tidata,modules,shns)) -> do - (hdep,ldep) <- fmap mconcat . forM deps $ \ (CompNode h _ ref) -> do - cl <- readIORef ref - case compLinkCompUnit cl of - CompLibrary ho _ -> return ([],[hoModuleGroup ho]) - CompDummy {} -> return ([],[]) - _ -> return ([h],[]) - showProgress (snds modules) - let (mgName:_) = sort $ map (hsModuleName . snd) modules - (cho',newHo) <- func cho mempty { hoModuleGroup = mgName, hoTcInfo = htc } tidata - modifyIORef ksm_r (Map.union $ Map.fromList [ (h,(hsModuleName mod, hsModuleRequires mod)) | (h,mod) <- modules]) - ksm <- readIORef ksm_r - let hoh = HoHeader { - hohVersion = error "hohVersion", - hohName = Left mgName, - hohHash = hh, - hohArchDeps = [], - hohLibDeps = Map.toList (choLibDeps cho') - } - idep = HoIDeps { - hoIDeps = ksm, - hoDepends = [ (hsModuleName mod,h) | (h,mod) <- modules], - hoModDepends = hdep, - hoModuleGroupNeeds = ldep - } - recordHoFile (mapHoBodies eraseE newHo) idep shns hoh - writeIORef ref (CompCollected cho' (CompHo hoh idep newHo)) - return cho' - CompSources _ -> error "sources still exist!?" - f cn - -hsModuleRequires x = snub ((toModule "Jhc.Prim.Prim",bogusASrcLoc):ans) where - noPrelude = FO.Prelude `Set.notMember` optFOptsSet (hsModuleOpt x) - ans = (if noPrelude then id else ((preludeModule,bogusASrcLoc):)) [ (hsImportDeclModule y,hsImportDeclSrcLoc y) | y <- hsModuleImports x] - -searchPaths :: Opt -> String -> [(String,String)] -searchPaths modOpt m = ans where - f m | (xs,'.':ys) <- span (/= '.') m = let n = (xs ++ "/" ++ ys) in m:f n - | otherwise = [m] - ans = [ (root ++ suf,root ++ ".ho") | i <- optIncdirs modOpt, n <- f m, suf <- [".hs",".lhs",".hsc"], let root = i ++ "/" ++ n] - -mapHoBodies :: (E -> E) -> Ho -> Ho -mapHoBodies sm ho = ho { hoBuild = g (hoBuild ho) } where - g ho = ho { hoEs = map f (hoEs ho) , hoRules = runIdentity (E.Rules.mapBodies (return . sm) (hoRules ho)) } - f (t,e) = (t,sm e) - -eraseE :: E -> E -eraseE e = runIdentity $ f e where - f (EVar tv) = return $ EVar tvr { tvrIdent = tvrIdent tv } - f e = emapE f e - ---------------------------------- --- library specific routines ---------------------------------- - -buildLibrary :: (CollectedHo -> Ho -> IO CollectedHo) - -> (CollectedHo -> Ho -> TiData -> IO (CollectedHo,Ho)) -- ^ Process set of mutually recursive modules to produce final Ho - -> FilePath - -> IO () -buildLibrary ifunc func = ans where - ans fp = do - (desc,name,vers,hmods,emods,modOpts,sources) <- parse fp - vers <- runReadP parseVersion vers - let allMods = emodSet `Set.union` hmodSet - emodSet = Set.fromList emods - hmodSet = Set.fromList hmods - let outName = case optOutName modOpts of - Nothing -> name ++ "-" ++ showVersion vers ++ ".hl" - Just fn -> fn - -- TODO - must check we depend only on libraries - (rnode@(CompNode lhash _ _),cho) <- parseFiles modOpts [outName] [] (map Left $ Set.toList allMods) ifunc func - (_,(mmap,mdeps,prvds,lcor,ldef)) <- let - f (CompNode hs cd ref) = do - cl <- readIORef ref - case cl of - CompLinkLib l _ -> return l - CompCollected _ y -> g hs cd ref y - _ -> error "Build.buildLibrary: bad1." - g hh deps ref cn = do - deps <- mapM f deps - let (mg,mll) = case cn of - CompDummy -> (error "modgroup of dummy",mempty) - CompLibrary ho lib -> (hoModuleGroup ho,mempty) - CompHo hoh hidep ho -> (mg,( - Map.fromList $ zip (providesModules hidep) (repeat mg), - Map.singleton mg (sort $ fsts deps), - Set.fromList $ providesModules hidep, - Map.singleton mg (hoBuild ho'), - Map.singleton mg (hoTcInfo ho') - )) where - mg = hoModuleGroup ho - ho' = mapHoBodies eraseE ho - _ -> error "Build.buildLibrary: bad2." - res = (mg,mconcat (snds deps) `mappend` mll) - writeIORef ref (CompLinkLib res cn) - return res - in f rnode - let unknownMods = Set.toList $ Set.filter (`Set.notMember` allMods) prvds - mapM_ ((putStrLn . ("*** Module depended on in library that is not in export list: " ++)) . show) unknownMods - mapM_ ((putStrLn . ("*** We are re-exporting the following modules from other libraries: " ++)) . show) $ Set.toList (allMods Set.\\ prvds) - let hoh = HoHeader { - hohHash = lhash, - hohName = Right (packString name,vers), - hohLibDeps = Map.toList (choLibDeps cho), - hohArchDeps = [], - hohVersion = error "hohVersion" - } - let pdesc = [(packString n, packString v) | (n,v) <- ("jhc-hl-filename",outName):("jhc-description-file",fp):("jhc-compiled-by",versionString):desc, n /= "exposed-modules" ] - libr = HoLib { - hoReexports = Map.fromList [ (m,m) | m <- Set.toList $ allMods Set.\\ prvds ], - hoMetaInfo = pdesc, - hoModuleMap = mmap, - hoModuleDeps = mdeps - } - putProgressLn $ "Writing Library: " ++ outName - efs <- mapM fetchExtraFile sources - recordHlFile Library { libHoHeader = hoh, libHoLib = libr, libTcMap = ldef, - libBuildMap = lcor, libFileName = outName, libExtraFiles = efs } - -- parse library description file - parse fp = do - putProgressLn $ "Creating library from description file: " ++ show fp - LibDesc dlist dsing <- readDescFile fp - when verbose2 $ do - mapM_ print (Map.toList dlist) - mapM_ print (Map.toList dsing) - let jfield x = maybe (fail $ "createLibrary: description lacks required field " ++ show x) return $ Map.lookup x dsing - mfield x = maybe [] id $ Map.lookup x dlist - --mfield x = maybe [] (words . map (\c -> if c == ',' then ' ' else c)) $ Map.lookup x dlist - name <- jfield "name" - vers <- jfield "version" - let (modOpts,flags) = (lproc bopt,modOptions) where - Just bopt = fileOptions options modOptions `mplus` Just options - (pfs,nfs,_) = languageFlags (mfield "extensions") - lproc opt = opt { optFOptsSet = Set.union pfs (optFOptsSet opt) Set.\\ nfs } - dirs = [ "-i" ++ dd x | x <- mfield "hs-source-dirs" ] - ++ [ "-I" ++ dd x | x <- mfield "include-dirs" ] - ++ [ "-p" ++ x | x <- mfield "build-depends" ] - modOptions = (mfield "options" ++ dirs) - dd "." = FP.takeDirectory fp - dd ('.':'/':x) = dd x - dd x = FP.takeDirectory fp FP. x - when verbose $ - print (flags,optFOptsSet modOpts) - let hmods = map toModule $ snub $ mfield "hidden-modules" - emods = map toModule $ snub $ mfield "exposed-modules" - sources = map (FP.takeDirectory fp FP.) $ snub $ mfield "c-sources" ++ mfield "include-sources" - return (Map.toList dsing,name,vers,hmods,emods,modOpts,sources) - -fetchExtraFile fp = do - c <- BS.readFile fp - return ExtraFile { extraFileName = packString (FP.takeFileName fp), - extraFileData = c } - ------------------------------------- --- dumping contents of a ho file ------------------------------------- - -instance DocLike d => PPrint d MD5.Hash where - pprint h = tshow h - -instance DocLike d => PPrint d SrcLoc where - pprint sl = tshow sl - -instance DocLike d => PPrint d Version where - pprint sl = text $ showVersion sl - -instance DocLike d => PPrint d PackedString where - pprint sl = text (unpackPS sl) - -{-# NOINLINE dumpHoFile #-} -dumpHoFile :: String -> IO () -dumpHoFile fn = ans where - ans = do - putStrLn fn - case reverse fn of - 'l':'h':'.':_ -> doHl fn - 'o':'h':'.':_ -> doHo fn - _ -> putErrDie "Error: --show-ho requires a .hl or .ho file" - vindent xs = vcat (map (" " ++) xs) - showList nm xs = when (not $ null xs) $ putStrLn $ (nm ++ ":\n") <> vindent xs - doHoh hoh = do - putStrLn $ "Version:" <+> pprint (hohVersion hoh) - putStrLn $ "Hash:" <+> pprint (hohHash hoh) - putStrLn $ "Name:" <+> pprint (hohName hoh) - showList "LibDeps" (map pprint . sortUnder fst $ hohLibDeps hoh) - showList "ArchDeps" (map pprint . sortUnder fst $ hohArchDeps hoh) - doHl fn = do - l <- readHlFile fn - doHoh $ libHoHeader l - showList "MetaInfo" (sort [text (unpackPS k) <> char ':' <+> show v | - (k,v) <- hoMetaInfo (libHoLib l)]) - showList "ModuleMap" (map pprint . sortUnder fst $ Map.toList $ hoModuleMap $ libHoLib l) - showList "ModuleDeps" (map pprint . sortUnder fst $ Map.toList $ hoModuleDeps $ libHoLib l) - showList "ModuleReexports" (map pprint . sortUnder fst $ Map.toList $ hoReexports $ libHoLib l) - forM_ (Map.toList $ libBuildMap l) $ \ (g,hoB) -> do - print g - doHoB hoB - doHo fn = do - (hoh,idep,ho) <- readHoFile fn - doHoh hoh - let hoB = hoBuild ho - hoE = hoTcInfo ho - showList "Dependencies" (map pprint . sortUnder fst $ hoDepends idep) - showList "ModDependencies" (map pprint $ hoModDepends idep) - showList "IDepCache" (map pprint . sortUnder fst $ Map.toList $ hoIDeps idep) - putStrLn $ "Modules contained:" <+> tshow (keys $ hoExports hoE) - putStrLn $ "number of definitions:" <+> tshow (size $ hoDefs hoE) - putStrLn $ "hoAssumps:" <+> tshow (size $ hoAssumps hoE) - putStrLn $ "hoFixities:" <+> tshow (size $ hoFixities hoE) - putStrLn $ "hoKinds:" <+> tshow (size $ hoKinds hoE) - putStrLn $ "hoClassHierarchy:" <+> tshow (length $ classRecords $ hoClassHierarchy hoE) - putStrLn $ "hoTypeSynonyms:" <+> tshow (size $ hoTypeSynonyms hoE) - wdump FD.Exports $ do - putStrLn "---- exports information ----"; - putStrLn $ (pprint $ hoExports hoE :: String) - wdump FD.Defs $ do - putStrLn "---- defs information ----"; - putStrLn $ (pprint $ hoDefs hoE :: String) - when (dump FD.Kind) $ do - putStrLn "---- kind information ----"; - putStrLn $ (pprint $ hoKinds hoE :: String) - when (dump FD.ClassSummary) $ do - putStrLn "---- class summary ---- " - printClassSummary (hoClassHierarchy hoE) - when (dump FD.Class) $ - do {putStrLn "---- class hierarchy ---- "; - printClassHierarchy (hoClassHierarchy hoE)} - wdump FD.Types $ do - putStrLn " ---- the types of identifiers ---- " - putStrLn $ PPrint.render $ pprint (hoAssumps hoE) - doHoB hoB - doHoB hoB = do - putStrLn $ "hoDataTable:" <+> tshow (size $ hoDataTable hoB) - putStrLn $ "hoEs:" <+> tshow (size $ hoEs hoB) - putStrLn $ "hoRules:" <+> tshow (size $ hoRules hoB) - let rules = hoRules hoB - wdump FD.Rules $ putStrLn " ---- user rules ---- " >> printRules RuleUser rules - wdump FD.Rules $ putStrLn " ---- user catalysts ---- " >> printRules RuleCatalyst rules - wdump FD.RulesSpec $ putStrLn " ---- specializations ---- " >> printRules RuleSpecialization rules - wdump FD.Datatable $ do - putStrLn " ---- data table ---- " - putDocM putStr (showDataTable (hoDataTable hoB)) - putChar '\n' - wdump FD.Core $ do - putStrLn " ---- lambdacube ---- " - mapM_ (\ (v,lc) -> putChar '\n' >> printCheckName'' (hoDataTable hoB) v lc) (hoEs hoB) - printCheckName'' :: DataTable -> TVr -> E -> IO () - printCheckName'' _dataTable tvr e = do - when (dump FD.EInfo || verbose2) $ putStrLn (show $ tvrInfo tvr) - putStrLn (render $ hang 4 (pprint tvr <+> text "::" <+> pprint (tvrType tvr))) - putStrLn (render $ hang 4 (pprint tvr <+> equals <+> pprint e)) -{-* Generated by DrIFT : Look, but Don't Touch. *-} --- Imported from other files :- diff --git a/drift_processed/Ho/Type.hs b/drift_processed/Ho/Type.hs deleted file mode 100644 --- a/drift_processed/Ho/Type.hs +++ /dev/null @@ -1,244 +0,0 @@ -{- Generated by DrIFT (Automatic class derivations for Haskell) -} -{-# LINE 1 "src/Ho/Type.hs" #-} -module Ho.Type where - -import Data.Monoid -import qualified Data.ByteString as BS -import qualified Data.Map as Map - -import Data.Version -import DataConstructors(DataTable) -import E.Rules(Rules) -import E.Type -import E.TypeCheck() -import FrontEnd.Class(ClassHierarchy) -import FrontEnd.Infix(FixityMap) -import FrontEnd.KindInfer(KindEnv) -import FrontEnd.Rename(FieldMap()) -import FrontEnd.SrcLoc(SrcLoc) -import FrontEnd.Tc.Type(Type()) -import FrontEnd.TypeSynonyms(TypeSynonyms) -import Name.Id -import Name.Name(Name,Module) -import PackedString -import Support.CFF -import Support.MapBinaryInstance() -import qualified Support.MD5 as MD5 - -cff_magic = chunkType "JHC" -cff_link = chunkType "LINK" -cff_libr = chunkType "LIBR" -cff_jhdr = chunkType "JHDR" -cff_core = chunkType "CORE" -cff_defs = chunkType "DEFS" -cff_lcor = chunkType "LCOR" -cff_ldef = chunkType "LDEF" -cff_idep = chunkType "IDEP" -cff_file = chunkType "FILE" - --- | A SourceHash is the hash of a specific file, it is associated with a --- specific 'Module' that said file implements. -type SourceHash = MD5.Hash --- | HoHash is a unique identifier for a ho file or library. -type HoHash = MD5.Hash - --- | while a 'Module' is a single Module associated with a single haskell source --- file, a 'ModuleGroup' identifies a group of mutually recursive modules. --- Generally it is chosen from among the Modules making up the group, but the --- specific choice has no other meaning. We could use the HoHash, but for readability --- reasons when debugging it makes more sense to choose an arbitrary Module. -type ModuleGroup = Module - --- | the collected information that is passed around --- this is not stored in any file, but is what is collected from the ho files. -data CollectedHo = CollectedHo { - -- | this is a list of external names that are valid but that we may not know - -- anything else about it is used to recognize invalid ids. - choExternalNames :: IdSet, - -- | these are the functions in Comb form. - choCombinators :: IdMap Comb, - -- | these are rules that may need to be retroactively applied to other - -- modules - choOrphanRules :: Rules, - -- | the hos - choHoMap :: Map.Map ModuleGroup Ho, - -- | libraries depended on - choLibDeps :: Map.Map PackedString HoHash, - -- | these are caches of pre-computed values - choHo :: Ho, -- ^ cache of combined and renamed ho - choVarMap :: IdMap (Maybe E) -- ^ cache of variable substitution map - } - {-! derive: update !-} - --- | The header contains basic information about the file, it should be enough to determine whether --- we can discard the file right away or consider it further. -data HoHeader = HoHeader { - -- | the version of the file format. it comes first so we don't try to read data that may be in a different format. - hohVersion :: Int, - -- | my sha1 id - hohHash :: HoHash, - -- | the human readable name, either the ModuleGroup or the library name and version. - hohName :: Either ModuleGroup (PackedString,Version), - -- | library dependencies - hohLibDeps :: [(PackedString,HoHash)], - -- | arch dependencies, these say whether the file is specialized for a - -- given arch. - hohArchDeps :: [(PackedString,PackedString)] - } - --- | These are the dependencies needed to check if a ho file is up to date. it --- only appears in ho files as hl files do not have source code to check --- against or depend on anything but other libraries. -data HoIDeps = HoIDeps { - -- | modules depended on indexed by a hash of the source. - hoIDeps :: Map.Map SourceHash (Module,[(Module,SrcLoc)]), - -- | Haskell Source files depended on - hoDepends :: [(Module,SourceHash)], - -- | Other objects depended on to be considered up to date. - hoModDepends :: [HoHash], - -- | library module groups needed - hoModuleGroupNeeds :: [ModuleGroup] - } - -data HoLib = HoLib { - -- | arbitrary metainformation such as library author, web site, etc. - hoModuleMap :: Map.Map Module ModuleGroup, - hoReexports :: Map.Map Module Module, - hoModuleDeps :: Map.Map ModuleGroup [ModuleGroup], - hoMetaInfo :: [(PackedString,PackedString)] - } - -data Library = Library { - libHoHeader :: HoHeader, - libHoLib :: HoLib, - libTcMap :: (Map.Map ModuleGroup HoTcInfo), - libBuildMap :: (Map.Map ModuleGroup HoBuild), - libExtraFiles :: [ExtraFile], - libFileName :: FilePath - } - -instance Show Library where - showsPrec n lib = showsPrec n (hohHash $ libHoHeader lib) - --- | data only needed for type checking. -data HoTcInfo = HoTcInfo { - hoExports :: Map.Map Module [Name], - hoDefs :: Map.Map Name (SrcLoc,[Name]), - hoAssumps :: Map.Map Name Type, -- ^ used for typechecking - hoFixities :: FixityMap, - hoKinds :: KindEnv, -- ^ used for typechecking - hoTypeSynonyms :: TypeSynonyms, - hoClassHierarchy :: ClassHierarchy, - hoFieldMap :: FieldMap - } - {-! derive: update, Monoid !-} - -data HoBuild = HoBuild { - -- | Filled in by E generation - hoDataTable :: DataTable, - hoEs :: [(TVr,E)], - hoRules :: Rules - } - {-! derive: update, Monoid !-} - -data Ho = Ho { - hoModuleGroup :: ModuleGroup, - hoTcInfo :: HoTcInfo, - hoBuild :: HoBuild - } - {-! derive: update !-} - -instance Monoid Ho where - mempty = Ho (error "unknown module group") mempty mempty - mappend ha hb = Ho (hoModuleGroup ha) (hoTcInfo ha `mappend` hoTcInfo hb) (hoBuild ha `mappend` hoBuild hb) - -data ExtraFile = ExtraFile { - extraFileName :: PackedString, - extraFileData :: BS.ByteString - } - -{- -instance Monoid Ho where - mempty = Ho mempty mempty - mappend a b = Ho { - hoTcInfo = hoTcInfo a `mappend` hoTcInfo b, - hoBuild = hoBuild a `mappend` hoBuild b - } - -instance Monoid HoTcInfo where - mempty = HoTcInfo mempty mempty - mappend a b = HoTcInfo { - hoExports = hoExports a `mappend` hoExports b, - hoDefs = hoDefs a `mappend` hoDefs b - } - -instance Monoid HoBuild where - mempty = HoBuild mempty mempty mempty mempty mempty mempty mempty mempty - mappend a b = HoBuild { - hoAssumps = hoAssumps a `mappend` hoAssumps b, - hoFixities = hoFixities a `mappend` hoFixities b, - hoKinds = hoKinds a `mappend` hoKinds b, - hoClassHierarchy = hoClassHierarchy a `mappend` hoClassHierarchy b, - hoTypeSynonyms = hoTypeSynonyms a `mappend` hoTypeSynonyms b, - hoDataTable = hoDataTable a `mappend` hoDataTable b, - hoEs = hoEs a `mappend` hoEs b, - hoRules = hoRules a `mappend` hoRules b - } - - -} -{-* Generated by DrIFT : Look, but Don't Touch. *-} -choCombinators_u f r@CollectedHo{choCombinators = x} = r{choCombinators = f x} -choExternalNames_u f r@CollectedHo{choExternalNames = x} = r{choExternalNames = f x} -choHo_u f r@CollectedHo{choHo = x} = r{choHo = f x} -choHoMap_u f r@CollectedHo{choHoMap = x} = r{choHoMap = f x} -choLibDeps_u f r@CollectedHo{choLibDeps = x} = r{choLibDeps = f x} -choOrphanRules_u f r@CollectedHo{choOrphanRules = x} = r{choOrphanRules = f x} -choVarMap_u f r@CollectedHo{choVarMap = x} = r{choVarMap = f x} -choCombinators_s v = choCombinators_u (const v) -choExternalNames_s v = choExternalNames_u (const v) -choHo_s v = choHo_u (const v) -choHoMap_s v = choHoMap_u (const v) -choLibDeps_s v = choLibDeps_u (const v) -choOrphanRules_s v = choOrphanRules_u (const v) -choVarMap_s v = choVarMap_u (const v) - -hoAssumps_u f r@HoTcInfo{hoAssumps = x} = r{hoAssumps = f x} -hoClassHierarchy_u f r@HoTcInfo{hoClassHierarchy = x} = r{hoClassHierarchy = f x} -hoDefs_u f r@HoTcInfo{hoDefs = x} = r{hoDefs = f x} -hoExports_u f r@HoTcInfo{hoExports = x} = r{hoExports = f x} -hoFieldMap_u f r@HoTcInfo{hoFieldMap = x} = r{hoFieldMap = f x} -hoFixities_u f r@HoTcInfo{hoFixities = x} = r{hoFixities = f x} -hoKinds_u f r@HoTcInfo{hoKinds = x} = r{hoKinds = f x} -hoTypeSynonyms_u f r@HoTcInfo{hoTypeSynonyms = x} = r{hoTypeSynonyms = f x} -hoAssumps_s v = hoAssumps_u (const v) -hoClassHierarchy_s v = hoClassHierarchy_u (const v) -hoDefs_s v = hoDefs_u (const v) -hoExports_s v = hoExports_u (const v) -hoFieldMap_s v = hoFieldMap_u (const v) -hoFixities_s v = hoFixities_u (const v) -hoKinds_s v = hoKinds_u (const v) -hoTypeSynonyms_s v = hoTypeSynonyms_u (const v) - -instance Monoid HoTcInfo where - mempty = HoTcInfo mempty mempty mempty mempty mempty mempty mempty mempty - mappend (HoTcInfo aa ab ac ad ae af ag ah) (HoTcInfo aa' ab' ac' ad' ae' af' ag' ah') = HoTcInfo (mappend aa aa')(mappend ab ab')(mappend ac ac')(mappend ad ad')(mappend ae ae')(mappend af af')(mappend ag ag')(mappend ah ah') - -hoDataTable_u f r@HoBuild{hoDataTable = x} = r{hoDataTable = f x} -hoEs_u f r@HoBuild{hoEs = x} = r{hoEs = f x} -hoRules_u f r@HoBuild{hoRules = x} = r{hoRules = f x} -hoDataTable_s v = hoDataTable_u (const v) -hoEs_s v = hoEs_u (const v) -hoRules_s v = hoRules_u (const v) - -instance Monoid HoBuild where - mempty = HoBuild mempty mempty mempty - mappend (HoBuild aa ab ac) (HoBuild aa' ab' ac') = HoBuild (mappend aa aa')(mappend ab ab')(mappend ac ac') - -hoBuild_u f r@Ho{hoBuild = x} = r{hoBuild = f x} -hoModuleGroup_u f r@Ho{hoModuleGroup = x} = r{hoModuleGroup = f x} -hoTcInfo_u f r@Ho{hoTcInfo = x} = r{hoTcInfo = f x} -hoBuild_s v = hoBuild_u (const v) -hoModuleGroup_s v = hoModuleGroup_u (const v) -hoTcInfo_s v = hoTcInfo_u (const v) - --- Imported from other files :- diff --git a/drift_processed/Name/VConsts.hs b/drift_processed/Name/VConsts.hs deleted file mode 100644 --- a/drift_processed/Name/VConsts.hs +++ /dev/null @@ -1,94 +0,0 @@ -{- Generated by DrIFT (Automatic class derivations for Haskell) -} -{-# LINE 1 "src/Name/VConsts.hs" #-} -module Name.VConsts where - -import Control.Applicative -import Data.Foldable -import Data.Monoid -import Data.Traversable - --- This is much more verbose/complicated than it needs be. - -class TypeNames a where - tInt :: a - tRational :: a - tChar :: a - tIntzh :: a - tEnumzh :: a - tCharzh :: a - tBool :: a - tUnit :: a - tString :: a - tInteger :: a - tWorld__ :: a - - tInt = error "tInt" - tRational = error "tRational" - tChar = error "tChar" - tIntzh = error "tIntzh" - tEnumzh = error "tEnumzh" - tCharzh = error "tCharzh" - tBool = error "tBool" - tUnit = error "tUnit" - tString = error "tString" - tInteger = error "tInteger" - tWorld__ = error "tWorld" - -class ConNames a where - vTrue :: a - vFalse :: a - vCons :: a - vUnit :: a - - vTrue = error "vTrue" - vFalse = error "vFalse" - vCons = error "vCons" - vUnit = error "vUnit" - -class FromTupname a where - fromTupname :: Monad m => a -> m Int - -instance FromTupname String where - fromTupname ('(':s) | (cs,")") <- span (== ',') s, lc <- length cs, lc > 0 = return $! (lc + 1) - fromTupname xs = fail $ "fromTupname: not tuple " ++ xs - -instance FromTupname (String,String) where - fromTupname ("Jhc.Prim.Prim",n) = fromTupname n - fromTupname xs = fail $ "fromTupname: not tuple " ++ show xs - -class ToTuple a where - toTuple :: Int -> a - -instance ToTuple String where - toTuple n = '(': replicate (n - 1) ',' ++ ")" - -instance ToTuple (String,String) where - toTuple n = ("Jhc.Prim.Prim",toTuple n) - --- | various functions needed for desugaring. -data FuncNames a = FuncNames { - func_equals :: a, - func_fromInt :: a, - func_fromInteger :: a, - func_fromRational :: a, - func_negate :: a, - func_runExpr :: a, - func_runMain :: a, - func_runNoWrapper :: a, - func_runRaw :: a - } - {-! derive: Functor, Traversable, Foldable !-} -{-* Generated by DrIFT : Look, but Don't Touch. *-} -instance Functor FuncNames where - fmap f (FuncNames aa ab ac ad ae af ag ah - ai) = FuncNames (f aa) (f ab) (f ac) (f ad) (f ae) (f af) (f ag) (f ah) (f ai) - -instance Data.Traversable.Traversable FuncNames where - traverse f (FuncNames aa ab ac ad ae af ag ah - ai) = FuncNames <$> f aa <*> f ab <*> f ac <*> f ad <*> f ae <*> f af <*> f ag <*> f ah <*> f ai - -instance Foldable FuncNames where - foldMap f (FuncNames aa ab ac ad ae af ag ah - ai) = (f aa) `Data.Monoid.mappend` (f ab) `Data.Monoid.mappend` (f ac) `Data.Monoid.mappend` (f ad) `Data.Monoid.mappend` (f ae) `Data.Monoid.mappend` (f af) `Data.Monoid.mappend` (f ag) `Data.Monoid.mappend` (f ah) `Data.Monoid.mappend` (f ai) - --- Imported from other files :- diff --git a/drift_processed/Options.hs b/drift_processed/Options.hs deleted file mode 100644 --- a/drift_processed/Options.hs +++ /dev/null @@ -1,597 +0,0 @@ -{- Generated by DrIFT (Automatic class derivations for Haskell) -} -{-# LINE 1 "src/Options.hs" #-} -{-# OPTIONS -w -funbox-strict-fields #-} -module Options( - processOptions, - Opt(..), - options, - Mode(..), - StopCondition(..), - putVerbose, - putVerboseLn, - putProgress, - putProgressLn, - getArguments, - findHoCache, - verbose, - verbose2, - progress, - dump, - wdump, - fopts, - flint, - fileOptions, - withOptions, - withOptionsT, - getArgString, - outputName, - OptM(), - OptT(), - OptionMonad(..), - flagOpt - ) where - -import Control.Monad.Error() -- IO MonadPlus instance -import Control.Monad.Identity -import Control.Monad.Reader -import Data.List(nub) -import Data.Maybe -import System.Console.GetOpt -import System.Directory -import System.IO.Unsafe -import System.Environment (getArgs, getProgName, getEnv) -import System.Exit -import qualified Data.ByteString.UTF8 as BS -import qualified Data.Map as M -import qualified Data.Set as S - -import RawFiles(targets_ini) -import Support.IniParse -import Support.TempDir -import Support.Cabal -import Util.ExitCodes -import Util.Gen -import Util.YAML -import Version.Config -import Version.Version(versionString,versionContext) -import qualified FlagDump -import qualified FlagOpts -import qualified Version.Config as VC - -{-@CrossCompilation - -# Basics - -Unlike many other compilers, Ajhc is a native cross compiler. What this means is -that every compile of Ajhc is able to create code for all possible target -systems. This leads to many simplifications when it comes to cross compiling -with Ajhc. Basically in order to cross compile, you need only pass the flag -'--cross' to Ajhc, and pass an appropriate '-m' option to tell Ajhc what machine -you are targetting. An example would be - - ; ajhc --cross -mwin32 test/HelloWorld.hs - -The targets list is extensible at run-time via the targets.ini file explained -below. - -# targets.ini - -This file determines what targets are available. The format consists of entries as follows. - - [targetname] - key1=value - key2=value - key3+=value - merge=targetname2 - -merge is a special key meaning to merge the contents of another target into the -current one. The configuration file is read in order, and the final value set -for a given key is the one that is used. - -An example describing how to cross compile for windows is as follows: - - [win32] - cc=i386-mingw32-gcc - cflags+=-mwindows -mno-cygwin - executable_extension=.exe - merge=i686 - -This sets the compiler to use as well as a few other options then jumps to the -generic i686 routine. The special target [default] is always read before all -other targets. If '--cross' is specified on the command line then this is the -only implicitly included configuration, otherwise Ajhc will assume you are -compiling for the current architecture and choose an appropriate target to -include in addition to default. - -Ajhc will attempt to read several targets.ini files in order. they are - -$PREFIX/etc/ajhc-\$VERSION/targets.ini -: this is the targets.ini that is included with Ajhc and contains the default options. - -$PREFIX/etc/ajhc-\$VERSION/targets-local.ini -: Ajhc will read this if it exists, it is used to specify custom system wide configuration options, such as the name of local compilers. - -$HOME/.ajhc/targets.ini -: this is where a users local configuration information goes. - -$HOME/etc/ajhc/targets.ini -: this is simply for people that prefer to not use hidden directories for configuration - -The last value specified for an option is the one used, so a users local -configuration overrides the system local version which overrides the built in -options. - -# Options available - -Option Meaning ------- --------------------------------------------------------------------------- -_cc_ what c compiler to use. generally this will be gcc for local builds and something like $ARCH-$HOST-gcc for cross compiles -_byteorder_ one of *le* or *be* for little or big endian -_gc_ what garbage collector to use. It should be one of *static* or *boehm*. -_cflags_ options to pass to the c compiler -_cflags\_debug_ options to pass to the c compiler only when debugging is enabled -_cflags\_nodebug_ options to pass to the c compiler only when debugging is disabled -_profile_ whether to include profiling code in the generated executable -_autoload_ what haskell libraries to autoload, seperated by commas. -_executable\_extension_ specifies an extension that should be appended to executable files, (i.e. .EXE on windows) -_merge_ a special option that merges the contents of another configuration target into the currrent one. -_bits_ the number of bits a pointer contains on this architecture -_bits\_max_ the number of bits in the largest integral type. should be the number of bits in the 'intmax_t' C type. -_arch_ what to pass to gcc as the architecture - -# Special defines to set cflags - -Define Meaning ------- --------------------------------------------------------------------------- -\_JHC\_ARM\_STAY\_IN\_THUMB\_MODE set bit0 to any function pointers, for Cortex-M*. ([more detail](http://communities.mentor.com/community/cs/archives/arm-gnu/msg01904.html)) -\_JHC\_JGC\_NAIVEGC run gc when have no more blocks. -\_JHC\_JGC\_STACKGROW number of stack entry growed when run short of it. -\_JHC\_JGC\_FIXED\_MEGABLOCK use a single megablock without allocation megablock. -\_JHC\_JGC\_BLOCK\_SHIFT bit shift to specify block size. Use it internally like this: (1 << (_JHC_JGC_BLOCK_SHIFT)). -\_JHC\_JGC\_MEGABLOCK\_SHIFT bit shift to specify megablock size. Use it internally like this: (1 << (_JHC_JGC_MEGABLOCK_SHIFT)). - --} - -data Mode = BuildHl FilePath -- ^ Build the specified hl-file given a description file. - | Interactive -- ^ Run interactively. - | Version -- ^ Print version and die. - | VersionCtx -- ^ Print version context and die. - | ShowHelp -- ^ Show help message and die. - | ShowConfig -- ^ Show configuration info. - | CompileExe -- ^ Compile executable - | ShowHo String -- ^ Show ho-file. - | ListLibraries -- ^ List libraries - | PrintHscOptions -- ^ Print options for hsc2hs - | PurgeCache -- ^ Purge the cache - | Preprocess -- ^ Filter through preprocessor - deriving(Eq) - -data StopCondition - = StopError String -- ^ error - | StopParse -- ^ Just parse and rename modules then exit - | StopTypeCheck -- ^ Stop after type checking - | StopC -- ^ Stop after producing C code. - | CompileHo -- ^ Compile ho - | StopNot -- ^ Don't stop believing. - deriving(Eq) - -data Opt = Opt { - optMode :: Mode, -- ^ Mode of interaction - optColumns :: !Int, -- ^ Width of terminal. - optDump :: [String], -- ^ Dump options (raw). - optStmts :: [String], -- ^ statements to execute - optFOpts :: [String], -- ^ Flag options (raw). - optIncdirs :: [String], -- ^ Include directories. - optCCargs :: [String], -- ^ Optional arguments to the C compiler. - optHls :: [String], -- ^ Load the specified hl-files (haskell libraries). - optAutoLoads :: [String], -- ^ AutoLoaded haskell libraries. - optHlPath :: [String], -- ^ Path to look for libraries. - optIncs :: [String], - optDefs :: [String], - optExtensions :: [String], - optStop :: StopCondition, - optWorkDir :: Maybe FilePath, - optAnnotate :: Maybe FilePath, - optDeps :: Maybe FilePath, - optHoDir :: Maybe FilePath, - optHoCache :: Maybe FilePath, - optArgs :: [String], - optStale :: [String], -- ^ treat these modules as stale - optKeepGoing :: !Bool, -- ^ Keep going when encountering errors. - optMainFunc :: Maybe (Bool,String), -- ^ Entry point name for the main function. - optArch :: [String], -- ^ target architecture - optCross :: Bool, - optOutName :: Maybe String, -- ^ Name of output file. - optIgnoreHo :: !Bool, -- ^ Ignore ho-files. - optNoWriteHo :: !Bool, -- ^ Don't write ho-files. - optNoAuto :: !Bool, -- ^ Don't autoload packages - optVerbose :: !Int, -- ^ Verbosity - optStatLevel :: !Int, -- ^ Level to print statistics - optInis :: M.Map String String, -- ^ options read from ini files - optDumpSet :: S.Set FlagDump.Flag, -- ^ Dump flags. - optFOptsSet :: S.Set FlagOpts.Flag -- ^ Flag options (-f\). - } {-!derive: update !-} - -emptyOpt = Opt { - optMode = CompileExe, - optColumns = getColumns, - optCross = False, - optIncdirs = initialIncludes, - optAnnotate = Nothing, - optDeps = Nothing, - optHls = [], - optAutoLoads = [], - optHlPath = initialLibIncludes, - optIncs = [], - optDefs = [], - optExtensions = [], - optStop = StopNot, - optDump = [], - optStale = [], - optStmts = [], - optFOpts = ["default"], - optCCargs = [], - optWorkDir = Nothing, - optHoDir = Nothing, - optHoCache = Nothing, - optArgs = [], - optIgnoreHo = False, - optNoWriteHo = False, - optKeepGoing = False, - optMainFunc = Nothing, - optArch = ["default"], - optOutName = Nothing, - optVerbose = 0, - optStatLevel = 1, - optNoAuto = False, - optDumpSet = S.singleton FlagDump.Progress, - optFOptsSet = S.empty -} - -idu "-" _ = [] -idu d ds = ds ++ [d] - -theoptions :: [OptDescr (Opt -> Opt)] -theoptions = - [ Option ['V'] ["version"] (NoArg (optMode_s Version)) "print version info and exit" - , Option [] ["version-context"] (NoArg (optMode_s VersionCtx)) "print version context info and exit" - , Option [] ["help"] (NoArg (optMode_s ShowHelp)) "print help information and exit" - , Option [] ["info"] (NoArg (optMode_s ShowConfig)) "show compiler configuration information and exit" - , Option [] ["purge-cache"] (NoArg (optMode_s PurgeCache)) "clean out Ajhc compilation cache" - , Option ['v'] ["verbose"] (NoArg (optVerbose_u (+1))) "chatty output on stderr" - , Option ['z'] [] (NoArg (optStatLevel_u (+1))) "Increase verbosity of statistics" - , Option ['d'] [] (ReqArg (optDump_u . (:)) "[no-]flag") "dump specified data during compilation" - , Option ['f'] [] (ReqArg (optFOpts_u . (:)) "[no-]flag") "set or clear compilation options" - , Option ['X'] [] (ReqArg (optExtensions_u . (:)) "ExtensionName") "enable the given language extension" - , Option ['o'] ["output"] (ReqArg (optOutName_s . Just) "FILE") "output to FILE" - , Option ['i'] ["include"] (ReqArg (optIncdirs_u . idu) "DIR") "where to look for source files" - , Option ['I'] [] (ReqArg (optIncs_u . idu) "DIR") "add to preprocessor include path" - , Option ['D'] [] (ReqArg (optDefs_u . (:)) "NAME=VALUE") "add new definitions to set in preprocessor" - , Option [] ["optc"] (ReqArg (optCCargs_u . idu) "option") "extra options to pass to c compiler" - , Option ['c'] [] (NoArg (optStop_s CompileHo)) "just compile the modules, caching the results." - , Option ['C'] [] (NoArg (optStop_s StopC)) "compile to C code" - , Option ['E'] [] (NoArg (optMode_s Preprocess)) "preprocess the input and print result to stdout" - , Option ['k'] ["keepgoing"] (NoArg (optKeepGoing_s True)) "keep going on errors" - , Option [] ["cross"] (NoArg (optCross_s True)) "enable cross-compilation, choose target with the -m flag" - , Option [] ["stop"] (ReqArg (optStop_s . stop) "parse/typecheck/c") "stop after the given pass, parse/typecheck/c" - , Option [] ["width"] (ReqArg (optColumns_s . read) "COLUMNS") "width of screen for debugging output" - , Option [] ["main"] (ReqArg (optMainFunc_s . Just . (,) False) "Main.main") "main entry point" - , Option ['m'] ["arch"] (ReqArg (optArch_u . idu ) "arch") "target architecture options" - , Option [] ["entry"] (ReqArg (optMainFunc_s . Just . (,) True) "") "main entry point, showable expression" - -- , Option ['e'] [] (ReqArg (\d -> optStmts_u ( d:)) "") "run given statement as if on jhci prompt" - , Option [] ["show-ho"] (ReqArg (optMode_s . ShowHo) "file.ho") "Show ho file" - , Option [] ["noauto"] (NoArg (optNoAuto_s True)) "Don't automatically load base and haskell98 packages" - , Option ['p'] [] (ReqArg (optHls_u . (:)) "package") "Load given haskell library package" - , Option ['L'] [] (ReqArg (optHlPath_u . idu) "path") "Look for haskell libraries in the given directory" - , Option [] ["build-hl"] (ReqArg (optMode_s . BuildHl) "desc.yaml") "Build hakell library from given library description file" - , Option [] ["annotate-source"] (ReqArg (optAnnotate_s . Just) "") "Write preprocessed and annotated source code to the directory specified" - , Option [] ["deps"] (ReqArg (optDeps_s . Just) "") "Write dependency information to file specified" - , Option [] ["interactive"] (NoArg (optMode_s Interactive)) "run interactivly ( for debugging only)" - , Option [] ["ignore-cache"] (NoArg (optIgnoreHo_s True)) "Ignore existing compilation cache entries." - , Option [] ["readonly-cache"] (NoArg (optNoWriteHo_s True)) "Do not write new information to the compilation cache." - , Option [] ["no-cache"] (NoArg (optNoWriteHo_s True . optIgnoreHo_s True)) "Do not use or update the cache." - , Option [] ["cache-dir"] (ReqArg (optHoCache_s . Just ) "AJHC_CACHE") "Use a global cache located in the directory passed as an argument." --- , Option [] ["ho-dir"] (ReqArg (optHoDir_s . Just ) "") "Where to place and look for ho files" - , Option [] ["stale"] (ReqArg (optStale_u . idu) "Module") "Treat these modules as stale, even if they exist in the cache" - , Option [] ["list-libraries"] (NoArg (optMode_s ListLibraries)) "List of installed libraries" - , Option [] ["tdir"] (ReqArg (optWorkDir_s . Just) "dir/") "specify the directory where all intermediate files/dumps will be placed." --- , Option [] ["print-hsc-options"] (NoArg (optMode_s PrintHscOptions)) "print options to pass to hsc2hs" - ] - -stop "parse" = StopParse -stop "deps" = StopParse -stop "typecheck" = StopTypeCheck -stop "c" = StopC -stop s = StopError s - --- | Width of terminal. -getColumns :: Int -getColumns = read $ unsafePerformIO (getEnv "COLUMNS" `mplus` return "80") - -postProcessFD :: Monad m => Opt -> m Opt -postProcessFD o = case FlagDump.process (optDumpSet o) (optDump o ++ vv) of - (s,[]) -> return $ o { optDumpSet = s, optDump = [] } - (_,xs) -> fail ("Unrecognized dump flag passed to '-d': " - ++ unwords xs ++ "\nValid dump flags:\n\n" ++ FlagDump.helpMsg) - where - vv | optVerbose o >= 2 = ["veryverbose"] - | optVerbose o >= 1 = ["verbose"] - | otherwise = [] - -postProcessFO :: Monad m => Opt -> m Opt -postProcessFO o = case FlagOpts.process (optFOptsSet o) (optFOpts o) of - (s,[]) -> return $ o { optFOptsSet = s, optFOpts = [] } - (_,xs) -> fail ("Unrecognized flag passed to '-f': " - ++ unwords xs ++ "\nValid flags:\n\n" ++ FlagOpts.helpMsg) - -getArguments = do - x <- lookupEnv "AJHC_OPTS" - let eas = maybe [] words x - as <- getArgs - return (eas ++ as) - -pfill :: - Int -- ^ maximum width - -> (a -> Int) -- ^ find width of any element - -> [a] -- ^ input elements - -> [[a]] -- ^ output element -pfill maxn length xs = f maxn xs [] [] where - f n (x:xs) ws ls | lx < n = f (n - lx) xs (x:ws) ls where - lx = length x - f _ (x:xs) [] ls = f (maxn - length x) xs [x] ls - f _ (x:xs) ws ls = f (maxn - length x) xs [x] (ws:ls) - f _ [] [] ls = reverse (map reverse ls) - f _ [] ws ls = reverse (map reverse (ws:ls)) - -helpUsage = usageInfo header theoptions ++ trailer where - header = "Usage: ajhc [OPTION...] Main.hs" - trailer = "\n" ++ mkoptlist "-d" FlagDump.helpFlags ++ "\n" ++ mkoptlist "-f" FlagOpts.helpFlags - mkoptlist d os = "valid " ++ d ++ " arguments: 'help' for more info\n " ++ intercalate "\n " (map (intercalate ", ") $ pfill 100 ((2 +) . length) os) ++ "\n" - -{-# NOINLINE processOptions #-} --- | Parse commandline options. -processOptions :: IO Opt -processOptions = do - -- initial argument processing - argv <- getArguments - let (o,ns,rc) = getOpt Permute theoptions argv - o <- return (foldl (flip ($)) emptyOpt o) - when (rc /= []) $ putErrLn (concat rc ++ helpUsage) >> exitWith exitCodeUsage - case optStop o of - StopError s -> putErrLn "bad option passed to --stop should be one of parse, deps, typecheck, or c" >> exitWith exitCodeUsage - _ -> return () - case optMode o of - ShowHelp -> doShowHelp - ShowConfig -> doShowConfig - Version -> putStrLn versionString >> exitSuccess - VersionCtx -> putStrLn (versionString ++ BS.toString versionContext) >> exitSuccess - PrintHscOptions -> do - putStrLn $ "-I" ++ VC.datadir ++ "/" ++ VC.package ++ "-" ++ VC.shortVersion ++ "/include" - exitSuccess - _ -> return () - -- read targets.ini file - Just home <- fmap (`mplus` Just "/") $ lookupEnv "HOME" - inis <- parseIniFiles (optVerbose o > 0) (BS.toString targets_ini) [confDir ++ "/targets.ini", confDir ++ "/targets-local.ini", home ++ "/etc/ajhc/targets.ini", home ++ "/.ajhc/targets.ini"] (optArch o) - -- process dump flags - o <- either putErrDie return $ postProcessFD o - when (FlagDump.Ini `S.member` optDumpSet o) $ flip mapM_ (M.toList inis) $ \(a,b) -> putStrLn (a ++ "=" ++ b) - -- set flags based on ini options - let o1 = case M.lookup "gc" inis of - Just "jgc" -> optFOptsSet_u (S.insert FlagOpts.Jgc) o - Just "boehm" -> optFOptsSet_u (S.insert FlagOpts.Boehm) o - _ -> o - o2 <- either putErrDie return $ postProcessFO o1 - when (FlagDump.Ini `S.member` optDumpSet o) $ do - putStrLn (show $ optDumpSet o) - putStrLn (show $ optFOptsSet o) - -- add autoloads based on ini options - let autoloads = maybe [] (tokens (',' ==)) (M.lookup "autoload" inis) - return o2 { optArgs = ns, optInis = inis, optAutoLoads = autoloads } - -doShowHelp = do - putStrLn helpUsage - exitSuccess - -doShowConfig = do - --mapM_ (\ (x,y) -> putStrLn (x ++ ": " ++ y)) configs - putStrLn $ showYAML configs - exitSuccess - -findHoCache :: IO (Maybe FilePath) -findHoCache = do - cd <- lookupEnv "AJHC_CACHE" - case optHoCache options `mplus` cd of - Just s -> do return (Just s) - Just "-" -> do return Nothing - Nothing | isNothing (optHoDir options) -> do - Just home <- fmap (`mplus` Just "/") $ lookupEnv "HOME" - let cd = home ++ "/.ajhc/cache" - createDirectoryIfMissing True cd - return (Just cd) - _ -> return Nothing - -configs :: Node -configs = toNode [ - "jhclibpath" ==> initialLibIncludes, - "version" ==> version, - "package" ==> package, - "libdir" ==> libdir, - "datadir" ==> datadir, - "libraryInstall" ==> libraryInstall, - "host" ==> host - ] where - (==>) :: ToNode b => String -> b -> (String,Node) - a ==> b = (a,toNode b) - -{-# NOINLINE fileOptions #-} -fileOptions :: Monad m => Opt -> [String] -> m Opt -fileOptions options xs = case getOpt Permute theoptions xs of - (os,[],[]) -> postProcessFD (foldl (flip ($)) options os) >>= postProcessFO - (_,_,errs) -> fail (concat errs) - -{-# NOINLINE options #-} --- | The global options currently used. -options :: Opt -options = unsafePerformIO processOptions - --- | Put a string to stderr when running verbose. -putVerbose :: String -> IO () -putVerbose s = when (optVerbose options > 0) $ putErr s - --- | Put a line to stderr when running verbose. -putVerboseLn :: String -> IO () -putVerboseLn s = putVerbose (s ++ "\n") - -putProgress :: String -> IO () -putProgress s = when progress $ putErr s - --- | Put a line to stderr when running verbose. -putProgressLn :: String -> IO () -putProgressLn s = putProgress (s ++ "\n") - --- | Is verbose > 0? -progress :: Bool -progress = dump FlagDump.Progress - --- | Is verbose > 0? -verbose :: Bool -verbose = optVerbose options > 0 --- | Is verbose > 1? -verbose2 :: Bool -verbose2 = optVerbose options > 1 - --- | Test whether a dump flag is set. -dump :: FlagDump.Flag -> Bool -dump s = s `S.member` optDumpSet options --- | Test whether an option flag is set. -fopts :: FlagOpts.Flag -> Bool -fopts s = s `S.member` optFOptsSet options --- | Do the action when the suplied dump flag is set. -wdump :: (Monad m) => FlagDump.Flag -> m () -> m () -wdump f = when (dump f) - --- | Is the \"lint\" option flag set? -flint :: Bool -flint = FlagOpts.Lint `S.member` optFOptsSet options - --- | Include directories taken from JHCPATH enviroment variable. -initialIncludes :: [String] -initialIncludes = unsafePerformIO $ do - p <- lookupEnv "AJHC_PATH" - let x = fromMaybe "" p - return (".":(tokens (== ':') x)) - --- | Include directories taken from JHCLIBPATH enviroment variable. -initialLibIncludes :: [String] -initialLibIncludes = unsafePerformIO $ do - ps <- lookupEnv "AJHC_LIBRARY_PATH" - h <- lookupEnv "HOME" - let paths = h ++ ["/usr/local","/usr"] - bases = ["/lib","/share"] - vers = ["/ajhc-" ++ shortVersion, "/ajhc"] - dat <- getDataFileNameMaybe "lib" - return $ nub $ maybe [] (tokens (':' ==)) ps ++ [ p ++ b ++ v | p <- paths, v <- vers, b <- bases ] - ++ [d ++ v | d <- [libdir,datadir], v <- vers] ++ [libraryInstall] ++ maybeToList dat - -class Monad m => OptionMonad m where - getOptions :: m Opt - getOptions = return options - -instance OptionMonad Identity - -newtype OptT m a = OptT (ReaderT Opt m a) - deriving(MonadIO,Monad,Functor,MonadTrans) - -type OptM = OptT Identity - -instance Monad m => OptionMonad (OptT m) where - getOptions = OptT ask - -withOptions :: Opt -> OptM a -> a -withOptions opt (OptT x) = runIdentity (runReaderT x opt) - -withOptionsT :: Opt -> OptT m a -> m a -withOptionsT opt (OptT x) = runReaderT x opt - -outputName = fromMaybe "hs.out" (optOutName options) - -flagOpt :: OptionMonad m => FlagOpts.Flag -> m Bool -flagOpt flag = do - opt <- getOptions - return (flag `S.member` optFOptsSet opt) - -getArgString = do - name <- getProgName - args <- getArguments - return (simpleQuote (name:args),head $ lines versionString) -{-* Generated by DrIFT : Look, but Don't Touch. *-} -optAnnotate_u f r@Opt{optAnnotate = x} = r{optAnnotate = f x} -optArch_u f r@Opt{optArch = x} = r{optArch = f x} -optArgs_u f r@Opt{optArgs = x} = r{optArgs = f x} -optAutoLoads_u f r@Opt{optAutoLoads = x} = r{optAutoLoads = f x} -optCCargs_u f r@Opt{optCCargs = x} = r{optCCargs = f x} -optColumns_u f r@Opt{optColumns = x} = r{optColumns = f x} -optCross_u f r@Opt{optCross = x} = r{optCross = f x} -optDefs_u f r@Opt{optDefs = x} = r{optDefs = f x} -optDeps_u f r@Opt{optDeps = x} = r{optDeps = f x} -optDump_u f r@Opt{optDump = x} = r{optDump = f x} -optDumpSet_u f r@Opt{optDumpSet = x} = r{optDumpSet = f x} -optExtensions_u f r@Opt{optExtensions = x} = r{optExtensions = f x} -optFOpts_u f r@Opt{optFOpts = x} = r{optFOpts = f x} -optFOptsSet_u f r@Opt{optFOptsSet = x} = r{optFOptsSet = f x} -optHlPath_u f r@Opt{optHlPath = x} = r{optHlPath = f x} -optHls_u f r@Opt{optHls = x} = r{optHls = f x} -optHoCache_u f r@Opt{optHoCache = x} = r{optHoCache = f x} -optHoDir_u f r@Opt{optHoDir = x} = r{optHoDir = f x} -optIgnoreHo_u f r@Opt{optIgnoreHo = x} = r{optIgnoreHo = f x} -optIncdirs_u f r@Opt{optIncdirs = x} = r{optIncdirs = f x} -optIncs_u f r@Opt{optIncs = x} = r{optIncs = f x} -optInis_u f r@Opt{optInis = x} = r{optInis = f x} -optKeepGoing_u f r@Opt{optKeepGoing = x} = r{optKeepGoing = f x} -optMainFunc_u f r@Opt{optMainFunc = x} = r{optMainFunc = f x} -optMode_u f r@Opt{optMode = x} = r{optMode = f x} -optNoAuto_u f r@Opt{optNoAuto = x} = r{optNoAuto = f x} -optNoWriteHo_u f r@Opt{optNoWriteHo = x} = r{optNoWriteHo = f x} -optOutName_u f r@Opt{optOutName = x} = r{optOutName = f x} -optStale_u f r@Opt{optStale = x} = r{optStale = f x} -optStatLevel_u f r@Opt{optStatLevel = x} = r{optStatLevel = f x} -optStmts_u f r@Opt{optStmts = x} = r{optStmts = f x} -optStop_u f r@Opt{optStop = x} = r{optStop = f x} -optVerbose_u f r@Opt{optVerbose = x} = r{optVerbose = f x} -optWorkDir_u f r@Opt{optWorkDir = x} = r{optWorkDir = f x} -optAnnotate_s v = optAnnotate_u (const v) -optArch_s v = optArch_u (const v) -optArgs_s v = optArgs_u (const v) -optAutoLoads_s v = optAutoLoads_u (const v) -optCCargs_s v = optCCargs_u (const v) -optColumns_s v = optColumns_u (const v) -optCross_s v = optCross_u (const v) -optDefs_s v = optDefs_u (const v) -optDeps_s v = optDeps_u (const v) -optDump_s v = optDump_u (const v) -optDumpSet_s v = optDumpSet_u (const v) -optExtensions_s v = optExtensions_u (const v) -optFOpts_s v = optFOpts_u (const v) -optFOptsSet_s v = optFOptsSet_u (const v) -optHlPath_s v = optHlPath_u (const v) -optHls_s v = optHls_u (const v) -optHoCache_s v = optHoCache_u (const v) -optHoDir_s v = optHoDir_u (const v) -optIgnoreHo_s v = optIgnoreHo_u (const v) -optIncdirs_s v = optIncdirs_u (const v) -optIncs_s v = optIncs_u (const v) -optInis_s v = optInis_u (const v) -optKeepGoing_s v = optKeepGoing_u (const v) -optMainFunc_s v = optMainFunc_u (const v) -optMode_s v = optMode_u (const v) -optNoAuto_s v = optNoAuto_u (const v) -optNoWriteHo_s v = optNoWriteHo_u (const v) -optOutName_s v = optOutName_u (const v) -optStale_s v = optStale_u (const v) -optStatLevel_s v = optStatLevel_u (const v) -optStmts_s v = optStmts_u (const v) -optStop_s v = optStop_u (const v) -optVerbose_s v = optVerbose_u (const v) -optWorkDir_s v = optWorkDir_u (const v) - --- Imported from other files :- diff --git a/lib/haskell-extras/Control/Concurrent.hs b/lib/haskell-extras/Control/Concurrent.hs new file mode 100644 --- /dev/null +++ b/lib/haskell-extras/Control/Concurrent.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Control.Concurrent (forkOS, ThreadId) where +import Foreign.Ptr +import Foreign.StablePtr +import Foreign.Storable +import Foreign.Marshal.Alloc +import Control.Monad (when) +import Jhc.Prim.Rts + +data {-# CTYPE "rts/conc.h jhc_threadid_t" #-} CthreadIdT +data ThreadId = ThreadId CthreadIdT + +foreign import ccall "rts/conc.h forkOS_createThread" forkOScreateThread :: + FunPtr (Bang_ (StablePtr (IO ())) -> IO (Ptr ())) -> Bang_ a -> Ptr Int -> IO CthreadIdT + +forkOScreateThreadWrapper :: Bang_ (StablePtr (IO ())) -> IO (Ptr ()) +forkOScreateThreadWrapper b = do + let s = fromBang_ b + d <- deRefStablePtr s + d + freeStablePtr s + return nullPtr + +foreign export ccall "forkOScreateThreadWrapper" forkOScreateThreadWrapper :: + Bang_ (StablePtr (IO ())) -> IO (Ptr ()) +foreign import ccall "&forkOScreateThreadWrapper" p_forkOScreateThreadWrapper :: + FunPtr (Bang_ (StablePtr (IO ())) -> IO (Ptr ())) + +forkOS :: IO () -> IO ThreadId +forkOS f = alloca $ \ip -> do + s <- newStablePtr f + pth <- forkOScreateThread p_forkOScreateThreadWrapper (toBang_ s) ip + i <- peek ip + when (i /= 0) $ fail "Cannot create OS thread." + return $ ThreadId pth diff --git a/lib/haskell-extras/Foreign/StablePtr.hs b/lib/haskell-extras/Foreign/StablePtr.hs --- a/lib/haskell-extras/Foreign/StablePtr.hs +++ b/lib/haskell-extras/Foreign/StablePtr.hs @@ -37,6 +37,6 @@ fromUIO $ \w -> case c_derefStablePtr (toBang_ x) w of (# w', s #) -> (# w', fromBang_ s #) -foreign import ccall unsafe "rts/stableptr.c c_freeStablePtr" c_freeStablePtr :: Bang_ (StablePtr a) -> IO () -foreign import ccall unsafe "rts/stableptr.c c_newStablePtr" c_newStablePtr :: Bang_ a -> UIO (Bang_ (StablePtr a)) -foreign import ccall unsafe "rts/stableptr.c c_derefStablePtr" c_derefStablePtr :: Bang_ (StablePtr a) -> UIO (Bang_ a) +foreign import ccall unsafe "rts/stableptr.h c_freeStablePtr" c_freeStablePtr :: Bang_ (StablePtr a) -> IO () +foreign import ccall unsafe "rts/stableptr.h c_newStablePtr" c_newStablePtr :: Bang_ a -> UIO (Bang_ (StablePtr a)) +foreign import ccall unsafe "rts/stableptr.h c_derefStablePtr" c_derefStablePtr :: Bang_ (StablePtr a) -> UIO (Bang_ a) diff --git a/lib/haskell-extras/System/IO/Binary.hs b/lib/haskell-extras/System/IO/Binary.hs --- a/lib/haskell-extras/System/IO/Binary.hs +++ b/lib/haskell-extras/System/IO/Binary.hs @@ -25,13 +25,13 @@ foreign import primitive "Lobits" cintToWord8 :: CInt -> Word8 --foreign import primitive "const.\"rb\"" read_str :: Ptr CChar -foreign import ccall "stdio.h getc_unlocked" c_getc :: Ptr () -> IO CInt +foreign import ccall "stdio.h getc" c_getc :: Ptr () -> IO CInt foreign import ccall "stdio.h fopen" c_fopen :: CString -> BitsPtr_ -> IO (Ptr ()) foreign import ccall "stdio.h fclose" c_fclose :: Ptr () -> IO CInt -- Int translates to CInt in the calling conventions so this is safe. -foreign import ccall "stdio.h putchar_unlocked" c_putchar :: Int -> IO Int -foreign import ccall "stdio.h getchar_unlocked" c_getchar :: IO Int +foreign import ccall "stdio.h putchar" c_putchar :: Int -> IO Int +foreign import ccall "stdio.h getchar" c_getchar :: IO Int putWord8 :: Word8 -> IO () putWord8 w = c_putchar (fromIntegral w) >> return () diff --git a/lib/haskell-extras/haskell-extras.yaml.m4 b/lib/haskell-extras/haskell-extras.yaml.m4 --- a/lib/haskell-extras/haskell-extras.yaml.m4 +++ b/lib/haskell-extras/haskell-extras.yaml.m4 @@ -7,6 +7,7 @@ Exposed-Modules: - Control.Exception - Control.Monad + - Control.Concurrent - Data.Array - Data.Char - Data.Complex diff --git a/lib/jhc/Jhc/ForeignPtr.hs b/lib/jhc/Jhc/ForeignPtr.hs --- a/lib/jhc/Jhc/ForeignPtr.hs +++ b/lib/jhc/Jhc/ForeignPtr.hs @@ -55,13 +55,13 @@ case gc_malloc_foreignptr (int2word align) (int2word size) True w of (# w', bp #) -> (# w', fromBang_ bp #) -foreign import safe ccall gc_malloc_foreignptr +foreign import jhc_context ccall gc_malloc_foreignptr :: Word -- alignment in words -> Word -- size in words -> Bool -- false for plain foreignptrs, true for ones with finalizers. -> UIO (Bang_ (ForeignPtr a)) -foreign import safe ccall gc_new_foreignptr :: +foreign import jhc_context ccall gc_new_foreignptr :: Ptr a -> UIO (Bang_ (ForeignPtr a)) foreign import unsafe ccall gc_add_foreignptr_finalizer diff --git a/lib/jhc/System/C/Stdio.hs b/lib/jhc/System/C/Stdio.hs --- a/lib/jhc/System/C/Stdio.hs +++ b/lib/jhc/System/C/Stdio.hs @@ -15,8 +15,8 @@ foreign import ccall "wchar.h jhc_utf8_getc" c_fgetwc :: FILE -> IO Int foreign import ccall "wchar.h jhc_utf8_getchar" c_getwchar :: IO Int foreign import ccall "wchar.h jhc_utf8_putc" c_fputwc :: Int -> FILE -> IO Int -foreign import ccall "stdio.h fwrite_unlocked" c_fwrite :: Ptr a -> CSize -> CSize -> FILE -> IO CSize -foreign import ccall "stdio.h fread_unlocked" c_fread :: Ptr a -> CSize -> CSize -> FILE -> IO CSize +foreign import ccall "stdio.h fwrite" c_fwrite :: Ptr a -> CSize -> CSize -> FILE -> IO CSize +foreign import ccall "stdio.h fread" c_fread :: Ptr a -> CSize -> CSize -> FILE -> IO CSize foreign import ccall "stdio.h fflush" c_fflush :: FILE -> IO () foreign import ccall "stdio.h feof" c_feof :: FILE -> IO Int foreign import ccall "stdio.h ftell" c_ftell :: FILE -> IO IntMax diff --git a/src/C/FFI.hs b/src/C/FFI.hs new file mode 100644 --- /dev/null +++ b/src/C/FFI.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE TemplateHaskell #-} +module C.FFI( + CallConv(..), + Safety(..), + FfiType(..), + FfiExport(..), + FfiSpec(..), + Requires(..) + ) where + +import C.Prims +import Data.Binary +import Data.DeriveTH +import Data.Typeable + +type CName = String + +data FfiType = Import CName Requires + | ImportAddr CName Requires + | Wrapper + | Dynamic + deriving(Eq,Ord,Show) + +data FfiSpec = FfiSpec FfiType Safety CallConv + deriving(Eq,Ord,Show) + +data FfiExport = FfiExport { + ffiExportCName :: CName, + ffiExportSafety :: Safety, + ffiExportCallConv :: CallConv, + ffiExportArgTypes :: [ExtType], + ffiExportRetType :: ExtType + } + deriving(Eq,Ord,Show,Typeable) + +$(derive makeBinary ''FfiExport) diff --git a/src/C/FromGrin2.hs b/src/C/FromGrin2.hs new file mode 100644 --- /dev/null +++ b/src/C/FromGrin2.hs @@ -0,0 +1,1025 @@ +{-# LANGUAGE OverloadedStrings, RecordWildCards, ViewPatterns, TemplateHaskell #-} +module C.FromGrin2(compileGrin) where + +import Control.Monad.Identity +import Control.Monad.RWS(asks,tell,local,get,runRWST,RWST,MonadState(..),MonadWriter(..),MonadReader(..)) +import Data.Char +import Data.List +import Data.Maybe +import Data.Monoid(Monoid(..)) +import Data.DeriveTH +import System.FilePath +import Text.PrettyPrint.HughesPJ(nest,($$),fsep) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.UTF8 as BS +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Text.PrettyPrint.HughesPJ as P + +import C.FFI +import C.Generate +import C.Prims +import Cmm.Number +import Doc.DocLike +import Doc.PPrint +import Grin.Grin +import Grin.HashConst +import Grin.Noodle +import Grin.Show() +import Grin.Val +import Options +import PackedString +import StringTable.Atom +import Support.CanType +import Support.FreeVars +import Util.Gen +import Util.SetLike +import Util.UniqueMonad +import qualified Cmm.Op as Op +import qualified FlagOpts as FO + +--------------- +-- C Monad +--------------- + +data Todo = TodoReturn | TodoExp [Expression] | TodoDecl Name Type | TodoNothing + +data Written = Written { + wRequires :: Requires, + wStructures :: Map.Map Name Structure, + wTags :: Set.Set Atom, + wAllocs :: Set.Set (Atom,Int), + wEnums :: Map.Map Name Int, + wFunctions :: Map.Map Name Function + } + +$(derive makeMonoid ''Written) + +-- special type representations when possible +data TyRep + = TyRepRawTag -- stored raw tag + | TyRepUntagged -- memory, without a tag + | TyRepRawVal !Bool -- stored raw argument and whether it is signed + +data Env = Env { + rTodo :: Todo, + rInscope :: Set.Set Name, + rStowed :: Set.Set Name, -- names that the garbage collector knows about + rDeclare :: Bool, + rEMap :: Map.Map Atom (Name,[Expression]), + rCPR :: Map.Map Atom TyRep, + rConst :: Set.Set Atom, + rGrin :: Grin + } + +rEMap_u f r@Env{rEMap = x} = r{rEMap = f x} +rInscope_u f r@Env{rInscope = x} = r{rInscope = f x} + +newtype C a = C (RWST Env Written HcHash Uniq a) + deriving(Monad,UniqueProducer,MonadState HcHash,MonadWriter Written,MonadReader Env,Functor) + +runC :: Grin -> C a -> ((a,HcHash,Written),Map.Map Atom TyRep) +runC grin (C m) = (execUniq1 (runRWST m startEnv emptyHcHash),ityrep) where + TyEnv tmap = grinTypeEnv grin + ityrep = Map.mapMaybeWithKey tyRep (fromDistinctAscList $ Util.SetLike.toList tmap) + startEnv = Env { + rCPR = ityrep, + rGrin = grin, + rStowed = Set.empty, + rDeclare = False, + rTodo = TodoExp [], + rEMap = mempty, + rConst = Map.keysSet $ Map.filter isConst ityrep, + rInscope = mempty + } + isConst TyRepRawVal {} = True + isConst TyRepRawTag {} = True + isConst _ = False + tyRep k _ | k == cChar = Just $ TyRepRawVal False + tyRep k _ | not (fopts FO.FullInt), k == cWord = Just $ TyRepRawVal False + tyRep k _ | not (fopts FO.FullInt), k == cInt = Just $ TyRepRawVal True + tyRep k TyTy { tySlots = [s], tySiblings = Just [k'] } | k == k', good s = Just $ TyRepRawVal False + tyRep k tyty | null (tySlots tyty) = Just TyRepRawTag + tyRep k tyty | Just xs <- tySiblings tyty, all triv [ x | x <- xs, x /= k] = Just TyRepUntagged where + triv x = case mlookup x tmap of + Just t -> null (tySlots t) + Nothing -> False + tyRep _ _ = Nothing +-- tyRep k tyty | tySiblings tyty == Just [k] = Just TyRepUntagged + --cpr = iw `Map.union` Map.insert cChar False (Map.fromList [ (a,False) | (a,TyTy { tySlots = [s], tySiblings = Just [a'] }) <- Map.assocs tmap, a == a', isJust (good s) ]) + --iw = if fopts FO.FullInt then mempty else Map.fromList [(cInt,True), (cWord,False)] + good s = isJust $ do + ct <- Op.toCmmTy s + b <- Op.cmmTyBits ct + guard $ b <= 30 + Op.HintNone <- Op.cmmTyHint ct + return () + +tellFunctions :: [Function] -> C () +tellFunctions fs = tell mempty { wFunctions = Map.fromList $ map (\x -> (functionName x,x)) fs } + +localTodo :: Todo -> C a -> C a +localTodo todo (C act) = C $ local (\ r -> r { rTodo = todo }) act + +-------------- +-- entry point +-------------- + +{-# NOINLINE compileGrin #-} +compileGrin :: Grin -> (LBS.ByteString,Requires) +compileGrin grin = (LBS.fromChunks code, req) where + code = [ + BS.fromString "#include \"jhc_rts_header.h\"\n", + BS.fromString $ P.render ans, + BS.fromString "\n" + ] + ans = vcat [ + vcat jgcs, + vcat includes, +-- vcat cincludes, + text "", + enum_tag_t, + header, + cafs, + buildConstants cpr grin finalHcHash, + text "", + nh_stuff, + text "", + body + ] + jgcs | fopts FO.Jgc = text "struct s_caches_pub {" : ( [text " struct s_cache *" <> tshow (nodeCacheName m) <> char ';' | (m,_) <- Set.toList wAllocs] ++ text "};" ) + | otherwise = empty + fromRequires (Requires s) = map (unpackPS . snd) (Set.toList s) + nh_stuff = text "const void * const nh_stuff[] = {" $$ fsep (punctuate (char ',') (cafnames ++ constnames ++ [text "NULL"])) $$ text "};" + includes = map include (filter ((".h" ==) . takeExtension) $ fromRequires req) +-- cincludes = map include (filter ((".c" ==) . takeExtension) $ fromRequires req) + include fn = text "#include <" <> text fn <> text ">" + (header,body) = generateC (function (name "jhc_hs_init") voidType (mgct []) [Public] icaches:Map.elems fm) (Map.elems sm) + icaches :: Statement + icaches | fopts FO.Jgc = + mconcat $ [toStatement $ f_alloc_pubcache (toExpression . name $ "arena") (sizeof . structType . name $ "s_caches_pub")] ++ + [toStatement $ functionCall (name "find_cache") [ + reference . toExpression . pub_cache . nodeCacheName $ t, + toExpression . name $ "arena", + tbsize . sizeof . structType . nodeStructName $ t, + toExpression nptrs] + | (t,nptrs) <- Set.toList wAllocs ] + | otherwise = mempty + cafnames = [ text "&_" <> tshow (varName v) | (v,_) <- grinCafs grin ] + constnames = map (\n -> text "&_c" <> tshow n) [ 1 .. length $ Grin.HashConst.toList finalHcHash] + ((cafs',finalHcHash,Written { wRequires = req, wFunctions = fm, wEnums = wenum, wStructures = sm, wTags = ts, .. }),cpr) = runC grin $ go >> mapM convertCAF (grinCafs grin) + enum_tag_t | null enums = mempty + | otherwise = text "enum {" $$ nest 4 (P.vcat (punctuate P.comma $ enums)) $$ text "};" + where + f t n = tshow t <> text " = " <> tshow (n :: Int) + enums = map (uncurry f) (Map.toList wenum) ++ (zipWith f (Set.toList (Set.map nodeTagName ts)) [0 ..]) + go = do + funcs <- liftM concat $ flip mapM (grinFuncs grin) $ \(a,l) -> do + convertFunc (mlookup a (grinEntryPoints grin)) (a,l) + tellFunctions funcs + h <- get + let tset = Set.fromList [ n | (HcNode n (_:_),_) <- hconsts] + tset' = Set.fromList [ n | (HcNode n [],_) <- hconsts] + hconsts = Grin.HashConst.toList h + mapM_ tellAllTags [ v | (HcNode _ vs,_) <- hconsts, Left v <- vs] + mapM_ declareStruct (Set.toList tset) + mapM_ tellTags (Set.toList $ tset `mappend` tset') + cafs = text "/* CAFS */" $$ (vcat $ cafs') + convertCAF (v,val@(NodeC a [])) = do + en <- declareEvalFunc True a + let ef = drawG $ f_TO_FPTR (reference $ variable en) + let ts = text "/* " <> text (show v) <> text " = " <> (text $ P.render (pprint val)) <> text "*/\n" <> + text "static node_t _" <> tshow (varName v) <> text " = { .head = " <> ef <> text " };\n" <> + text "#define " <> tshow (varName v) <+> text "(MKLAZY_C(&_" <> tshow (varName v) <> text "))\n"; + return ts + convertCAF _ = error "FromGrin2.compileGrin: bad." + +convertFunc :: Maybe FfiExport -> (Atom,Lam) -> C [Function] +convertFunc ffie (n,as :-> body) = do + s <- localTodo TodoReturn (convertBody body) + let bt = getType body + mmalloc [TyINode] = [a_MALLOC] + mmalloc [TyNode] = [a_MALLOC] + mmalloc _ = [] + ats = a_STD:mmalloc bt + fnname = nodeFuncName n + + fr <- convertTypes bt + as' <- flip mapM (zip [1 :: Int .. ] as) $ \ (ix,(Var v t)) -> do + t' <- convertType t + return $ if v == v0 then (name $ 'u':show ix,t') else (varName v,t') + + mstub <- case ffie of + Nothing -> return [] + Just ~(FfiExport cn Safe CCall argTys retTy) -> do + newVars <- mapM (liftM (name . show) . newVar . basicType') argTys + + let fnname2 = name cn + as2 = zip (newVars) (map basicType' argTys) + fr2 = basicType' retTy + g = if fopts FO.Jgc then localVariable gc_t (name "gc") =* nullPtr else mempty + a = if fopts FO.Jgc then localVariable arena_t (name "arena") =* nullPtr else mempty + ai = toStatement $ functionCall (name "jhc_alloc_init") $ mgcr [] + hi = toStatement $ functionCall (name "jhc_hs_init") $ mgc [] + fi = toStatement $ functionCall (name "jhc_alloc_fini") $ mgc [] + funcall = functionCall fnname $ mgc $ + zipWith cast (map snd as') (map variable newVars) + (callret,tmp) <- fr2 `newTmpVar` (cast fr2 $ funcall) + + let call = if voidType == fr2 then toStatement $ funcall else callret + r = if voidType == fr2 then mempty else creturn tmp + return [function fnname2 fr2 as2 [Public] + (g & a & ai & hi & call & fi & r)] + + return (function fnname fr (mgct as') ats s : mstub) + +fetchVar :: Var -> Ty -> C Expression +fetchVar (V 0) _ = return $ noAssign (err "fetchVar v0") +fetchVar v@(V n) _ | n < 0 = return $ (variable $ varName v) +fetchVar v ty = do + t <- convertType ty + is <- asks rInscope + let n = varName v + dclare <- asks rDeclare + return $ (if v == v0 then noAssign else id) $ if not dclare then variable n else localVariable t n + +fetchVar' :: Var -> Ty -> C (Name,Type) +fetchVar' (V n) _ | n < 0 = error "fetchVar': CAF" +fetchVar' v ty = do + t <- convertType ty + return $ (varName v,t) + +convertVals :: [Val] -> C Expression +convertVals [] = return emptyExpression +convertVals [x] = convertVal x +convertVals xs = do + ts <- mapM convertType (map getType xs) + xs <- mapM convertVal xs + return (structAnon (zip xs ts)) + +convertVal :: Val -> C Expression +convertVal v = cvc v where + cvc v = convertConst v >>= maybe (cv v) return + cv (Var v ty) = fetchVar v ty + cv (Const h) = do + cpr <- asks rConst + case h of + NodeC a ts -> do + bn <- basicNode a ts + case bn of + Just bn -> return (cast sptr_t bn) + _ -> do + (_,i) <- newConst cpr h + return $ variable (name $ 'c':show i ) + _ -> do + (_,i) <- newConst cpr h + return $ variable (name $ 'c':show i ) + cv h@(NodeC a ts) | valIsConstant h = do + cpr <- asks rConst + bn <- basicNode a ts + case bn of + Just bn -> return bn + _ -> do + (_,i) <- newConst cpr h + return $ f_PROMOTE (variable (name $ 'c':show i )) + + cv (ValPrim p [x] (TyPrim opty)) = do + x' <- convertVal x + case p of + Op (Op.UnOp n ta) r -> primUnOp n ta r x' + Op (Op.ConvOp n ta) r -> return $ castFunc n ta r x' + x -> return $ err ("convertVal: " ++ show x) + cv (ValPrim p [x,y] _) = do + x' <- convertVal x + y' <- convertVal y + case p of + Op (Op.BinOp n ta tb) r -> primBinOp n ta tb r x' y' + x -> return $ err ("convertVal: " ++ show x) + + cv x = return $ err ("convertVal: " ++ show x) + +convertTypes [] = return voidType +convertTypes [t] = convertType t +convertTypes xs = do + xs <- mapM convertType xs + return (anonStructType xs) + +convertType TyNode = return wptr_t +convertType TyINode = return sptr_t +convertType (TyPtr TyINode) = return $ ptrType sptr_t +convertType (TyPtr TyNode) = return $ ptrType wptr_t +convertType ~(TyPrim opty) = return (opTyToC opty) + +tyToC _ Op.TyBool = "bool" +tyToC dh (Op.TyComplex ty) = "_Complex " ++ tyToC dh ty +tyToC dh (Op.TyBits (Op.BitsExt s) _) = s +tyToC dh (Op.TyBits b h) = f b h where + f b Op.HintNone = f b dh + f b Op.HintUnsigned = case b of + (Op.Bits n) -> "uint" ++ show n ++ "_t" + (Op.BitsArch Op.BitsMax) -> "uintmax_t" + (Op.BitsArch Op.BitsPtr) -> "uintptr_t" + _ -> error "tyToC: unknown" + f b Op.HintSigned = case b of + (Op.Bits n) -> "int" ++ show n ++ "_t" + (Op.BitsArch Op.BitsMax) -> "intmax_t" + (Op.BitsArch Op.BitsPtr) -> "intptr_t" + _ -> error "tyToC: unknown" + f b Op.HintFloat = case b of + (Op.Bits 32) -> "float" + (Op.Bits 64) -> "double" + (Op.Bits 128) -> "__float128" + _ -> error "tyToC: unknown" + f _ _ = error "tyToC: unknown" +tyToC _ _ = error "FromGrin2.tToC: bad." + +opTyToCh hint opty = basicType (tyToC hint opty) +opTyToC opty = basicType (tyToC Op.HintUnsigned opty) +opTyToC' opty = tyToC Op.HintUnsigned opty + +localScope xs action = do + let fvs = freeVars xs + aas <- mapM (\ (v,t) -> do t <- convertType t ; return . toStatement $ localVariable t (varName v)) (filter ((v0 /=) . fst) $ Set.toList fvs) + local (rInscope_u $ Set.union (Set.map varName (freeVars xs))) (action . statementOOB $ mconcat aas) + +iDeclare action = local (\e -> e { rDeclare = True }) action + +convertBody :: Exp -> C Statement +convertBody Let { expDefs = defs, expBody = body } = do + u <- newUniq + nn <- flip mapM defs $ \FuncDef { funcDefName = name, funcDefBody = as :-> _ } -> do + vs' <- mapM convertVal as + let nm = (toName (show name ++ "_" ++ show u)) + return (as,(name,(nm,vs'))) + let done = (toName $ "done" ++ show u) + let localJumps xs action = localScope (fsts xs) $ \dcls -> local (rEMap_u (Map.fromList (snds xs) `mappend`)) (fmap (dcls &) action) + localJumps nn $ do + rs <- flip mapM defs $ \FuncDef { funcDefName = name, funcDefBody = as :-> b } -> do + ss <- convertBody b + return (annotate (show as) (label (toName (show name ++ "_" ++ show u))) & subBlock ss) + ss <- (convertBody body) + todo <- asks rTodo + case todo of + TodoReturn -> return (ss & mconcat rs); + _ -> return (ss & goto done & mconcat (intersperse (goto done) rs) & label done); +convertBody (e :>>= [] :-> e') = do + ss <- localTodo TodoNothing (convertBody e) + ss' <- convertBody e' + return (ss & ss') +convertBody (Return [v] :>>= [(NodeC t as)] :-> e') = nodeAssign v t as e' +--convertBody (Fetch v :>>= [(NodeC t as)] :-> e') = nodeAssign v t as e' +convertBody (Case v [p1@([NodeC _ (_:_)] :-> _),p2@([NodeC _ []] :-> _)]) = convertBody $ Case v [p2,p1] +convertBody (Case v@(getType -> TyNode) [[p1@(NodeC t fps)] :-> e1,[p2] :-> e2]) = do + scrut <- convertVal v + cpr <- asks rConst + tellTags t + let da (Var v _) e | v == v0 = convertBody e + da v@Var {} e = do + v'' <- iDeclare $ convertVal v + e' <- convertBody e + return $ v'' =* scrut & e' + da n1@(NodeC t _) (Return [n2@NodeC {}]) | n1 == n2 = convertBody (Return [v]) + da ~(NodeC t as) e = nodeAssign v t as e + am Var {} e = return e + am ~(NodeC t2 _) e = do + --tellTags t2 + --return $ annotate (show p2) (f_assert ((constant $ enum (nodeTagName t2)) `eq` tag) & e) + return $ annotate (show p2) e + tag = if null fps then f_FETCH_RAW_TAG scrut else f_FETCH_TAG scrut + ifscrut = if null fps then f_SET_RAW_TAG tenum `eq` scrut else tenum `eq` tag where + tenum = (constant $ enum (nodeTagName t)) + p1' <- da p1 e1 + p2' <- am p2 =<< da p2 e2 + return $ cif ifscrut p1' p2' + +-- zero is usually faster to test for than other values, so flip them if zero is being tested for. +convertBody (Case v [v1, v2@([Lit n _] :-> _)]) | n == 0 = convertBody (Case v [v2,v1]) +convertBody (Case v@(getType -> t) [[p1] :-> e1, [p2] :-> e2]) | Set.null ((freeVars p2 :: Set.Set Var) `Set.intersection` freeVars e2) = do + scrut <- convertVal v + let cp ~(Lit i _) = constant (number $ fromIntegral i) + am e | isVar p2 = e + | otherwise = annotate (show p2) (f_assert ((cp p2) `eq` scrut) & e) + e1' <- convertBody e1 + e2' <- convertBody e2 + return $ cif (cp p1 `eq` scrut) e1' (am e2') +convertBody (Case v@(getType -> TyNode) ls) = do + scrut <- convertVal v + let tag = f_FETCH_TAG scrut + da ([(Var v _)] :-> e) | v == v0 = do + e' <- convertBody e + return $ (Nothing,e') + da ([v@(Var {})] :-> e) = do + v'' <- iDeclare $ convertVal v + e' <- convertBody e + return $ (Nothing,v'' =* scrut & e') + da ([n1@(NodeC t _)] :-> Return [n2@NodeC {}]) | n1 == n2 = do + tellTags t + e' <- convertBody (Return [v]) + return (Just (enum (nodeTagName t)),e') + da (~[(NodeC t as)] :-> e) = do + tellTags t + declareStruct t + as' <- iDeclare $ mapM convertVal as + e' <- convertBody e + let tmp = concrete t scrut + ass = mconcat [if needed a then a' =* (project' (arg i) tmp) else mempty | a' <- as' | a <- as | i <- [(1 :: Int) ..] ] + fve = freeVars e + needed ~(Var v _) = v `Set.member` fve + return $ (Just (enum (nodeTagName t)), ass & e') + ls' <- mapM da ls + return $ switch' tag ls' +convertBody (Case v ls) = do + scrut <- convertVal v + let da ([(Var vv _)] :-> e) | vv == v0 = do + e' <- convertBody e + return (Nothing,e') + da ([v@(Var {})] :-> e) = do + v'' <- iDeclare $ convertVal v + e' <- convertBody e + return (Nothing,v'' =* scrut & e') + da (~[(Lit i _)] :-> e) = do + e' <- convertBody e + return $ (Just (number $ fromIntegral i), e') + --da (~[x] :-> e) = da ( x :-> e ) + ls' <- mapM da ls + return $ switch' scrut ls' +convertBody (Error s t) = do + x <- asks rTodo + let jerr | null s = toStatement $ functionCall (name "jhc_exit") [constant $ number 255] + | otherwise = toStatement $ functionCall (name "jhc_error") [string s] + let f (TyPtr _) = return nullPtr + f TyNode = return nullPtr + f TyINode = return nullPtr + f (TyPrim x) = return $ cast (opTyToC x) (constant $ number 0) + f x = return $ err ("error-type " ++ show x) + g [] = return emptyExpression + g [x] = f x + g xs = do ts <- mapM convertType xs; xs <- mapM f xs ; return $ structAnon (zip xs ts) + case x of + TodoNothing -> return jerr + TodoExp _ -> return jerr + TodoDecl {} -> return jerr + TodoReturn -> do + v <- g t + return (jerr & creturn v) + +convertBody (BaseOp (StoreNode b) [n@NodeC {}]) = newNode region_heap (bool b wptr_t sptr_t) n >>= \(x,y) -> simpleRet y >>= \v -> return (x & v) +convertBody (BaseOp (StoreNode b) [n@NodeC {},region]) = newNode region (bool b wptr_t sptr_t) n >>= \(x,y) -> simpleRet y >>= \v -> return (x & v) + +convertBody (e :>>= [(Var vn _)] :-> e') | vn == v0 = do + ss <- localTodo TodoNothing (convertBody e) + ss' <- convertBody e' + return (ss & ss') + +convertBody (e :>>= [(Var vn' vt')] :-> e') | not (isCompound e) = do + (vn,vt) <- fetchVar' vn' vt' + ss <- localTodo (TodoDecl vn vt) (convertBody e) + ss' <- convertBody e' + return (ss & ss') + +convertBody (e :>>= [v@(Var vn vt)] :-> e') = do + v' <- convertVal v + vt <- convertType vt + let sdecl = statementOOB $ toStatement (localVariable vt (varName vn)) + ss <- localTodo (TodoExp [v']) (convertBody e) + ss' <- convertBody e' + return (sdecl & ss & ss') + +convertBody (e :>>= xs@(_:_:_) :-> e') = do + ts <- mapM (convertType . getType) xs + (dcl,st) <- newDeclVar (anonStructType ts) + vs <- iDeclare $ mapM convertVal xs + ss <- localTodo (TodoExp [st]) (convertBody e) + ss' <- convertBody e' + return $ dcl & ss & mconcat [ v =* projectAnon i st | v <- vs | i <- [0..] ] & ss' + +-- mutable arrays and iorefs +convertBody (BaseOp PokeVal [Index base off,z]) = do + base <- convertVal base + off <- convertVal off + z' <- convertVal z + return $ indexArray base off =* z' +convertBody (BaseOp PokeVal [base,z]) = do + base <- convertVal base + z' <- convertVal z + return $ indexArray base (constant $ number 0) =* z' +convertBody (BaseOp PeekVal [Index base off]) | getType base == TyPtr tyINode = do + base <- convertVal base + off <- convertVal off + simpleRet (indexArray base off) +convertBody (BaseOp (Coerce ty) [v]) = do + v <- convertVal v + ty <- convertType ty + simpleRet $ cast ty v +convertBody (GcRoots vs b) = do + vs <- mapM convertVal vs + b' <- convertBody b + return $ subBlock (gc_roots vs & b') + +-- return, promote and demote +convertBody (BaseOp Promote [v]) | getType v == tyINode = simpleRet =<< f_promote `liftM` convertVal v +convertBody (BaseOp Demote [n@Var {}]) | getType n == tyDNode = simpleRet =<< f_demote `liftM` convertVal n +--convertBody (Store n@Var {}) | getType n == tyDNode = simpleRet =<< f_demote `liftM` convertVal n + +convertBody (Return []) = simpleRet emptyExpression +convertBody (Return [v]) = simpleRet =<< convertVal v +convertBody (Return xs@(_:_:_)) = do + t <- asks rTodo + case t of + TodoExp [e] -> do + xs <- mapM convertVal xs + ss <- forMn xs $ \ (v,i) -> return (projectAnon i e =* v) + return (mconcat ss) + _ -> simpleRet =<< convertVals xs + +convertBody e = do + x <- asks rTodo + (ss,er) <- convertExp e + r <- simpleRet er + return (ss & r) + +simpleRet er = do + x <- asks rTodo + case x of + TodoReturn -> return (creturn er) + _ | isEmptyExpression er -> return mempty + TodoNothing -> return (toStatement er) + TodoExp [v] -> return (v =* er) + TodoDecl n t -> do newAssignVar t n er + TodoExp [] -> return $ toStatement er + _ -> error "simpleRet: odd rTodo" + +nodeAssign :: Val -> Atom -> [Val] -> Exp -> C Statement +nodeAssign v t as e' = do + cpr <- asks rCPR + v' <- convertVal v + case mlookup t cpr of + Just (TyRepRawVal signed) -> do + [arg] <- return as + t <- convertType $ getType arg + arg' <- iDeclare $ convertVal arg + let s = arg' =* cast t (if signed then f_RAW_GET_F v' else f_RAW_GET_UF v') + ss <- convertBody e' + return $ s & ss + _ -> do + declareStruct t + as' <- iDeclare $ mapM convertVal as + let ass = concat [perhapsM (a `Set.member` fve) $ a' =* (project' (arg i) (concrete t v')) | a' <- as' | Var a _ <- as | i <- [( 1 :: Int) ..] ] + fve = freeVars e' + ss' <- convertBody e' + return $ mconcat ass & ss' + +--isCompound Fetch {} = False +isCompound BaseOp {} = False +isCompound Return {} = False +--isCompound Store {} = False +isCompound Prim {} = False +isCompound _ = True + +mgc = if fopts FO.Jgc then ([v_gc, v_arena] ++) else id +mgcr = if fopts FO.Jgc then ([reference v_gc, reference v_arena] ++) else id +mgct = if fopts FO.Jgc then ([(name "gc",gc_t), (name "arena",arena_t)] ++) else id + +convertExp :: Exp -> C (Statement,Expression) +convertExp (Prim Func { primArgTypes = as, primRetType = r, primRetArgs = rs@(_:_), ..} vs ty) = do + tell mempty { wRequires = primRequires } + vs' <- mapM convertVal vs + rt <- mapM convertType ty + --let rrs = map basicType' (r:rs) + ras <- mapM (newVar . basicType') rs + (stmt,rv) <- basicType' r `newTmpVar` (functionCall (name $ unpackPS funcName) ([ cast (basicType' t) v | v <- vs' | t <- as ] ++ map reference ras)) + return $ (stmt, structAnon (zip (rv:ras) rt)) +convertExp (Prim Func { primRetArgs = [], .. } vs ty) = do + tell mempty { wRequires = primRequires } + vs' <- mapM convertVal vs + rt <- convertTypes ty + let addgc = if primSafety == JhcContext && fopts FO.Jgc then mgc else id + fcall = cast rt (functionCall (name $ unpackPS funcName) $ addgc [ cast (basicType' t) v | v <- vs' | t <- primArgTypes ]) + return (mempty, fcall) +convertExp (Prim p vs ty) = do + tell mempty { wRequires = primReqs p } + e <- convertPrim p vs ty + return (mempty,e) + +--convertExp (App a [fn,x] _) | a == funcApply = do +-- fn' <- convertVal fn +-- x' <- convertVal x +-- return (mempty,(functionCall (name "eval") [v'])) +convertExp (BaseOp Eval [v]) = do + v' <- convertVal v + return (mempty,f_eval v') +convertExp (BaseOp GcTouch _) = do + return (mempty, emptyExpression) +convertExp (App a vs _) = do + lm <- asks rEMap + vs' <- mapM convertVal vs + case a `mlookup` lm of + Just (nm,as) -> do + let ss = [ a =* v | a <- as | v <- vs' ] + return (mconcat ss & goto nm, emptyExpression) + Nothing -> return $ (mempty, functionCall (toName (fromAtom a)) (mgc vs')) +convertExp (BaseOp Overwrite [v@(Var vv _),tn@(NodeC t as)]) | getType v == TyINode = do + v' <- convertVal v + as' <- mapM convertVal as + nt <- nodeTypePtr t + let tmp' = cast nt (f_FROM_SPTR v') + if not (tagIsSuspFunction t) && vv < v0 then do + (nns, nn) <- newNode region_heap fptr_t tn + return (nns & getHead (f_NODEP(f_FROM_SPTR v')) =* nn,emptyExpression) + else do + s <- tagAssign tmp' t + let ass = [project' (arg i) tmp' =* a | a <- as' | i <- [(1 :: Int) ..] ] + return (mconcat $ s:ass,emptyExpression) + +convertExp Alloc { expValue = v, expCount = c, expRegion = r } + | r == region_heap, TyINode == getType v = do + v' <- convertVal v + c' <- convertVal c + (malloc,tmp) <- jhc_malloc_ptrs c' =:: ptrType sptr_t + fill <- case v of + ValUnknown _ -> return mempty + _ -> do + i <- newVar (basicType "int") + return $ forLoop i (expressionRaw "0") c' $ indexArray tmp i =* v' + return (malloc `mappend` fill, tmp) +convertExp Alloc { expValue = v, expCount = c, expRegion = r } | + r == region_atomic_heap, TyPrim Op.bits_ptr == getType v = do + v' <- convertVal v + c' <- convertVal c + (malloc,tmp) <- jhc_malloc_atomic c' =:: ptrType uintptr_t + fill <- case v of + ValUnknown _ -> return mempty + _ -> do + i <- newVar (basicType "int") + return $ forLoop i (expressionRaw "0") c' $ indexArray tmp i =* v' + return (malloc `mappend` fill, tmp) + +convertExp e = return (err (show e),err "nothing") + +{- +ccaf :: (Var,Val) -> P.Doc +ccaf (v,val) = text "/* " <> text (show v) <> text " = " <> + (text $ P.render (pprint val)) <> text "*/\n" <> + text "static node_t _" <> tshow (varName v) <> text ";\n" <> + text "#define " <> tshow (varName v) <+> text "(MKLAZY_C(&_" <> + tshow (varName v) <> text "))\n"; +-} + +buildConstants cpr grin fh = P.vcat (map cc (Grin.HashConst.toList fh)) where + --tyenv = grinTypeEnv grin + comm nn = text "/* " <> tshow (nn) <> text " */" + cc nn@(HcNode a zs,i) = comm nn $$ cd $$ def where + cd = text "static const struct" <+> tshow (nodeStructName a) <+> text "_c" <> tshow i <+> text "= {" <> hsep (punctuate P.comma (ntag ++ rs)) <> text "};" + --Just TyTy { tySiblings = sibs } = findTyTy tyenv a + ntag = case mlookup a cpr of + --Just [a'] | a' == a -> [] + Just _ -> [] + _ -> [text ".what =" <+> text "(what_t)SET_RAW_TAG(" <> tshow (nodeTagName a) <> text ")"] + def = text "#define c" <> tshow i <+> text "(TO_SPTR_C(P_WHNF, (sptr_t)&_c" <> tshow i <> text "))" + rs = [ f z i | (z,i) <- zip zs [ 1 :: Int .. ]] + f (Right i) a = text ".a" <> tshow a <+> text "=" <+> text ('c':show i) + f (Left (Var n _)) a = text ".a" <> tshow a <+> text "=" <+> tshow (varName n) + f (Left v) a = text ".a" <> tshow a <+> text "=" <+> text (show $ drawG e) where + Just e = fst3 . fst . runC grin $ convertConst v + +convertConst :: Val -> C (Maybe Expression) +convertConst (NodeC n as) | all valIsConstant as = basicNode n as +convertConst (Const (NodeC n as)) = fmap (fmap $ cast sptr_t) $ basicNode n as +convertConst v = return (f v) where + f :: Val -> Maybe Expression + f (Lit i (TyPrim Op.TyBool)) = return $ toExpression (i /= 0) + f (Lit i (TyPrim (Op.TyBits _ Op.HintFloat))) = return (constant $ floating (realToFrac i)) + f (Lit i _) = return (constant $ number (fromIntegral i)) + f (ValPrim p [] ty) = case p of + CConst _ s -> return $ expressionRaw $ unpackPS s + AddrOf _ t -> do rt <- convertType ty; return . cast rt $ expressionRaw ('&':unpackPS t) + PrimTypeInfo { primArgTy = arg, primTypeInfo = PrimSizeOf } -> + return $ expressionRaw ("sizeof(" ++ tyToC Op.HintUnsigned arg ++ ")") + PrimTypeInfo { primArgTy = arg, primTypeInfo = PrimMinBound } -> + return $ expressionRaw ("prim_minbound(" ++ tyToC Op.HintUnsigned arg ++ ")") + PrimTypeInfo { primArgTy = arg, primTypeInfo = PrimMaxBound } -> + return $ expressionRaw ("prim_maxbound(" ++ tyToC Op.HintUnsigned arg ++ ")") + PrimTypeInfo { primArgTy = arg, primTypeInfo = PrimUMaxBound } -> + return $ expressionRaw ("prim_umaxbound(" ++ tyToC Op.HintUnsigned arg ++ ")") + PrimString s -> return $ cast (basicType "uintptr_t") (expressionRaw (show s)) + x -> return $ err (show x) + f (ValPrim p [x] (TyPrim opty)) = do + x' <- f x + case p of + Op (Op.UnOp n ta) r -> primUnOp n ta r x' + Op (Op.ConvOp n ta) r -> return $ castFunc n ta r x' + x -> return $ err (show x) + f (ValPrim p [x,y] _) = do + x' <- f x + y' <- f y + case p of + Op (Op.BinOp n ta tb) r -> primBinOp n ta tb r x' y' + x -> return $ err (show x) + f x = fail "f" + +--convertPrim p vs = return (mempty,err $ show p) +convertPrim p vs ty + | (CConst _ s) <- p = do + return $ expressionRaw $ unpackPS s + | Op {} <- p = do + let [rt] = ty + convertVal (ValPrim p vs rt) + | (IFunc _ as r) <- p = do + v':vs' <- mapM convertVal vs + rt <- convertTypes ty + let fn = cast (funPtrType (basicType' r) (map basicType' as)) v' + return $ cast (rt) (indirectFunctionCall fn [ cast (basicType' t) v | v <- vs' | t <- as ]) + | (Peek t) <- p, [v] <- vs = do + v' <- convertVal v + return $ expressionRaw ("*((" <> (opTyToC' t) <+> "*)" <> (parens $ renderG v') <> char ')') + | (Poke t) <- p, [v,x] <- vs = do + v' <- convertVal v + x' <- convertVal x + return $ expressionRaw ("*((" <> (opTyToC' t) <+> "*)" <> (parens $ renderG v') <> text ") = " <> renderG x') + | (AddrOf _ t) <- p, [] <- vs = do + rt <- convertTypes ty + return . cast rt $ expressionRaw ('&':unpackPS t) + | otherwise = return $ err ("prim: " ++ show (p,vs)) + +signedOps = [ +-- (Op.Div,"/"), -- TODO round to -Infinity +-- (Op.Mod,"%"), -- TODO round to -Infinity + (Op.Quot,"/"), + (Op.Rem,"%"), + (Op.Shra,">>"), + (Op.Gt,">"), + (Op.Lt,"<"), + (Op.Gte,">="), + (Op.Lte,"<=") + ] + +floatOps = [ + (Op.FDiv,"/"), + (Op.FAdd,"+"), + (Op.FSub,"-"), + (Op.FMul,"*"), + (Op.FEq,"=="), + (Op.FNEq,"!="), + (Op.FGt,">"), + (Op.FLt,"<"), + (Op.FGte,">="), + (Op.FLte,"<=") + ] + +binopSigned :: Op.BinOp -> Maybe String +binopSigned b = lookup b signedOps + +castSigned ty v = return $ cast (basicType $ tyToC Op.HintSigned ty) v + +primBinOp n ta tb r a b + | Just fn <- Op.binopFunc ta tb n = return $ functionCall (toName fn) [a,b] + | Just (t,_) <- Op.binopInfix n = return $ operator t a b + | Just t <- binopSigned n = do + a <- castSigned ta a + b <- castSigned tb b + return $ operator t a b + | Just t <- lookup n floatOps = return $ operator t a b + | otherwise = return $ err ("primBinOp: " ++ show ((n,ta,tb,r),a,b)) + +primUnOp Op.Neg ta r a = do + a <- castSigned ta a + return $ uoperator "-" a +primUnOp Op.Com ta r a = do return $ uoperator "~" a +primUnOp Op.FNeg ta r a = do return $ uoperator "-" a +primUnOp op ta r a | Just fn <- Op.unopFloat ta op = return $ functionCall (toName fn) [a] +primUnOp n ta r a + | otherwise = return $ err ("primUnOp: " ++ show ((n,ta,r),a)) + +tagAssign :: Expression -> Atom -> C Statement +tagAssign e t | tagIsSuspFunction t = do + en <- declareEvalFunc False t + return $ getHead e =* f_TO_FPTR (reference (variable en)) +tagAssign e t = do + cpr <- asks rCPR + declareStruct t + tyenv <- asks (grinTypeEnv . rGrin) + --TyTy { tySiblings = sib } <- findTyTy tyenv t + case mlookup t cpr of + --Just [n'] | n' == t -> return mempty + Just _ -> return mempty + _ -> do + tellTags t + return . toStatement $ f_SET_MEM_TAG e (constant (enum $ nodeTagName t)) + +tellAllTags :: Val -> C () +tellAllTags (NodeC n vs) = tellTags n >> mapM_ tellAllTags vs +tellAllTags n = mapValVal tt n >> return () where + tt v = tellAllTags v >> return v + +tellTags :: Atom -> C () +tellTags t | tagIsSuspFunction t = return () +tellTags t = do + tyenv <- asks (grinTypeEnv . rGrin) + TyTy { tySiblings = sib } <- findTyTy tyenv t + case sib of +-- Just [n'] | n' == t -> return () + Just rs -> tell mempty { wEnums = Map.fromList (zip (map nodeTagName rs) [0..]) } + Nothing -> tell mempty { wTags = Set.singleton t } + +newNode region ty ~(NodeC t as) = do + let sf = tagIsSuspFunction t + bn <- basicNode t as + cpr <- asks rCPR + case bn of + Just e -> return (mempty,if ty == wptr_t then e else cast ty e) + Nothing -> do + st <- nodeType t + as' <- mapM convertVal as + let wmalloc | fopts FO.Jgc = \_ -> functionCall (name "s_alloc") [toExpression $ name "gc", toExpression $ name "arena", toExpression . pub_cache . nodeCacheName $ t] + | otherwise = jhc_malloc (reference (toExpression $ nodeCacheName t)) nptrs' + nptrs = length (filter (not . nonPtr . getType) as) + if sf then 1 else 0 + nptrs' = if nptrs > 0 && not sf && t `Map.notMember` cpr then nptrs + 1 else nptrs + malloc = wmalloc (sizeof st) + nonPtr TyPtr {} = False + nonPtr TyNode = False + nonPtr TyINode = False + nonPtr _ = True + (dtmp,tmp) <- case region == region_stack of + True -> do + v <- newVar st + return (mempty,reference v) + False -> do + tell mempty { wAllocs = Set.singleton (t,nptrs') } + ty `newTmpVar` malloc + let tmp' = concrete t tmp + ass = [ if isValUnknown aa then mempty else project' i tmp' =* a | a <- as' | aa <- as | i <- map arg [(1 :: Int) ..] ] + tagassign <- tagAssign tmp' t + let res = if sf then (f_MKLAZY tmp) else tmp + return (mconcat $ dtmp:tagassign:ass,res) + +------------------ +-- declaring stuff +------------------ + +declareStruct n = do + grin <- asks rGrin + cpr <- asks rCPR + let TyTy { tySlots = ts, tySiblings = ss } = runIdentity $ findTyTy (grinTypeEnv grin) n + ts' <- mapM convertType ts + let (dis,needsDis) | tagIsSuspFunction n = ([(name "head",fptr_t)],False) + | null ts = ([],False) + | Just TyRepUntagged <- mlookup n cpr = ([],False) + | Just [n'] <- ss, n == n' = ([],False) + | otherwise = ([],True) + fields = (dis ++ zip [ name $ 'a':show i | i <- [(1 :: Int) ..] ] ts') + theStruct = basicStructure { + structureName = nodeStructName n, + structureFields = fields, + structureAligned = True, + structureHasDiscriminator = not $ null dis, + --structureNeedsDiscriminator = not (fopts FO.Jgc) && needsDis + structureNeedsDiscriminator = needsDis + } + unless (null fields) $ tell mempty { wStructures = Map.singleton (structureName theStruct) theStruct } + +basicNode :: Atom -> [Val] -> C (Maybe Expression) +basicNode a _ | tagIsSuspFunction a = return Nothing +basicNode a [] = do tellTags a ; return . Just $ (f_SET_RAW_TAG (constant $ enum (nodeTagName a))) +basicNode a [v] = do + cpr <- asks rCPR + case mlookup a cpr of + Just (TyRepRawVal signed) -> case v of + Lit i ty | a == cChar, Just c <- ch -> return $ Just (f_RAW_SET_UF (toExpression c)) where + ch = do + c <- toIntegral i + guard $ c >= ord minBound && c <= ord maxBound + c <- return $ chr c + guard $ isPrint c && isAscii c + return c + _ -> do + v <- convertVal v + return $ Just (if signed then f_RAW_SET_F v else f_RAW_SET_UF v) + _ -> return Nothing +basicNode _ _ = return Nothing + +instance Op.ToCmmTy Ty where + toCmmTy (TyPrim p) = Just p + toCmmTy _ = Nothing + +declareEvalFunc isCAF n = do + fn <- tagToFunction n + grin <- asks rGrin + declareStruct n + nt <- nodeType n + let ts = runIdentity $ findArgs (grinTypeEnv grin) n + fname = toName $ "E_" ++ show fn + aname = name "arg" + rvar = localVariable wptr_t (name "r") + atype = ptrType nt + body = rvar =* functionCall (toName (show $ fn)) (mgc [ project' (arg i) (variable aname) | _ <- ts | i <- [(1 :: Int) .. ] ]) + update = f_update (variable aname) rvar + addroot = if isCAF && fopts FO.Jgc then f_gc_add_root (cast sptr_t rvar) else emptyExpression + body' = if not isCAF && fopts FO.Jgc then subBlock (gc_roots [f_MKLAZY(variable aname)] & rest) else rest + rest = body & update & addroot & creturn rvar + tellFunctions [function fname wptr_t (mgct [(aname,atype)]) [a_STD, a_FALIGNED] body'] + return fname + +castFunc :: Op.ConvOp -> Op.Ty -> Op.Ty -> Expression -> Expression +castFunc co ta tb e | ta == tb = e +castFunc co _ Op.TyBool e = cast (basicType "bool") e +castFunc co Op.TyBool tb e = cast (opTyToC tb) e + +castFunc Op.Lobits _ tb e = cast (opTyToC tb) e +castFunc Op.U2U _ tb e = cast (opTyToC tb) e +castFunc Op.Zx _ tb e = cast (opTyToC tb) e + +castFunc Op.I2I tf tb e = cast (opTyToCh Op.HintSigned tb) (cast (opTyToCh Op.HintSigned tf) e) +castFunc Op.Sx tf tb e = cast (opTyToCh Op.HintSigned tb) (cast (opTyToCh Op.HintSigned tf) e) + +castFunc Op.F2I tf tb e = cast (opTyToCh Op.HintSigned tb) e +castFunc Op.I2F tf tb e = cast (opTyToC tb) (cast (opTyToCh Op.HintSigned tf) e) + +castFunc _ _ tb e = cast (opTyToC tb) e + +---------------------------- +-- c constants and utilities +---------------------------- + +gc_roots vs = case length vs of +-- 1 -> functionCall (name "gc_frame1") (v_gc:vs) +-- 2 -> functionCall (name "gc_frame2") (v_gc:vs) + lvs -> functionCall (name "gc_frame0") (v_gc:constant (number (fromIntegral lvs)):vs) +--gc_end = functionCall (name "gc_end") [] +tbsize sz = functionCall (name "TO_BLOCKS") [sz] + +jhc_malloc_atomic sz | fopts FO.Jgc = functionCall (name "gc_array_alloc_atomic") [v_gc, v_arena, nullPtr, sz, toExpression (0::Int)] + | otherwise = jhc_malloc nullPtr (0::Int) (sizeof sptr_t *# sz) + +jhc_malloc ntn nptrs sz | fopts FO.Jgc = functionCall (name "gc_alloc") [v_gc, v_arena, ntn, tbsize sz, toExpression nptrs] +-- | fopts FO.Jgc = functionCall (name "gc_alloc") [v_gc, v_arena, tbsize sz, toExpression nptrs] +jhc_malloc _ 0 sz = functionCall (name "jhc_malloc_atomic") [sz] +jhc_malloc _ _ sz = functionCall (name "jhc_malloc") [sz] + +jhc_malloc_ptrs sz | fopts FO.Jgc = functionCall (name "gc_array_alloc") [v_gc, v_arena, sz] +jhc_malloc_ptrs sz = functionCall (name "jhc_malloc") [sizeof sptr_t *# sz] + +f_assert e = functionCall (name "assert") [e] +f_FROM_SPTR e = functionCall (name "FROM_SPTR") [e] +f_NODEP e = functionCall (name "NODEP") [e] +f_RAW_SET_F e = functionCall (name "RAW_SET_F") [e] +f_RAW_SET_UF e = functionCall (name "RAW_SET_UF") [e] +f_RAW_GET_F e = functionCall (name "RAW_GET_F") [e] +f_RAW_GET_UF e = functionCall (name "RAW_GET_UF") [e] +f_MKLAZY e = functionCall (name "MKLAZY") [e] +f_TO_FPTR e = functionCall (name "TO_FPTR") [e] +f_eval e = functionCall (name "eval") (mgc [e]) +f_gc_add_root e = functionCall (name "gc_add_root") (mgc [e]) +f_promote e = functionCall (name "promote") [e] +f_PROMOTE e = functionCall (name "PROMOTE") [e] +f_FETCH_TAG e = functionCall (name "FETCH_TAG") [e] +f_FETCH_RAW_TAG e = functionCall (name "FETCH_RAW_TAG") [e] +--f_FETCH_MEM_TAG e = functionCall (name "FETCH_MEM_TAG") [e] +f_SET_RAW_TAG e = functionCall (name "SET_RAW_TAG") [e] +f_SET_MEM_TAG e v = functionCall (name "SET_MEM_TAG") [e,v] +f_demote e = functionCall (name "demote") [e] +--f_follow e = functionCall (name "follow") [e] +f_update x y = functionCall (name "update") [x,y] +f_alloc_pubcache a s = functionCall (name "alloc_public_caches") [a,s] + +arg i = name $ 'a':show i + +varName (V n) | n < 0 = name $ 'g':show (- n) +varName (V n) = name $ 'v':show n + +nodeTagName :: Atom -> Name +nodeTagName a = toName (fromAtom a) +nodeFuncName :: Atom -> Name +nodeFuncName a = toName (fromAtom a) + +sptr_t = basicGCType "sptr_t" +uintptr_t = basicGCType "uintptr_t" +fptr_t = basicGCType "fptr_t" +wptr_t = basicGCType "wptr_t" +gc_t = basicGCType "gc_t" +arena_t = basicGCType "arena_t" +v_gc = variable (name "gc") +v_arena = variable (name "arena") +pub_cache n = project' n $ functionCall (name "public_caches") [variable (name "arena")] + +a_STD = Attribute "A_STD" +a_FALIGNED = Attribute "A_FALIGNED" +a_MALLOC = Attribute "A_MALLOC" + +concrete :: Atom -> Expression -> Expression +concrete t e = cast (ptrType $ structType (nodeStructName t)) e + +getHead :: Expression -> Expression +getHead e = project' (name "head") e + +nodeTypePtr a = liftM ptrType (nodeType a) +nodeType a = return $ structType (nodeStructName a) +nodeStructName :: Atom -> Name +nodeStructName a = toName ('s':fromAtom a) +nodeCacheName a = toName ('c':fromAtom a) + +bool b x y = if b then x else y + +x =:: y = newTmpVar y x + +basicType' :: ExtType -> Type +basicType' b = basicType (show b) diff --git a/src/C/Prims.hs b/src/C/Prims.hs new file mode 100644 --- /dev/null +++ b/src/C/Prims.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} +module C.Prims where + +import Data.Binary +import Data.Monoid(Monoid(..)) +import Data.Typeable +import Data.DeriveTH +import qualified Data.Set as Set + +import Doc.DocLike +import Doc.PPrint +import PackedString +import StringTable.Atom +import qualified Cmm.Op as Op + +import GHC.Exts + +data CallConv = CCall | StdCall | CApi | Primitive | DotNet + deriving(Eq,Ord,Show) +$(derive makeBinary ''CallConv) + +data Safety = Safe | Unsafe | JhcContext deriving(Eq,Ord,Show) + +newtype ExtType = ExtType PackedString + deriving(Binary,IsString,Eq,Ord) + +instance Show ExtType where + show (ExtType p) = unpackPS p + +instance Show Requires where + show (Requires s) = show (Set.toList s) + +newtype Requires = Requires (Set.Set (CallConv,PackedString)) + deriving(Eq,Ord,Monoid,Binary) + +data DotNetPrim = DotNetField | DotNetCtor | DotNetMethod + deriving(Typeable, Eq, Ord, Show) + +primReqs p = f p where + f CConst {} = primRequires p + f Func {} = primRequires p + f IFunc {} = primRequires p + f AddrOf {} = primRequires p + f _ = mempty + +data Prim = + PrimPrim Atom -- Special primitive implemented in the compiler somehow. + | CConst { + primRequires :: Requires, + primConst :: !PackedString + } -- C code which evaluates to a constant + | Func { + primRequires :: Requires, + funcName :: !PackedString, + primArgTypes :: [ExtType], + primRetType :: ExtType, + primRetArgs :: [ExtType], + primSafety :: Safety + } -- function call with C calling convention + | IFunc { + primRequires :: Requires, + primArgTypes :: [ExtType], + primRetType :: ExtType + } -- indirect function call with C calling convention + | AddrOf { + primRequires :: Requires, + primConst :: !PackedString -- address of linker name + } + | Peek { primArgTy :: Op.Ty } -- read value from memory + | Poke { primArgTy :: Op.Ty } -- write value to memory + | PrimTypeInfo { + primArgTy :: Op.Ty, + primRetTy :: Op.Ty, + primTypeInfo :: !PrimTypeInfo + } + | PrimString !PackedString -- address of a raw string. encoded in utf8. + | PrimDotNet { + primStatic :: !Bool, + primDotNet :: !DotNetPrim, + primIOLike :: !Bool, + primAssembly :: !PackedString, + primDotNetName :: !PackedString + } + | Op { + primCOp :: Op.Op Op.Ty, + primRetTy :: Op.Ty + } + deriving(Typeable, Eq, Ord, Show) + +data PrimTypeInfo = PrimSizeOf | PrimMaxBound | PrimMinBound | PrimAlignmentOf | PrimUMaxBound + deriving(Typeable, Eq, Ord, Show) + +primStaticTypeInfo :: Op.Ty -> PrimTypeInfo -> Maybe Integer +primStaticTypeInfo (Op.TyBits (Op.Bits b) _) w = Just ans where + bits = toInteger b + ans = case w of + PrimSizeOf -> bits `div` 8 + PrimAlignmentOf -> bits `div` 8 + PrimMinBound -> negate $ 2^(bits - 1) + PrimMaxBound -> 2^(bits - 1) - 1 + PrimUMaxBound -> 2^bits - 1 +primStaticTypeInfo _ _ = Nothing + +-- | These primitives may safely be duplicated without affecting performance or +-- correctness too adversly. either because they are cheap to begin with, or +-- will be recombined in a later pass. + +primIsCheap :: Prim -> Bool +primIsCheap AddrOf {} = True +primIsCheap CConst {} = True +primIsCheap PrimString {} = True +primIsCheap PrimTypeInfo {} = True +primIsCheap Op { primCOp = op } = Op.isCheap op +primIsCheap _ = False + +-- | whether a primitive represents a constant expression (assuming all its arguments are constant) +-- TODO needs grin support +primIsConstant :: Prim -> Bool +primIsConstant CConst {} = True +primIsConstant AddrOf {} = True +primIsConstant PrimString {} = True +primIsConstant PrimTypeInfo {} = True +primIsConstant Op { primCOp = op } = Op.isEagerSafe op +primIsConstant _ = False + +-- | whether a primitive can be eagarly evaluated. +-- TODO needs grin support +primEagerSafe :: Prim -> Bool +primEagerSafe CConst {} = True +primEagerSafe PrimString {} = True +primEagerSafe AddrOf {} = True +primEagerSafe PrimTypeInfo {} = True +primEagerSafe Op { primCOp = op } = Op.isEagerSafe op +primEagerSafe _ = False + +primPrim s = PrimPrim $ toAtom s + +instance DocLike d => PPrint d ExtType where + pprint t = tshow t +--instance DocLike d => PPrint d PackedString where +-- pprint t = text $ unpackPS t + +instance DocLike d => PPrint d Prim where + pprint (PrimPrim t) = text (fromAtom t) + pprint (CConst _ s) = parens (text $ unpackPS s) + pprint Func { .. } = parens (tshow primRetType) <> text (unpackPS funcName) <> tupled (map pprint primArgTypes) + pprint IFunc { .. } = parens (tshow primRetType) <> parens (char '*') <> tupled (map pprint primArgTypes) + pprint (AddrOf _ s) = char '&' <> text (unpackPS s) + pprint (PrimString s) = tshow s <> char '#' + pprint (Peek t) = char '*' <> tshow t + pprint (Poke t) = char '=' <> tshow t + pprint Op { primCOp = Op.BinOp bo ta tb, primRetTy = rt } | rt == ta && rt == tb = parens (pprint rt) <> tshow bo + pprint Op { primCOp = Op.UnOp bo ta, primRetTy = rt } | rt == ta = parens (pprint rt) <> tshow bo + pprint Op { primCOp = op, primRetTy = rt } = parens (pprint rt) <> pprint op + pprint PrimDotNet { primDotNet = dn, primDotNetName = nn} = parens (text (unpackPS nn)) + pprint PrimTypeInfo { primArgTy = at, primTypeInfo = PrimSizeOf } = text "sizeof" <> parens (tshow at) + pprint PrimTypeInfo { primArgTy = at, primTypeInfo = PrimAlignmentOf } = text "alignmentof" <> parens (tshow at) + pprint PrimTypeInfo { primArgTy = at, primTypeInfo = PrimMaxBound } = text "max" <> parens (tshow at) + pprint PrimTypeInfo { primArgTy = at, primTypeInfo = PrimUMaxBound } = text "umax" <> parens (tshow at) + pprint PrimTypeInfo { primArgTy = at, primTypeInfo = PrimMinBound } = text "min" <> parens (tshow at) + +instance DocLike d => PPrint d Op.Ty where + pprintAssoc _ n p = text (showsPrec n p "") +instance (DocLike d,Show v) => PPrint d (Op.Op v) where + pprintAssoc _ n p = text (showsPrec n p "") + +parseDotNetFFI :: Monad m => String -> m Prim +parseDotNetFFI s = ans where + init = PrimDotNet { primIOLike = False, primStatic = False, primDotNet = DotNetField, primAssembly = packString "", primDotNetName = packString "" } + ans = case words s of + ("static":rs) -> f rs init { primStatic = True } + rs -> f rs init + f ("field":rs) dn = g dn { primDotNet = DotNetField } rs + f ("ctor":rs) dn = g dn { primDotNet = DotNetCtor } rs + f ("method":rs) dn = g dn { primDotNet = DotNetMethod } rs + f _ _ = fail "invalid .NET ffi specification" + g dn ['[':rs] | (as,']':nm) <- span (/= ']') rs = return dn { primAssembly = packString as, primDotNetName = packString nm } + g dn [n] = return dn { primDotNetName = packString n } + g _ _ = fail "invalid .NET ffi specification" + +$(derive makeBinary ''Safety) +$(derive makeBinary ''DotNetPrim) +$(derive makeBinary ''Prim) +$(derive makeBinary ''PrimTypeInfo) diff --git a/src/Cmm/Op.hs b/src/Cmm/Op.hs new file mode 100644 --- /dev/null +++ b/src/Cmm/Op.hs @@ -0,0 +1,411 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS -funbox-strict-fields #-} +module Cmm.Op where + +import Data.Binary +import Data.DeriveTH +import Util.Gen +import qualified Text.ParserCombinators.ReadP as P +import Text.Read.Lex + +{- + +Basic operations. These are chosen to be roughly equivalent to c-- operations, +but can be effectively used to generate C or assembly code as well. + +An operation consists of the operation itself, the type of the arguments and +return value, and a hint attached to each argument. + +A condition is that the operation must be fully determined by the operation +name and the type of its arguments. this specifically does not include the +hint. For instance, since whether a number is signed or unsigned is in the +hint, so the operation itself must say whether it is signed or unsigned. + +Also, distinct algorithms should be given different operations, for instance +floating point and integer comparison are so different that they should be +separate opcodes, even if it could be determined by the type they operate on. + +-} + +-- these take 2 arguments of the same type, and return one of the same type. +-- an exception are the mulx routines, which may return a type exactly +-- double in size of the original, and the shift and rotate routines, where the +-- second argument may be of any width and is interpreted as an unsigned +-- number. +-- +-- the invarient is that the return type is always exactly determined by the +-- argument types + +data BinOp + = Add + | Sub + + | Mul + | Mulx + | UMulx + + | Div -- ^ round to -Infinity + | Mod -- ^ mod rounding to -Infinity + + | Quot -- ^ round to 0 + | Rem -- ^ rem rounding to 0 + + | UDiv -- ^ round to zero (unsigned) + | UMod -- ^ unsigned mod + + -- bitwise + | And + | Or + | Xor + | Shl + | Shr -- ^ shift right logical + | Shra -- ^ shift right arithmetic + | Rotl + | Rotr + + -- floating + | FAdd + | FSub + | FDiv + | FMul + | FPwr + | FAtan2 + + -- These all compare two things of the same type, and return a boolean. + | Eq + | NEq + | Gt + | Gte + | Lt + | Lte + -- unsigned versions + | UGt + | UGte + | ULt + | ULte + + -- floating point comparasons + | FEq + | FNEq + | FGt + | FGte + | FLt + | FLte + -- whether two values can be compared at all. + | FOrdered + deriving(Eq,Show,Ord,Read,Enum,Bounded) + +data UnOp + = Neg -- ^ 2s compliment negation + | Com -- ^ bitwise compliment + -- floating + | FAbs -- ^ floating absolute value + | FNeg -- ^ floating point negation + | Sin + | Cos + | Tan + | Sinh + | Cosh + | Tanh + | Asin + | Acos + | Atan + | Log + | Exp + | Sqrt + -- exotic bit operations + | Bswap -- ^ Switch the order of the bytes in a word + | Ffs -- ^ Returns one plus the index of the least + -- significant 1-bit of x, 0 if x is zero. + | Clz -- ^ number of leading (from MSB) zeros, undefined if zero + | Ctz -- ^ number of trailing (from LSB) zeros, undefined if zero. + | Popcount -- ^ number of bits set to 1 in word + | Parity -- ^ number of bits set to 1 mod 2 + deriving(Eq,Show,Ord,Read,Enum,Bounded) + +-- conversion ops + +data ConvOp + = F2I -- ^ convert a floating point to an integral value via truncation + | F2U -- ^ convert a floating point to an unsigned integral value via truncation, negative values become zero + | U2F -- ^ convert an unsigned integral value to a floating point number + | I2F -- ^ convert an integral value to a floating point number + | F2F -- ^ convert a float from one precision to another, preserving value as much as possible + | Lobits -- ^ extract the low order bits + | Sx -- ^ sign extend a value (signed) + | Zx -- ^ zero extend a value (unsigned) + | I2I -- ^ perform a 'Lobits' or a 'Sx' depending on the sizes of the arguments + | U2U -- ^ perform a 'Lobits' or a 'Zx' depending on the sizes of the arguments + | B2B -- ^ a nop, useful for coercing hints (bits 2 bits) + deriving(Eq,Show,Ord,Read,Enum,Bounded) + +data ValOp + = NaN + | PInf + | NInf + | PZero + | NZero + deriving(Eq,Show,Ord,Read,Bounded) + +data ArchBits = BitsMax | BitsPtr | BitsUnknown + deriving(Eq,Ord) + +data TyBits = Bits {-# UNPACK #-} !Int | BitsArch !ArchBits | BitsExt String + deriving(Eq,Ord) + +data TyHint + = HintSigned + | HintUnsigned + | HintFloat -- an IEEE floating point value + | HintCharacter -- a unicode character, implies unsigned + | HintNone -- no hint + deriving(Eq,Ord) + +data Ty + = TyBits !TyBits !TyHint + | TyBool + | TyComplex Ty + | TyVector !Int Ty + deriving(Eq,Ord) + +--runReadP :: ReadP a -> String -> Maybe a +--runReadP rp s = case readP_to_S rp s of +-- [(x,"")] -> Just x +-- _ -> Nothing + +preadTy :: P.ReadP Ty +preadTy = P.choice cs where + cs = [ do P.string "bool"; return TyBool + , do P.char 's'; TyBits x _ <- preadTy; return $ TyBits x HintSigned + , do P.char 'u'; TyBits x _ <- preadTy; return $ TyBits x HintUnsigned + , do P.char 'f'; TyBits x _ <- preadTy; return $ TyBits x HintFloat + , do P.char 'c'; TyBits x _ <- preadTy; return $ TyBits x HintCharacter + , do P.string "bits<"; x <- P.manyTill P.get (P.char '>'); return $ TyBits (f x) HintNone + , do P.string "bits"; x <- readDecP; return $ TyBits (Bits x) HintNone + , do n <- readDecP; P.char '*'; t <- preadTy; return (TyVector n t) + , do P.string "i"; t <- preadTy; return (TyComplex t) + ] + f "ptr" = BitsArch BitsPtr + f "max" = BitsArch BitsMax + f "?" = BitsArch BitsUnknown + f x = BitsExt x + +readTy :: Monad m => String -> m Ty +readTy s = case runReadP preadTy s of + Nothing -> fail "readTy: not type" + Just x -> return x + +stringToOpTy :: String -> Ty +stringToOpTy s = case readTy s of + Just t -> t + _ -> error $ "stringToOpTy: " ++ show s + +bool = TyBool +bits_ptr = TyBits (BitsArch BitsPtr) HintNone +bits_max = TyBits (BitsArch BitsMax) HintNone +bits8 = TyBits (Bits 8) HintNone +bits16 = TyBits (Bits 16) HintNone +bits32 = TyBits (Bits 32) HintNone +bits64 = TyBits (Bits 64) HintNone + +class ToCmmTy a where + toCmmTy :: a -> Maybe Ty + +instance ToCmmTy Ty where + toCmmTy a = Just a + +instance ToCmmTy String where + toCmmTy s = readTy s + +cmmTyBits :: ToCmmTy a => a -> Maybe Int +cmmTyBits x = do TyBits (Bits b) _ <- toCmmTy x; return b +cmmTyHint x = do TyBits _ hint <- toCmmTy x; return hint + +instance Show TyHint where + showsPrec _ HintSigned = ('s':) + showsPrec _ HintUnsigned = ('u':) + showsPrec _ HintFloat = ('f':) + showsPrec _ HintCharacter = ('c':) + showsPrec _ HintNone = id + +instance Show Ty where + showsPrec _ TyBool = showString "bool" + showsPrec _ (TyBits b h) = shows h . showString "bits" . shows b + showsPrec _ (TyVector n t) = shows n . showChar '*' . shows t + showsPrec _ (TyComplex t) = showChar 'i' . shows t + +instance Show TyBits where + showsPrec _ (Bits n) = shows n + showsPrec _ (BitsExt s) = showChar '<' . showString s . showChar '>' + showsPrec _ (BitsArch s) = showChar '<' . shows s . showChar '>' + +instance Show ArchBits where + show BitsMax = "max" + show BitsPtr = "ptr" + show BitsUnknown = "?" + +data Op v + = BinOp BinOp v v + | UnOp UnOp v + | ValOp ValOp + | ConvOp ConvOp v + deriving(Eq,Show,Ord) + +binopType :: BinOp -> Ty -> Ty -> Ty +binopType Mulx (TyBits (Bits i) h) _ = TyBits (Bits (i*2)) h +binopType UMulx (TyBits (Bits i) h) _ = TyBits (Bits (i*2)) h +binopType Eq _ _ = TyBool +binopType NEq _ _ = TyBool +binopType Gt _ _ = TyBool +binopType Gte _ _ = TyBool +binopType Lt _ _ = TyBool +binopType Lte _ _ = TyBool +binopType UGt _ _ = TyBool +binopType UGte _ _ = TyBool +binopType ULt _ _ = TyBool +binopType ULte _ _ = TyBool +binopType FEq _ _ = TyBool +binopType FNEq _ _ = TyBool +binopType FGt _ _ = TyBool +binopType FGte _ _ = TyBool +binopType FLt _ _ = TyBool +binopType FLte _ _ = TyBool +binopType FOrdered _ _ = TyBool +binopType _ t1 _ = t1 + +isCommutable :: BinOp -> Bool +isCommutable x = f x where + f Add = True + f Mul = True + f And = True + f Or = True + f Xor = True + f Eq = True + f NEq = True + f FAdd = True + f FMul = True + f FEq = True + f FNEq = True + f FOrdered = True + f _ = False + +commuteBinOp :: BinOp -> Maybe BinOp +commuteBinOp x | isCommutable x = return x +commuteBinOp Lt = return Gt +commuteBinOp Gt = return Lt +commuteBinOp Lte = return Gte +commuteBinOp Gte = return Lte +commuteBinOp ULt = return UGt +commuteBinOp UGt = return ULt +commuteBinOp ULte = return UGte +commuteBinOp UGte = return ULte +commuteBinOp FLt = return FGt +commuteBinOp FGt = return FLt +commuteBinOp FLte = return FGte +commuteBinOp FGte = return FLte +commuteBinOp _ = Nothing + +isAssociative :: BinOp -> Bool +isAssociative x = f x where + f Add = True + f Mul = True + f And = True + f Or = True + f Xor = True + f _ = False + +unopFloat :: Ty -> UnOp -> Maybe String +unopFloat (TyBits b HintFloat) op = g b =<< f op where + g (Bits 64) x = return x + g (Bits 32) x = return $ x ++ "f" + g _ _ = Nothing + f FAbs = return "fabs" + f Sin = return "sin" + f Cos = return "cos" + f Tan = return "tan" + f Sinh = return "sinh" + f Cosh = return "cosh" + f Tanh = return "tanh" + f Asin = return "asin" + f Acos = return "acos" + f Atan = return "atan" + f Sqrt = return "sqrt" + f Log = return "log" + f Exp = return "exp" + + f _ = Nothing +unopFloat _ _ = Nothing + +binopFunc :: Ty -> Ty -> BinOp -> Maybe String +binopFunc (TyBits b _) _ bop = g b =<< f bop where + g (Bits 64) x = return x + g (Bits 32) x = return $ x ++ "f" + g _ _ = Nothing + f FPwr = Just "pow" + f FAtan2 = Just "atan2" + f _ = Nothing +binopFunc TyBool _ bop = Nothing +binopFunc _ _ _ = error "Op.binopFunc: bad." + +binopInfix :: BinOp -> Maybe (String,Int) +binopInfix UDiv = Just ("/",8) +binopInfix Mul = Just ("*",8) +binopInfix UMod = Just ("%",8) +binopInfix Sub = Just ("-",7) +binopInfix Add = Just ("+",7) +binopInfix Shr = Just (">>",6) +binopInfix Shl = Just ("<<",6) +binopInfix And = Just ("&",5) +binopInfix Xor = Just ("^",4) +binopInfix Or = Just ("|",3) +binopInfix UGte = Just (">=",2) +binopInfix UGt = Just (">",2) +binopInfix ULte = Just ("<=",2) +binopInfix ULt = Just ("<",2) +binopInfix Eq = Just ("==",2) +binopInfix NEq = Just ("!=",2) +binopInfix _ = Nothing + +class IsOperator o where + isCheap :: o -> Bool + isEagerSafe :: o -> Bool + +instance IsOperator BinOp where + isCheap FAtan2 = False + isCheap _ = True + + isEagerSafe Div = False + isEagerSafe Mod = False + isEagerSafe Quot = False + isEagerSafe Rem = False + isEagerSafe UDiv = False + isEagerSafe UMod = False + isEagerSafe _ = True + +instance IsOperator UnOp where + isCheap _ = True + isEagerSafe _ = True + +instance IsOperator ConvOp where + isCheap _ = True + isEagerSafe _ = True + +instance IsOperator (Op v) where + isCheap (BinOp o _ _) = isCheap o + isCheap (UnOp o _) = isCheap o + isCheap (ConvOp o _) = isCheap o + isCheap _ = False + isEagerSafe (BinOp o _ _) = isEagerSafe o + isEagerSafe (UnOp o _) = isEagerSafe o + isEagerSafe (ConvOp o _) = isEagerSafe o + isEagerSafe _ = False + +$(derive makeBinary ''BinOp) +$(derive makeBinary ''UnOp) +$(derive makeBinary ''ConvOp) +$(derive makeBinary ''ValOp) +$(derive makeBinary ''ArchBits) +$(derive makeBinary ''TyBits) +$(derive makeBinary ''TyHint) +$(derive makeBinary ''Ty) +$(derive makeBinary ''Op) diff --git a/src/DataConstructors.hs b/src/DataConstructors.hs new file mode 100644 --- /dev/null +++ b/src/DataConstructors.hs @@ -0,0 +1,926 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} +module DataConstructors( + AliasType(..), + boxPrimitive, + collectDeriving, + conSlots, + constructionExpression, + Constructor(..), + DataFamily(..), + DataTable(..), + DataTableMonad(..), + dataTablePrims, + deconstructionExpression, + deriveClasses, + extractIO, + extractIO', + extractPrimitive, + ExtTypeInfo(..), + extTypeInfoExtType, + followAlias, + followAliases, + getConstructor, + getConstructorArities, + getProduct, + getSiblings, + lookupExtTypeInfo, + mktBox, + modBox, + numberSiblings, + onlyChild, + pprintTypeOfCons, + primitiveAliases, + removeNewtypes, + samplePrimitiveDataTable, + showDataTable, + Slot(..), + slotTypes, + slotTypesHs, + tAbsurd, + toDataTable, + typesCompatable, + updateLit + ) where + +import Control.Monad.Identity +import Control.Monad.Writer(tell,execWriter) +import Data.Maybe +import Data.Monoid hiding(getProduct) +import Data.List(sortBy) +import qualified Data.Map as Map hiding(map) +import qualified Data.Set as Set hiding(map) + +import C.Prims +import Data.Binary +import Data.DeriveTH +import Doc.DocLike as D +import Doc.PPrint +import Doc.Pretty +import E.Binary() +import E.E +import E.Show +import E.Subst +import E.Traverse +import E.TypeCheck +import E.Values +import FrontEnd.Class(instanceName) +import FrontEnd.HsSyn +import FrontEnd.SrcLoc +import FrontEnd.Syn.Traverse +import FrontEnd.Tc.Type +import GenUtil +import Info.Types +import Name.Id +import Name.Name as Name +import Name.Names +import Name.VConsts +import PackedString +import Support.CanType +import Support.FreeVars +import Support.MapBinaryInstance +import Support.Unparse +import Util.HasSize +import Util.SameShape +import Util.SetLike as S +import Util.VarName +import qualified Cmm.Op as Op +import qualified Util.Graph as G +import qualified Util.Seq as Seq + +tipe' (TAp t1 t2) = liftM2 eAp (tipe' t1) (tipe' t2) +tipe' (TArrow t1 t2) = do + t1' <- tipe' t1 + t2' <- tipe' t2 + return $ EPi (tVr emptyId (t1')) t2' +tipe' (TCon (Tycon n k)) | Just n' <- Map.lookup n primitiveAliases = return $ ELit litCons { litName = n', litType = kind k } +tipe' (TCon (Tycon n k)) = return $ ELit litCons { litName = n, litType = kind k } +tipe' (TVar tv@Tyvar { tyvarKind = k}) = do + v <- lookupName tv + return $ EVar $ tVr v (kind k) +tipe' (TForAll [] (_ :=> t)) = tipe' t +tipe' (TExists [] (_ :=> t)) = tipe' t +tipe' (TForAll xs (_ :=> t)) = do + xs' <- flip mapM xs $ \tv -> do + v <- newName (map anonymous [35 .. ]) () tv + return $ tVr v (kind $ tyvarKind tv) + t' <- tipe' t + return $ foldr EPi t' xs' -- [ tVr n (kind k) | n <- [2,4..] | k <- xs ] +tipe' ~(TExists xs (_ :=> t)) = do + xs' <- flip mapM xs $ \tv -> do + --v <- newName [70,72..] () tv + --return $ tVr v (kind $ tyvarKind tv) + return $ (kind $ tyvarKind tv) + t' <- tipe' t + return $ ELit litCons { litName = unboxedNameTuple TypeConstructor (length xs' + 1), litArgs = (t':xs'), litType = eHash } + +kind (KBase KUTuple) = eHash +kind (KBase KHash) = eHash +kind (KBase Star) = eStar +kind (KBase (KNamed t)) = ESort (ESortNamed t) +kind (Kfun k1 k2) = EPi (tVr emptyId (kind k1)) (kind k2) +kind k = error $ "DataConstructors.kind: cannot convert " ++ show k + +data AliasType = ErasedAlias | RecursiveAlias + deriving(Eq,Ord,Show) + +-- these apply to types +data DataFamily = + DataAbstract -- abstract internal type, has children of representation unknown and irrelevant. + | DataNone -- children don't apply. data constructor for instance + | DataPrimitive -- primitive type, children are all numbers. + | DataEnum {-# UNPACK #-} !Int -- bounded integral type, argument is maximum number + | DataNormal [Name] -- child constructors + | DataAlias !AliasType + deriving(Eq,Ord,Show) + +-- | Record describing a data type. +-- * is also a data type containing the type constructors, which are unlifted, yet boxed. + +data Constructor = Constructor { + conName :: Name, -- name of constructor + conType :: E, -- type of constructor + conExpr :: E, -- expression which constructs this value + conOrigSlots :: [Slot], -- original slots + conInhabits :: Name, -- what constructor it inhabits, similar to conType, but not quite. + conVirtual :: Maybe [Name], -- whether this is a virtual constructor that translates into an enum and its siblings + conChildren :: DataFamily, + conCTYPE :: Maybe ExtType -- external type + } deriving(Show) + +data Slot = + SlotNormal E + | SlotUnpacked E !Name [E] + | SlotExistential TVr + deriving(Eq,Ord,Show) + +mapESlot f (SlotExistential t) = SlotExistential t { tvrType = f (tvrType t) } +mapESlot f (SlotNormal e) = SlotNormal $ f e +mapESlot f (SlotUnpacked e n es) = SlotUnpacked (f e) n (map f es) + +conSlots s = getSlots $ conOrigSlots s + +getSlots ss = concatMap f ss where + f (SlotNormal e) = [e] + f (SlotUnpacked _ _ es) = es + f (SlotExistential e) = [tvrType e] + +getHsSlots ss = map f ss where + f (SlotNormal e) = e + f (SlotUnpacked e _ es) = e + f (SlotExistential e) = tvrType e + +newtype DataTable = DataTable (Map.Map Name Constructor) + deriving(Monoid) + +instance Binary DataTable where + put (DataTable dt) = putMap dt + get = fmap DataTable getMap + +emptyConstructor = Constructor { + conName = error "emptyConstructor.conName", + conType = Unknown, + conOrigSlots = [], + conExpr = Unknown, + conInhabits = error "emptyConstructor.conInhabits", + conVirtual = Nothing, + conCTYPE = Nothing, + conChildren = DataNone + } + +instance HasSize DataTable where + size (DataTable d) = Map.size d + +{-# NOINLINE getConstructor #-} +getConstructor :: Monad m => Name -> DataTable -> m Constructor +getConstructor n _ | isJust me = return (emptyConstructor { + conName = n, conType = e, + conExpr = foldr ELam (foldl eAp (mktBox e) (map EVar tvrs)) tvrs, + conInhabits = s_Star, conOrigSlots = map SlotNormal sts }) where + sts = map tvrType ss + tvrs = [ tvr { tvrIdent = i , tvrType = t } | i <- anonymousIds | t <- sts ] + (_,ss) = fromPi e + me@(~(Just e)) = fromConjured modBox n `mplus` fromConjured modAbsurd n +getConstructor n _ | RawType <- nameType n = return $ primitiveConstructor n +getConstructor n _ | Just v <- fromUnboxedNameTuple n, DataConstructor <- nameType n = return $ snd $ tunboxedtuple v +getConstructor n _ | Just v <- fromUnboxedNameTuple n, TypeConstructor <- nameType n = return $ fst $ tunboxedtuple v +getConstructor n (DataTable map) = case Map.lookup n map of + Just x -> return x + Nothing -> fail $ "getConstructor: " ++ show (nameType n,n) + +-- | return the single constructor of product types +getProduct :: Monad m => DataTable -> E -> m Constructor +getProduct dataTable e | (ELit LitCons { litName = cn }) <- + followAliases dataTable e, Just c <- getConstructor cn dataTable = f c where + f c | DataNormal [x] <- conChildren c = getConstructor x dataTable + | otherwise = fail "Not Product type" +getProduct _ _ = fail "Not Product type" + +tunboxedtuple :: Int -> (Constructor,Constructor) +tunboxedtuple n = (typeCons,dataCons) where + dataCons = emptyConstructor { + conName = dc, + conType = dtipe, + conOrigSlots = map (SlotNormal . EVar) typeVars, + conExpr = foldr ($) (ELit litCons + { litName = dc + , litArgs = map EVar vars + , litType = ftipe + }) (map ELam vars), + conInhabits = tc + } + typeCons = emptyConstructor { + conName = tc, + conType = foldr EPi eHash (replicate n tvr { tvrType = eStar }), + conOrigSlots = replicate n (SlotNormal eStar), + conExpr = tipe, + conInhabits = s_Hash, + conChildren = DataNormal [dc] + } + dc = unboxedNameTuple DataConstructor n + tc = unboxedNameTuple TypeConstructor n + tipe = foldr ELam ftipe typeVars + typeVars = take n [ tvr { tvrType = eStar, tvrIdent = v } | v <- anonymousIds ] + vars = [ tvr { tvrType = EVar t, tvrIdent = v } | v <- map anonymous [ n + 8, n + 9 ..] | t <- typeVars ] + ftipe = ELit (litCons { litName = tc, litArgs = map EVar typeVars, litType = eHash }) + dtipe = foldr EPi (foldr EPi ftipe [ v { tvrIdent = emptyId } | v <- vars]) typeVars + +-- | conjured data types, these data types are created as needed and can be of any type, their +-- actual type is encoded in their names. +-- +-- Absurd - this is a type that it used to default otherwise unconstrained +-- types, it is not special in any particular way but is just an arbitrary type +-- to give to things. +-- +-- Box - this type can be used to represent any boxed values. It is considered +-- equivalent to all boxed values so is not a very precise type. It is used in +-- the final stages of compilation before core mangling so that optimizations +-- that were previously blocked by type variables can be carried out. + +tAbsurd k = ELit (litCons { + litName = nameConjured modAbsurd k, litArgs = [], litType = k }) +mktBox k = ELit (litCons { + litName = nameConjured modBox k, litArgs = [], + litType = k, litAliasFor = af }) where + af = case k of + EPi TVr { tvrType = t1 } t2 -> Just (ELam tvr { tvrType = t1 } (mktBox t2)) + _ -> Nothing + +tarrow = emptyConstructor { + conName = tc_Arrow, + conType = EPi (tVr emptyId eStar) (EPi (tVr emptyId eStar) eStar), + conOrigSlots = [SlotNormal eStar,SlotNormal eStar], + conExpr = ELam (tVr va1 eStar) (ELam (tVr va2 eStar) (EPi (tVr emptyId (EVar $ tVr va1 eStar)) (EVar $ tVr va2 eStar))), + conInhabits = s_Star, + conChildren = DataAbstract + } + +primitiveConstructor name = emptyConstructor { + conName = name, + conType = eHash, + conExpr = ELit (litCons { litName = name, litArgs = [], litType = eHash }), + conInhabits = s_Hash, + conChildren = DataPrimitive + } + +sortName :: ESort -> Name +sortName s = f s where + f EStar = s_Star -- the sort of boxed lazy types + f EBang = s_Bang -- the sort of boxed strict types + f EHash = s_Hash -- the sort of unboxed types + f ETuple = s_Tuple -- the sort of unboxed tuples + f EHashHash = s_HashHash -- the supersort of unboxed types + f EStarStar = s_StarStar -- the supersort of boxed types + f (ESortNamed n) = n -- user defined sorts + +sortConstructor name ss = emptyConstructor { + conName = name, + conType = ESort ss, + conExpr = ESort (ESortNamed name), + conInhabits = sortName ss +} + +typesCompatable :: forall m . Monad m => E -> E -> m () +typesCompatable a b = f etherealIds a b where + f :: [Id] -> E -> E -> m () + f _ (ESort a) (ESort b) = when (a /= b) $ fail $ "Sorts don't match: " ++ pprint (ESort a,ESort b) + f _ (EVar a) (EVar b) = when (a /= b) $ fail $ "Vars don't match: " ++ pprint (a,b) + -- we expand aliases first, because the newtype might have phantom types as arguments + f c (ELit (LitCons { litAliasFor = Just af, litArgs = as })) b = do + f c (foldl eAp af as) b + f c a (ELit (LitCons { litAliasFor = Just af, litArgs = as })) = do + f c a (foldl eAp af as) + f c (ELit LitCons { litName = n, litArgs = xs, litType = t }) (ELit LitCons { litName = n', litArgs = xs', litType = t' }) | n == n' = do + f c t t' + when (not $ sameShape1 xs xs') $ fail "Arg lists don't match" + zipWithM_ (f c) xs xs' + f c (EAp a b) (EAp a' b') = do + f c a a' + f c b b' + f c (ELam va ea) (ELam vb eb) = lam va ea vb eb c + f c (EPi va ea) (EPi vb eb) = lam va ea vb eb c + f c (EPi (TVr { tvrIdent = eid, tvrType = a}) b) (ELit (LitCons { litName = n, litArgs = [a',b'], litType = t })) | eid == emptyId, conName tarrow == n, t == eStar = do + f c a a' + f c b b' + f c (ELit (LitCons { litName = n, litArgs = [a',b'], litType = t })) (EPi (TVr { tvrIdent = eid, tvrType = a}) b) | eid == emptyId, conName tarrow == n, t == eStar = do + f c a a' + f c b b' + f _ a b | boxCompat a b || boxCompat b a = return () + f _ a b = fail $ "Types don't match:" ++ pprint (a,b) + + lam :: TVr -> E -> TVr -> E -> [Id] -> m () + lam va ea vb eb ~(c:cs) = do + f (c:cs) (tvrType va) (tvrType vb) + f cs (subst va (EVar va { tvrIdent = c }) ea) (subst vb (EVar vb { tvrIdent = c }) eb) + boxCompat (ELit (LitCons { litName = n })) t | Just e <- fromConjured modBox n = e == getType t + boxCompat _ _ = False + +extractPrimitive :: Monad m => DataTable -> E -> m (E,(ExtType,E)) +extractPrimitive dataTable e = case followAliases dataTable (getType e) of + st@(ELit LitCons { litName = c, litArgs = [], litType = t }) + | t == eHash -> return (e,(ExtType (packString $ show c),st)) + | otherwise -> do + Constructor { conChildren = DataNormal [cn] } <- getConstructor c dataTable + Constructor { conOrigSlots = [SlotNormal st] } <- getConstructor cn dataTable + (ELit LitCons { litName = n, litArgs = []}) <- return $ followAliases dataTable st + let tvra = tVr vn st + (vn:_) = newIds (freeIds e) + return (eCase e [Alt (litCons { litName = cn, litArgs = [tvra], + litType = (getType e) }) (EVar tvra)] Unknown,(ExtType (packString $ show n),st)) + e' -> fail $ "extractPrimitive: " ++ show (e,e') + +boxPrimitive :: + Monad m + => DataTable + -> E -- primitive to box + -> E -- what type we want it to have + -> m (E,(ExtType,E)) +boxPrimitive dataTable e et = case followAliases dataTable et of + st@(ELit LitCons { litName = c, litArgs = [], litType = t }) + | t == eHash -> return (e,(ExtType . packString $ show c,st)) + | otherwise -> do + Constructor { conChildren = DataNormal [cn] } <- getConstructor c dataTable + Constructor { conOrigSlots = [SlotNormal st] } <- getConstructor cn dataTable + (ELit LitCons { litName = n, litArgs = []}) <- return $ followAliases dataTable st + let tvra = tVr vn st + (vn:_) = newIds (freeVars (e,et)) + if isManifestAtomic e then + return $ (ELit litCons { litName = cn, litArgs = [e], litType = et },(ExtType . packString $ show n,st)) + else + return $ (eStrictLet tvra e $ ELit litCons { litName = cn, litArgs = [EVar tvra], litType = et },(ExtType . packString $ show n,st)) + e' -> fail $ "boxPrimitive: " ++ show (e,e') + +extractIO :: Monad m => E -> m E +extractIO e = f e where + f (ELit LitCons { litName = c, litArgs = [x] }) | c == tc_IO = return x + f (ELit LitCons { litAliasFor = Just af, litArgs = as }) = f (foldl eAp af as) + f _ = fail "extractIO: not an IO type" + +-- extract IO or an unboxed version of it, (ST, World -> (# Wold, a #)) +extractIO' :: E -> ([E],Bool,E) +extractIO' e = f e [] where + f (ELit LitCons { litName = c, litArgs = [x] }) rs | c == tc_IO = (reverse rs, True,x) + f (ELit LitCons { litName = c, litArgs = [_,x] }) rs | c == tc_ST = (reverse rs, True,x) + f (expandAlias -> Just t) rs = f t rs + f (fromPi -> (fromUnboxedTuple -> Just [s',x],[getType -> s''])) rs + | isState_ s' && isState_ s'' = (reverse rs, True,x) + f (EPi v e) rs = f e (getType v:rs) + f e rs = (reverse rs, False,e) +-- f (fromPi -> (getType -> s',[getType -> s''])) | isState_ s' && isState_ s'' = (True,tUnit) + +data ExtTypeInfo + = ExtTypeVoid -- maps to 'void' + | ExtTypeRaw ExtType -- value is an unboxed type suitable for passing with the argument calling convention + | ExtTypeBoxed Name E ExtType -- boxed type, name is constructor of box, E is type of the slice, and ExtType is the calling convention to use + +extTypeInfoExtType (ExtTypeRaw et) = et +extTypeInfoExtType (ExtTypeBoxed _ _ et) = et +extTypeInfoExtType ExtTypeVoid = "void" + +lookupExtTypeInfo :: Monad m => DataTable -> E -> m ExtTypeInfo +lookupExtTypeInfo dataTable oe = f Set.empty oe where + f :: Monad m => Set.Set Name -> E -> m ExtTypeInfo + -- handle the void context ones first + f _ e@(ELit LitCons { litName = c }) | c == tc_Unit || c == tc_State_ = return ExtTypeVoid + -- if the constructor is in the external type map, replace its external + -- type with the one in the map + f seen e@(ELit LitCons { litName = c, litArgs = [ta] }) | c == tc_Ptr = do + ExtTypeBoxed b t _ <- g seen e -- we know a pointer is a boxed BitsPtr + case f seen ta of + Just (ExtTypeBoxed _ _ (ExtType et)) -> return $ ExtTypeBoxed b t (ExtType $ et `mappend` "*") + Just (ExtTypeRaw (ExtType et)) -> return $ ExtTypeBoxed b t (ExtType $ et `mappend` "*") + _ -> return $ ExtTypeBoxed b t "HsPtr" + f seen e@(ELit LitCons { litName = c, litArgs = [ta] }) | c == tc_Complex = do + case f seen ta of + Just (ExtTypeRaw (ExtType et)) -> return $ ExtTypeRaw (ExtType $ "_Complex " `mappend` et) + _ -> fail "invalid _Complex type" + f seen e@(ELit LitCons { litName = c }) | Just (conCTYPE -> Just et) <- getConstructor c dataTable = do + return $ case g seen e of + Just (ExtTypeBoxed b t _) -> ExtTypeBoxed b t et + Just ExtTypeVoid -> ExtTypeVoid + _ -> ExtTypeRaw et + f seen e = g seen e + -- if we are a raw type, we can be foreigned + g _ (ELit LitCons { litName = c }) + | Just et <- Map.lookup c rawExtTypeMap = return (ExtTypeRaw et) + -- if we are a single constructor data type with a single foreignable unboxed + -- slot, we are foreiginable + g _ (ELit LitCons { litName = c, litAliasFor = Nothing }) + | Just Constructor { conChildren = DataNormal [cn] } <- getConstructor c dataTable, + Just Constructor { conOrigSlots = [SlotNormal st] } <- getConstructor cn dataTable, + Just (ExtTypeRaw et) <- lookupExtTypeInfo dataTable st = return $ ExtTypeBoxed cn st et + g seen e@(ELit LitCons { litName = n }) | Just e' <- followAlias dataTable e, + n `Set.notMember` seen = f (Set.insert n seen) e' + g _ e = fail $ "lookupExtTypeInfo: " ++ show (oe,e) + +expandAlias :: Monad m => E -> m E +expandAlias (ELit LitCons { litAliasFor = Just af, litArgs = as }) = return (foldl eAp af as) +expandAlias _ = fail "expandAlias: not alias" + +followAlias :: Monad m => DataTable -> E -> m E +followAlias _ (ELit LitCons { litAliasFor = Just af, litArgs = as }) = return (foldl eAp af as) +followAlias _ _ = fail "followAlias: not alias" + +followAliases :: DataTable -> E -> E +followAliases _dataTable e = f e where + f (ELit LitCons { litAliasFor = Just af, litArgs = as }) = f (foldl eAp af as) + f e = e + +dataTablePrims = DataTable $ Map.fromList ([ (conName x,x) | x <- [tarrow] ]) + +deriveClasses :: IdMap Comb -> DataTable -> [(SrcLoc,Name,Name)] -> [(TVr,E)] +deriveClasses cmap dt@(DataTable mp) ctd = concatMap f ctd where + f (_,cd,t) | Just c <- getConstructor t dt, TypeConstructor == nameType (conName c), Just is <- conVirtual c = g is c cd + f _ = [] + g is c cl = h cl where + lupvar v = EVar (combHead comb) where + Just comb = mlookup (toId v) cmap + typ = conExpr c + DataNormal [con] = conChildren c + Just conr = getConstructor con (DataTable mp) + [it@(ELit LitCons { litName = it_name })] = conSlots conr + Just itr = getConstructor it_name (DataTable mp) + DataEnum mv = conChildren itr + v1 = tvr { tvrIdent = anonymous 1, tvrType = typ } + v2 = tvr { tvrIdent = anonymous 2, tvrType = typ } + i1 = tvr { tvrIdent = anonymous 3, tvrType = it } + i2 = tvr { tvrIdent = anonymous 4, tvrType = it } + b3 = tvr { tvrIdent = anonymous 5, tvrType = tBoolzh } + val1 = tvr { tvrIdent = anonymous 7, tvrType = typ } + unbox e = ELam v1 (ELam v2 (ec (EVar v1) i1 (ec (EVar v2) i2 e))) where + ec v i e = eCase v [Alt (litCons { litName = con, litArgs = [i], litType = typ }) e] Unknown + h cl | cl == class_Eq = [mkCmpFunc v_equals Op.Eq] + h cl | cl == class_Ord = [ + mkCmpFunc v_geq Op.UGte, + mkCmpFunc v_leq Op.ULte, + mkCmpFunc v_lt Op.ULt, + mkCmpFunc v_gt Op.UGt] + h cl | Just ans <- lookup cl mthds = ans where + mthds = [(class_Enum,[ + (iv_te,ib_te), + (iv_fe,ib_fe), + iv v_succ succ_body, + iv v_pred pred_body, + iv v_enumFrom from_body, + iv v_enumFromTo fromTo_body, + iv v_enumFromThen fromThen_body, + iv v_enumFromThenTo fromThenTo_body + ]), + (class_Ix,[ + iv v_range range_body, +-- iv v_inRange inRange_body, + iv v_index index_body + ])] + iv_te = setProperty prop_INSTANCE tvr { tvrIdent = toId $ instanceName v_toEnum (nameName $ conName c), tvrType = getType ib_te } + iv_fe = setProperty prop_INSTANCE tvr { tvrIdent = toId $ instanceName v_fromEnum (nameName $ conName c), tvrType = getType ib_fe } + iv fname body = (setProperty prop_INSTANCE tvr { tvrIdent = toId $ instanceName fname (nameName $ conName c), tvrType = getType body },body) + succ_body = foldl EAp (lupvar v_enum_succ) [typ, box, debox, max] + pred_body = foldl EAp (lupvar v_enum_pred) [typ, box, debox] + from_body = foldl EAp (lupvar v_enum_from) [typ, box, debox, max] + fromTo_body = foldl EAp (lupvar v_enum_fromTo) [typ, box, debox] + fromThen_body = foldl EAp (lupvar v_enum_fromThen) [typ, box, debox, max] + fromThenTo_body = foldl EAp (lupvar v_enum_fromThenTo) [typ, box, debox] + range_body = foldl EAp (lupvar v_ix_range) [typ, box, debox] + --inRange_body = foldl EAp (lupvar v_ix_inRange) [typ, box, debox] + index_body = foldl EAp (lupvar v_ix_index) [typ, box, debox] + + ib_te = foldl EAp (lupvar v_enum_toEnum) [typ, box, toEzh (mv - 1)] + ib_fe = ELam val1 (create_uintegralCast_toInt con tEnumzh (EVar val1)) + + max = ELit (LitInt (fromIntegral $ mv - 1) tEnumzh) + + box = ELam i1 (ELit (litCons { litName = con, litArgs = [EVar i1], litType = typ })) + debox = ELam v1 (ec (EVar v1) i1 (EVar i1)) where + ec v i e = eCase v [Alt (litCons { litName = con, litArgs = [i], litType = typ }) e] Unknown + + h _ = [] + mkCmpFunc fname op = (iv_eq,ib_eq) where + ib_eq = unbox (eStrictLet b3 (oper_IIB op (EVar i1) (EVar i2)) (ELit (litCons { litName = dc_Boolzh, litArgs = [EVar b3], litType = tBool }))) + iv_eq = setProperty prop_INSTANCE tvr { tvrIdent = toId $ instanceName fname (nameName $ conName c), tvrType = getType ib_eq } + oper_IIB op a b = EPrim (Op (Op.BinOp op Op.bits16 Op.bits16) Op.bits16) [a,b] tBoolzh + +create_integralCast conv c1 t1 c2 t2 e t = eCase e [Alt (litCons { litName = c1, litArgs = [tvra], litType = te }) cc] Unknown where + te = getType e + ELit LitCons { litName = n1, litArgs = [] } = t1 + ELit LitCons { litName = n2, litArgs = [] } = t2 + Just n1' = nameToOpTy n1 + Just n2' = nameToOpTy n2 + tvra = tVr va2 t1 + tvrb = tVr va3 t2 + cc = if n1 == n2 then ELit (litCons { litName = c2, litArgs = [EVar tvra], litType = t }) else + eStrictLet tvrb (EPrim (Op (Op.ConvOp conv n1') n2') [EVar tvra] t2) (ELit (litCons { litName = c2, litArgs = [EVar tvrb], litType = t })) + +nameToOpTy n = do RawType <- return $ nameType n; Op.readTy (show n) + +create_uintegralCast_toInt c1 t1 e = create_integralCast Op.U2U c1 t1 dc_Int tIntzh e tInt + +updateLit :: DataTable -> Lit e t -> Lit e t +updateLit _ l@LitInt {} = l +updateLit dataTable lc@LitCons { litAliasFor = Just {} } = lc +updateLit dataTable lc@LitCons { litName = n } = lc { litAliasFor = af } where + af = do + Constructor { conChildren = DataNormal [x], conOrigSlots = cs } <- getConstructor n dataTable + Constructor { conChildren = DataAlias ErasedAlias, conOrigSlots = [SlotNormal sl] } <- getConstructor x dataTable + return (foldr ELam sl [ tVr i s | s <- getSlots cs | i <- anonymousIds]) + +removeNewtypes :: DataTable -> E -> E +removeNewtypes dataTable e = runIdentity (f e) where + f ec@ECase {} = emapEGH f f return ec { eCaseAlts = map g (eCaseAlts ec) } where + g (Alt l e) = Alt (gl $ updateLit dataTable l) e + f (ELit l) = emapEGH f f return (ELit (gl $ updateLit dataTable l)) + f e = emapEGH f f return e + gl lc@LitCons { litAliasFor = Just e } = lc { litAliasFor = Just $ removeNewtypes dataTable e } + gl l = l + +collectDeriving :: [HsDecl] -> [(SrcLoc,Name,Name)] +collectDeriving ds = concatMap f ds where + f decl@HsDataDecl {} = g decl + f decl@HsDeclDeriving {} = h decl + f _ = [] + g decl = [(hsDeclSrcLoc decl, toName ClassName c, + toName TypeConstructor (hsDeclName decl)) | c <- hsDeclDerives decl ] + h decl@(hsDeclClassHead -> ch) | [(ltc -> Just t)] <- hsClassHeadArgs ch = [(hsDeclSrcLoc decl,toName ClassName (hsClassHead ch), t)] where + ltc (HsTyApp t1 _) = ltc t1 + ltc (HsTyCon n) = Just (toName TypeConstructor n) + ltc x = Nothing + h _ = [] + +{-# NOINLINE toDataTable #-} +toDataTable :: (Map.Map Name Kind) -> (Map.Map Name Type) -> [HsDecl] -> DataTable -> DataTable +toDataTable km cm ds currentDataTable = newDataTable where + newDataTable = DataTable (Map.mapWithKey fixupMap $ + Map.fromList [ (conName x,procNewTypes x) | x <- ds', conName x `notElem` keys primitiveAliases ]) + fullDataTable = (newDataTable `mappend` currentDataTable) + procNewTypes c = c { conExpr = f (conExpr c), conType = f (conType c), conOrigSlots = map (mapESlot f) (conOrigSlots c) } where + f = removeNewtypes fullDataTable + fixupMap k _ | Just n <- getConstructor k dataTablePrims = n + fixupMap _ n = n + ds' = Seq.toList $ execWriter (mapM_ f ds) + newtypeLoopBreakers = map fst $ fst $ G.findLoopBreakers (const 0) (const True) (G.newGraph newtypeDeps fst snd) where + newtypeDeps = [ (n,concatMap (fm . hsBangType) $ hsConDeclArgs c) | + HsDataDecl { hsDeclDeclType = DeclTypeNewtype, hsDeclName = n, hsDeclCons = (head -> c) } <- ds ] + fm t = execWriter $ f t + f HsTyCon { hsTypeName = n } = tell [n] + f t = traverseHsType_ f t + f decl@HsDataDecl { hsDeclDeclType = DeclTypeNewtype, hsDeclName = nn, hsDeclCons = cs } = + dt decl (if nn `elem` newtypeLoopBreakers then DataAlias RecursiveAlias else DataAlias ErasedAlias) cs + f decl@HsDataDecl { hsDeclDeclType = DeclTypeKind } = dkind decl + f decl@HsDataDecl { hsDeclCons = cs } = dt decl DataNone cs + f _ = return () + dt decl DataNone cs@(_:_:_) | all null (map hsConDeclArgs cs) = do + let virtualCons'@(fc:_) = map (makeData DataNone typeInfo) cs + typeInfo@(theType,_,_) = makeType decl (hsDeclCTYPE decl) + virt = Just (map conName virtualCons') + f (n,vc) = vc { conExpr = ELit (litCons { litName = consName, litArgs = [ELit (LitInt (fromIntegral n) rtype)], litType = conType vc }), conVirtual = virt } + virtualCons = map f (zip [(0 :: Int) ..] virtualCons') + consName = mapName (id,(++ "#")) $ toName DataConstructor (nameName (conName theType)) + rtypeName = mapName (id,(++ "#")) $ toName TypeConstructor (nameName (conName theType)) + rtype = ELit litCons { litName = rtypeName, litType = eHash, litAliasFor = Just tEnumzh } + dataCons = fc { conName = consName, conType = getType (conExpr dataCons), conOrigSlots = [SlotNormal rtype], conExpr = ELam (tVr (anonymous 3) rtype) (ELit (litCons { litName = consName, litArgs = [EVar (tVr (anonymous 6) rtype)], litType = conExpr theType })) } + rtypeCons = emptyConstructor { + conName = rtypeName, + conType = eHash, + conExpr = rtype, + conInhabits = s_Hash, + conChildren = DataEnum (length virtualCons) + } + tell (Seq.fromList virtualCons) + tell (Seq.singleton dataCons) + tell (Seq.singleton rtypeCons) + tell $ Seq.singleton theType { conChildren = DataNormal [consName], conVirtual = virt } + return () + + dt decl alias cs = do + let dataCons = map (makeData alias typeInfo) cs + typeInfo@(theType,_,_) = makeType decl (hsDeclCTYPE decl) + tell (Seq.fromList dataCons) + tell $ Seq.singleton theType { conChildren = DataNormal (map conName dataCons) } + + dkind HsDataDecl { .. } = do + tell $ Seq.singleton $ (sortConstructor hsDeclName EHashHash) { + conChildren = DataNormal (map hsConDeclName hsDeclCons) } + flip mapM_ hsDeclCons $ \ HsConDecl { .. } -> do + let Just theKind = kind `fmap` (Map.lookup hsConDeclName km) + (theTypeFKind,theTypeKArgs') = fromPi theKind + theTypeArgs = [ tvr { tvrIdent = x } | tvr <- theTypeKArgs' | x <- anonymousIds ] + theTypeExpr = ELit litCons { + litName = hsConDeclName, + litArgs = map EVar theTypeArgs, + litType = theTypeFKind } + tell $ Seq.singleton emptyConstructor { + conName = hsConDeclName, + conType = theKind, + conOrigSlots = map (SlotNormal . tvrType) theTypeArgs, + conExpr = foldr ($) theTypeExpr (map ELam theTypeArgs), + conInhabits = hsDeclName + } + dkind _ = error "dkind passed bad decl" + + makeData alias (theType,theTypeArgs,theTypeExpr) x = theData where + theData = emptyConstructor { + conName = dataConsName, + conType =foldr ($) (getType theExpr) (map EPi theTypeArgs), + conOrigSlots = origSlots, + conExpr = theExpr, + conInhabits = conName theType, + conChildren = alias + } + dataConsName = toName Name.DataConstructor (hsConDeclName x) + + theExpr = foldr ELam (strictize tslots $ ELit litCons { litName = dataConsName, litArgs = map EVar dvars, litType = theTypeExpr }) hsvars + + strictize tslots con = E.Subst.subst tvr { tvrIdent = sillyId } Unknown $ f tslots con where + f (Left (v,False):rs) con = f rs con + f (Left (v,True):rs) con = eStrictLet v (EVar v) (f rs con) + f (Right (v,dc,rcs):rs) con = eCase (EVar v) [Alt pat (f rs con)] Unknown where + pat = litCons { litName = dc, litArgs = rcs, litType = (getType v) } + f [] con = con + + -- substitution is only about substituting type variables + (ELit LitCons { litArgs = thisTypeArgs }, origArgs) = fromPi $ runVarName $ do + let (vs,ty) = case Map.lookup dataConsName cm of Just (TForAll vs (_ :=> ty)) -> (vs,ty); ~(Just ty) -> ([],ty) + mapM_ (newName anonymousIds ()) vs + tipe' ty + subst = substMap $ fromList [ (tvrIdent tv ,EVar $ tv { tvrIdent = p }) | EVar tv <- thisTypeArgs | p <- anonymousIds ] + + origSlots = map SlotExistential existentials ++ map f tslots where + f (Left (e,_)) = SlotNormal (getType e) + f (Right (e,n,es)) = SlotUnpacked (getType e) n (map getType es) + hsvars = existentials ++ map f tslots where + f (Left (e,_)) = e + f (Right (e,_,_)) = e + dvars = existentials ++ concatMap f tslots where + f (Left (e,_)) = [e] + f (Right (_,_,es)) = es + tslots = f (newIds fvset) (map isHsBangedTy (hsConDeclArgs x)) origArgs where + f (i:is) (False:bs) (e:es) = Left (e { tvrIdent = i, tvrType = subst (tvrType e) },False):f is bs es + f (i:j:is) (True:bs) (e:es) = maybe (Left (e { tvrIdent = i, tvrType = subst (tvrType e) },True):f is bs es) id $ g e (tvrType e) where + g e te = do + ELit LitCons { litName = n } <- return $ followAliases fullDataTable te + Constructor { conChildren = DataNormal [dc] } <- getConstructor n fullDataTable + con <- getConstructor dc fullDataTable + case (conChildren con,slotTypes fullDataTable dc te) of + (DataAlias ErasedAlias,[nt]) -> g e nt + (_,[st]) -> do + let nv = tvr { tvrIdent = j, tvrType = st } + return $ Right (e { tvrIdent = i, tvrType = subst (tvrType e)},dc,[nv]):f is bs es + _ -> fail "not unboxable" + f _ [] [] = [] + f _ _ _ = error "DataConstructors.tslots" + fvset = freeVars (thisTypeArgs,origArgs) `mappend` fromList (take (length theTypeArgs + 2) anonymousIds) + + -- existentials are free variables in the arguments, that arn't bound in the type + existentials = values $ freeVars (map getType origArgs) S.\\ (freeVars thisTypeArgs :: IdMap TVr) + + -- arguments that the front end passes or pulls out of this constructor + --hsArgs = existentials ++ [ tvr {tvrIdent = x} | tvr <- origArgs | x <- drop (5 + length theTypeArgs) [2,4..] ] + + makeType decl ct = (theType,theTypeArgs,theTypeExpr) where + theTypeName = toName Name.TypeConstructor (hsDeclName decl) + Just theKind = kind `fmap` (Map.lookup theTypeName km) + (theTypeFKind,theTypeKArgs') = fromPi theKind + theTypeArgs = [ tvr { tvrIdent = x } | tvr <- theTypeKArgs' | x <- anonymousIds ] + theTypeExpr = ELit litCons { litName = theTypeName, litArgs = map EVar theTypeArgs, litType = theTypeFKind } + theType = emptyConstructor { + conCTYPE = fmap (ExtType . packString) ct, + conExpr = foldr ($) theTypeExpr (map ELam theTypeArgs), + conInhabits = if theTypeFKind == eStar then s_Star else s_Hash, + conName = theTypeName, + conOrigSlots = map (SlotNormal . tvrType) theTypeArgs, + conType = theKind, + conVirtual = Nothing + } + +isHsBangedTy HsBangedTy {} = True +isHsBangedTy _ = False + +getConstructorArities :: DataTable -> [(Name,Int)] +getConstructorArities (DataTable dt) = [ (n,length $ conSlots c) | (n,c) <- Map.toList dt] + +constructionExpression :: + DataTable -- ^ table of data constructors + -> Name -- ^ name of said constructor + -> E -- ^ type of eventual constructor + -> E -- ^ saturated lambda calculus term +constructionExpression dataTable n typ@(ELit LitCons { litName = pn, litArgs = xs }) + | DataAlias ErasedAlias <- conChildren mc = ELam var (EVar var) + | DataAlias RecursiveAlias <- conChildren mc = let var' = var { tvrType = st } in ELam var' (prim_unsafeCoerce (EVar var') typ) + | pn == conName pc = sub (conExpr mc) where + ~[st] = slotTypes dataTable n typ + var = tvr { tvrIdent = vid, tvrType = typ } + (vid:_) = newIds (freeVars typ) + Just mc = getConstructor n dataTable + Just pc = getConstructor (conInhabits mc) dataTable + sub = substMap $ fromDistinctAscList [ (i,sl) | sl <- xs | i <- anonymousIds ] +constructionExpression wdt n e | Just fa <- followAlias wdt e = constructionExpression wdt n fa +constructionExpression _ n e = error $ "constructionExpression: error in " ++ show n ++ ": " ++ show e + +deconstructionExpression :: + UniqueProducer m + => DataTable -- ^ table of data constructors + -> Name -- ^ name of said constructor + -> E -- ^ type of pattern + -> [TVr] -- ^ variables to be bound + -> E -- ^ body of alt + -> m (Alt E) -- ^ resulting alternative +deconstructionExpression dataTable name typ@(ELit LitCons { litName = pn, litArgs = xs }) vs e | pn == conName pc = ans where + Just mc = getConstructor name dataTable + Just pc = getConstructor (conInhabits mc) dataTable + sub = substMap $ fromDistinctAscList [ (i,sl) | sl <- xs | i <- anonymousIds ] + ans = case conVirtual mc of + Just _ -> return $ let ELit LitCons { litArgs = [ELit (LitInt n t)] } = conExpr mc in Alt (LitInt n t) e + Nothing -> do + let f vs (SlotExistential t:ss) rs ls = f vs ss (t:rs) ls + f (v:vs) (SlotNormal _:ss) rs ls = f vs ss (v:rs) ls + f (v:vs) (SlotUnpacked e n es:ss) rs ls = do + let g t = do + s <- newUniq + return $ tVr (anonymous s) t + as <- mapM g (map sub es) + f vs ss (reverse as ++ rs) ((v,ELit litCons { litName = n, litArgs = map EVar as, litType = sub e }):ls) + f [] [] rs ls = return $ Alt (litCons { litName = name, litArgs = reverse rs, litType = typ }) (eLetRec ls e) + f _ _ _ _ = error "DataConstructors.deconstructuonExpression.f" + f vs (conOrigSlots mc) [] [] +deconstructionExpression wdt n ty vs e | Just fa <- followAlias wdt ty = deconstructionExpression wdt n fa vs e +deconstructionExpression _ n e _ _ = error $ "deconstructionExpression: error in " ++ show n ++ ": " ++ show e + +slotTypes :: + DataTable -- ^ table of data constructors + -> Name -- ^ name of constructor + -> E -- ^ type of value + -> [E] -- ^ type of each slot +slotTypes wdt n (ELit LitCons { litName = pn, litArgs = xs, litType = _ }) + | pn == conName pc = [sub x | x <- conSlots mc ] + where + Identity mc = getConstructor n wdt + Identity pc = getConstructor (conInhabits mc) wdt + sub = substMap $ fromDistinctAscList [ (i,sl) | sl <- xs | i <- anonymousIds ] +slotTypes wdt n kind + | sortKindLike kind, (e,ts) <- fromPi kind = take (length (conSlots mc) - length ts) (conSlots mc) + ---- | sortKindLike kind, (e,ts) <- fromPi kind = (conSlots mc) + where Identity mc = getConstructor n wdt +slotTypes wdt n e | Just fa <- followAlias wdt e = slotTypes wdt n fa +slotTypes _ n e = error $ "slotTypes: error in " ++ show n ++ ": " ++ show e + +slotTypesHs :: + DataTable -- ^ table of data constructors + -> Name -- ^ name of constructor + -> E -- ^ type of value + -> [E] -- ^ type of each slot +slotTypesHs wdt n (ELit LitCons { litName = pn, litArgs = xs, litType = _ }) + | pn == conName pc = [sub x | x <- getHsSlots $ conOrigSlots mc ] + where + Identity mc = getConstructor n wdt + Identity pc = getConstructor (conInhabits mc) wdt + sub = substMap $ fromDistinctAscList [ (i,sl) | sl <- xs | i <- anonymousIds ] +slotTypesHs wdt n kind + | sortKindLike kind, (e,ts) <- fromPi kind = take (length (conSlots mc) - length ts) (conSlots mc) + where Identity mc = getConstructor n wdt +slotTypesHs wdt n e | Just fa <- followAlias wdt e = slotTypes wdt n fa +slotTypesHs _ n e = error $ "slotTypesHs: error in " ++ show n ++ ": " ++ show e + +{-# NOINLINE showDataTable #-} +showDataTable (DataTable mp) = vcat xs where + c con = vcat [t,e,cs,vt,ih,ch,mc] where + t = text "::" <+> ePretty conType + e = text "=" <+> ePretty conExpr + cs = text "slots:" <+> tupled (map ePretty (conSlots con)) + vt = text "virtual:" <+> tshow conVirtual + ih = text "inhabits:" <+> tshow conInhabits + ch = text "children:" <+> tshow conChildren + mc = text "CTYPE:" <+> tshow conCTYPE + Constructor { .. } = con + xs = [text x <+> hang 0 (c y) | (x,y) <- ds ] + ds = sortBy (\(x,_) (y,_) -> compare x y) [(show x,y) | (x,y) <- Map.toList mp] + +{-# NOINLINE samplePrimitiveDataTable #-} +samplePrimitiveDataTable :: DataTable +samplePrimitiveDataTable = DataTable $ Map.fromList [ (x,c) | x <- xs, c <- getConstructor x mempty] where + nt v = map (flip unboxedNameTuple (v::Int)) [DataConstructor, TypeConstructor] + xs = nt 0 ++ nt 3 ++ [nameConjured modAbsurd eStar,nameConjured modBox hs, nameConjured modAbsurd hs', nameConjured modBox hs',rt_bits16,rt_bits_ptr_] + hs = EPi (tVr emptyId eHash) eStar + hs' = tFunc eStar (tFunc (tFunc eStar eHash) eStar) + +getSiblings :: DataTable -> Name -> Maybe [Name] +getSiblings dt n + | Just c <- getConstructor n dt, Just Constructor { conChildren = DataNormal cs } <- getConstructor (conInhabits c) dt = Just cs + | otherwise = Nothing + +numberSiblings :: DataTable -> Name -> Maybe Int +numberSiblings dt n + | Just c <- getConstructor n dt, Just Constructor { conChildren = cc } <- getConstructor (conInhabits c) dt = case cc of + DataNormal ds -> Just $ length ds + DataEnum n -> Just n + _ -> Nothing + | otherwise = Nothing + +-- whether the type has a single slot +onlyChild :: DataTable -> Name -> Bool +onlyChild dt n = isJust ans where + ans = do + c <- getConstructor n dt + case conChildren c of + DataNormal [_] -> return () + _ -> do + c <- getConstructor (conInhabits c) dt + case conChildren c of + DataNormal [_] -> return () + _ -> fail "not cpr" + +pprintTypeOfCons :: (Monad m,DocLike a) => DataTable -> Name -> m a +pprintTypeOfCons dataTable name = do + c <- getConstructor name dataTable + return $ pprintTypeAsHs (conType c) + +pprintTypeAsHs :: DocLike a => E -> a +pprintTypeAsHs e = unparse $ runVarName (f e) where + f e | e == eStar = return $ atom $ text "*" + | e == eHash = return $ atom $ text "#" + f (EPi (TVr { tvrIdent = eid, tvrType = t1 }) t2) | eid == emptyId = do + t1 <- f t1 + t2 <- f t2 + return $ t1 `arr` t2 + f (ELit LitCons { litName = n, litArgs = as }) | (a:as') <- reverse as = f $ EAp (ELit litCons { litName = n, litArgs = reverse as' }) a + f (ELit LitCons { litName = n, litArgs = [] }) = return $ atom $ text $ show n + f (EAp a b) = do + a <- f a + b <- f b + return $ a `app` b + f (EVar v) = do + vo <- newLookupName ['a' .. ] () (tvrIdent v) + return $ atom $ char vo + f v | (e,ts@(_:_)) <- fromPi v = do + ts' <- mapM (newLookupName ['a'..] () . tvrIdent) ts + r <- f e + return $ fixitize (N,-3) $ pop (text "forall" <+> hsep (map char ts') <+> text ". ") (atomize r) + f e = error $ "printTypeAsHs: " ++ show e + arr = bop (R,0) (space D.<> text "->" D.<> space) + app = bop (L,100) (text " ") + +class Monad m => DataTableMonad m where + getDataTable :: m DataTable + getDataTable = return mempty + +instance DataTableMonad Identity + +-- | list of declared data types that map +-- directly to primitive real types + +primitiveAliases :: Map.Map Name Name +primitiveAliases = Map.fromList [ + (tc_Bits1, rt_bool), + (tc_Bits8, rt_bits8), + (tc_Bits16, rt_bits16), + (tc_Bits32, rt_bits32), + (tc_Bits64, rt_bits64), + (tc_Bits128, rt_bits128), + (tc_BitsPtr, rt_bits_ptr_), + (tc_BitsMax, rt_bits_max_), + (tc_Float32, rt_float32), + (tc_Float64, rt_float64), + (tc_Float80, rt_float80), + (tc_Float128, rt_float128) + ] + +-- mapping of primitive types to the C calling convention used +-- when passing to/from foreign functions + +rawExtTypeMap :: Map.Map Name ExtType +rawExtTypeMap = Map.fromList [ + (rt_bool, "bool"), + (rt_bits8, "uint8_t"), + (rt_bits16, "uint16_t"), + (rt_bits32, "uint32_t"), + (rt_bits64, "uint64_t"), + (rt_bits128, "uint128_t"), + (rt_bits_ptr_, "uintptr_t" ), + (rt_bits_max_, "uintmax_t"), + (rt_float32, "float"), + (rt_float64, "double"), + (rt_float80, "long double"), + (rt_float128, "__float128") + ] + +$(derive makeBinary ''AliasType) +$(derive makeBinary ''DataFamily) +$(derive makeBinary ''Constructor) +$(derive makeBinary ''Slot) diff --git a/src/DataConstructors.hs-boot b/src/DataConstructors.hs-boot new file mode 100644 --- /dev/null +++ b/src/DataConstructors.hs-boot @@ -0,0 +1,13 @@ +module DataConstructors where + + +import E.E +import Name.Name + +data DataTable +followAliases :: DataTable -> E -> E +followAlias :: Monad m => DataTable -> E -> m E +typesCompatable :: Monad m => E -> E -> m () +updateLit :: DataTable -> Lit e t -> Lit e t +slotTypes :: DataTable -> Name -> E -> [E] +mktBox :: E -> E diff --git a/src/E/CPR.hs b/src/E/CPR.hs new file mode 100644 --- /dev/null +++ b/src/E/CPR.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE TemplateHaskell #-} +module E.CPR(Val(..), cprAnalyzeDs, cprAnalyzeProgram) where + +import Control.Monad.Writer(runWriter,tell,Monoid(..)) +import Data.Binary +import Data.Monoid() +import Data.Typeable +import Data.DeriveTH +import qualified Data.Map as Map + +import Cmm.Number +import DataConstructors +import Doc.DocLike +import E.E +import E.Program +import GenUtil +import Name.Name +import Name.Names +import Name.VConsts +import Util.SameShape +import qualified Doc.Chars as C +import qualified E.Demand as Demand +import qualified Info.Info as Info + +newtype Env = Env (Map.Map TVr Val) + deriving(Monoid) + +data Val = + Top -- the top. + | Fun Val -- function taking an arg + | Tup Name [Val] -- A constructed product + | VInt Number -- A number + | Tag [Name] -- A nullary constructor, like True, False + | Bot -- the bottom + deriving(Eq,Ord,Typeable) + +trimVal v = f (0::Int) v where + f !n Tup {} | n > 5 = Top + f n (Tup x vs) = Tup x (map (f (n + 1)) vs) + f n (Fun v) = Fun (f n v) + f _ x = x + +toVal c = case conSlots c of + [] -> Tag [conName c] + ss -> Tup (conName c) [ Top | _ <- ss] + +instance Show Val where + showsPrec _ Top = C.top + showsPrec _ Bot = C.bot + showsPrec n (Fun v) = C.lambda <> showsPrec n v + showsPrec _ (Tup n [x,xs]) | n == dc_Cons = shows x <> showChar ':' <> shows xs + showsPrec _ (Tup n xs) | Just _ <- fromTupname n = tupled (map shows xs) + showsPrec _ (Tup n xs) = shows n <> tupled (map shows xs) + showsPrec _ (VInt n) = shows n + showsPrec _ (Tag [n]) | n == dc_EmptyList = showString "[]" + showsPrec _ (Tag [n]) = shows n + showsPrec _ (Tag ns) = shows ns + +lub :: Val -> Val -> Val +lub Bot a = a +lub a Bot = a +lub Top a = Top +lub a Top = Top +lub (Tup a xs) (Tup b ys) + | a == b, sameShape1 xs ys = Tup a (zipWith lub xs ys) + | a == b = error "CPR.lub this shouldn't happen" + | otherwise = Top +lub (Fun l) (Fun r) = Fun (lub l r) +lub (VInt n) (VInt n') | n == n' = VInt n +lub (Tag xs) (Tag ys) = Tag (smerge xs ys) +lub (Tag _) (Tup _ _) = Top +lub (Tup _ _) (Tag _) = Top +lub _ _ = Top +--lub a b = error $ "CPR.lub: " ++ show (a,b) + +instance Monoid Val where + mempty = Bot + mappend = lub + +{-# NOINLINE cprAnalyzeProgram #-} +cprAnalyzeProgram :: Program -> Program +cprAnalyzeProgram prog = ans where + nds = cprAnalyzeDs (progDataTable prog) (programDs prog) + ans = programSetDs' nds prog -- { progStats = progStats prog `mappend` stats } + +cprAnalyzeDs :: DataTable -> [(TVr,E)] -> [(TVr,E)] +cprAnalyzeDs dataTable ds = fst $ cprAnalyzeBinds dataTable mempty ds + +cprAnalyzeBinds :: DataTable -> Env -> [(TVr,E)] -> ([(TVr,E)],Env) +cprAnalyzeBinds dataTable env bs = f env (decomposeDs bs) [] where + f env (Left (t,e):rs) zs = case cprAnalyze dataTable env e of + (e',v) -> f (envInsert t v env) rs ((tvrInfo_u (Info.insert $ trimVal v) t,e'):zs) + f env (Right xs:rs) zs = g (length xs + 2) ([ (t,(e,Bot)) | (t,e) <- xs]) where + g 0 mp = f nenv rs ([ (tvrInfo_u (Info.insert $ trimVal b) t,e) | (t,(e,b)) <- mp] ++ zs) where + nenv = Env (Map.fromList [ (t,b) | (t,(e,b)) <- mp]) `mappend` env + g n mp = g (n - 1) [ (t,cprAnalyze dataTable nenv e) | (t,e) <- xs] where + nenv = Env (Map.fromList [ (t,b) | (t,(e,b)) <- mp]) `mappend` env + f env [] zs = (reverse zs,env) + +envInsert :: TVr -> Val -> Env -> Env +envInsert tvr val (Env mp) = Env $ Map.insert tvr val mp + +cprAnalyze :: DataTable -> Env -> E -> (E,Val) +cprAnalyze dataTable env e = cprAnalyze' env e where + cprAnalyze' (Env mp) (EVar v) + | Just t <- Map.lookup v mp = (EVar v,t) + | Just t <- Info.lookup (tvrInfo v) = (EVar v,t) + | otherwise = (EVar v,Top) + cprAnalyze' env ELetRec { eDefs = ds, eBody = e } = (ELetRec ds' e',val) where + (ds',env') = cprAnalyzeBinds dataTable env ds + (e',val) = cprAnalyze' (env' `mappend` env) e + + cprAnalyze' env (ELam t e) + | Just (Demand.S _) <- Info.lookup (tvrInfo t), Just c <- getProduct dataTable (tvrType t) = let + (e',val) = cprAnalyze' (envInsert t (toVal c) env) e + in (ELam t e',Fun val) + cprAnalyze' env (ELam t e) = (ELam t e',Fun val) where + (e',val) = cprAnalyze' (envInsert t Top env) e + cprAnalyze' env ec@(ECase {}) = runWriter (caseBodiesMapM f ec) where + f e = do + (e',v) <- return $ cprAnalyze' env e + tell v + return e' + cprAnalyze' env (EAp fun arg) = (EAp fun_cpr arg,res_res) where + (fun_cpr, fun_res) = cprAnalyze' env fun + res_res = case fun_res of + Fun x -> x + Top -> Top + Bot -> Bot + v -> error $ "cprAnalyze'.res_res: " ++ show v + cprAnalyze' env e = (e,f e) where + f (ELit (LitInt n _)) = VInt n + f (ELit LitCons { litName = n, litArgs = [], litType = _ }) = Tag [n] + f (ELit LitCons { litName = n, litArgs = xs, litType = _ }) = Tup n (map g xs) + f (EPi t e) = Tup tc_Arrow [g $ tvrType t, g e] + f (EPrim {}) = Top -- TODO fix primitives + f (EError {}) = Bot + f e = error $ "cprAnalyze'.f: " ++ show e + g = snd . cprAnalyze' env + +$(derive makeBinary ''Val) diff --git a/src/E/Demand.hs b/src/E/Demand.hs new file mode 100644 --- /dev/null +++ b/src/E/Demand.hs @@ -0,0 +1,410 @@ +{-# LANGUAGE TemplateHaskell #-} +module E.Demand( + Demand(..), + DemandSignature(..), + DemandType(..), + SubDemand(..), + analyzeProgram, + absSig, + lazy + ) where + +import Control.Monad.Reader +import Control.Monad.Writer hiding(Product(..)) +import Data.Binary +import Data.List hiding(union,delete) +import Data.Typeable +import Data.DeriveTH + +--import Debug.Trace +import DataConstructors +import Doc.DocLike +import Doc.PPrint +import E.E +import E.Program +import GenUtil +import Info.Types +import Name.Id +import Util.HasSize +import Util.SetLike +import qualified Info.Info as Info + +trace _ x = x + +data Demand = + Bottom -- always diverges + | L !SubDemand -- lazy + | S !SubDemand -- strict + | Error !SubDemand -- diverges, might use arguments + | Absent -- Not used + deriving(Eq,Ord,Typeable) + +data SubDemand = None | Product ![Demand] + deriving(Eq,Ord) + +data DemandEnv = DemandEnv !(IdMap Demand) !Demand + deriving(Eq,Ord) + +data DemandType = (:=>) !DemandEnv ![Demand] + deriving(Eq,Ord) + +data DemandSignature = DemandSignature {-# UNPACK #-} !Int !DemandType + deriving(Eq,Ord,Typeable) + +idGlb = Absent + +absType = (DemandEnv mempty idGlb) :=> [] +--botType = (DemandEnv mempty Bottom) :=> [] +botType = (DemandEnv mempty Bottom) :=> [] + +--lazyType = (DemandEnv mempty lazy) :=> [] +--lazySig = DemandSignature 0 lazyType +absSig = DemandSignature 0 absType + +class Lattice a where + glb :: a -> a -> a + lub :: a -> a -> a + +-- Sp [L .. L] = S +-- Sp [.. _|_ ..] = _|_ + +sp [] = S None +sp xs = S (allLazy xs) -- None + +l None = L None +l (Product xs) = lp xs + +s None = S None +s (Product xs) = sp xs + +allLazy xs | all (== lazy) xs = None +allLazy xs = Product xs + +lp [] = L None +lp xs = L (allLazy (map f xs)) where + f (S None) = lazy + f (S (Product ys)) = lp ys + f Bottom = Absent + f (Error None) = lazy + f (Error (Product xs)) = lp xs + f x = x + +{- +sp s = sp' True s where + sp' True [] = S None + sp' False [] = S (Product s) + sp' allLazy (L _:rs) = sp' allLazy rs + sp' _ (Bottom:_) = Error (Product s) + sp' _ (_:rs) = sp' False rs +-} + +instance Lattice DemandType where + lub (env :=> ts) (env' :=> ts') | length ts < length ts' = (env `lub` env') :=> strictList (zipWith lub (ts ++ repeat lazy) ts') + | otherwise = (env `lub` env') :=> strictList (zipWith lub ts (ts' ++ repeat lazy)) + glb (env :=> ts) (env' :=> ts') | length ts < length ts' = (env `glb` env') :=> strictList (zipWith glb (ts ++ repeat lazy) ts') + | otherwise = (env `glb` env') :=> strictList (zipWith glb ts (ts' ++ repeat lazy)) + +lazy = L None +strict = S None +err = Error None + +strictList (x:xs) = x `seq` xs' `seq` (x:xs') where + xs' = strictList xs +strictList [] = [] + +comb _ None None = None +comb f None (Product xs) = Product $ zipWith f (repeat lazy) xs +comb f (Product xs) None = Product $ zipWith f xs (repeat lazy) +comb f (Product xs) (Product ys) = Product $ zipWith f xs ys + +instance Lattice Demand where + lub Bottom s = s + lub s Bottom = s + lub Absent Absent = Absent + lub (S x) Absent = l x + lub Absent (S x) = l x + lub (L x) Absent = l x + lub Absent (L x) = l x + lub Absent sa = lazy + lub sa Absent = lazy + + lub (S x) (S y) = s (comb lub x y) + lub (L x) (L y) = l (comb lub x y) + lub (Error x) (Error y) = Error (comb lub x y) + + lub (S x) (L y) = l (comb lub x y) + lub (L x) (S y) = l (comb lub x y) + + lub (S x) (Error y) = s (comb lub x y) + lub (Error x) (S y) = s (comb lub x y) + + lub (L x) (Error y) = lazy + lub (Error x) (L y) = lazy + + glb Bottom Bottom = Bottom + glb Absent sa = sa + glb sa Absent = sa + + glb Bottom _ = err + glb _ Bottom = err + + glb (S x) (S y) = s (comb glb x y) + glb (L x) (L y) = l (comb glb x y) + glb (Error x) (Error y) = Error (comb glb x y) + + glb (S _) (Error _) = err + glb (Error _) (S _) = err + + glb (S x) (L y) = s (comb glb x y) + glb (L x) (S y) = s (comb glb x y) + + glb (L _) (Error _) = err + glb (Error _) (L _) = err + +lenv e (DemandEnv m r) = case mlookup e m of + Nothing -> r + Just x -> x + +demandEnvSingleton :: TVr -> Demand -> DemandEnv +demandEnvSingleton _ Absent = DemandEnv mempty idGlb +demandEnvSingleton t d = DemandEnv (msingleton (tvrIdent t) d) idGlb + +demandEnvMinus :: DemandEnv -> TVr -> DemandEnv +demandEnvMinus (DemandEnv m r) x = DemandEnv (delete (tvrIdent x) m) r + +instance Lattice DemandEnv where + lub d1@(DemandEnv m1 r1) d2@(DemandEnv m2 r2) = DemandEnv m (r1 `lub` r2) where + m = fromList [ (x,lenv x d1 `lub` lenv x d2) | x <- keys (m1 `union` m2)] + glb d1@(DemandEnv m1 r1) d2@(DemandEnv m2 r2) = DemandEnv m (r1 `glb` r2) where + m = fromList [ (x,lenv x d1 `glb` lenv x d2) | x <- keys (m1 `union` m2)] + +newtype IM a = IM (Reader (Env,DataTable) a) + deriving(Monad,Functor,MonadReader (Env,DataTable)) + +type Env = IdMap (Either DemandSignature E) + +getEnv :: IM Env +getEnv = asks fst + +extEnv TVr { tvrIdent = i } _ | isEmptyId i = id +extEnv t e = local (\ (env,dt) -> (minsert (tvrIdent t) (Left e) env,dt)) + +extEnvE TVr { tvrIdent = i } _ | isEmptyId i = id +extEnvE t e = local (\ (env,dt) -> (minsert (tvrIdent t) (Right e) env,dt)) + +instance DataTableMonad IM where + getDataTable = asks snd + +runIM :: Monad m => IM a -> DataTable -> m a +runIM (IM im) dt = return $ runReader im (mempty,dt) + +-- returns the demand type and whether it was found in the local environment or guessed +determineDemandType :: TVr -> Demand -> IM (Either DemandType E) +determineDemandType tvr demand = do + let g (DemandSignature n dt@(DemandEnv phi _ :=> _)) = f n demand where + f 0 (S _) = dt + f n (S (Product [s])) = f (n - 1) s + f _ _ = lazify (DemandEnv phi Absent) :=> [] + env <- getEnv + case mlookup (tvrIdent tvr) env of + Just (Left ds) -> return (Left $ g ds) + Just (Right e) -> return (Right e) + Nothing -> case Info.lookup (tvrInfo tvr) of + Nothing -> return (Left absType) + Just ds -> return (Left $ g ds) + +extendSig (DemandSignature n1 t1) (DemandSignature n2 t2) = DemandSignature (max n1 n2) (glb t1 t2) + +splitSigma [] = (lazy,[]) +splitSigma (x:xs) = (x,xs) + +analyze :: E -> Demand -> IM (E,DemandType) +analyze e Absent = return (e,absType) +analyze (EVar v) s = do + ddt <- determineDemandType v s + (phi :=> sigma) <- case ddt of + Left dt -> return dt + Right e -> liftM snd $ analyze e s + return (EVar v,(phi `glb` (demandEnvSingleton v s)) :=> sigma) +analyze (EAp e1 e2) s = do + (e1',phi1 :=> sigma1') <- analyze e1 (sp [s]) + let (sa,sigma1) = splitSigma sigma1' + (e2',phi2 :=> sigma2) <- analyze e2 sa + return $ (EAp e1' e2',(phi1 `glb` phi2) :=> sigma1) +analyze el@(ELit lc@LitCons { litName = h, litArgs = ts@(_:_) }) (S (Product ss)) | length ss == length ts = do + dataTable <- getDataTable + case onlyChild dataTable h of + True -> do -- product type + envs <- flip mapM (zip ts ss) $ \(a,s) -> do + (_,env :=> _) <- analyze a s + return env + return (el,foldr1 glb envs :=> []) + _ -> do + rts <- mapM (\e -> analyze e lazy) ts + return (ELit lc { litArgs = fsts rts }, foldr glb absType (snds rts)) + +analyze (ELit lc@LitCons { litArgs = ts }) _s = do + rts <- mapM (\e -> analyze e lazy) ts + return (ELit lc { litArgs = fsts rts }, foldr glb absType (snds rts)) +analyze e s | Just (t1,t2,pt) <- from_dependingOn e = do + (t1',dt1) <- analyze t1 s + (t2',dt2) <- analyze t2 lazy + return (EPrim p_dependingOn [t1',t2'] pt,dt1 `glb` dt2) +analyze (EPrim ap ts pt) _s = do + rts <- mapM (\e -> analyze e lazy) ts + return (EPrim ap (fsts rts) pt, foldr glb absType (snds rts)) +analyze (EPi tvr@TVr { tvrType = t1 } t2) _s = do + (t1',dt1) <- analyze t1 lazy + (t2',dt2) <- analyze t2 lazy + return (EPi tvr { tvrType = t1' } t2',dt1 `glb` dt2) + +analyze (ELam x@TVr { tvrIdent = eid } e) (S (Product [s])) | eid == emptyId = do + (e',phi :=> sigma) <- analyze e s + let sx = Absent + return (ELam (tvrInfo_u (Info.insert $! sx) x) e',demandEnvMinus phi x :=> (sx:sigma)) +analyze (ELam x e) (S (Product [s])) = do + (e',phi :=> sigma) <- analyze e s + let sx = lenv (tvrIdent x) phi + return (ELam (tvrInfo_u (Info.insert $! sx) x) e',demandEnvMinus phi x :=> (sx:sigma)) + +analyze (ELam x e) (L (Product [s])) = do + (e',phi :=> sigma) <- analyze e s + let sx = lenv (tvrIdent x) phi + return (ELam (tvrInfo_u (Info.insert $! sx) x) e',lazify (demandEnvMinus phi x) :=> (sx:sigma)) +analyze (ELam x e) (S None) = analyze (ELam x e) (S (Product [lazy])) -- simply to ensure binder is annotated +analyze (ELam x e) (L None) = analyze (ELam x e) (L (Product [lazy])) -- simply to ensure binder is annotated +analyze (ELam x e) (Error None) = analyze (ELam x e) (Error (Product [lazy])) -- simply to ensure binder is annotated +analyze e@EError {} (S _) = return (e,botType) +analyze e@EError {} (L _) = return (e,absType) +analyze ec@ECase { eCaseBind = b, eCaseAlts = [Alt lc@LitCons { litName = h, litArgs = ts } alt], eCaseDefault = Nothing } s = do + dataTable <- getDataTable + case onlyChild dataTable h of + True -> do -- product type + (alt',enva :=> siga) <- extEnvE b (eCaseScrutinee ec) $ analyze alt s + (e',enve :=> []) <- analyze (eCaseScrutinee ec) (sp [ lenv (tvrIdent t) enva | t <- ts]) + let nenv = enve `glb` foldr denvDelete enva (b:ts) + return (caseUpdate $ ec { eCaseScrutinee = e', eCaseAlts = [Alt lc alt'] }, nenv :=> siga) + _ -> analyzeCase ec s +analyze ec@ECase {} s = analyzeCase ec s +analyze ELetRec { eDefs = ds, eBody = b } s = f (decomposeDs ds) [] where + f [] ds' = do + (b',phi :=> sig) <- analyze b s + let g (t,e) = (tvrInfo_u (Info.insert $! (lenv (tvrIdent t) phi)) t,e) + return (ELetRec (map g ds') b', foldr denvDelete phi (fsts ds) :=> sig) + f (Left (t,e):rs) fs = + solveDs' (Just False) [(t,e)] fixupDemandSignature (\nn -> f rs (nn ++ fs)) + f (Right rg:rs) fs = do + solveDs' (Just True) rg fixupDemandSignature (\nn -> f rs (nn ++ fs)) +analyze Unknown _ = return (Unknown,absType) +analyze es@ESort {} _ = return (es,absType) +analyze es@(ELit LitInt {}) _ = return (es,absType) +analyze e x = fail $ "analyze: " ++ show (e,x) + +from_dependingOn (EPrim don [t1,t2] pt) | don == p_dependingOn = return (t1,t2,pt) +from_dependingOn _ = fail "not dependingOn" + +lazify (DemandEnv x r) = DemandEnv (fmap f x) Absent where + f (S xs) = l xs + f Absent = Absent + f (L xs) = l xs + f Bottom = Absent + f (Error xs) = l xs + +analyzeCase ec s = do + (ec',dts) <- extEnvE (eCaseBind ec) (eCaseScrutinee ec) $ runWriterT $ flip caseBodiesMapM ec $ \e -> do + (ne,dt) <- lift $ analyze e s + tell [dt] + return ne + (ecs,env :=> _) <- analyze (eCaseScrutinee ec') strict + let enva :=> siga = foldr1 lub dts + let nenv = foldr denvDelete (glb enva env) (caseBinds ec') + return (caseUpdate $ ec' {eCaseScrutinee = ecs},nenv :=> siga) + +denvDelete x (DemandEnv m r) = DemandEnv (delete (tvrIdent x) m) r + +topAnalyze :: TVr -> E -> IM (E,DemandSignature) +topAnalyze tvr e | getProperty prop_PLACEHOLDER tvr = return (e,DemandSignature 0 absType) +topAnalyze _tvr e = clam e strict 0 where + clam (ELam _ x) s n = clam x (sp [s]) (n + 1) + clam _ s n = do + (e,dt) <- analyze e s + return (e,DemandSignature n dt) + +fixupDemandSignature (DemandSignature n (DemandEnv _ r :=> dt)) = DemandSignature n (DemandEnv mempty r :=> dt) + +shouldBind ELit {} = True +shouldBind EVar {} = True +shouldBind EPi {} = True +shouldBind _ = False + +solveDs' :: (Maybe Bool) -> [(TVr,E)] -> (DemandSignature -> DemandSignature) -> ([(TVr,E)] -> IM a) -> IM a +solveDs' Nothing ds fixup wdone = do + let f (Left d:rs) xs = solveDs' (Just False) [d] fixup (\nds -> f rs (nds ++ xs)) + f (Right ds:rs) xs = solveDs' (Just True) ds fixup (\nds -> f rs (nds ++ xs)) + f [] xs = wdone xs + f (decomposeDs ds) [] +solveDs' (Just False) [(t,e)] fixup wdone | shouldBind e = do + (ne,ds) <- topAnalyze t e + extEnvE t e $ wdone [(tvrInfo_u (Info.insert (fixup ds)) t,ne)] +solveDs' (Just False) [(t,e)] fixup wdone = do + (ne,ds) <- topAnalyze t e + extEnv t ds $ wdone [(tvrInfo_u (Info.insert (fixup ds)) t,ne)] +--solveDs' (Just False) ds fixup wdone = solveDs' Nothing ds fixup wdone +solveDs' (Just False) ds fixup wdone = error "solveDs' (Just False) called with more than one definition" +solveDs' (Just True) ds fixup wdone = trace "solveDs': jt" $ do + let ds' = [ ((t,e),sig) | (t,e) <- ds, let sig = maybe absSig id (Info.lookup (tvrInfo t))] + g 0 _ [] ds = trace "gdonetout" $ wdone [ (tvrInfo_u (Info.insert $! (fixup sig)) t,e) | ((t,e),sig) <- ds ] + g _ False [] ds = trace "gdone1" $ wdone [ (tvrInfo_u (Info.insert $! (fixup sig)) t,e) | ((t,e),sig) <- ds ] + g n True [] ds = do + (oe,dt) <- ask + let nenv = fromList [ (tvrIdent t,Left s) | ((t,_),s) <- ds, not (isEmptyId (tvrIdent t))] `Util.SetLike.union` oe + local (const (nenv,dt)) $ trace ("grepeating: " ++ show (length ds)) $ g (n - 1) False ds [] + g n ch (((t,e),sig):rs) fs = do + (ne,sig') <- topAnalyze t e + let sig'' = sig `extendSig` sig' + --(if sig'' /= sig then trace ("signe: " ++ show(tvrIdent t,sig)) else id) $ + g n (ch || (sig'' /= sig)) rs (((t,ne),sig''):fs) + g (5::Int) True [] ds' + +{-# NOINLINE analyzeProgram #-} +analyzeProgram prog = do + let ds = programDs prog + nds <- runIM (solveDs' Nothing ds fixupDemandSignature return) (progDataTable prog) + --flip mapM_ nds $ \ (t,_) -> + -- putStrLn $ "strictness: " ++ pprint t ++ ": " ++ show (maybe absSig id $ Info.lookup (tvrInfo t)) + return $ programSetDs' nds prog + +---------------------------- +-- show and pprint instances +---------------------------- + +instance Show Demand where + showsPrec _ Bottom = ("_|_" ++) + showsPrec _ Absent = ('A':) + showsPrec _ (L None) = ('L':) + showsPrec _ (L (Product ds)) = showString "L(" . foldr (.) id (map shows ds) . showString ")" + showsPrec _ (S None) = ('S':) + showsPrec _ (S (Product ds)) = showString "S(" . foldr (.) id (map shows ds) . showString ")" + showsPrec _ (Error None) = showString "Err" + showsPrec _ (Error (Product ds)) = showString "Err(" . foldr (.) id (map shows ds) . showString ")" + +instance DocLike d => PPrint d Demand where + pprint demand = tshow demand + +instance Show DemandType where + showsPrec _ (DemandEnv e Absent :=> d) | isEmpty e = shows d + showsPrec _ (env :=> ds) = shows env . showString " :=> " . shows ds + +instance Show DemandEnv where + showsPrec _ (DemandEnv m Absent) = showString "{" . foldr (.) id (intersperse (showString ",") [ showString (pprint t) . showString " -> " . shows v | (t,v) <- idMapToList m]) . showString "}" + showsPrec _ (DemandEnv _ Bottom) = showString "_|_" + showsPrec _ (DemandEnv m demand) = showString "{" . shows demand . showString " - " . foldr (.) id (intersperse (showString ",") [ showString (pprint t) . showString " -> " . shows v | (t,v) <- idMapToList m]) . showString "}" + +instance Show DemandSignature where + showsPrec _ (DemandSignature n dt) = showString "<" . shows n . showString "," . shows dt . showString ">" + +$(derive makeBinary ''Demand) +$(derive makeBinary ''SubDemand) +$(derive makeBinary ''DemandEnv) +$(derive makeBinary ''DemandType) +$(derive makeBinary ''DemandSignature) diff --git a/src/E/LambdaLift.hs b/src/E/LambdaLift.hs new file mode 100644 --- /dev/null +++ b/src/E/LambdaLift.hs @@ -0,0 +1,345 @@ +module E.LambdaLift(lambdaLift,staticArgumentTransform) where + +import Control.Monad.Reader +import Control.Monad.Writer +import Data.IORef +import Data.Maybe +import Text.Printf + +import Doc.PPrint +import E.Annotate +import E.E +import E.Inline +import E.Program +import E.Subst +import E.Traverse +import E.TypeCheck +import E.Values +import Fixer.Fixer +import Fixer.Supply +import GenUtil +import Name.Id +import Name.Name +import Options (verbose) +import Stats(mtick,runStatM,runStatT) +import StringTable.Atom +import Support.CanType +import Support.FreeVars +import Util.Graph as G +import Util.HasSize +import Util.SetLike hiding(Value) +import Util.UniqueMonad + +annotateId mn x = case fromId x of + Just y -> toId (toName Val (mn,'f':show y)) + Nothing -> toId (toName Val (mn,'f':show x)) + +-- | transform simple recursive functions into non-recursive variants +-- this is exactly the opposite of lambda lifting, but is a big win if the function ends up inlined +-- and is conducive to other optimizations +-- +-- in particular, the type arguments can almost always be transformed away from the recursive inner function +-- +-- this has potentially exponential behavior. beware + +staticArgumentTransform :: Program -> Program +staticArgumentTransform prog = ans where + ans = progCombinators_s (concat ds') prog { progStats = progStats prog `mappend` nstat } + (ds',nstat) = runStatM $ mapM h (programDecomposedCombs prog) + h (True,[comb]) = do [(_,nb)] <- f True (Right [(combHead comb, combBody comb)]); return [combBody_s nb comb] + h (_,cs) = do + forM cs $ \ c -> do + e' <- g (combBody c) + return (combBody_s e' c) + f _ (Left (t,e)) = gds [(t,e)] + f always (Right [(t,v@ELam {})]) | not (null collectApps), always || dropArgs > 0 = ans where + nname = annotateId "R@" (tvrIdent t) + dropArgs = minimum [ countCommon args aps | aps <- collectApps ] where + args = map EVar $ snd $ fromLam v + countCommon (x:xs) (y:ys) | x == y = 1 + countCommon xs ys + countCommon _ _ = 0 + collectApps = execWriter (ca v) where + ca e | (EVar v,as) <- fromAp e, tvrIdent v == tvrIdent t = tell [as] >> mapM_ ca as >> return e + ca e = emapE ca e + (body,args) = fromLam v + (droppedAs,keptAs) = splitAt dropArgs args + rbody = foldr ELam (subst t newV body) keptAs + newV = foldr ELam (EVar tvr') [ t { tvrIdent = emptyId } | t <- droppedAs ] + tvr' = tvr { tvrIdent = nname, tvrType = getType rbody } + ne' = foldr ELam (ELetRec [(tvr',rbody)] (foldl EAp (EVar tvr') (map EVar keptAs))) args + ans = do + mtick $ "SimpleRecursive.{" ++ pprint t + ne' <- g ne' + return [(t,ne')] + f _ (Right ts) = gds ts + gds ts = mapM g' ts >>= return where + g' (t,e) = g e >>= return . (,) t + g elet@ELetRec { eDefs = ds } = do + ds'' <- mapM (f False) (decomposeDs ds) + e' <- g $ eBody elet + return elet { eDefs = concat ds'', eBody = e' } + g e = emapE g e + +data S = S { + funcName :: Name, + topVars :: IdSet, + isStrict :: Bool, + declEnv :: [(TVr,E)] + } + +isStrict_u f r@S{isStrict = x} = r{isStrict = f x} +topVars_u f r@S{topVars = x} = r{topVars = f x} +isStrict_s v = isStrict_u (const v) + +{- +etaReduce :: E -> (E,Int) +etaReduce e = case f e 0 of + (ELam {},_) -> (e,0) + x -> x + where + f (ELam t (EAp x (EVar t'))) n | n `seq` True, t == t' && not (tvrIdent t `member` (freeVars x :: IdSet)) = f x (n + 1) + f e n = (e,n) +-} + +-- | we do not lift functions that only appear in saturated strict contexts, +-- as these functions will never have an escaping thunk or partial app +-- built and can be turned into local functions in grin. +-- +-- Although grin is only able to take advantage of groups of possibily +-- mutually recursive local functions that only tail-call each other, we leave +-- all candidate functions local, as further grin transformations can expose +-- tail-calls that arn't evident in core. +-- +-- A final lambda-lifting needs to be done in grin to get rid of these local +-- functions that cannot be turned into loops + +calculateLiftees :: Program -> IO IdSet +calculateLiftees prog = do + fixer <- newFixer + sup <- newSupply fixer + + let f v env ELetRec { eDefs = ds, eBody = e } = do + let nenv = fromList [ (tvrIdent t,length (snd (fromLam e))) | (t,e) <- ds ] `mappend` env + nenv :: IdMap Int + g (t,e@ELam {}) = do + v <- supplyValue sup (tvrIdent t) + let (a,_as) = fromLam e + f v nenv a + g (t,e) = do + f (value True) nenv e + mapM_ g ds + f v nenv e + f v env e@ESort {} = return () + f v env e@Unknown {} = return () + f v env e@EError {} = return () + f v env (EVar TVr { tvrIdent = vv }) = do + nv <- supplyValue sup vv + assert nv + f v env e | (EVar TVr { tvrIdent = vv }, as@(_:_)) <- fromAp e, Just n <- mlookup vv env = do + nv <- supplyValue sup vv + if length as >= n then v `implies` nv else assert nv + mapM_ (f (value True) env) as + f v env e | (a, as@(_:_)) <- fromAp e = do + mapM_ (f (value True) env) as + f v env a + f v env (ELit LitCons { litArgs = as }) = mapM_ (f (value True) env) as + f v env ELit {} = return () + f v env (EPi TVr { tvrType = a } b) = f (value True) env a >> f (value True) env b + f v env (EPrim _ as _) = mapM_ (f (value True) env) as + f v env ec@ECase {} = do + f v env (eCaseScrutinee ec) + mapM_ (f v env) (caseBodies ec) + f v env (ELam _ e) = f (value True) env e + f _ _ EAp {} = error "this should not happen" + mapM_ (f (value False) mempty) [ fst (fromLam e) | (_,e) <- programDs prog] + + findFixpoint Nothing {-"Liftees"-} fixer + vs <- supplyReadValues sup + let nlset = (fromList [ x | (x,False) <- vs]) + when verbose $ printf "%d lambdas not lifted\n" (size nlset) + return nlset + +implies :: Value Bool -> Value Bool -> IO () +implies x y = addRule $ y `isSuperSetOf` x + +assert x = value True `implies` x + +lambdaLift :: Program -> IO Program +lambdaLift prog@Program { progDataTable = dataTable, progCombinators = cs } = do + noLift <- calculateLiftees prog + let wp = fromList [ combIdent x | x <- cs ] :: IdSet + fc <- newIORef [] + fm <- newIORef mempty + statRef <- newIORef mempty + let z comb = do + (n,as,v) <- return $ combTriple comb + let ((v',(cs',rm)),stat) = runReader (runStatT $ execUniqT 1 $ runWriterT (f v)) S { funcName = mkFuncName (tvrIdent n), topVars = wp,isStrict = True, declEnv = [] } + modifyIORef statRef (mappend stat) + modifyIORef fc (\xs -> combTriple_s (n,as,v') comb:cs' ++ xs) + modifyIORef fm (rm `mappend`) + shouldLift t _ | tvrIdent t `member` noLift = False + shouldLift _ ECase {} = True + shouldLift _ ELam {} = True + shouldLift _ _ = False + f e@(ELetRec ds _) = do + let (ds',e') = decomposeLet e + h ds' e' [] + f e = do + st <- asks isStrict + if ((tvrIdent tvr `notMember` noLift && isELam e) || (shouldLift tvr e && not st)) then do + (e,fvs'') <- pLift e + doBigLift e fvs'' return + else g e + -- This ensures there are no 'orphaned type terms' when something is + -- lifted out. The problem occurs when a type is subsituted in some + -- places and not others, the type as free variable will not be the + -- same as its substituted instances if the variable is bound by a + -- lambda, Although the program is still typesafe, it is no longer + -- easily proven so, so we avoid the whole mess by subtituting known + -- type variables within lifted expressions. This can not duplicate work + -- since types are unpointed, but might change space usage slightly. +-- g ec@ECase { eCaseScrutinee = (EVar v), eCaseAlts = as, eCaseDefault = d} | sortKindLike (tvrType v) = do +-- True <- asks isStrict +-- d' <- fmapM f d +-- let z (Alt l e) = do +-- e' <- local (declEnv_u ((v,followAliases dataTable $ patToLitEE l):)) $ f e +-- return $ Alt l e' +-- as' <- mapM z as +-- return $ caseUpdate ec { eCaseAlts = as', eCaseDefault = d'} + g (ELam t e) = do + e' <- local (isStrict_s True) (g e) + return (ELam t e') + g e = emapE' f e + pLift e = do + gs <- asks topVars + ds <- asks declEnv + let fvs = freeVars e + fvs' = filter (not . (`member` gs) . tvrIdent) fvs + --ss = filter (sortKindLike . tvrType) fvs' + ss = [] + f [] e False = return (e,fvs'') + f [] e True = pLift e + f (s:ss) e x + | Just v <- lookup s ds = f ss (removeType s v e) True -- TODO subst + | otherwise = f ss e x + fvs'' = reverse $ topSort $ newGraph fvs' tvrIdent freeVars + f ss e False + h (Left (t,e):ds) rest ds' | shouldLift t e = do + (e,fvs'') <- pLift e + case fvs'' of + [] -> doLift t e (h ds rest ds') + fs -> doBigLift e fs (\e'' -> h ds rest ((t,e''):ds')) + h (Left (t,e@ELam {}):ds) rest ds' = do + let (a,as) = fromLam e + a' <- local (isStrict_s True) (f a) + h ds rest ((t,foldr ELam a' as):ds') + + h (Left (t,e):ds) rest ds' = do + let fvs = freeVars e :: [Id] + gs <- asks topVars + let fvs' = filter (not . (`member` gs) ) fvs + case fvs' of + [] -> doLift t e (h ds rest ds') -- We always lift CAFS to the top level for now. (GC?) + _ -> local (isStrict_s False) (f e) >>= \e'' -> h ds rest ((t,e''):ds') + --h (Left (t,e):ds) e' ds' = local (isStrict_s False) (f e) >>= \e'' -> h ds e' ((t,e''):ds') + h (Right rs:ds) rest ds' | any (uncurry shouldLift) rs = do + gs <- asks topVars + let fvs = freeVars (snds rs)-- (Set.fromList (map tvrIdent $ fsts rs) `Set.union` gs) + let fvs' = filter (not . (`member` (fromList (map tvrIdent $ fsts rs) `mappend` gs) ) . tvrIdent) fvs + fvs'' = reverse $ topSort $ newGraph fvs' tvrIdent freeVars + case fvs'' of + [] -> doLiftR rs (h ds rest ds') -- We always lift CAFS to the top level for now. (GC?) + fs -> doBigLiftR rs fs (\rs' -> h ds rest (rs' ++ ds')) + h (Right rs:ds) e' ds' = do + rs' <- local (isStrict_s False) $ do + flip mapM rs $ \te -> case te of + (t,e@ELam {}) -> do + let (a,as) = fromLam e + a' <- local (isStrict_s True) (f a) + return (t,foldr ELam a' as) + (t,e) -> do + e'' <- f e + return (t,e'') + h ds e' (rs' ++ ds') + h [] e ds = f e >>= return . eLetRec ds + tellCombinator c = tell ([combTriple_s c emptyComb],mempty) + tellCombinators c = tell (map (`combTriple_s` emptyComb) c,mempty) + doLift t e r = local (topVars_u (insert (tvrIdent t)) ) $ do + --(e,tn) <- return $ etaReduce e + let (e',ls) = fromLam e + mtick (toAtom $ "E.LambdaLift.doLift." ++ typeLift e ++ "." ++ show (length ls)) + --mticks tn (toAtom $ "E.LambdaLift.doLift.etaReduce") + e'' <- local (isStrict_s True) $ f e' + t <- globalName t + tellCombinator (t,ls,e'') + r + doLiftR rs r = local (topVars_u (mappend (fromList (map (tvrIdent . fst) rs)) )) $ do + flip mapM_ rs $ \ (t,e) -> do + --(e,tn) <- return $ etaReduce e + let (e',ls) = fromLam e + mtick (toAtom $ "E.LambdaLift.doLiftR." ++ typeLift e ++ "." ++ show (length ls)) + --mticks tn (toAtom $ "E.LambdaLift.doLift.etaReduce") + e'' <- local (isStrict_s True) $ f e' + t <- globalName t + tellCombinator (t,ls,e'') + r + globalName tvr | isNothing $ fromId (tvrIdent tvr) = do + TVr { tvrIdent = t } <- newName Unknown + let ntvr = tvr { tvrIdent = t } + tell ([],msingleton (tvrIdent tvr) (Just $ EVar ntvr)) + return ntvr + globalName tvr = return tvr + newName tt = do + un <- newUniq + n <- asks funcName + return $ tVr (toId $ mapName (id,(++ ('$':show un))) n) tt + doBigLift e fs dr = do + mtick (toAtom $ "E.LambdaLift.doBigLift." ++ typeLift e ++ "." ++ show (length fs)) + ds <- asks declEnv + let tt = typeInfer' dataTable ds (foldr ELam e fs) + tvr <- newName tt + let (e',ls) = fromLam e + e'' <- local (isStrict_s True) $ f e' + tellCombinator (tvr,fs ++ ls,e'') + let e'' = foldl EAp (EVar tvr) (map EVar fs) + dr e'' + doBigLiftR rs fs dr = do + ds <- asks declEnv + rst <- flip mapM rs $ \ (t,e) -> do + case shouldLift t e of + True -> do + mtick (toAtom $ "E.LambdaLift.doBigLiftR." ++ typeLift e ++ "." ++ show (length fs)) + let tt = typeInfer' dataTable ds (foldr ELam e fs) + tvr <- newName tt + let (e',ls) = fromLam e + e'' <- local (isStrict_s True) $ f e' + --tell [(tvr,fs ++ ls,e'')] + let e''' = foldl EAp (EVar tvr) (map EVar fs) + return ((t,e'''),[(tvr,fs ++ ls,e'')]) + False -> do + mtick (toAtom $ "E.LambdaLift.skipBigLiftR." ++ show (length fs)) + return ((t,e),[]) + let (rs',ts) = unzip rst + tellCombinators [ (t,ls,substLet rs' e) | (t,ls,e) <- concat ts] + dr rs' + + mkFuncName x = case fromId x of + Just y -> y + Nothing -> toName Val ("LL@",'f':show x) + mapM_ z cs + ncs <- readIORef fc + nstat <- readIORef statRef + nz <- readIORef fm + annotateProgram nz (\_ nfo -> return nfo) (\_ nfo -> return nfo) (\_ nfo -> return nfo) prog { progCombinators = ncs, progStats = progStats prog `mappend` nstat } + +typeLift ECase {} = "Case" +typeLift ELam {} = "Lambda" +typeLift _ = "Other" + +removeType t v e = subst' t v e +{- +removeType t v e = ans where + (b,ls) = fromLam e + ans = foldr f (substLet [(t,v)] e) ls + f tv@(TVr { tvrType = ty} ) e = ELam nt (subst tv (EVar nt) e) where nt = tv { tvrType = (subst t v ty) } +-} diff --git a/src/E/SSimplify.hs b/src/E/SSimplify.hs new file mode 100644 --- /dev/null +++ b/src/E/SSimplify.hs @@ -0,0 +1,1085 @@ +{-# LANGUAGE TemplateHaskell #-} +module E.SSimplify( + Occurance(..), + cacheSimpOpts, + simplifyE, + collectOccurance', + programPruneOccurance, + programSSimplify, + programSSimplifyPStat, + SimplifyOpts(..), + emptySimplifyOpts + ) where + +import Control.Monad.Identity +import Data.Maybe +import Data.Typeable +import Data.DeriveTH +import Debug.Trace +import Data.List hiding(delete,union,insert) +import qualified Data.Set as Set +import qualified Data.Traversable as T + +import C.Prims +import Cmm.Number +import DataConstructors +import Doc.PPrint +import E.E +import E.Eta +import E.Inline +import E.PrimOpt +import E.Program +import E.Rules +import E.Subst +--import E.Traverse(runRename) +import E.TypeCheck +import E.Values +import GenUtil hiding (split) +import Info.Types +import Name.Id +import Name.Name +import Name.Names +import Name.VConsts +import Options +import Stats hiding(null,new,print,Stats,singleton) +import StringTable.Atom +import Support.CanType +import Support.FreeVars +import Util.Graph +import Util.HasSize +import Util.NameMonad +import Util.RWS +import Util.ReaderWriter +import Util.SetLike as S +import qualified E.Demand as Demand +import qualified FlagDump as FD +import qualified FlagOpts as FO +import qualified Info.Info as Info + +--type Bind = (TVr,E) + +data Occurance = + Unused -- ^ unused means a var is not used at the term level, but might be at the type level + | Once -- ^ Used at most once not inside a lambda or as an argument + | OnceInLam -- ^ used once inside a lambda + | ManyBranch -- ^ used once in several branches + | Many -- ^ used many or an unknown number of times + | LoopBreaker -- ^ chosen as a loopbreaker, never inline + deriving(Show,Eq,Ord) + +data UseInfo = UseInfo { + useOccurance :: !Occurance, -- ^ occurance Info + minimumArgs :: {-# UNPACK #-} !Int -- ^ minimum number of args that are ever passed to this function (if used) + } + deriving(Show,Eq,Ord,Typeable) + +noUseInfo = UseInfo { useOccurance = Many, minimumArgs = 0 } +notUsedInfo = UseInfo { useOccurance = Unused, minimumArgs = maxBound } + +programPruneOccurance :: Program -> Program +programPruneOccurance prog = + let dsIn = progCombinators prog -- (runIdentity $ programMapBodies (return . subst (tVr (-1) Unknown) Unknown) prog) + (dsIn',(OMap fvs,uids)) = runReaderWriter (unOM $ collectDs dsIn mempty) (progEntry prog) + in --trace ("dsIn: "++show (length dsIn)) $ + (progCombinators_s dsIn' prog) { progFreeIds = idMapToIdSet fvs, progUsedIds = uids } + +newtype OM a = OM (ReaderWriter IdSet (OMap,IdSet) a) + deriving(Monad,Functor,MonadWriter (OMap,IdSet),MonadReader IdSet) + +unOM (OM a) = a + +newtype OMap = OMap (IdMap UseInfo) + deriving(HasSize,Collection,Unionize,SetLike,MapLike,Show,IsEmpty,Eq,Ord) + +type instance Value OMap = UseInfo +type instance Key OMap = Id +type instance Elem OMap = (Key OMap,Value OMap) + +instance Monoid OMap where + mempty = OMap mempty + mappend (OMap a) (OMap b) = OMap (andOM a b) + +maybeLetRec [] e = e +maybeLetRec ds e = ELetRec ds e + +-- | occurance analysis + +grump :: OM a -> OM (a,OMap) +grump m = fmap ( \ (x, (y,z)) -> (x,y) ) $ censor (\ (_,y) -> (mempty,y)) (listen m) + +collectOccurance' :: E -> (E,IdMap UseInfo) +collectOccurance' e = (fe,omap) where + (fe,(OMap omap,_)) = runReaderWriter (unOM $ collectOccurance e) mempty + +collectOccurance :: E -> OM E -- ^ (annotated expression, free variables mapped to their occurance info) +collectOccurance e = f e where + f e@ESort {} = return e + f e@Unknown {} = return e + f (EPi tvr@TVr { tvrIdent = eid, tvrType = a} b) | isEmptyId eid = arg $ do + a <- f a + b <- f b + return (EPi tvr { tvrType = a } b) + f (EPi tvr@(TVr { tvrIdent = n, tvrType = a}) b) = arg $ do + a <- f a + (b,tfvs) <- grump (f b) + case mlookup n tfvs of + Nothing -> tell (tfvs,mempty) >> return (EPi tvr { tvrIdent = emptyId, tvrType = a } b) + Just occ -> tell (delete n tfvs,singleton n) >> return (EPi (annb' tvr { tvrType = a }) b) + f (ELit lc@LitCons { litArgs = as, litType = t }) = arg $ do + t <- f t + as <- mapM f as + return (ELit lc { litArgs = as, litType = t }) + f (ELit (LitInt i t)) = do + t <- arg (f t) + return $ ELit (LitInt i t) + f (EPrim p as t) = arg $ do + t <- f t + as <- mapM f as + return (EPrim p as t) + f (EError err t) = do + t <- arg (f t) + return $ EError err t + f e | (b,as@(_:_)) <- fromLam e = do + (b',bvs) <- grump (f b) + (as',asfv) <- grump (arg $ mapM ftvr as) + let avs = bvs `andOM` asfv + as'' = map (annbind' avs) as' + case all (getProperty prop_ONESHOT) as of + True -> tell $ (foldr delete avs (map tvrIdent as),fromList $ map tvrIdent as) + False -> tell $ (inLam $ foldr delete avs (map tvrIdent as),fromList $ map tvrIdent as) + return (foldr ELam b' as'') + f e | Just (x,t) <- from_unsafeCoerce e = do x <- f x ; t <- (arg (f t)); return (prim_unsafeCoerce x t) + f (EVar tvr@TVr { tvrIdent = n, tvrType = t}) = do + tell $ (msingleton n UseInfo { useOccurance = Once, minimumArgs = 0 },mempty) + t <- arg (f t) + return $ EVar tvr { tvrType = t } + f e | (EVar tvr@TVr { tvrIdent = n, tvrType = t},xs@(_:_)) <- fromAp e = do + tell $ (msingleton n UseInfo { useOccurance = Once, minimumArgs = length xs },mempty) + t <- arg (f t) + xs <- arg (mapM f xs) + return (foldl EAp (EVar tvr { tvrType = t}) xs) + f e | (x,xs@(_:_)) <- fromAp e = do + x <- f x + xs <- arg (mapM f xs) + return (foldl EAp x xs) + f ec@ECase { eCaseScrutinee = e, eCaseBind = b, eCaseAlts = as, eCaseDefault = d} = do + scrut' <- f e + (d',fvb) <- grump (T.mapM f d) + (as',fvas) <- mapAndUnzipM (grump . alt) as + let fidm = orMaps (fvb:fvas) + ct <- arg $ f (eCaseType ec) + b <- arg (ftvr b) + tell $ (delete (tvrIdent b) fidm,singleton (tvrIdent b)) + return $ caseUpdate ec { eCaseScrutinee = scrut', eCaseAlts = as', + eCaseBind = annbind' fidm b, eCaseType = ct, eCaseDefault = d'} + f ELetRec { eDefs = ds, eBody = e } = do + (e',fve) <- grump (f e) + ds''' <- collectDs (map bindComb ds) fve + return (maybeLetRec (map combBind ds''') e') + f e = error $ "SSimplify.collectOcc.f: " ++ show e + alt (Alt l e) = do + (e',fvs) <- grump (f e) + l <- arg (mapLitBindsM ftvr l) + l <- arg (T.mapM f l) + let fvs' = foldr delete fvs (map tvrIdent $ litBinds l) + l' = mapLitBinds (annbind' fvs) l + tell (fvs',fromList $ map tvrIdent (litBinds l')) + return (Alt l' e') + arg m = do + let mm (OMap mp,y) = (OMap $ fmap (const noUseInfo) mp,y) + censor mm m + ftvr tvr = do + tt <- f (tvrType tvr) + return tvr { tvrType = tt } + +-- delete any occurance info for non-let-bound vars to be safe +annb' tvr = tvrInfo_u (Info.delete noUseInfo) tvr +annbind' idm tvr = case mlookup (tvrIdent tvr) idm of + Nothing | sortTermLike (getType tvr) -> annb' tvr { tvrIdent = emptyId } + _ -> annb' tvr + +-- add ocucrance info +annbind idm tvr = case mlookup (tvrIdent tvr) idm of + Nothing -> annb notUsedInfo tvr { tvrIdent = emptyId } + Just x -> annb x tvr +annb x tvr = tvrInfo_u (Info.insert x) tvr + +mapLitBinds f lc@LitCons { litArgs = es } = lc { litArgs = map f es } +mapLitBinds f (LitInt e t) = LitInt e t +mapLitBindsM f lc@LitCons { litArgs = es } = do + es <- mapM f es + return lc { litArgs = es } +mapLitBindsM f (LitInt e t) = return $ LitInt e t + +collectBinding :: Comb -> OM (Comb,OMap) +collectBinding comb = do + e' <- collectOccurance $ combBody comb + let rvars = freeVars (combRules comb) :: IdSet + romap = OMap (idSetToIdMap (const noUseInfo) rvars) + return (combBody_s e' comb,romap) + +unOMap (OMap x) = x + +--collectCombs :: [Comb] -> OMap -> OM [Comb] +--collectCombs cs _ = return cs + +collectDs :: [Comb] -> OMap -> OM [Comb] +collectDs ds (OMap fve) = do + ds' <- mapM (grump . collectBinding) ds + exp <- ask + let (reachable',_) = newGraphReachable ds' (\ ((comb,_),_) -> combIdent comb) (\ ((_,rv),fv) -> keys (fv `mappend` rv)) + rds = reachable' (keys fve ++ [ combIdent t | t <- ds, (combIdent t `member` exp)]) + -- ignore rules when calculating loopbreakers + -- we must not simplify the expanded body of a rule without recalculating occurance info. + graph' = newGraph rds (\ ((comb,_),_) -> combIdent comb) (\ (_,fv) -> keys fv) + (lb,lbds) = findLoopBreakers (\ ((comb,_),_) -> loopFunc (combHead comb) (combBody comb)) canBeLoopBreaker graph' + canBeLoopBreaker n = not $ getProperty prop_WRAPPER (fst $ fst $ n) + ds'' = map ( \ ((t,rv),rv') -> (t,rv `mappend` rv') ) lbds + fids = foldl andOM mempty (fve:map unOMap (snds ds'')) + ffids = fromList [ (tvrIdent t,lup t) | (Comb { combHead = t },_) <- ds'' ] + cycNodes = (fromList $ [ combIdent c | ((c,_),_) <- cyclicNodes graph'] :: IdSet) + calcStrictInfo :: TVr -> TVr + calcStrictInfo t + | tvrIdent t `member` cycNodes = setProperty prop_CYCLIC t + | otherwise = t + lup t = case tvrIdent t `elem` [ combIdent c | ((c,_),_) <- lb] of + True -> noUseInfo { useOccurance = LoopBreaker } + False -> case (tvrIdent t `member` exp) of + True -> noUseInfo + False | Just r <- mlookup (tvrIdent t) fids -> r + _ -> error "SSimplify.collectDs: bad." + ds''' = [ combHead_s (calcStrictInfo $ annbind ffids (combHead comb)) comb | (comb,_) <- ds''] + froo comb = (combHead_s (combHead comb) {tvrType = t' } comb,fvs) where + (t',fvs) = collectOccurance' (tvrType $ combHead comb) + (ds'''',nfids) = unzip $ map froo ds''' + nfid' = fmap (const noUseInfo) (mconcat nfids) + tell $ ((OMap $ nfid' `andOM` fids) S.\\ ffids,fromList (map combIdent ds'''')) + return (ds'''') + +-- TODO this should use the occurance info +-- loopFunc t _ | getProperty prop_PLACEHOLDER t = -100 -- we must not choose the placeholder as the loopbreaker +loopFunc t e = negate (baseInlinability t e) + +inLam (OMap om) = OMap (fmap il om) where + il ui@UseInfo { useOccurance = Once } = ui { useOccurance = OnceInLam } + il ui = ui { useOccurance = Many } + +--andOM :: IdMap UseInfo -> IdMap UseInfo -> IdMap UseInfo +andOM x y = unionWith andOcc x y +andOcc UseInfo { useOccurance = Unused } x = x +andOcc x UseInfo { useOccurance = Unused } = x +andOcc x y = UseInfo { useOccurance = Many, + minimumArgs = min (minimumArgs x) (minimumArgs y) } + +orMaps ms = OMap $ fmap orMany $ foldl (unionWith (++)) mempty (map (fmap (:[])) + (map unOMap ms)) where unOMap (OMap m) = m + +orMany [] = error "empty orMany" +orMany xs = f (filter ((/= Unused) . useOccurance) xs) where + f [] = notUsedInfo + f [x] = x + f xs = if all good (map useOccurance xs) then ui ManyBranch else ui Many where + good Once = True + good ManyBranch = True + good _ = False + ui x = UseInfo { minimumArgs = minimum (map minimumArgs xs), useOccurance = x } + +data SimplifyOpts = SimpOpts { + so_noInlining :: !Bool, -- ^ this inhibits all inlining inside functions which will always be inlined + so_finalPhase :: !Bool, -- ^ no rules and don't inhibit inlining + so_postLift :: !Bool, -- ^ don't inline anything that was lifted out + so_boundVars :: IdMap Comb, -- ^ bound variables + so_forwardVars :: IdSet, -- ^ variables that we know will exist, but might not yet. + + so_boundVarsCache :: IdSet, + so_cachedScope :: Env + } + +emptySimplifyOpts = SimpOpts { so_noInlining = False + , so_finalPhase = False + , so_boundVars = mempty + , so_forwardVars = mempty + , so_postLift = False + , so_boundVarsCache = mempty + , so_cachedScope = mempty } + +cacheSimpOpts opts = opts { + so_boundVarsCache = idMapToIdSet (so_boundVars opts), + so_cachedScope = cacheSubst (extendScope initScope mempty { + envSubst = mapMaybeIdMap bb (so_boundVars opts), envRules = rules }) + } where + bb Comb { combBody = e } | isFullyConst e = Just (Done e) + bb _ = Nothing + initScope = fmap (\ c -> isBoundTo opts (combHead c) noUseInfo (combBody c)) (so_boundVars opts) + rules = mapMaybeIdMap f (so_boundVars opts) + f Comb { combRules = rs } = if null rs then Nothing else Just $ arules rs + +data Range = Done OutE | Susp InE Subst + deriving(Show,Eq,Ord) +type Subst = IdMap Range + +data Forced = ForceInline | ForceNoinline | NotForced + deriving(Eq,Ord,Show) + +data Binding + = NotAmong [Name] + | IsBoundTo { + bindingOccurance :: !Occurance, + bindingE :: OutE, + bindingCheap :: !Bool, + inlineForced :: !Forced, + bindingAtomic :: !Bool + } + | NotKnown + deriving(Ord,Eq,Show) + +isBoundTo opt v o e = fixInline (so_finalPhase opt) v $ IsBoundTo { + bindingOccurance = useOccurance o, + bindingE = e, + bindingCheap = isCheap e, + inlineForced = case () of + _ | useOccurance o == LoopBreaker -> ForceNoinline + | otherwise -> NotForced, + bindingAtomic = atomic + } where + atomic = isAtomic e + +instance Monoid Forced where + mempty = NotForced + mappend NotForced x = x + mappend x NotForced = x + mappend _ ForceNoinline = ForceNoinline + mappend ForceNoinline _ = ForceNoinline + mappend ForceInline ForceInline = ForceInline + +fixInline finalPhase v bt@IsBoundTo {} = bt { + inlineForced = inlineForced bt `mappend` calcForced finalPhase v } +fixInline _ _ _ = error "SSimplify.fixInline: bad." + +calcForced finalPhase v = + let props = getProperties v in + case (forceNoinline props,finalPhase,forceInline props) of + (True,_,_) -> ForceNoinline + (False,_,True) -> ForceInline + (False,True,_) -> NotForced + (False,False,False) -> NotForced + +data Env = Env { + envCachedSubst :: IdMap E, + envSubst :: Subst, + envRules :: IdMap ARules, + envInScope :: IdMap Binding, + envInScopeCache :: IdMap E + } + +envSubst_u f r@Env{envSubst = x} = r{envSubst = f x} +envSubst_s v = envSubst_u (const v) + +susp:: E -> Subst -> Range +susp e sub = Susp e sub + +--insertSuspSubst :: TVr -> InE -> Env -> Env +--insertSuspSubst t e env = insertSuspSubst' (tvrIdent t) e env + +--insertSuspSubst' :: Id -> InE -> Env -> Env +--insertSuspSubst' z _e env | isEmptyId z = env +--insertSuspSubst' t e env = cacheSubst env { +-- envSubst = minsert t (susp e (envSubst env)) (envSubst env) } + +insertRange :: Id -> Range -> Env -> Env +insertRange z e env | isEmptyId z = env +insertRange t e env = cacheSubst env { envSubst = minsert t e (envSubst env) } + +insertDoneSubst :: TVr -> OutE -> Env -> Env +insertDoneSubst t e env = insertDoneSubst' (tvrIdent t) e env + +insertDoneSubst' :: Id -> OutE -> Env -> Env +insertDoneSubst' z _e env | isEmptyId z = env +insertDoneSubst' t e env = insertRange t (Done e) env + +insertInScope :: Id -> Binding -> Env -> Env +insertInScope z _b env | isEmptyId z = env +insertInScope t b env = extendScope (msingleton t b) env + +extendScope :: IdMap Binding -> Env -> Env +extendScope m env = cacheSubst env { envInScope = m `union` envInScope env + , envInScopeCache = cachedM `union` envInScopeCache env } + where cachedM = mapMaybeIdMap fromBinding m + fromBinding (IsBoundTo {bindingE = e}) = Just e + fromBinding _ = Nothing + +changeScope :: (Binding -> Binding) -> Env -> Env +changeScope fn env = cacheScope $ cacheSubst env { envInScope = fmap fn (envInScope env) } + +cacheScope :: Env -> Env +cacheScope env = env { envInScopeCache = mapMaybeIdMap fromBinding (envInScope env) } + where fromBinding (IsBoundTo {bindingE = e}) = Just e + fromBinding _ = Nothing + +substLookup :: Id -> SM (Maybe Range) +substLookup id = SM $ ask >>= return . mlookup id . envSubst + +substAddList ls env = cacheSubst env { envSubst = fromList ls `union` envSubst env } + +applySubst :: Subst -> IdMap a -> IdMap OutE +applySubst s nn = applySubst' s where + check n = n `member` s || n `member` nn + applySubst' s = fmap g s + g (Done e) = e + g (Susp e s') = doSubst' False False (applySubst' s') check e + +evalRange :: Range -> SM OutE +evalRange (Done e) = return e +evalRange (Susp e s) = localEnv (envSubst_s s) $ dosub e + +cacheSubst env = env { envCachedSubst = applySubst (envSubst env) (envInScope env) } + +dosub :: InE -> SM OutE +dosub e = ask >>= \inb -> coerceOpt return (doSubst' False False (envCachedSubst inb) (`member` envCachedSubst inb) e) + +simplifyE :: SimplifyOpts -> InE -> (Stat,OutE) +simplifyE sopts e = (stat,e') where + Identity ([Comb { combBody = e' }],stat) = runStatT $ simplifyDs program sopts [bindComb (tvrSilly,e)] + +programSSimplify :: SimplifyOpts -> Program -> Program +programSSimplify sopts prog = let + Identity (dsIn,stats) = runStatT $ simplifyDs prog sopts (progCombinators prog) + in (progCombinators_s dsIn prog) { progStats = progStats prog `mappend` stats } + +programSSimplifyPStat :: SimplifyOpts -> Program -> IO Program +programSSimplifyPStat sopts prog = do + setPrintStats True + dsIn <- simplifyDs prog sopts (progCombinators prog) + return (progCombinators_s dsIn prog) + +type InE = E +type OutE = E +type InTVr = TVr +type OutTVr = TVr + +data Cont = + ApplyTo { + contArg :: Range, + contNext :: Cont + } + | LazyContext TVr -- the RHS of a let statement + | StartContext +-- | ArgContext + | Coerce Range Cont +{- | Scrutinee { + contExamined :: Bool -- ^ whether the result is actually examined, or just bound to a variable + }-} + deriving(Show) + +--isApplyTo ApplyTo {} = True +--isApplyTo _ = False + +simplifyDs :: forall m . MonadStats m => Program -> SimplifyOpts -> [Comb] -> m [Comb] +simplifyDs prog sopts dsIn = ans where + finalPhase = so_finalPhase sopts + ans = do + let ((dsOut,_),stats) = runSM (so_cachedScope sopts) doit + mtickStat stats + let lupRules t = concat [ combRules c | c <- dsIn, combIdent c == t] + return [ combRules_s (lupRules (tvrIdent t)) $ bindComb (t,e) | (t,e) <- dsOut ] + + getType e = infertype (progDataTable prog) e + doit = do + smAddNamesIdSet (progUsedIds prog) + smAddBoundNamesIdSet (progFreeIds prog) + smAddBoundNamesIdSet (sfilter (`notElem` map combIdent dsIn) $ so_forwardVars sopts) + smAddBoundNamesIdSet (so_boundVarsCache sopts) + doDs (map combBind dsIn) + makeRange b = do + sub <- asks envSubst + return $ susp b sub + f :: Cont -> InE -> SM OutE + --f cont e | trace (take 20 (show cont) ++ " - " ++ take 40 (show e)) False = undefined +-- f ArgContext e = dosub e + f c (EAp a b) = do + b' <- makeRange b + f ApplyTo { contArg = b', contNext = c } a + f (ApplyTo rng cont) (ELam t b) = do + addBoundNames [tvrIdent t] + mtick (toAtom $ "E.Simplify.f-beta-reduce/{" ++ pprint t) + localEnv (insertRange (tvrIdent t) rng) $ f cont b + f (ApplyTo rng cont) (EPi t b) = do + addBoundNames [tvrIdent t] + mtick (toAtom $ "E.Simplify.f-pi-reduce/{" ++ pprint t) + localEnv (insertRange (tvrIdent t) rng) $ f cont b + f cont (EVar v) = do + z <- substLookup (tvrIdent v) + case z of + Just (Done e) -> done cont e + Just (Susp e s) -> localEnv (envSubst_s s) $ f cont e + Nothing -> done cont (EVar v) + f (Coerce t cont) (EError s _) = evalRange t >>= \t' -> done cont (EError s t') + f (Coerce t cont) (ELit (LitInt n _)) = evalRange t >>= \t' -> done cont (ELit (LitInt n t')) + f cont v | Just (e,t) <- from_unsafeCoerce v = + makeRange t >>= \t' -> f (g t' cont) e where g t' (Coerce _ cont) = Coerce t' cont ; g t' cont = Coerce t' cont + f cont ep@EPrim {} = do + ep' <- performPrimOpt ep + ep'' <- dosub ep' + done cont ep'' + f cont (ELit lc@LitCons { litArgs = xs }) = do + xs' <- mapM performPrimOpt xs + dosub (ELit lc { litArgs = xs' }) >>= done cont + f cont e@ELit {} = dosub e >>= done cont + f cont (ELam v e) = do + addNames [tvrIdent v] + v' <- nname v + e' <- localEnv (insertDoneSubst v (EVar v') . insertInScope (tvrIdent v') NotKnown) $ f StartContext e + done cont $ ELam v' e' + f cont e@(EPi (TVr { tvrIdent = n }) _) = do + addNames [n] + e' <- dosub e + done cont e' + f cont (EError s t) = (EError s `fmap` dosub t) >>= done cont + f cont ec@ECase { eCaseScrutinee = e, eCaseBind = b, eCaseAlts = as, eCaseDefault = d} = do + addNames (map tvrIdent $ caseBinds ec) +-- e' <- f (Scrutinee (not $ null as)) e + e' <- f StartContext e + ec' <- doCaseCont cont e' (eCaseType ec) b as d + done StartContext ec' + f cont ELetRec { eDefs = [], eBody = e } = f cont e + f cont ELetRec { eDefs = ds@(_:_), eBody = e } = do + tickCont cont "let" + (ds',inb') <- doDs ds + e' <- localEnv (const inb') $ f cont e + res <- case ds' of + [(t,e)] | worthStricting e, Just (Demand.S _) <- Info.lookup (tvrInfo t), not (getProperty prop_CYCLIC t) -> do + mtick $ "E.Simplify.strictness.let-to-case/{" ++ pprint t + return $ eStrictLet t e e' + [(t,ec@ECase { eCaseScrutinee = sc@(EPrim p _ _), eCaseAlts = [], eCaseDefault = Just def })] | primEagerSafe p && not (getProperty prop_CYCLIC t) -> do + mtick $ "E.Simplify.strictness.cheap-eagerness.def/{" ++ pprint t + return $ caseUpdate ec { eCaseDefault = Just $ ELetRec [(t,def)] e', eCaseType = getType e' } + [(t,ec@ECase { eCaseScrutinee = sc@(EPrim p _ _), eCaseAlts = [Alt c def], eCaseDefault = Nothing })] | primEagerSafe p && not (getProperty prop_CYCLIC t) -> do + mtick $ "E.Simplify.strictness.cheap-eagerness.con/{" ++ pprint t + return $ caseUpdate ec { eCaseAlts = [Alt c (ELetRec [(t,def)] e')], eCaseType = getType e' } + _ -> do + let fn ds (ELetRec { eDefs = ds', eBody = e}) | not (hasRepeatUnder fst (ds ++ ds')) = fn (ds' ++ ds) e + fn ds e = f ds (Set.fromList $ fsts ds) [] False where + f ((t,ELetRec { eDefs = ds', eBody = e}):rs) us ds b | all (not . (`Set.member` us)) (fsts ds') = f ((t,e):rs) (Set.fromList (fsts ds') `Set.union` us) (ds':ds) True + f (te:rs) us ds b = f rs us ([te]:ds) b + f [] _ ds True = fn (concat ds) e + f [] _ ds False = (concat ds,e) + let (ds'',e'') = fn ds' e' + when (flint && hasRepeatUnder fst ds'') $ fail "hasRepeats!" + mticks (length ds'' - length ds') (toAtom $ "E.Simplify.let-coalesce") + return $ eLetRec ds'' e'' + done StartContext res + f cont e = trace ("Fall through: " ++ show (cont,e)) $ dosub e >>= done cont + + showName t | isJust (fromId t) || dump FD.EVerbose = tvrShowName (tVr t Unknown) + | otherwise = "(epheremal)" + + -- Rename a if necessary. We always have to substitute all occurrences because we update the type. + nname tvr@(TVr { tvrIdent = n, tvrType = t}) = do + t' <- dosub t + inb <- ask + let t'' = substMap' (envInScopeCache inb) t' + n' <- if n == emptyId then return emptyId else uniqueName n + return $ tvr { tvrIdent = n', tvrType = t'' } + -- TODO - case simplification + tickCont (ApplyTo _ cont) cs = mtick ("E.Simplify.application-push." ++ cs) >> tickCont cont cs + tickCont (Coerce _ cont) cs = mtick ("E.Simplify.coerce-push." ++ cs) >> tickCont cont cs + tickCont _ _ = return () + contType (ApplyTo z cont) t = contType cont t >>= \t' -> evalRange z >>= \z' -> return (eAp t' z') + contType (Coerce t cont) _ = evalRange t + contType _ t = return t + doCaseCont :: Cont -> OutE -> InE -> InTVr -> [Alt InE] -> (Maybe InE) -> SM OutE + doCaseCont cont e t b as d = do + inb <- ask + let + varval = do EVar v <- return e; mlookup (tvrIdent v) (envInScope inb) + doCase ELetRec { eDefs = ds, eBody = e} t b as d = do + mtick "E.Simplify.let-from-case" + e' <- doCaseCont cont e t b as d + done StartContext (substLet' ds e') + + doCase _ t b as d | Just IsBoundTo { bindingE = ELit l } <- varval = doConstCase cont l t b as d + doCase (EPi TVr { tvrType = x} y) t b as d = doConstCase cont litCons { litName = tc_Arrow, litArgs = [x,y], litType = eStar} t b as d + doCase (ELit l) t b as d = doConstCase cont l t b as d + doCase (EVar v) t b as d | Just IsBoundTo { bindingE = e } <- varval , isBottom e = do + mtick "E.Simplify.case-of-bottom'" + t' <- makeRange t + done (Coerce t' cont) (EVar v) + doCase e t b as d | isBottom e = do + mtick "E.Simplify.case-of-bottom" + t' <- makeRange t + done (Coerce t' cont) e + + doCase ic@ECase { eCaseScrutinee = e, eCaseBind = b, eCaseAlts = as, eCaseDefault = d } t b' as' d' + | length (filter (not . isBottom) (caseBodies ic)) <= 1 || + all whnfOrBot (caseBodies ic) || + all whnfOrBot (caseBodies emptyCase { eCaseAlts = as', eCaseDefault = d'} ) = do + mtick (toAtom "E.Simplify.case-of-case") + let f (Alt l e) = do + e' <- localEnv (extendScope (fromList [ (n,NotKnown) | TVr { tvrIdent = n } <- litBinds l ])) + $ doCaseCont StartContext e t b' as' d' + return (Alt l e') + --g e >>= return . Alt l + g x = localEnv (insertInScope (tvrIdent b) NotKnown) $ doCaseCont StartContext x t b' as' d' + as'' <- mapM f as + d'' <- T.mapM g d + t' <- dosub t + done cont $ caseUpdate ECase { + eCaseAllFV = error "eCaseAllFV", + eCaseScrutinee = e, + eCaseType = t', + eCaseBind = b, + eCaseAlts = as'', + eCaseDefault = d''} -- XXX -- we duplicate code so continue for next renaming pass before going further. + doCase ic@ECase { eCaseType = it, eCaseScrutinee = e, eCaseBind = b, eCaseAlts = as, eCaseDefault = d } t b' as' d' | not (isUnboxedTuple it) = do + mtick (toAtom "E.Simplify.case-of-case-join") + n1 <- newName + n2 <- newName + let cvar = setProperty prop_ONESHOT $ tVr n1 it + rcc <- doCaseCont StartContext (EVar cvar) t b' as' d' + let fbody = ELam cvar rcc + zvar = setProperties [prop_JOINPOINT,prop_ONESHOT] $ tVr n2 (EPi tvr { tvrType = it } (getType rcc)) + nic <- flip caseBodiesMapM ic $ \body -> return $ eLet cvar body (eAp (EVar zvar) (EVar cvar)) + done cont $ eLet zvar fbody nic { eCaseType = getType rcc } + doCase e t b as@(Alt LitCons { litName = n } _:_) (Just d) | Just nsib <- numberSiblings (progDataTable prog) n, nsib <= length as = do + mtick "E.Simplify.case-no-default" + doCase e t b as Nothing + doCase e t b (a@(Alt LitCons { litName = n } _):_) (Just d) | Just _ <- fromUnboxedNameTuple n = do + mtick "E.Simplify.case-unboxed-no-default" + doCase e t b [a] Nothing +{- + Remove the default case if possible. + case lst of [] -> True; _ -> False + ==> + case lst of [] -> True; (:) _ _ -> False +-} + doCase e t b as (Just d) | te /= tWorld__, (ELit LitCons { litName = cn }) <- followAliases dt te + , Just Constructor { conChildren = DataNormal cs } <- getConstructor cn dt + , length as == length cs - 1 || (False && length as < length cs && isAtomic d) = do + let ns = [ n | Alt ~LitCons { litName = n } _ <- as ] + ls = filter (`notElem` ns) cs + ff n = do + con <- getConstructor n dt + let g t = do + n <- newName + return $ tVr n t + ts <- mapM g (slotTypes (progDataTable prog) n te) + let wtd = ELit $ updateLit (progDataTable prog) litCons { litName = n, litArgs = map EVar ts, litType = te } + return $ Alt (updateLit (progDataTable prog) litCons { litName = n, litArgs = ts, litType = te }) (eLet b wtd d) + mtick $ "E.Simplify.case-improve-default.{" ++ show (sort ls) ++ "}" + ls' <- mapM ff ls + --ec <- dosub $ caseUpdate emptyCase { eCaseScrutinee = e, eCaseType = t, eCaseBind = b, eCaseAlts = as ++ ls' } + --localEnv (envSubst_s mempty) $ f StartContext (caseUpdate ec { eCaseScrutinee = e }) + doCase e t b (as ++ ls') Nothing + where + te = getType b + dt = (progDataTable prog) + doCase e _ b [] (Just d) | not (isLifted e || isUnboxed (getType e)) = do + mtick "E.Simplify.case-unlifted" + b' <- nname b + d' <- localEnv (insertDoneSubst b (EVar b') . (insertInScope (tvrIdent b') (isBoundTo sopts b' noUseInfo e))) $ f cont d + done StartContext $ eLet b' e d' + doCase e@ELam {} _ b [] (Just d) = do + mtick "E.Simplify.case-lambda" + b' <- nname b + d' <- localEnv (insertDoneSubst b (EVar b') . (insertInScope (tvrIdent b') (isBoundTo sopts b' noUseInfo e))) $ f cont d + done StartContext $ eLet b' e d' + -- atomic unboxed values may be substituted or discarded without replicating work or affecting program semantics. + doCase e _ b [] (Just d) | isUnboxed (getType e), isAtomic e = do + mtick "E.Simplify.case-atomic-unboxed" + localEnv (insertDoneSubst b e) $ f cont d + doCase e _ TVr { tvrIdent = z } [] (Just d) | isEmptyId z, isOmittable inb e = do + mtick "E.Simplify.case-omittable" + f cont d + doCase (EVar v) _ b [] (Just d) | Just (NotAmong _) <- varval = do + mtick $ "E.Simplify.case-evaled/{" ++ pprint v + localEnv (insertDoneSubst b (EVar v)) $ f cont d + doCase e _ b [] (Just (EVar v')) | b == v' = do + mtick $ "E.Simplify.case-trailing/{" ++ pprint b + done cont e + doCase scrut _ v [] (Just sc@ECase { eCaseScrutinee = EVar v'} ) | v == v', tvrIdent v `notMember` (freeVars (caseBodies sc) :: IdSet) = do + mtick "E.Simplify.case-default-case" + doCase scrut (eCaseType sc) (eCaseBind sc) (eCaseAlts sc) (eCaseDefault sc) + doCase e t b as d = do + tickCont cont "case" + b' <- nname b + (ids,b') <- case (e,tvrIdent b') of + (EVar v,z) | isEmptyId z -> do + nn <- newName + b' <- return b' { tvrIdent = nn } + return $ (insertInScope (tvrIdent v) (isBoundTo sopts v noUseInfo (EVar b')),b') + (EVar v,_) -> return $ (insertDoneSubst b (EVar b') . insertInScope (tvrIdent v) (isBoundTo sopts v noUseInfo (EVar b')),b') + _ -> return $ (insertDoneSubst b (EVar b'),b') + inb <- ask + let dd e' = localEnv (const $ ids $ extendScope newinb inb) $ f cont e' where + na = NotAmong [ n | Alt LitCons { litName = n } _ <- as] + newinb = fromList [ (n,na) | EVar (TVr { tvrIdent = n }) <- [EVar b']] + da (Alt (LitInt n t) ae) = do + t' <- dosub t + let p' = LitInt n t' + e' <- localEnv (ids . mins e (patToLitEE p')) $ f cont ae + return $ Alt p' e' + da (Alt lc@LitCons { litName = n, litArgs = ns, litType = t } ae) = do + t' <- dosub t + ns' <- mapM nname ns + let p' = lc { litArgs = ns', litType = t' } + nsub = [ (n,Done (EVar t)) | TVr { tvrIdent = n } <- ns | t <- ns' ] + ninb = fromList [ (n,NotKnown) | TVr { tvrIdent = n } <- ns' ] + e' <- localEnv (const $ ids $ substAddList nsub (extendScope ninb $ mins e (patToLitEE p') inb)) $ f cont ae + return $ Alt p' e' + mins _ e | emptyId `notMember` (freeVars e :: IdSet) = insertInScope (tvrIdent b') (isBoundTo sopts b' noUseInfo e) + mins _ _ = id + + d' <- T.mapM dd d + as' <- mapM da as + t' <- dosub t + t' <- contType cont t' + done StartContext $ caseUpdate ECase { + eCaseAllFV = error "eCaseAllFV", + eCaseScrutinee = e, + eCaseType = t', + eCaseBind = b', + eCaseAlts = as', + eCaseDefault = d'} + doCase e t b as d + + isOmittable _ ELit {} = True + isOmittable _ EPi {} = True + isOmittable _ ELam {} = True + isOmittable _ (EPrim p _ _) = primIsConstant p + isOmittable inb (EVar v) = case mlookup (tvrIdent v) (envInScope inb) of + Just IsBoundTo { bindingE = e } | not (isEVar e) -> isOmittable inb e + Just (NotAmong _) -> True + _ -> False + isOmittable _ _ = False + + doConstCase :: Cont -> {- Out -} Lit E E -> InE -> InTVr -> [Alt E] -> Maybe InE -> SM OutE + doConstCase cont l t b as d = do + t' <- dosub t + mr <- match l as (b,d) + inb <- ask + case mr of + Just (bs,e) -> do + let bs' = [ x | x@(TVr { tvrIdent = n },_) <- bs, n /= emptyId] + binds <- mapM (\ (v,e) -> nname v >>= return . (,,) e v) bs' + e' <- localEnv (substAddList [ (n,Done $ EVar nt) | (_,TVr { tvrIdent = n },nt) <- binds] . extendScope (fromList [ (n,isBoundTo sopts t noUseInfo e) | (e,_,t@TVr { tvrIdent = n }) <- binds])) $ f StartContext e + done cont $ eLetRec [ (v,e) | (e,_,v) <- binds ] e' + Nothing -> do + done cont $ EError ("match falls off bottom: " ++ pprint l) t' + + match m@LitCons { litName = c, litArgs = xs } ((Alt LitCons { litName = c', litArgs = bs } e):rs) d@(b,_) | c == c' = do + mtick (toAtom $ "E.Simplify.known-case." ++ show c ) + return $ Just ((b,ELit m):(zip bs xs),e) + | otherwise = match m rs d + match m@(LitInt x _) ((Alt (LitInt y _) e):rs) d@(b,_) | x == y = do + mtick (toAtom $ "E.Simplify.known-case." ++ show x) + return $ Just ([(b,ELit m)],e) + | otherwise = match m rs d + match m@LitCons { litName = c } [] (_,Just e) | Just _ <- fromUnboxedNameTuple c = do + mtick (toAtom $ "E.Simplify.known-case._#" ++ show c ) + return (Just ([],e)) + match l [] (b,Just e) = do + mtick (toAtom "E.Simplify.known-case._") + return $ Just ([(b,ELit l)],e) + match m [] (_,Nothing) = do + mtick (toAtom "E.Simplify.known-case.unmatch") + return Nothing + match m as d = error $ "Odd Match: " ++ show ((m,getType m),as,d) + + applyRule :: OutTVr -> [OutE] -> SM (Maybe (OutE,[OutE])) + applyRule v xs = do + inb <- ask + z <- builtinRule v xs + let lup x = case mlookup x (envInScope inb) of + Just IsBoundTo { bindingE = e } -> Just e + _ -> Nothing + case z of + Nothing | fopts FO.Rules -> applyRules lup (findWithDefault mempty (tvrIdent v) $ envRules inb) xs + x -> return x + done cont e = z cont [] where + z (ApplyTo r cont') rs = evalRange r >>= \a -> z cont' (a:rs) + z (Coerce t cont) rs = do + t' <- evalRange t + z <- hFunc e (reverse rs) + done cont (prim_unsafeCoerce z t') + z _ rs = hFunc e (reverse rs) + hFunc :: OutE -> [OutE] -> SM OutE + hFunc (EVar v) xs' = do + inb <- ask + z <- applyRule v xs' + let txs = map tx xs' where + tx (ELit l) = knowLit l + tx EPi {} = KnowSomething + tx (EVar v) = case mlookup (tvrIdent v) (envInScope inb) of + Just (NotAmong xs) -> KnowNotOneOf xs + Just IsBoundTo { bindingE = ELit l } -> knowLit l + Just IsBoundTo {} -> KnowSomething + _ -> KnowNothing + tx _ = KnowNothing + knowLit LitCons { litName = c } = KnowIsCon c + knowLit (LitInt n _) = KnowIsNum n + case z of + (Just (x,xs)) -> didInline x xs + _ -> case mlookup (tvrIdent v) (envInScope inb) of + Just IsBoundTo { inlineForced = ForceNoinline } -> appVar v xs' + Just IsBoundTo { bindingOccurance = Once } -> error "IsBoundTo: Once" + Just IsBoundTo { bindingE = e, bindingAtomic = True } -> do + mtick (toAtom $ "E.Simplify.inline.atomic/{" ++ tvrShowName v ++ "}") + didInline e xs' + Just IsBoundTo { bindingE = e, inlineForced = ForceInline } | someBenefit v e txs -> do + mtick (toAtom $ "E.Simplify.inline.Forced/{" ++ tvrShowName v ++ "}") + didInline e xs' +-- Just ibt@IsBoundTo { bindingE = e } | False && someBenefit v e txs && getProperty prop_WRAPPER v -> do +-- mtick (toAtom $ "E.Simplify.inline.Wrapper/{" ++ tvrShowName v ++ "}") +-- trace (show (v,e,ibt,tvrInfo v)) didInline e xs' + Just IsBoundTo { bindingOccurance = OnceInLam, bindingE = e, bindingCheap = True } | someBenefit v e txs -> do + mtick (toAtom $ "E.Simplify.inline.OnceInLam/{" ++ showName (tvrIdent v) ++ "}") + didInline e xs' + Just IsBoundTo { bindingOccurance = ManyBranch, bindingE = e } | multiInline v e txs -> do + mtick (toAtom $ "E.Simplify.inline.ManyBranch/{" ++ showName (tvrIdent v) ++ "}") + didInline e xs' + Just IsBoundTo { bindingOccurance = Many, bindingE = e, bindingCheap = True } | multiInline v e txs -> do + mtick (toAtom $ "E.Simplify.inline.Many/{" ++ showName (tvrIdent v) ++ "}") + didInline e xs' + Just _ -> appVar v xs' + Nothing -> appVar v xs' + -- Nothing | tvrIdent v `Set.member` exports -> app (EVar v,xs') + -- Nothing -> error $ "Var not in scope: " ++ show v + hFunc e xs' = do app (e,xs') + didInline ::OutE -> [OutE] -> SM OutE + didInline z zs = return (foldl EAp z zs) + --didInline z zs = do + -- used <- smUsedNames + -- let (ne,nn) = runRename used (foldl EAp z zs) + -- smAddNamesIdSet nn + -- return ne + appVar v xs | so_postLift sopts = app (EVar v,xs) + appVar v xs = do + me <- etaExpandAp (progDataTable prog) v xs + case me of + Just e -> return e + Nothing -> app (EVar v,xs) + + app (e,[]) = return e + app (e,xs) = app' e xs + + app' (ELit lc@LitCons { litName = n, litArgs = xs, litType = EPi ta tt }) (a:as) = do + mtick (toAtom $ "E.Simplify.typecon-reduce.{" ++ show n ++ "}" ) + app' (ELit lc { litArgs = xs ++ [a], litType = subst ta a tt }) as + app' (ELit LitCons { litName = n, litArgs = es, litAliasFor = Just af }) bs@(_:_) = do + mtick (toAtom $ "E.Simplify.newtype-reduce.{" ++ show n ++ "}" ) + app' (foldl eAp af (es ++ bs)) [] + app' (EError s t) xs = do + mticks (length xs) (toAtom "E.Simplify.error-application") + return $ EError s (foldl eAp t xs) + app' e as = do + return $ foldl EAp e as + doDs ds = do + addNames $ map (tvrIdent . fst) ds + let z :: (InTVr,InE) -> SM (Id,UseInfo,OutTVr,InE) + z (t,EVar t') | t == t' = do -- look for simple loops and replace them with errors. + t'' <- nname t + mtick $ "E.Simplify.<>.{" ++ showName (tvrIdent t) ++ "}" + return (tvrIdent t,noUseInfo,t'',EError "<>" (getType t)) + z (t,e) = do + t' <- nname t + case Info.lookup (tvrInfo t) of + _ | forceNoinline t -> return (tvrIdent t,noUseInfo { useOccurance = LoopBreaker },t',e) + | so_postLift sopts && (isELam e || isECase e) -> return (tvrIdent t,noUseInfo { useOccurance = LoopBreaker },t',e) + Just ui@UseInfo { useOccurance = Once } -> return (tvrIdent t,ui,error $ "Once: " ++ show t,e) + Just n -> return (tvrIdent t,n,t',e) + -- We don't want to inline things we don't have occurance info for because they might lead to an infinite loop. hopefully the next pass will fix it. + Nothing -> return (tvrIdent t,noUseInfo { useOccurance = LoopBreaker },t',e) + -- Nothing -> error $ "No Occurance info for " ++ show t + w :: [(Id,UseInfo,OutTVr,InE)] -> [(OutTVr,OutE)] -> SM ([(OutTVr,OutE)],Env) + w ((t,UseInfo { useOccurance = Once },t',e):rs) ds = do + mtick $ "E.Simplify.inline.Once/{" ++ showName t ++ "}" + w rs ds -- (minsert t (Susp e sub) sub) inb ds + w ((t,n,t',e):rs) ds = do + let inb = case isForced of + ForceInline -> cacheSubst . changeScope nogrowth + _ -> id + isForced = calcForced finalPhase t' + nogrowth IsBoundTo { bindingAtomic = False } = NotKnown + nogrowth x = x + e' <- localEnv inb $ f (LazyContext t') e + let ibt = isBoundTo sopts t' n e' + case (bindingAtomic ibt,inlineForced ibt) of + (True,f) | f /= ForceNoinline -> do + --when (n /= Unused) $ mtick $ "E.Simplify.inline.Atomic.{" ++ showName t ++ "}" + localEnv (insertDoneSubst' t e' . insertInScope (tvrIdent t') ibt) $ w rs ((t',e'):ds) + _ -> localEnv (insertInScope (tvrIdent t') ibt) $ w rs ((t',e'):ds) + w [] ds = ask >>= \inb -> return (ds,inb) + s' <- mapM z ds + inb <- ask + let sub'' = fromList [ (t,susp e sub'') | (t, UseInfo { useOccurance = Once },_,e) <- s'] `union` fromList [ (t,Done (EVar t')) | (t,n,t',_) <- s', useOccurance n /= Once] `union` envSubst inb + (ds',inb') <- localEnv (envSubst_s sub'' . extendScope (fromList [ (tvrIdent t',NotKnown) | (_,n,t',_) <- s', useOccurance n /= Once])) $ w s' [] + let minArgs t = case Info.lookup (tvrInfo t) of + Just (UseInfo { minimumArgs = min }) -> min + Nothing -> 0 + + ds' <- if so_postLift sopts then return ds' else sequence [ etaExpandDef' (progDataTable prog) (minArgs t) t e | (t,e) <- ds'] + return (ds',inb') + +data KnowSomething = KnowNothing | KnowNotOneOf [Name] | KnowIsCon Name | KnowIsNum Number | KnowSomething + deriving(Eq) + +someBenefit _ e _ | isAtomic e = True +someBenefit _ ELit {} _ = True +someBenefit _ EPi {} _ = True +someBenefit _ EPrim {} _ = True +someBenefit v ELetRec { eDefs = ds, eBody = e } xs | someBenefit v e xs = True +--someBenefit _v ECase {} (_:_) = True +someBenefit _ e xs | f e xs = True where + f (ELam _ e) (_:xs) = f e xs + f ELam {} [] = any (/= KnowNothing) xs + f _ _ = not (null xs) +someBenefit v e xs = any (/= KnowNothing) xs + +exprSize :: + Int -- ^ maximum size before bailing out + -> E -- ^ expression + -> Int -- ^ discount for case of something known + -> [(Id,KnowSomething)] -- ^ things that are known + -> Maybe Int +exprSize max e discount known = f max e >>= \n -> return (max - n) where + f n _ | n <= 0 = fail "exprSize: expression too big" + f n EVar {} = return $! n - 1 + f n (EAp x@(EVar v) y) | Just _ <- lookup (tvrIdent v) known = do + v <- f (n + discount) x + f v x + f n (EAp x y) = do + v <- f n x + f v x + f n (ELam t x) = f (n - 1) x + f n EPi {} = return $! n - 1 + f n ELit {} = return $! n - 1 + f n ESort {} = return $! n - 1 + f n EPrim {} = return $! n - 1 + f n EError {} = return $! n - 1 + f n ec@ECase { eCaseScrutinee = EVar tv } | Just l <- lookup (tvrIdent tv) known = do + n <- f (n + discount) (EVar tv) + let g n [] | Just d <- eCaseDefault ec = f n d + | otherwise = return n + g n (Alt LitCons { litName = c' } e:rs) | KnowIsCon c <- l = if c == c' then f n e else g n rs + g n (Alt (LitInt c' _) e:rs) | KnowIsNum c <- l = if c == c' then f n e else g n rs + g n (Alt LitCons { litName = c } e:rs) | KnowNotOneOf na <- l = if c `elem` na then g n rs else f n e >>= \n' -> g n' rs + g n (Alt _ e:rs) = f n e >>= \n' -> g n' rs + g n (eCaseAlts ec) + f n ec@ECase {} = do + n <- f n (eCaseScrutinee ec) + foldM f n (caseBodies ec) + f n ELetRec {eDefs = ds, eBody = e } = do + n <- foldM f n (snds ds) + f n e + f _ Unknown = error "SSimplify.exprSize: bad." + +noSizeIncrease e xs = f e xs where + currentSize = 1 + length xs + f (ELam t e) (x:xs) = f e xs + f ELam {} [] = False -- abort if we will create a lambda + f e [] = isJust $ exprSize currentSize e 3 [] + f e xs = isJust $ exprSize (currentSize - length xs) e 3 [] + +--multiInline _ e xs | isSmall (f e xs) = True where -- should be noSizeIncrease +-- f e [] = e +-- f (ELam _ e) (_:xs) = f e xs +-- f e xs = foldl EAp e xs +-- +-- + +scrutineeDiscount = 4 +extraArgDiscount = 1 +knowSomethingDiscount = 2 + +multiInline _ e xs | noSizeIncrease e xs = True +multiInline v e xs | not (someBenefit v e xs) = False +multiInline v e xs = f e xs [] where + currentSize = 1 + length xs + f (ELam t e) (KnowNothing:xs) rs = f e xs rs + f (ELam t e) (x:xs) rs = f e xs ((tvrIdent t,x):rs) + f e xs rs = isJust $ exprSize (knowSomethingDiscount*(length rs) + discount + currentSize + (if null xs then 0 else extraArgDiscount)) e scrutineeDiscount rs where + discount = if safeToDup e then 4 else 0 + +worthStricting EError {} = True +worthStricting ELit {} = False +worthStricting ELam {} = False +worthStricting x = sortTermLike x + +coerceOpt :: MonadStats m => (E -> m E) -> E -> m E +coerceOpt fn e = do + let (n,e',p) = unsafeCoerceOpt e + n `seq` stat_unsafeCoerce `seq` mticks n stat_unsafeCoerce + e'' <- fn e' + return (p e'') + +stat_unsafeCoerce = toAtom "E.Simplify.unsafeCoerce" + +----------------------- +-- simplification Monad +----------------------- + +data SmState = SmState { + idsSeed :: {-# UNPACK #-} !Int, + idsUsed :: !IdSet, + idsBound :: !IdSet + } + +smState = SmState { idsSeed = 1, idsUsed = mempty, idsBound = mempty } + +newtype SM a = SM (RWS Env Stats.Stat SmState a) + deriving(Monad,Functor,MonadReader Env, MonadState SmState) + +localEnv f (SM action) = SM $ local (cacheSubst . f) action + +runSM :: Env -> SM a -> (a,Stat) +runSM env (SM x) = (r,s) where + (r,_,s) = runRWS x (cacheSubst env) smState + +instance MonadStats SM where + mticks' n k = SM $ tell (Stats.singleStat n k) >> return () + mtickStat = error "MonadStats.mtickStat: not impl." + +modifyIds fn = SM $ modify f where + f s@SmState { idsUsed = used, idsBound = bound } = case fn (used,bound) of (used',bound') -> s { idsUsed = used', idsBound = bound' } +getIds = SM $ liftM f get where + f s@SmState { idsUsed = used, idsBound = bound } = (used,bound) +putIds x = SM $ modify (f x) where + f (used,bound) = \s -> s { idsUsed = used, idsBound = bound } + +instance NameMonad Id SM where + addNames ns = do + modifyIds (\ (used,bound) -> -- trace ("AddNames: " ++ show (size used,size bound)) $ + (fromList ns `union` used, bound) ) + addBoundNames ns = do + let nset = fromList ns + modifyIds (\ (used,bound) -> --trace ("AddBoundNames: " ++ show (size used, size bound)) + (nset `union` used, nset `union` bound) ) + uniqueName n = do + (used,bound) <- getIds + if n `member` bound then newName else putIds (insert n used,insert n bound) >> return n + newNameFrom vs = do + (used,bound) <- getIds + let f (x:xs) + | x `member` used = f xs + | otherwise = x + f [] = error "newNameFrom: finite list!" + nn = f vs + putIds (insert nn used, insert nn bound) + return nn + newName = do + seed <- gets idsSeed + modify (\e -> e { idsSeed = seed + 1 }) +-- (used,bound) <- getIds + newNameFrom $ candidateIds seed -- (size used + 10000*size bound) + +--smUsedNames = SM $ gets idsUsed +--smBoundNames = SM $ gets idsBound + +smAddNamesIdSet nset = --trace ("addNamesIdSet: "++ show (size nset)) $ + do modifyIds (\ (used,bound) -> (nset `union` used, bound) ) +smAddBoundNamesIdSet nset = --trace ("addBoundNamesIdSet: "++show (size nset)) $ + do modifyIds (\ (used,bound) -> (nset `union` used, nset `union` bound) ) + +--smAddBoundNamesIdMap = smAddNamesIdSet . idMapToIdSet + +$(derive makeMonoid ''Env) diff --git a/src/E/Type.hs b/src/E/Type.hs new file mode 100644 --- /dev/null +++ b/src/E/Type.hs @@ -0,0 +1,265 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | The definitions related to jhc core + +module E.Type where + +import Data.Foldable hiding(concat) +import Data.Traversable +import Data.DeriveTH + +import C.Prims +import Cmm.Number +import Doc.DocLike hiding((<$>)) +import Info.Types +import Name.Id +import Name.Name +import Name.Names +import StringTable.Atom +import Util.Gen +import Util.SetLike +import qualified Info.Info as Info + +{- @Internals + +# Jhc core normalized forms + +Jhc core has a number of 'normalized forms' in which certain invarients are +met. many routines expect code to be in a certain form, and guarentee theier +output is also in a given form. The type system also can change with each form +by adding/removing terms from the PTS axioms and rules. + +normalized form alpha +: There are basically no restrictions other than the code is typesafe, but +certain constructs that are checked by the type checker are okay when they +wouldn't otherwise be. In particular, 'newtype' casts still exist at the data +level. 'enum' scrutinizations are creations may be in terms of the virtual +constructors rather than the internal representations. let may bind unboxed +values, which is normaly not allowed. + +normalized form beta +: This is like alpha except all data type constructors and case scrutinizations +are in their final form. As in, newtype coercions are removed, Enums are +desugared etc. also, 'let' bindings of unboxed values are translated to the +appropriate 'case' statements. The output of E.FromHs is in this form. + +normalized form blue +: This is the form that most routines work on. + +normalized form larry +: post lambda-lifting + +normalized form mangled +: All polymorphism has been replaced with subtyping + +-} + +-- the type of a supercombinator +data Comb = Comb { + combHead :: TVr, + combBody :: E, + combRules :: [Rule] + } + +instance HasProperties Comb where + modifyProperties f comb = combHead_u (modifyProperties f) comb + getProperties comb = getProperties $ combHead comb + putProperties p comb = combHead_u (putProperties p) comb + +instance HasProperties TVr where + modifyProperties f = tvrInfo_u (modifyProperties f) + getProperties = getProperties . tvrInfo + putProperties prop = tvrInfo_u (putProperties prop) + +combBody_u f r@Comb{combBody = x} = r{combBody = f x} +combHead_u f r@Comb{combHead = x} = r{combHead = f x} +combRules_u f r@Comb{combRules = x} = cp r{combRules = fx} where + cp = if null fx then unsetProperty PROP_HASRULE else setProperty PROP_HASRULE + fx = f x + +combBody_s v = combBody_u (const v) +combHead_s v = combHead_u (const v) +combRules_s v = combRules_u (const v) + +emptyComb = Comb { combHead = tvr, combBody = Unknown, combRules = [] } +combIdent = tvrIdent . combHead +combArgs = snd . fromLam . combBody +combABody = fst . fromLam . combBody +combBind b = (combHead b,combBody b) +bindComb (t,e) = combHead_s t . combBody_s e $ emptyComb +combTriple comb = (combHead comb,combArgs comb,combABody comb) +combTriple_s (t,as,e) comb = comb { combHead = t, combBody = Prelude.foldr ELam e as } + +data RuleType = RuleSpecialization | RuleUser | RuleCatalyst + deriving(Eq) + +-- a rule in its user visible form + +data Rule = Rule { + ruleHead :: TVr, + ruleBinds :: [TVr], + ruleArgs :: [E], + ruleNArgs :: {-# UNPACK #-} !Int, + ruleBody :: E, + ruleType :: RuleType, + ruleUniq :: (Module,Int), + ruleName :: Atom + } + +data ARules = ARules { + aruleFreeVars :: IdSet, + aruleRules :: [Rule] + } + +data Lit e t = LitInt { litNumber :: Number, litType :: t } + | LitCons { litName :: Name, litArgs :: [e], litType :: t, litAliasFor :: Maybe E } + deriving(Eq,Ord,Functor,Foldable,Traversable) + +-------------------------------------- +-- Lambda Cube (it's just fun to say.) +-- We are now based on a PTS, which is +-- a generalization of the lambda cube +-- see E.TypeCheck for a description +-- of the type system. +-------------------------------------- + +data ESort = + EStar -- ^ the sort of boxed lazy types + | EBang -- ^ the sort of boxed strict types + | EHash -- ^ the sort of unboxed types + | ETuple -- ^ the sort of unboxed tuples + | EHashHash -- ^ the supersort of unboxed types + | EStarStar -- ^ the supersort of boxed types + | ESortNamed Name -- ^ user defined sorts + deriving(Eq, Ord) + +data E = EAp E E + | ELam TVr E + | EPi TVr E + | EVar TVr + | Unknown + | ESort ESort + | ELit !(Lit E E) + | ELetRec { eDefs :: [(TVr, E)], eBody :: E } + | EPrim Prim [E] E + | EError String E + | ECase { + eCaseScrutinee :: E, + eCaseType :: E, -- due to GADTs and typecases, the final type of the expression might not be so obvious, so we include it here. + eCaseBind :: TVr, + eCaseAlts :: [Alt E], + eCaseDefault :: (Maybe E), + eCaseAllFV :: IdSet + } + deriving(Eq, Ord) + +--instance Functor (Lit e) where +-- fmap f x = runIdentity $ fmapM (return . f) x + +--instance FunctorM (Lit e) where +-- fmapM f x = case x of +-- LitCons { litName = a, litArgs = es, litType = e, litAliasFor = af } -> do e <- f e; return LitCons { litName = a, litArgs = es, litType = e, litAliasFor = af } +-- LitInt i t -> do t <- f t; return $ LitInt i t + +instance Show ESort where + showsPrec _ EStar = showString "*" + showsPrec _ EHash = showString "#" + showsPrec _ EStarStar = showString "**" + showsPrec _ EHashHash = showString "##" + showsPrec _ ETuple = showString "(#)" + showsPrec _ EBang = showString "!" + showsPrec _ (ESortNamed n) = shows n + +instance (Show e,Show t) => Show (Lit e t) where + showsPrec p (LitInt x t) = showParen (p > 10) $ shows x <> showString "::" <> shows t + showsPrec p LitCons { litName = n, litArgs = es, litType = t } = showParen (p > 10) $ hsep (shows n:map (showsPrec 11) es) <> showString "::" <> shows t + +instance Show a => Show (TVr' a) where + showsPrec n TVr { tvrIdent = eid, tvrType = e} | eid == emptyId = showParen (n > 10) $ showString "_::" . shows e + showsPrec n TVr { tvrIdent = x, tvrType = e} = showParen (n > 10) $ case fromId x of + Just n -> shows n . showString "::" . shows e + Nothing -> shows x . showString "::" . shows e + +type TVr = TVr' E +data TVr' e = TVr { tvrIdent :: !Id, tvrType :: e, tvrInfo :: Info.Info } + deriving(Functor,Foldable,Traversable) + +tvrInfo_u f r@TVr{tvrInfo = x} = r{tvrInfo = f x} +tvrType_u f r@TVr{tvrType = x} = r{tvrType = f x} +tvrInfo_s v = tvrInfo_u (const v) +tvrType_s v = tvrType_u (const v) + +data Alt e = Alt (Lit TVr e) e + deriving(Eq,Ord) + +instance Eq TVr where + (==) (TVr { tvrIdent = i }) (TVr { tvrIdent = i' }) = i == i' + (/=) (TVr { tvrIdent = i }) (TVr { tvrIdent = i' }) = i /= i' + +instance Ord TVr where + compare (TVr { tvrIdent = x }) (TVr { tvrIdent = y }) = compare x y + x < y = tvrIdent x < tvrIdent y + x > y = tvrIdent x > tvrIdent y + x >= y = tvrIdent x >= tvrIdent y + x <= y = tvrIdent x <= tvrIdent y + +-- simple querying routines +altHead :: Alt E -> Lit () () +altHead (Alt l _) = litHead l + +litHead :: Lit a b -> Lit () () +litHead (LitInt x _) = LitInt x () +litHead LitCons { litName = s, litAliasFor = af } = litCons { litName = s, litType = (), litAliasFor = af } + +litBinds (LitCons { litArgs = xs } ) = xs +litBinds _ = [] + +patToLitEE LitCons { litName = n, litArgs = [a,b], litType = t } | t == eStar, n == tc_Arrow = EPi (tVr emptyId (EVar a)) (EVar b) +patToLitEE LitCons { litName = n, litArgs = xs, litType = t, litAliasFor = af } = ELit $ LitCons { litName = n, litArgs = (map EVar xs), litType = t, litAliasFor = af } +patToLitEE (LitInt x t) = ELit $ LitInt x t + +caseBodies :: E -> [E] +caseBodies ec = [ b | Alt _ b <- eCaseAlts ec] ++ maybeToMonad (eCaseDefault ec) +casePats ec = [ p | Alt p _ <- eCaseAlts ec] +caseBinds ec = eCaseBind ec : concat [ xs | LitCons { litArgs = xs } <- casePats ec] + +-- | extract out EAp nodes a value and the arguments it is applied to. +fromAp :: E -> (E,[E]) +fromAp e = f [] e where + f as (EAp e a) = f (a:as) e + f as e = (e,as) + +-- | deconstruct EPi terms, getting function argument types. + +fromPi :: E -> (E,[TVr]) +fromPi e = f [] e where + f as (EPi v e) = f (v:as) e + f as e = (e,reverse as) + +-- | deconstruct ELam term. + +fromLam :: E -> (E,[TVr]) +fromLam e = f [] e where + f as (ELam v e) = f (v:as) e + f as e = (e,reverse as) + +litCons = LitCons { litName = error "litName: name not set", litArgs = [], litType = error "litCons: type not set", litAliasFor = Nothing } + +----------------- +-- E constructors +----------------- + +eStar :: E +eStar = ESort EStar + +eHash :: E +eHash = ESort EHash + +tVr x y = tvr { tvrIdent = x, tvrType = y } +tvr = TVr { tvrIdent = emptyId, tvrType = Unknown, tvrInfo = Info.empty } + +-- Imported from other files :- + +$(derive makeIs ''Lit) +$(derive makeIs ''ESort) +$(derive makeIs ''E) +$(derive makeFrom ''E) diff --git a/src/E/TypeCheck.hs b/src/E/TypeCheck.hs new file mode 100644 --- /dev/null +++ b/src/E/TypeCheck.hs @@ -0,0 +1,562 @@ +module E.TypeCheck( + canBeBox, + eAp, + inferType, + infertype, + typecheck, + match, + sortSortLike, + sortKindLike, + sortTermLike, + sortTypeLike, + typeInfer, + typeInfer' + ) where + +import Control.Monad.Reader +import Control.Monad.Writer +import qualified Data.Map as Map + +import Doc.DocLike +import Doc.PPrint +import Doc.Pretty +import E.E +import E.Eval(strong) +import E.Subst +import GenUtil +import Name.Id +import Name.Name +import Name.Names +import Support.CanType +import Util.ContextMonad +import Util.SetLike +import qualified Util.Seq as Seq +import {-# SOURCE #-} DataConstructors +import {-# SOURCE #-} E.Show + +{-@Internals + +# Ajhc Core Type System + +Ajhc's core is based on a pure type system. A pure type system (also called a +PTS) is actually a parameterized set of type systems. Ajhc's version is +described by the following. + + Sorts = (*, !, **, #, (#), ##, □) + Axioms = (*:**, #:##, !:**, **:□, ##:□) + + -- sort kind + * is the kind of boxed values + ! is the kind of boxed strict values + # is the kind of unboxed values + (#) is the kind of unboxed tuples + -- sort superkind + ** is the superkind of all boxed value + ## is the superkind of all unboxed values + -- sort box + □ superkinds inhabit this + + in addition there exist user defined kinds, which are always of supersort ## + +The following Rules table shows what sort of abstractions are allowed, a rule +of the form (A,B,C) means you can have functions of things of sort A to things +of sort B and the result is something of sort C. _Function_ in this context +subsumes both term and type level abstractions. + +Notice that functions are always boxed, but may be strict if they take an +unboxed tuple as an argument. When a function is strict it means that it is +represented by a pointer to code directly, it cannot be a suspended value that +evaluates to a function. + +These type system rules apply to lambda abstractions. It is possible that data +constructors might exist that cannot be given a type on their own with these +rules, even though when fully applied it has a well formed type. An example +would be unboxed tuples. This presents no difficulty as one concludes correctly +that it is a type error for these constructors to ever appear when not fully +saturated with arguments. + + as a shortcut we will use *# to mean every combination involving * and #, and so forth. + for instance, (*#,*#,*) means the set (*,*,*) (#,*,*) (*,#,*) (#,#,*) + + Rules = + (*#!,*#!,*) -- functions from values to values are boxed and lazy + (*#!,(#),*) -- functions from values to unboxed tuples are boxed and lazy + ((#),*#!,!) -- functions from unboxed tuples to values are boxed and strict + ((#),(#),!) -- functions from unboxed tuples to unboxed tuples are boxed and strict + (**,*,*) -- may have a function from an unboxed type to a value + (**,#,*) + (**,!,*) + (**,**,**) -- we have functions from types to types + (**,##,##) -- MutArray_ :: * -> # + (##,##,##) -- Complex_ :: # -> # + + The defining feature of boxed values is + + _|_ :: t iff t::* + + This PTS is functional but not injective + +The PTS can be considered stratified into the following levels + + □ - sort box + **,##, - sort superkind + *,#,(#),! - sort kind + Int,Bits32_,Char - sort type + 3,True,"bob" - sort value + +## On boxed kinds + +The boxed kinds (* and !) represent types that have a uniform run time +representation. Due to this, functions may be written that are polymorphic in types of these kinds. +Hence the rules of the form (**,?,?), allowing taking types of boxed kinds as arguments. + +the unboxed kind # is inhabited with types that have their own specific run +time representation. Hence you cannot write functions that are polymorphic in +unboxed types + +## On sort box, the unboxed tuple, and friends + +Although sort box does not appear in the code, it is useful from a theoretical +point of view to talk about certain types such as the types of unboxed tuples. +Unboxed tuples may have boxed and unboxed arguments, without sort box it would +be impossible to express this since it must be superkind polymorphic. sort box +allows one to express this as (in the case of the unboxed 2-tuple) + + ∀s1:□ ∀s2:□ ∀k1:s1 ∀k2:s2 ∀t1:k1 ∀t2:k2 . (# t1, t2 #) + +However, although this is a valid typing of what it would mean if a unboxed +tuple were not fully applied, since we do not have any rules of form (##,?,?) or +(□,?,?) this type obviously does not typecheck. Which is what enforces the +invarient that unboxed tuples are always fully applied, and is also why we do +not need a code representation of sort box. + +### Do we need a superbox? + +You will notice that if you look at the axioms involving the sorts, you end up +with a disjoint graph + + □ - the box + / \ + ** ## - superkind + /\ \ + * ! # (#) - kind + +This is simply due to the fact that nothing is polymorphic in unboxed tuples of +kind (#) so we never need to refer to any super-sorts of them. We can add sorts +(##),(□) and □□ to fill in the gaps, but since these sorts will never appear in +code or discourse, we will ignore them from now on. + + □□ - sort superbox + / \ + □ (□) - sort box + / \ \ + ** ## (##) - sort superkind + /\ \ | + * ! # (#) - sort kind + +-} + +ptsAxioms :: Map.Map ESort ESort +ptsAxioms = Map.fromList [ + (EStar,EStarStar), + (EBang,EStarStar), + (EHash,EHashHash), + (ETuple,EHashHash) + ] + +ptsRulesMap :: Map.Map (ESort,ESort) ESort +ptsRulesMap = Map.fromList [ ((a,b),c) | (as,bs,c) <- ptsRules, a <- as, b <- bs ] where + starHashBang = [EStar,EHash,EBang] + ptsRules = [ + (starHashBang,ETuple:starHashBang,EStar), + ([ETuple],ETuple:starHashBang,EBang), + ([EStarStar],starHashBang,EStar), + ([EStarStar],[EStarStar],EStarStar), + ([EStarStar],[EHashHash],EHashHash), + ([EHashHash],[EHashHash],EHashHash) + ] + +canBeBox x | getType (getType x) == ESort EStarStar = True +canBeBox _ = False + +tBox = mktBox eStar + +monadicLookup key m = case Map.lookup key m of + Just x -> return x + Nothing -> fail "Key not found" + +-- Fast (and lazy, and perhaps unsafe) typeof +instance CanType E where + type TypeOf E = E + getType (ESort s) = ESort $ getType s + getType (ELit l) = getType l + getType (EVar v) = getType v + getType e@(EPi TVr { tvrType = a } b) + | isUnknown typa || isUnknown typb = Unknown + | otherwise = maybe (error $ "E.TypeCheck.getType: " ++ show (e,getType a,getType b)) ESort $ do + ESort s1 <- return $ getType a + ESort s2 <- return $ getType b + monadicLookup (s1,s2) ptsRulesMap + where typa = getType a; typb = getType b + getType (EAp (ELit LitCons { litType = EPi tvr a }) b) = getType (subst tvr b a) + getType (EAp (ELit lc@LitCons { litAliasFor = Just af }) b) = getType (foldl eAp af (litArgs lc ++ [b])) + getType (EAp (EPi tvr a) b) = getType (subst tvr b a) + getType e@(EAp a b) = ans where + ans = if isUnknown typa then Unknown else if a == tBox || typa == tBox then tBox else (case a of + (ELit LitCons {}) -> error $ "getType: application of type alias " ++ (render $ parens $ ePretty e) + _ -> eAp typa b) + typa = getType a + getType (ELam (TVr { tvrIdent = x, tvrType = a}) b) = EPi (tVr x a) (getType b) + getType (ELetRec _ e) = getType e + getType ECase {eCaseType = ty} = ty + getType (EError _ e) = e + getType (EPrim _ _ t) = t + getType Unknown = Unknown + +instance CanType ESort where + type TypeOf ESort = ESort + getType (ESortNamed _) = EHashHash + getType s = case Map.lookup s ptsAxioms of + Just s -> s + Nothing -> error $ "getType: " ++ show s +instance CanType TVr where + type TypeOf TVr = E + getType = tvrType +instance CanType (Lit x t) where + type TypeOf (Lit x t) = t + getType l = litType l +instance CanType e => CanType (Alt e) where + type TypeOf (Alt e) = TypeOf e + getType (Alt _ e) = getType e + +sortSortLike (ESort s) = isEHashHash s || isEStarStar s +sortSortLike _ = False + +sortKindLike (ESort s) = not (isEHashHash s) && not (isEStarStar s) +sortKindLike e = sortSortLike (getType e) + +sortTypeLike ESort {} = False +sortTypeLike e = sortKindLike (getType e) + +sortTermLike ESort {} = False +sortTermLike e = sortTypeLike (getType e) + +withContextDoc s a = withContext (render s) a + +-- | Perform a full typecheck, evaluating type terms as necessary. + +inferType :: (ContextMonad m, ContextOf m ~ String) => DataTable -> [(TVr,E)] -> E -> m E +inferType dataTable ds e = rfc e where + inferType' ds e = inferType dataTable ds e + prettyE = ePretty + rfc e = withContextDoc (text "fullCheck:" prettyE e) (fc e >>= strong') + rfc' nds e = withContextDoc (text "fullCheck':" prettyE e) (inferType' nds e) + strong' e = withContextDoc (parens $ text "Strong:" prettyE e) $ strong ds e + fc s@(ESort _) = return $ getType s + fc (ELit lc@LitCons {}) | let lc' = updateLit dataTable lc, litAliasFor lc /= litAliasFor lc' = fail $ "Alias not correct: " ++ show (lc, litAliasFor lc') + fc (ELit LitCons { litName = n, litArgs = es, litType = t}) | nameType n == TypeConstructor, Just _ <- fromUnboxedNameTuple n = do + withContext ("Checking Unboxed Tuple: " ++ show n) $ do + -- we omit kind checking for unboxed tuples + valid t + es' <- mapM rfc es + strong' t + fc e@(ELit LitCons { litName = n, litArgs = es, litType = t}) = do + withContext ("Checking Constructor: " ++ show e) $ do + valid t + es' <- mapM rfc es + t' <- strong' t + let sts = slotTypes dataTable n t + les = length es + lsts = length sts + withContext ("Checking Args: " ++ show (sts,es')) $ do + unless (les == lsts || (les < lsts && isEPi t')) $ do + fail "constructor with wrong number of arguments" + zipWithM_ eq sts es' + return t' + fc e@(ELit _) = let t = getType e in valid t >> return t + fc (EVar (TVr { tvrIdent = eid })) | eid == emptyId = fail "variable with nothing!" + fc (EVar (TVr { tvrType = t})) = valid t >> strong' t + fc (EPi (TVr { tvrIdent = n, tvrType = at}) b) = do + ESort a <- rfc at + ESort b <- rfc' [ d | d@(v,_) <- ds, tvrIdent v /= n ] b + liftM ESort $ monadicLookup (a,b) ptsRulesMap + --valid at >> rfc' [ d | d@(v,_) <- ds, tvrIdent v /= n ] b + --fc (ELam tvr@(TVr n at) b) = valid at >> rfc' [ d | d@(v,_) <- ds, tvrIdent v /= n ] b >>= \b' -> (strong' $ EPi tvr b') + fc (ELam tvr@(TVr { tvrIdent = n, tvrType = at}) b) = do + withContext "Checking Lambda" $ do + valid at + b' <- withContext "Checking Lambda Body" $ rfc' [ d | d@(v,_) <- ds, tvrIdent v /= n ] b + withContext "Checking lambda pi" $ strong' $ EPi tvr b' + fc (EAp (EPi tvr e) b) = rfc (subst tvr b e) + fc (EAp (ELit lc@LitCons { litAliasFor = Just af }) b) = rfc (EAp (foldl eAp af (litArgs lc)) b) + fc (EAp a b) = do + withContextDoc (text "EAp:" parens (prettyE a) parens (prettyE b)) $ do + a' <- rfc a + if a' == tBox then return tBox else strong' (eAp a' b) + fc (ELetRec vs e) = do + let ck (TVr { tvrIdent = eid },_) | eid == emptyId = fail "binding of empty var" + ck (tv@(TVr { tvrType = t}),e) = withContextDoc (hsep [text "Checking Let: ", parens (pprint tv),text " = ", parens $ prettyE e ]) $ do + when (getType t == eHash && not (isEPi t)) $ fail $ "Let binding unboxed value: " ++ show (tv,e) + valid' nds t + fceq nds e t + nds = vs ++ ds + mapM_ ck vs + when (hasRepeatUnder (tvrIdent . fst) vs) $ fail "Repeat Variable in ELetRec" + inferType' nds e + --et <- inferType' nds e + --strong nds et + fc (EError _ e) = valid e >> (strong' e) + fc (EPrim _ ts t) = mapM_ valid ts >> valid t >> ( strong' t) + fc ec@ECase { eCaseScrutinee = e@ELit {}, eCaseBind = b, eCaseAlts = as, eCaseType = dt } | sortTypeLike e = do -- TODO - this is a hack to get around case of constants. + withContext "Checking typelike pattern binding case" $ do + et <- rfc e + withContext "Checking typelike default binding" $ eq et (getType b) + verifyPats (casePats ec) + -- skip checking alternatives + ps <- mapM (strong' . getType) $ casePats ec + withContext "Checking typelike pattern equality" $ eqAll (et:ps) + strong' dt + fc ec@ECase {eCaseScrutinee = e, eCaseBind = b, eCaseAlts = as, eCaseType = dt } | sortTypeLike e = do -- TODO - we should substitute the tested for value into the default type. + withContext "Checking typelike binding case" $ do + et <- rfc e + withContext "Checking typelike default binding" $ eq et (getType b) + --dt <- rfc d + --bs <- mapM rfc (caseBodies ec) -- these should be specializations of dt + withContext "Checking typelike alternatives" $ mapM_ (calt e) as + --eqAll bs + verifyPats (casePats ec) + ps <- withContext "Getting pattern types" $ mapM (strong' . getType) $ casePats ec + withContext "checking typelike pattern equality" $ eqAll (et:ps) + withContext "Evaluating Case Type" $ strong' dt + fc ec@ECase { eCaseScrutinee =e, eCaseBind = b } = do + withContext "Checking plain case" $ do + et <- rfc e + withContext "Checking default binding" $ eq et (getType b) + bs <- withContext "Checking case bodies" $ mapM rfc (caseBodies ec) + ect <- strong' (eCaseType ec) + withContext "Checking case bodies have equal types" $ eqAll (ect:bs) + verifyPats (casePats ec) + ps <- mapM (strong' . getType) $ casePats ec + withContext "checking pattern equality" $ eqAll (et:ps) + return ect + fc Unknown = return Unknown + --fc e = failDoc $ text "what's this? " (prettyE e) + calt (EVar v) (Alt l e) = do + let nv = followAliases undefined (patToLitEE l) + rfc (subst' v nv e) + calt _ (Alt _ e) = rfc e + verifyPats xs = do + mapM_ verifyPats' xs + when (hasRepeatUnder litHead xs) $ fail "Duplicate case alternatives" + + verifyPats' LitCons { litArgs = xs } = when (hasRepeatUnder id (filter (/= emptyId) $ map tvrIdent xs)) $ fail "Case pattern is non-linear" + verifyPats' _ = return () + + eqAll ts = withContextDoc (text "eqAll" list (map prettyE ts)) $ foldl1M_ eq ts + valid s = valid' ds s + valid' nds ESort {} = return () + valid' nds s + | Unknown <- s = return () + | otherwise = withContextDoc (text "valid:" <+> prettyE s) (do t <- inferType' nds s; valid' nds t) + eq box t2 | boxCompat box t2 = return t2 + eq t1 box | boxCompat box t1 = return t1 + -- box == tBox, canBeBox t2 = return t2 + -- eq t1 box | box == tBox, canBeBox t1 = return t1 + eq Unknown t2 = return t2 + eq t1 Unknown = return t1 + eq t1 t2 = eq' ds t1 t2 + eq' nds t1 t2 = do + e1 <- strong nds (t1) + e2 <- strong nds (t2) + case typesCompatable e1 e2 of + Just () -> return (e1) + Nothing -> failDoc $ text "eq:" <+> align $ vcat [ prettyE (e1), prettyE (e2) ] + fceq nds e1 t2 = do + withContextDoc (hsep [text "fceq:", align $ vcat [parens $ prettyE e1, parens $ prettyE t2]]) $ do + t1 <- inferType' nds e1 + eq' nds t1 t2 + boxCompat (ELit (LitCons { litName = n })) t | Just e <- fromConjured modBox n = e == getType t + boxCompat _ _ = False + +-- This should perform a full typecheck and may take any extra information needed as an extra parameter +class CanTypeCheck a where + typecheck :: Monad m => DataTable -> a -> m E + +infertype :: CanTypeCheck a => DataTable -> a -> E +infertype env a = case typecheck env a of + Left s -> error $ "infertype: " ++ s + Right x -> x + +instance CanTypeCheck E where + typecheck dataTable e = case runContextEither $ typeInfer'' dataTable [] e of + Left ss -> fail $ "\n>>> internal error:\n" ++ unlines ss + Right v -> return v + +instance CanTypeCheck TVr where + typecheck dt tvr = do + typecheck dt (getType tvr) + return $ getType tvr + +instance CanTypeCheck (Lit a E) where + typecheck dt LitCons { litType = t } = typecheck dt t >> return t + typecheck dt LitInt { litType = t } = typecheck dt t >> return t + +-- TODO, types might be bound in scrutinization +instance CanTypeCheck (Alt E) where + typecheck dt (Alt l e) = typecheck dt l >> typecheck dt e + +-- | Determine type of term using full algorithm with substitutions. This +-- should be used instead of 'typ' when let-bound type variables exist or you +-- wish a more thorough checking of types. + +typeInfer :: DataTable -> E -> E +typeInfer dataTable e = case runContextEither $ typeInfer'' dataTable [] e of + Left ss -> error $ "\n>>> internal error:\n" ++ unlines (tail ss) + Right v -> v + +typeInfer' :: DataTable -> [(TVr,E)] -> E -> E +typeInfer' dataTable ds e = case runContextEither $ typeInfer'' dataTable ds e of + Left ss -> error $ "\n>>> internal error:\n" ++ unlines (tail ss) + Right v -> v + +data TcEnv = TcEnv { + --tcDefns :: [(TVr,E)], + tcContext :: [String] + --tcDataTable :: DataTable + } + +tcContext_u f r@TcEnv{tcContext = x} = r{tcContext = f x} + +newtype Tc a = Tc (Reader TcEnv a) + deriving(Monad,Functor,MonadReader TcEnv) + +instance ContextMonad Tc where + type ContextOf Tc = String + withContext s = local (tcContext_u (s:)) + +{- +tcE :: E -> Tc E +tcE e = rfc e where + rfc e = withContextDoc (text "tcE:" ePretty e) (fc e >>= strong') + strong' e = do + ds <- asks tcDefns + withContextDoc (text "tcE.strong:" ePretty e) $ strong ds e + + fc s@ESort {} = return $ getType s + fc (ELit LitCons { litType = t }) = strong' t + fc e@ELit {} = strong' (getType e) + fc (EVar TVr { tvrIdent = eid }) | eid == emptyId = fail "variable with nothing!" + fc (EVar TVr { tvrType = t}) = strong' t + fc (EPi TVr { tvrIdent = n, tvrType = at} b) = do + ESort a <- rfc at + ESort b <- local (tcDefns_u (\ds -> [ d | d@(v,_) <- ds, tvrIdent v /= n ])) $ rfc b + liftM ESort $ monadicLookup (a,b) ptsRulesMap + fc (ELam tvr@TVr { tvrIdent = n, tvrType = at} b) = do + at' <- strong' at + b' <- local (tcDefns_u (\ds -> [ d | d@(v,_) <- ds, tvrIdent v /= n ])) $ rfc b + return (EPi (tVr n at') b') + fc (EAp (EPi tvr e) b) = do + b <- strong' b + rfc (subst tvr b e) + fc (EAp (ELit lc@LitCons { litAliasFor = Just af }) b) = fc (EAp (foldl eAp af (litArgs lc)) b) + fc (EAp a b) = do + a' <- rfc a + if a' == tBox then return tBox else strong' (eAp a' b) + fc (ELetRec vs e) = local (tcDefns_u (vs ++)) $ rfc e + fc (EError _ e) = strong' e + fc (EPrim _ ts t) = strong' t + fc ECase { eCaseType = ty } = do + strong' ty + fc Unknown = return Unknown + fc e = failDoc $ text "what's this? " (ePretty e) +-} + +typeInfer'' :: (ContextMonad m, ContextOf m ~ String) => DataTable -> [(TVr,E)] -> E -> m E +typeInfer'' dataTable ds e = rfc e where + inferType' ds e = typeInfer'' dataTable ds e + rfc e = withContextDoc (text "fullCheck':" ePretty e) (fc e >>= strong') + rfc' nds e = withContextDoc (text "fullCheck':" ePretty e) (inferType' nds e) + strong' e = withContextDoc (text "Strong':" ePretty e) $ strong ds e + fc s@ESort {} = return $ getType s + fc (ELit LitCons { litType = t }) = strong' t + fc e@ELit {} = strong' (getType e) + fc (EVar TVr { tvrIdent = eid }) | eid == emptyId = fail "variable with nothing!" + fc (EVar TVr { tvrType = t}) = strong' t + fc (EPi TVr { tvrIdent = n, tvrType = at} b) = do + ESort a <- rfc at + ESort b <- rfc' [ d | d@(v,_) <- ds, tvrIdent v /= n ] b + liftM ESort $ monadicLookup (a,b) ptsRulesMap + fc (ELam tvr@TVr { tvrIdent = n, tvrType = at} b) = do + at' <- strong' at + b' <- rfc' [ d | d@(v,_) <- ds, tvrIdent v /= n ] b + return (EPi (tVr n at') b') + fc (EAp (EPi tvr e) b) = do + b <- strong' b + rfc (subst tvr b e) + fc (EAp (ELit lc@LitCons { litAliasFor = Just af }) b) = fc (EAp (foldl eAp af (litArgs lc)) b) + fc (EAp a b) = do + a' <- rfc a + if a' == tBox then return tBox else strong' (eAp a' b) + fc (ELetRec vs e) = do + let nds = vs ++ ds + --et <- inferType' nds e + --strong nds et + inferType' nds e + fc (EError _ e) = strong' e + fc (EPrim _ ts t) = strong' t + fc ECase { eCaseType = ty } = do + strong' ty + fc Unknown = return Unknown + --fc e = failDoc $ text "what's this? " (ePretty e) + +-- | find substitution that will transform the left term into the right one, +-- only substituting for the vars in the list + +match :: Monad m => + (Id -> Maybe E) -- ^ function to look up values in the environment + -> [TVr] -- ^ vars which may be substituted + -> E -- ^ pattern to match + -> E -- ^ input expression + -> m [(TVr,E)] +match lup vs = \e1 e2 -> liftM Seq.toList $ execWriterT (un e1 e2 etherealIds) where + bvs :: IdSet + bvs = fromList (map tvrIdent vs) + + un (EAp a b) (EAp a' b') c = do + un a a' c + un b b' c + un (ELam va ea) (ELam vb eb) c = lam va ea vb eb c + un (EPi va ea) (EPi vb eb) c = lam va ea vb eb c + un (EPi va ea) (ELit LitCons { litName = ar, litArgs = [x,y], litType = lt}) c | ar == tc_Arrow = do + un (tvrType va) x c + un ea y c + un (EPrim s xs t) (EPrim s' ys t') c | length xs == length ys = do + sequence_ [ un x y c | x <- xs | y <- ys] + un t t' c + un (ESort x) (ESort y) c | x == y = return () + un (ELit (LitInt x t1)) (ELit (LitInt y t2)) c | x == y = un t1 t2 c + un (ELit LitCons { litName = n, litArgs = xs, litType = t }) (ELit LitCons { litName = n', litArgs = ys, litType = t'}) c | n == n' && length xs == length ys = do + sequence_ [ un x y c | x <- xs | y <- ys] + un t t' c + + un (EVar TVr { tvrIdent = i, tvrType = t}) (EVar TVr {tvrIdent = j, tvrType = u}) c | i == j = un t u c + un (EVar TVr { tvrIdent = i, tvrType = t}) (EVar TVr {tvrIdent = j, tvrType = u}) c | isEtherealId i || isEtherealId j = fail "Expressions don't match" + un (EAp a b) (ELit lc@LitCons { litArgs = bas@(_:_), litType = t }) c = do + let (al:as) = reverse bas + un a (ELit lc { litArgs = reverse as, litType = ePi tvr { tvrType = getType al } t }) c + un b al c + un (EAp a b) (EPi TVr { tvrType = a1 } a2) c = do + un a (ELit litCons { litArgs = [a1], litName = tc_Arrow, litType = EPi tvr { tvrType = getType a2 } (getType a1) }) c + un b a2 c + un (EVar tvr@TVr { tvrIdent = i, tvrType = t}) b c + | i `member` bvs = tell (Seq.single (tvr,b)) + | otherwise = fail $ "Expressions do not unify: " ++ show tvr ++ show b + un a (EVar tvr) c | Just b <- lup (tvrIdent tvr), not $ isEVar b = un a b c + --un a b c | Just a' <- followAlias undefined a = un a' b c + un a b c | Just b' <- followAlias undefined b = un a b' c + + un a b _ = fail $ "Expressions do not unify: " ++ show a ++ show b + lam va ea vb eb (c:cs) = do + un (tvrType va) (tvrType vb) (c:cs) + un (subst va (EVar va { tvrIdent = c }) ea) (subst vb (EVar vb { tvrIdent = c }) eb) cs + lam _ _ _ _ _ = error "TypeCheck.match: bad." diff --git a/src/FlagOpts.hs b/src/FlagOpts.hs --- a/src/FlagOpts.hs +++ b/src/FlagOpts.hs @@ -8,6 +8,7 @@ | Boehm -- ^ use Boehm garbage collector | Controlled -- ^ with the '-f' flag, the following options are availible, you can | Cpp -- ^ pass haskell source through c preprocessor + | Customthread -- ^ use your own thread mechanism | Debug -- ^ enable debugging code in generated executable | Defaulting -- ^ perform defaulting of ambiguous types | Exists -- ^ - exists keyword for existential types recognized @@ -21,8 +22,10 @@ | M4 -- ^ pass haskell source through m4 preprocessor | MonomorphismRestriction -- ^ enforce monomorphism restriction | Negate -- ^ any particular one by prepending 'no-' to it. + | Nothread -- ^ do not support thread | Prelude -- ^ implicitly import Prelude | Profile -- ^ enable profiling code in generated executable + | Pthread -- ^ use pthread for concurrency | Raw -- ^ just evaluate main to WHNF and nothing else. | Rules -- ^ use rules | Standalone -- ^ compile to a standalone executable @@ -63,45 +66,34 @@ show Profile = "profile" show Debug = "debug" show Raw = "raw" + show Nothread = "nothread" + show Pthread = "pthread" + show Customthread = "customthread" one "profile" = Right $ Set.insert Profile one "no-profile" = Right $ Set.delete Profile -one "boehm" = Right $ Set.insert Boehm -one "no-boehm" = Right $ Set.delete Boehm -one "jgc" = Right $ Set.insert Jgc -one "no-jgc" = Right $ Set.delete Jgc one "m4" = Right $ Set.insert M4 one "no-m4" = Right $ Set.delete M4 -one "defaulting" = Right $ Set.insert Defaulting -one "no-defaulting" = Right $ Set.delete Defaulting one "lint" = Right $ Set.insert Lint one "no-lint" = Right $ Set.delete Lint one "ffi" = Right $ Set.insert Ffi one "no-ffi" = Right $ Set.delete Ffi -one "rules" = Right $ Set.insert Rules -one "no-rules" = Right $ Set.delete Rules one "monomorphism-restriction" = Right $ Set.insert MonomorphismRestriction one "no-monomorphism-restriction" = Right $ Set.delete MonomorphismRestriction one "prelude" = Right $ Set.insert Prelude one "no-prelude" = Right $ Set.delete Prelude -one "controlled" = Right $ Set.insert Controlled -one "no-controlled" = Right $ Set.delete Controlled +one "customthread" = Right $ Set.insert Customthread +one "no-customthread" = Right $ Set.delete Customthread one "debug" = Right $ Set.insert Debug one "no-debug" = Right $ Set.delete Debug one "wrapper" = Right $ Set.insert Wrapper one "no-wrapper" = Right $ Set.delete Wrapper one "bang-patterns" = Right $ Set.insert BangPatterns one "no-bang-patterns" = Right $ Set.delete BangPatterns -one "unboxed-values" = Right $ Set.insert UnboxedValues -one "no-unboxed-values" = Right $ Set.delete UnboxedValues -one "type-families" = Right $ Set.insert TypeFamilies -one "no-type-families" = Right $ Set.delete TypeFamilies -one "inline-pragmas" = Right $ Set.insert InlinePragmas -one "no-inline-pragmas" = Right $ Set.delete InlinePragmas +one "pthread" = Right $ Set.insert Pthread +one "no-pthread" = Right $ Set.delete Pthread one "unboxed-tuples" = Right $ Set.insert UnboxedTuples one "no-unboxed-tuples" = Right $ Set.delete UnboxedTuples -one "global-optimize" = Right $ Set.insert GlobalOptimize -one "no-global-optimize" = Right $ Set.delete GlobalOptimize one "forall" = Right $ Set.insert Forall one "no-forall" = Right $ Set.delete Forall one "full-int" = Right $ Set.insert FullInt @@ -112,16 +104,36 @@ one "user-kinds" = Right $ Set.insert UserKinds one "no-user-kinds" = Right $ Set.delete UserKinds one "glasgow-exts" = Right $ foldr (.) id [ f | Right f <- [ one "forall",one "ffi",one "unboxed-tuples"]] -one "cpp" = Right $ Set.insert Cpp -one "no-cpp" = Right $ Set.delete Cpp one "standalone" = Right $ Set.insert Standalone one "no-standalone" = Right $ Set.delete Standalone +one "type-analysis" = Right $ Set.insert TypeAnalysis +one "no-type-analysis" = Right $ Set.delete TypeAnalysis +one "boehm" = Right $ Set.insert Boehm +one "no-boehm" = Right $ Set.delete Boehm +one "jgc" = Right $ Set.insert Jgc +one "no-jgc" = Right $ Set.delete Jgc +one "defaulting" = Right $ Set.insert Defaulting +one "no-defaulting" = Right $ Set.delete Defaulting +one "nothread" = Right $ Set.insert Nothread +one "no-nothread" = Right $ Set.delete Nothread +one "rules" = Right $ Set.insert Rules +one "no-rules" = Right $ Set.delete Rules +one "controlled" = Right $ Set.insert Controlled +one "no-controlled" = Right $ Set.delete Controlled +one "type-families" = Right $ Set.insert TypeFamilies +one "no-type-families" = Right $ Set.delete TypeFamilies +one "unboxed-values" = Right $ Set.insert UnboxedValues +one "no-unboxed-values" = Right $ Set.delete UnboxedValues +one "inline-pragmas" = Right $ Set.insert InlinePragmas +one "no-inline-pragmas" = Right $ Set.delete InlinePragmas +one "global-optimize" = Right $ Set.insert GlobalOptimize +one "no-global-optimize" = Right $ Set.delete GlobalOptimize +one "cpp" = Right $ Set.insert Cpp +one "no-cpp" = Right $ Set.delete Cpp one "exists" = Right $ Set.insert Exists one "no-exists" = Right $ Set.delete Exists one "raw" = Right $ Set.insert Raw one "no-raw" = Right $ Set.delete Raw -one "type-analysis" = Right $ Set.insert TypeAnalysis -one "no-type-analysis" = Right $ Set.delete TypeAnalysis one x = Left x {-# NOINLINE process #-} @@ -130,6 +142,6 @@ f (Left x) (s,xs) = (s,x:xs) {-# NOINLINE helpMsg #-} -helpMsg = "\n-- Code options --\nbang-patterns - bang patterns\ncpp pass haskell source through c preprocessor\nexists - exists keyword for existential types recognized\nffi support foreign function declarations\nforall - forall keyword for rank-n types and explicit\n quantification\nm4 pass haskell source through m4 preprocessor\nprelude implicitly import Prelude\ntype-families type/data family support\nunboxed-tuples allow unboxed tuple syntax to be recognized\nunboxed-values allow unboxed value syntax\nuser-kinds user defined kinds\n\n-- Typechecking --\ndefaulting perform defaulting of ambiguous types\nmonomorphism-restriction enforce monomorphism restriction\n\n-- Debugging --\nlint perform lots of extra type checks\n\n-- Optimization Options --\nglobal-optimize perform whole program E optimization\ninline-pragmas use inline pragmas\nrules use rules\ntype-analysis perform a basic points-to analysis on types right after\n method generation\n\n-- Code Generation --\nboehm use Boehm garbage collector\ndebug enable debugging code in generated executable\nfull-int extend Int and Word to 32 bits on a 32 bit machine\n (rather than 30)\njgc use the jgc garbage collector\nprofile enable profiling code in generated executable\nraw just evaluate main to WHNF and nothing else.\nstandalone compile to a standalone executable\nwrapper wrap main in exception handler\n\n-- Default settings --\ndefault inline-pragmas rules wrapper defaulting type-analysis\n monomorphism-restriction global-optimize full-int\n prelude\nglasgow-exts forall ffi unboxed-tuples\n" -helpFlags = ["bang-patterns", "boehm", "controlled", "cpp", "debug", "default", "defaulting", "exists", "ffi", "forall", "full-int", "glasgow-exts", "global-optimize", "inline-pragmas", "jgc", "lint", "m4", "monomorphism-restriction", "negate", "prelude", "profile", "raw", "rules", "standalone", "type-analysis", "type-families", "unboxed-tuples", "unboxed-values", "user-kinds", "wrapper"] +helpMsg = "\n-- Code options --\nbang-patterns - bang patterns\ncpp pass haskell source through c preprocessor\nexists - exists keyword for existential types recognized\nffi support foreign function declarations\nforall - forall keyword for rank-n types and explicit\n quantification\nm4 pass haskell source through m4 preprocessor\nprelude implicitly import Prelude\ntype-families type/data family support\nunboxed-tuples allow unboxed tuple syntax to be recognized\nunboxed-values allow unboxed value syntax\nuser-kinds user defined kinds\n\n-- Typechecking --\ndefaulting perform defaulting of ambiguous types\nmonomorphism-restriction enforce monomorphism restriction\n\n-- Debugging --\nlint perform lots of extra type checks\n\n-- Optimization Options --\nglobal-optimize perform whole program E optimization\ninline-pragmas use inline pragmas\nrules use rules\ntype-analysis perform a basic points-to analysis on types right after\n method generation\n\n-- Code Generation --\nboehm use Boehm garbage collector\ncustomthread use your own thread mechanism\ndebug enable debugging code in generated executable\nfull-int extend Int and Word to 32 bits on a 32 bit machine\n (rather than 30)\njgc use the jgc garbage collector\nnothread do not support thread\nprofile enable profiling code in generated executable\npthread use pthread for concurrency\nraw just evaluate main to WHNF and nothing else.\nstandalone compile to a standalone executable\nwrapper wrap main in exception handler\n\n-- Default settings --\ndefault inline-pragmas rules wrapper defaulting type-analysis\n monomorphism-restriction global-optimize full-int\n prelude\nglasgow-exts forall ffi unboxed-tuples\n" +helpFlags = ["bang-patterns", "boehm", "controlled", "cpp", "customthread", "debug", "default", "defaulting", "exists", "ffi", "forall", "full-int", "glasgow-exts", "global-optimize", "inline-pragmas", "jgc", "lint", "m4", "monomorphism-restriction", "negate", "nothread", "prelude", "profile", "pthread", "raw", "rules", "standalone", "type-analysis", "type-families", "unboxed-tuples", "unboxed-values", "user-kinds", "wrapper"] diff --git a/src/FrontEnd/Class.hs b/src/FrontEnd/Class.hs new file mode 100644 --- /dev/null +++ b/src/FrontEnd/Class.hs @@ -0,0 +1,539 @@ +{-# LANGUAGE NoMonoLocalBinds, NamedFieldPuns, TemplateHaskell #-} +module FrontEnd.Class( + printClassHierarchy, + instanceToTopDecls, + ClassHierarchy(), + augmentClassHierarchy, + chToClassHead, + ClassRecord(..), + ClassType(..), + instanceName, + defaultInstanceName, + checkForDuplicateInstaces, + printClassSummary, + findClassInsts, + findClassRecord, + asksClassRecord, + classRecords, + addInstanceToHierarchy, + makeClassHierarchy, + scatterAliasInstances, + derivableClasses, + enumDerivableClasses, + noNewtypeDerivable, + makeInstanceEnv, + emptyInstance, + InstanceEnv(..), + Inst(..) + ) where + +import Control.Monad.Identity +import Control.Monad.Writer(Monoid(..)) +import Data.Generics(mkQ,something) +import Data.List(nub) +import Data.Maybe +import Data.DeriveTH +import Debug.Trace +import Text.PrettyPrint.HughesPJ(render,Doc()) +import Text.Printf +import qualified Data.List +import qualified Data.Map as Map +import qualified Text.PrettyPrint.HughesPJ as PPrint + +import Data.Binary +import Doc.DocLike +import Doc.PPrint +import FrontEnd.HsSyn +import FrontEnd.KindInfer +import FrontEnd.SrcLoc +import FrontEnd.Tc.Kind +import FrontEnd.Tc.Type +import FrontEnd.Utils +import FrontEnd.Warning +import Name.Name +import Name.Names +import Options (verbose) +import Support.FreeVars +import Support.MapBinaryInstance +import Support.Tickle +import Util.Gen +import Util.Inst() + +type Assump = (Name,Sigma) + +data Inst = Inst { + instSrcLoc :: SrcLoc, + instDerived :: !Bool, -- ^ whether this instance was derived + instHead :: Qual Pred, + instAssocs :: [(Tycon,[Tyvar],[Tyvar],Sigma)] + } deriving(Eq,Ord,Show) + +instance PPrint a (Qual Pred) => PPrint a Inst where + pprint Inst { instHead = h, instAssocs = [], instDerived = d } = (if d then text "*" else text " ") <> pprint h + pprint Inst { instHead = h, instAssocs = as, instDerived = d } = (if d then text "*" else text " ") <> pprint h <+> text "where" <$> vcat [ text " type" <+> pprint n <+> text "_" <+> hsep (map pprint ts) <+> text "=" <+> pprint sigma | (n,_,ts,sigma) <- as] + +emptyInstance = Inst { instDerived = False, instSrcLoc = bogusASrcLoc, instHead = error "emptyInstance", instAssocs = [] } + +-- augment heirarchy with just instances with full class definitions +augmentClassHierarchy :: ClassHierarchy -> ClassHierarchy -> ClassHierarchy +augmentClassHierarchy (CH full _) (CH res is) = ans where + ans = CH (Map.mapWithKey f is) is + f cn _ = r where Just r = Map.lookup cn (Map.union res full) + +data ClassType = ClassNormal | ClassTypeFamily | ClassDataFamily | ClassAlias + deriving(Eq,Ord) + +-- Bool is true if data declaration instead of type declaration +data AssociatedType = Assoc !Tycon !Bool [Tyvar] Kind + deriving(Eq,Show) + +data ClassRecord = ClassRecord { + className :: !Class, -- ^ can be a TypeConstructor if we are a type or data family + classSrcLoc :: !SrcLoc, + classArgs :: [Tyvar], + classSupers :: [Class], -- TODO: should be Pred + classAlias :: Maybe (Qual [Pred]), + classAssumps :: [(Name,Sigma)], -- ^ method signatures + classAssocs :: [AssociatedType] + } deriving (Show,Eq) + +newtype InstanceEnv = InstanceEnv { + instanceEnv :: Map.Map (Name,Name) ([Tyvar],[Tyvar],Type) } + +makeInstanceEnv :: ClassHierarchy -> InstanceEnv +makeInstanceEnv (CH _ is) = InstanceEnv $ Map.fromList (concatMap f (Map.toList is)) where + f (cr,is) = concatMap (g cr) is + g cr Inst { instHead = _ :=> IsIn _cname tt, instAssocs = as } | _cname == cr = ans where + ans = [ ((tyconName tc,getTypeHead tt),(is,rs,e)) | (tc,is,rs,e) <- as] + g cr x = error $ "makeInstanceEnv: " ++ show (cr,x) + +getTypeHead th = case fromTAp th of + (TArrow {},_) -> tc_Arrow + (TCon c,_) -> tyconName c + _ -> error $ "getTypeHead: " ++ show th + +data ClassHierarchy = CH (Map.Map Class ClassRecord) (Map.Map Class [Inst]) + +instance Binary ClassHierarchy where + get = do + m1 <- getMap + m2 <- getMap + return (CH m1 m2) + put (CH m1 m2) = do + putMap m1 + putMap m2 + +instance Monoid ClassHierarchy where + mempty = CH mempty mempty + mappend (CH a b) (CH c d) = + CH (Map.union a c) (Map.unionWith Data.List.union b d) + +classRecords :: ClassHierarchy -> [ClassRecord] +classRecords (CH ch _) = Map.elems ch + +findClassRecord (CH ch _) cn = case Map.lookup cn ch of + Nothing -> error $ "findClassRecord: " ++ show cn + Just n -> n + +asksClassRecord (CH ch _) cn f = case Map.lookup cn ch of + Nothing -> error $ "asksClassRecord: " ++ show cn + Just n -> f n +findClassInsts (CH _ is) cn = fromMaybe [] (Map.lookup cn is) + +showInst :: Inst -> String +showInst = PPrint.render . pprint + +aHsTypeSigToAssumps :: KindEnv -> HsDecl -> [(Name,Type)] +aHsTypeSigToAssumps kt ~sig@(HsTypeSig _ names qualType) = [ (toName Val n,typ) | n <- names] where + Identity typ = hsQualTypeToSigma kt qualType + +qualifyMethod :: [HsAsst] -> HsDecl -> HsDecl +qualifyMethod ~[HsAsst c [n]] ~(HsTypeSig sloc names (HsQualType oc t)) + = HsTypeSig sloc names (HsQualType (HsAsst c [n']:oc) t) where + Just n' = (something (mkQ mzero f)) t + f (HsTyVar n') | hsNameToOrig n' == hsNameToOrig n = return n' + f _ = mzero + +printClassSummary :: ClassHierarchy -> IO () +printClassSummary (CH h is) = mapM_ f (Map.toList h) where + --h' = [ (n,fromJust $ Map.lookup n h) | n <- (map fst [ (cn, classSupers ss) | (cn,ss) <- Map.toList h]) ] + f (cname, ClassRecord { .. }) = do + putStrLn $ "-- class: " ++ show cname + let insts = fromMaybe [] (Map.lookup cname is) + unless (null classSupers) $ putStrLn $ "super classes:" ++ unwords (map show classSupers) + unless (null insts) $ putStrLn $ "instances: " ++ (intercalate ", " (map showInst insts)) +-- putStrLn "" +-- f (cname, (ClassAliasRecord { classSupers = supers, classInsts = insts, classClasses = classes })) = do +-- putStrLn $ "-- class: " ++ show cname +-- unless (null supers) $ putStrLn $ "super classes:" ++ unwords (map show supers) +-- unless (null insts) $ putStrLn $ "instances: " ++ (intercalate ", " (map showInst insts)) +-- unless (null classes) $ putStrLn $ "alias for: " ++ unwords (map show classes) +-- putStrLn "" + +printClassHierarchy :: ClassHierarchy -> IO () +printClassHierarchy (CH h is) = mapM_ printClassDetails $ Map.toList h where + printClassDetails :: (Name, ClassRecord) -> IO () + printClassDetails (cname, cr) = do + let args = classArgs cr; supers = classSupers cr; + methodAssumps = classAssumps cr + assocs = classAssocs cr + let insts = fromMaybe [] (Map.lookup cname is) + putStrLn "..........." + putStrLn $ "class: " ++ hsep (pprint cname:map pprintParen args) + putStr $ "super classes:" + pnone supers $ do putStrLn $ " " ++ (intercalate " " (map show supers)) + putStr $ "instances:" + pnone insts $ putStr $ "\n" ++ (showListAndSepInWidth showInst 80 ", " insts) + when True $ do + putStr $ "method signatures:" + pnone methodAssumps $ putStr $ "\n" ++ (unlines $ map pretty methodAssumps) + putStr $ "associated types:" + pnone assocs $ putStrLn $ "\n" ++ (unlines $ map (render . passoc) assocs) + when (isJust (classAlias cr)) $ do + let Just x = classAlias cr + putStr $ "alias for:" + putStrLn (pprint x) + --Just $ --pnone classes $ do putStrLn $ " " ++ (intercalate " " (map show classes)) + putStr "\n" + pnone [] f = putStrLn " none" + pnone xs f = f + passoc (Assoc nk isData as kt) = text (if isData then "data" else "type") <+> + pprint nk <+> hsep (map pprint as) <+> text "::" <+> pprint kt + +-- this does not check for duplicates, use checkForDuplicateInstaces after all +-- instances have been added to do so. +addInstanceToHierarchy :: Inst -> ClassHierarchy -> ClassHierarchy +addInstanceToHierarchy inst@Inst { instHead = cntxt :=> ~(IsIn className _) } (CH r i) = + CH r (Map.insertWith Data.List.union className [inst] i) + +-- Kind inference has already been done so we don't need to check for kind +-- errors here. +hsInstDeclToInst :: Monad m => KindEnv -> HsDecl -> m [Inst] +hsInstDeclToInst kt (HsInstDecl sloc qType decls) + = return [emptyInstance { instSrcLoc = sloc, instDerived = False, + instHead = cntxt :=> IsIn className convertedArgType, instAssocs = assocs }] + where + (cntxt, (className, [convertedArgType])) = chToClassHead kt qType + assocs = [ (tc,as,bs,s) | (tc,as,bs,~(Just s)) <- createInstAssocs kt decls ] +hsInstDeclToInst kt (HsDeclDeriving sloc qType) + = return [emptyInstance { instSrcLoc = sloc, instDerived = True, + instHead = cntxt :=> IsIn className convertedArgType }] + where (cntxt, (className, [convertedArgType])) = chToClassHead kt qType +hsInstDeclToInst _ _ = return [] + +vtrace s v | False && verbose = trace s v +vtrace s v | otherwise = v + +chToClassHead :: KindEnv -> HsClassHead -> ([Pred],(Name,[Type])) +chToClassHead kt qt@HsClassHead { .. } = + vtrace ("chToClassHead" <+> show qt) $ + let res = (map (hsAsstToPred kt) hsClassHeadContext,(hsClassHead, + map (runIdentity . hsTypeToType (kiHsQualType kt (HsQualType hsClassHeadContext (HsTyTuple [])))) hsClassHeadArgs)) + in vtrace ("=" <+> show res) res + +createClassAssocs kt decls = [ Assoc (ctc n) False (map ct as) (ctype t) | HsTypeDecl { hsDeclName = n, hsDeclTArgs = as, hsDeclType = t } <- decls ] where + ctc n = let nn = toName TypeConstructor n in Tycon nn (kindOf nn kt) + ct (HsTyVar n) = let nn = toName TypeVal n in tyvar nn (kindOf nn kt) + ct _ = error "Class.createClassAssocs: bad1." + ctype HsTyAssoc = kindStar + ctype _ = error "Class.createClassAssocs: bad2." +-- ctype t = Just $ runIdentity $ hsTypeToType kt t + +createInstAssocs kt decls = [ (ctc n,map ct (czas ca),map ct as,ctype t) | HsTypeDecl { hsDeclName = n, hsDeclTArgs = (ca:as), hsDeclType = t } <- decls ] where + ctc n = let nn = toName TypeConstructor n in Tycon nn (kindOf nn kt) + ct (HsTyVar n) = let nn = toName TypeVal n in tyvar nn (kindOf nn kt) + ct _ = error "Class.createInstAssocs: bad." + czas ca = let (HsTyCon {},zas) = fromHsTypeApp ca in zas + ctype HsTyAssoc = Nothing + ctype t = Just $ runIdentity $ hsTypeToType kt t + +fromHsTypeApp t = f t [] where + f (HsTyApp a b) rs = f a (b:rs) + f t rs = (t,rs) + +instanceToTopDecls :: KindEnv -> ClassHierarchy -> HsDecl -> (([HsDecl],[Assump])) +instanceToTopDecls kt ch@(CH classHierarchy _) (HsInstDecl _ qualType methods) + = unzip $ concatMap (methodToTopDecls kt [] crecord qualType) $ methodGroups where + methodGroups = groupEquations (filter (not . isHsPragmaProps) methods) + (_,(className,_)) = chToClassHead kt qualType + crecord = case Map.lookup className classHierarchy of + Nothing -> error $ "instanceToTopDecls: could not find class " ++ show className ++ "in class hierarchy" + Just crecord -> crecord +instanceToTopDecls kt ch@(CH classHierarchy _) (HsClassDecl _ chead methods) + = unzip $ map (defaultMethodToTopDecls kt methodSigs chead) $ methodGroups where + className = hsClassHead chead + --HsQualType _ (HsTyApp (HsTyCon className) _) = qualType + methodGroups = groupEquations (filter (\x -> isHsPatBind x || isHsFunBind x) methods) + methodSigs = case Map.lookup (toName ClassName className) classHierarchy of + Nothing -> error $ "defaultInstanceToTopDecls: could not find class " ++ show className ++ "in class hierarchy" + Just sigs -> classAssumps sigs +instanceToTopDecls _ _ _ = mempty + +instanceName n t = toName Val ("Instance@",'i':show n ++ "." ++ show t) +defaultInstanceName n = toName Val ("Instance@",'i':show n ++ ".default") +-- aliasDefaultInstanceName :: Name -> Class -> Name +-- aliasDefaultInstanceName n ca = toName Val ("Instance@",'i':show n ++ ".default."++show ca) + +methodToTopDecls :: Monad m + => KindEnv -- ^ the kindenv + -> [Pred] -- ^ random extra predicates to add + -> ClassRecord -- ^ the class we are lifting methods from + -> HsClassHead + -> (Name, HsDecl) + -> m (HsDecl,Assump) +methodToTopDecls kt preds crecord qt (methodName, methodDecls) = do + let (cntxt,(className,[argType])) = chToClassHead kt qt + newMethodName = instanceName methodName (getTypeHead argType) + sigFromClass <- case [ s | (n, s) <- classAssumps crecord, n == methodName] of + [x] -> return x + _ -> fail $ "sigFromClass: " ++ (pprint className <+> pprint (classAssumps crecord)) + ++ " " ++ show methodName + let instantiatedSig = newMethodSig' kt methodName (preds ++ cntxt) sigFromClass argType + renamedMethodDecls = renameOneDecl newMethodName methodDecls + return (renamedMethodDecls,(newMethodName, instantiatedSig)) + +defaultMethodToTopDecls :: KindEnv -> [Assump] -> HsClassHead -> (Name, HsDecl) -> (HsDecl,Assump) +defaultMethodToTopDecls kt methodSigs HsClassHead { .. } (methodName, methodDecls) + = (renamedMethodDecls,(newMethodName,sigFromClass)) where + newMethodName = defaultInstanceName methodName + sigFromClass = case [ s | (n, s) <- methodSigs, n == methodName] of + [x] -> x + _ -> error $ "sigFromClass: " ++ show methodSigs ++ " " ++ show methodName + -- = newMethodSig cntxt newMethodName sigFromClass argType + renamedMethodDecls = renameOneDecl newMethodName methodDecls + +{- +aliasDefaultMethodToTopDecls :: KindEnv -> [Assump] -> Class -> (Name, HsDecl) -> (HsDecl,Assump) +aliasDefaultMethodToTopDecls kt methodSigs aliasName (methodName, methodDecls) + = (renamedMethodDecls,(newMethodName,sigFromClass)) where + newMethodName = aliasDefaultInstanceName methodName aliasName + sigFromClass = case [ s | (n, s) <- methodSigs, n == methodName] of + [x] -> x + _ -> error $ "sigFromClass: " ++ show methodSigs ++ " " ++ show methodName + -- = newMethodSig cntxt newMethodName sigFromClass argType + renamedMethodDecls = renameOneDecl newMethodName methodDecls +-} + +renameOneDecl :: Name -> HsDecl -> HsDecl +renameOneDecl newName (HsFunBind matches) + = HsFunBind (map (renameOneMatch newName) matches) +-- all pattern bindings are simple by this stage +-- (ie no compound patterns) +renameOneDecl newName (HsPatBind sloc (HsPVar patName) rhs wheres) + = HsPatBind sloc (HsPVar (nameName newName)) rhs wheres +renameOneDecl _ _ = error "Class.renameOneDecl" + +renameOneMatch :: Name -> HsMatch -> HsMatch +renameOneMatch newName (HsMatch sloc oldName pats rhs wheres) + = HsMatch sloc (nameName newName) pats rhs wheres + +newMethodSig' :: KindEnv -> Name -> [Pred] -> Sigma -> Type -> Sigma +newMethodSig' kt methodName newCntxt qt' instanceType = newQualType where + TForAll _ ((IsIn _ classArg:restContext) :=> t) = qt' + -- the assumption is that the context is non-empty and that + -- the class and variable that we are interested in are at the + -- front of the old context - the method of inserting instance types into + -- the class hierarchy should ensure this + --((className, classArg):restContxt) = cntxt + foo = "_" ++ (show methodName ++ show (getTypeHead instanceType)) ++ "@@" +-- newQualType = everywhere (mkT at) $ tForAll (nub $ freeVars qt) qt + + newQualType = tForAll vs nqt where + vs = nub $ freeVars nqt + nqt = map (tickle f) (newCntxt ++ restContext) :=> f t + f t | t == classArg = f instanceType + f (TVar t) = TVar (at t) + f (TForAll ta (ps :=> t)) = tickle f (TForAll (map at ta) (ps :=> t)) + f (TExists ta (ps :=> t)) = tickle f (TExists (map at ta) (ps :=> t)) + f t = tickle f t + + at (Tyvar n k) = tyvar (updateName (++ foo) n) k + updateName f n = toName nt (md,f nm) where + (nt,(md::String,nm)) = fromName n +-- qt = (newCntxt ++ restContext) :=> t + {- + qt = (newCntxt ++ restContext) :=> (everywhere (mkT ct) t) + ct n | n == classArg = instanceType + ct n = n + -} + +-- collect assumptions of all class methods + +--classMethodAssumps :: ClassHierarchy -> [Assump] +--classMethodAssumps hierarchy = concatMap classAssumps $ classRecords hierarchy + +-------------------------------------------------------------------------------- + +scatterAliasInstances :: ClassHierarchy -> ClassHierarchy +scatterAliasInstances = id +{- +scatterAliasInstances ch = + let cas = [cr | cr@(ClassAliasRecord {}) <- classRecords ch] + --ch `seq` liftIO $ putStrLn ("scatterAliasInstances: " ++ show cas) + instances = concatMap scatterInstancesOf cas + ret = foldr (modifyClassRecord $ \cr -> cr + { classInsts = [], + classMethodMap = Map.fromList [(meth, cls) | cls <- classClasses cr, + (meth,_) <- classAssumps (findClassRecord ch cls)] + }) + (ch `mappend` classHierarchyFromRecords instances) + (map className cas) + -- liftIO $ mapM_ print (classRecords ret) + in ret + +scatterInstancesOf :: ClassRecord -> [ClassRecord] +scatterInstancesOf cr = map extract (classClasses cr) + where + extract c = + (newClassRecord c) { classInsts = + [Inst sl d ((cxt ++ [IsIn c2 xs | c2 <- classClasses cr, c2 /= c]) :=> IsIn c xs) [] + | Inst sl d (cxt :=> IsIn _ xs) [] <- classInsts cr] } + +-} +-------------------------------------------------------------------------------- + +--failSl sl m = fail $ show sl ++ ": " ++ m + +classHierarchyFromRecords rs = + CH (Map.fromList [ (className x,x)| x <- rs ]) mempty + +fromHsTyVar (HsTyVar v) = return v +fromHsTyVar (HsTyExpKind (Located _ t) _) = fromHsTyVar t +fromHsTyVar _ = fail "fromHsTyVar" + +-- We give all instance declarations the benefit of the doubt here, assuming +-- they are correct. It is up to the typechecking pass to find any errors. +makeClassHierarchy :: MonadWarn m => ClassHierarchy -> KindEnv -> [HsDecl] -> m ClassHierarchy +makeClassHierarchy (CH ch _is) kt ds = mconcat `liftM` mapM f ds where + f (HsClassDecl sl chead decls) = do + let qualifiedMethodAssumps = concatMap (aHsTypeSigToAssumps kt . qualifyMethod newClassContext) (filter isHsTypeSig decls) + newClassContext = [HsAsst className args] + className = hsClassHead chead + args = [ a | ~(Just a) <- map fromHsTyVar (hsClassHeadArgs chead) ] + return $ classHierarchyFromRecords [ClassRecord { + classArgs, + classAssocs, + classAlias = Nothing, + className = toName ClassName className, + classSrcLoc = sl, + classSupers = [ toName ClassName x | ~(HsAsst x _) <- cntxt], + classAssumps = qualifiedMethodAssumps }] + where + cntxt = hsClassHeadContext chead + classAssocs = createClassAssocs kt decls + (_,(_,classArgs')) = chToClassHead kt chead + classArgs = [ v | ~(TVar v) <- classArgs' ] +-- f decl@(HsClassAliasDecl {}) = trace ("makeClassHierarchy: "++show decl) $ do +-- tell [ClassAliasRecord { className = toName ClassName (hsDeclName decl), +-- classArgs = [v | ~(TVar v) <- map (runIdentity . hsTypeToType kt) (hsDeclTypeArgs decl)], +-- classSrcLoc = hsDeclSrcLoc decl, +-- classSupers = [toName ClassName n | HsAsst n _ <- (hsDeclContext decl)], +-- classClasses = [toName ClassName n | HsAsst n _ <- (hsDeclClasses decl)], +-- classInsts = [], +-- classMethodMap = Map.empty +-- }] + + f decl@(HsInstDecl {}) = hsInstDeclToInst kt decl >>= \insts -> do + return $ foldl (flip addInstanceToHierarchy) mempty insts + f decl@(HsDeclDeriving {}) = hsInstDeclToInst kt decl >>= \insts -> do + return $ foldl (flip addInstanceToHierarchy) mempty insts + f _ = return mempty + +checkForDuplicateInstaces :: MonadWarn m + => ClassHierarchy -- ^ imported class hierarchy + -> ClassHierarchy -- ^ locally defined hierarchy + -> m ClassHierarchy -- ^ possibly simplified local hierarchy +checkForDuplicateInstaces iCh (CH ch is) = mapM_ f (Map.toList is) >> return (CH ch is) where + f (className,is) = do + let is' = findClassInsts iCh className ++ is + sgu = sortGroupUnderFG fst snd [ ((cn,getTypeHead tt), i) | + i@Inst { instSrcLoc = sl, instHead = _ :=> IsIn cn tt } <- is' ] + mapM_ g sgu + g (_,[_]) = return () + g (_,sls) | all instDerived sls = return () + g ((ch,th),sls) = warn (instSrcLoc $ head sls) DuplicateInstances $ + printf "instance (%s (%s ..)) defined multiple times: %s" + (show ch) (show th) (show $ map instSrcLoc sls) + +accLen :: Int -> [[a]] -> [(Int, [a])] +accLen width [] = [] +accLen width (x:xs) = let newWidth = length x + width in (newWidth, x) : accLen newWidth xs + +groupStringsToWidth :: Int -> [String] -> [String] +groupStringsToWidth width ss = groupStringsToWidth' width (accLen 0 ss) where + groupStringsToWidth' :: Int -> [(Int,String)] -> [String] + groupStringsToWidth' width [] = [] + groupStringsToWidth' width xs + = headString : groupStringsToWidth' width (accLen 0 $ map snd rest) + where + (headSegments, rest) + = case span ((<=width).fst) xs of + ([], ss) -> ([head ss], tail ss) + anythingElse -> anythingElse + headString = concatMap snd headSegments + +showListAndSepInWidth :: (a -> String) -> Int -> String -> [a] -> String +showListAndSepInWidth _ _ _ [] = [] +showListAndSepInWidth f width sep things = unlines $ groupStringsToWidth width newThings where + newThings = (map ((\t -> t ++ sep).f) (init things)) ++ [f (last things)] + +pretty :: PPrint Doc a => a -> String +pretty = render . pprint + +{- +nameOfTyCon :: NameType -> HsType -> Name +nameOfTyCon t (HsTyCon n) = toName t n +nameOfTyCon t (HsTyTuple xs) = nameTuple t (length xs) +nameOfTyCon t (HsTyFun _ _) = tc_Arrow +nameOfTyCon _ t = error $ "nameOfTyCon: " ++ show t +-} + +groupEquations :: [HsDecl] -> [(Name, HsDecl)] +groupEquations [] = [] +groupEquations (HsTypeDecl {}:ds) = groupEquations ds +groupEquations (d:ds) = (getDeclName d, d) : groupEquations ds + +derivableClasses :: [Name] +derivableClasses = [ + class_Eq, + class_Ord, + class_Enum, + class_Bounded, + class_Show, + class_Read, + class_Ix + ] + +-- can be automatically derived when +-- the class is an enumeration +enumDerivableClasses :: [Name] +enumDerivableClasses = [ + class_Eq, + class_Ord, + class_Enum, + class_Ix + ] + +-- classes that cannot be derived by the generalized +-- newtype deriving mechanism. +noNewtypeDerivable :: [Name] +noNewtypeDerivable = [ + class_Show, + class_Read + ] + +-- classes that behave identically to their component when they have a single +-- unary constructor but are not newtypes +{- +unaryPassDerivable :: [Name] +unaryPassDerivable = [ + class_Ix, + class_Eq, + class_Ord, + class_Bounded + ] +-} + +$(derive makeBinary ''Inst) +$(derive makeBinary ''AssociatedType) +$(derive makeBinary ''ClassRecord) diff --git a/src/FrontEnd/HsSyn.hs b/src/FrontEnd/HsSyn.hs new file mode 100644 --- /dev/null +++ b/src/FrontEnd/HsSyn.hs @@ -0,0 +1,456 @@ +{-# LANGUAGE TemplateHaskell #-} +module FrontEnd.HsSyn where + +import Data.Binary +import Data.Generics +import Data.DeriveTH + +import C.FFI +import FrontEnd.SrcLoc +import Name.Name +import Name.Names +import Options +import StringTable.Atom +import StringTable.Atom() + +instance HasLocation HsAlt where + srcLoc (HsAlt sl _ _ _) = sl + +instance HasLocation HsExp where + srcLoc (HsCase _ xs) = srcLoc xs + srcLoc (HsExpTypeSig sl _ _) = sl + srcLoc (HsLambda sl _ _) = sl + srcLoc HsError { hsExpSrcLoc = sl } = sl + srcLoc _ = bogusASrcLoc + +hsNameIdent_u f n = mapName (id,f) n +hsIdentString_u f x = f x + +type HsName = Name + +instance Binary Module where + get = do + ps <- get + return (Module $ fromAtom ps) + put (Module n) = put (toAtom n) + +instance HasLocation HsModule where + srcLoc x = hsModuleSrcLoc x + +data HsModule = HsModule { + hsModuleName :: Module, + hsModuleSrcLoc :: SrcLoc, + hsModuleExports :: (Maybe [HsExportSpec]), + hsModuleImports :: [HsImportDecl], + hsModuleDecls :: [HsDecl], + hsModuleOptions :: [String], + hsModuleOpt :: Opt + } + +-- Export/Import Specifications + +data HsExportSpec + = HsEVar HsName -- variable + | HsEAbs HsName -- T + | HsEThingAll HsName -- T(..) + | HsEThingWith HsName [HsName] -- T(C_1,...,C_n) + | HsEModuleContents Module -- module M (not for imports) + | HsEQualified NameType HsExportSpec -- class Foo, type Bar, kind ANY + deriving(Eq,Show) + +instance HasLocation HsImportDecl where + srcLoc x = hsImportDeclSrcLoc x + +data HsImportDecl = HsImportDecl { + hsImportDeclSrcLoc :: SrcLoc, + hsImportDeclModule :: Module, + hsImportDeclQualified :: !Bool, + hsImportDeclAs :: (Maybe Module), + hsImportDeclSpec :: (Maybe (Bool,[HsExportSpec])) + } + deriving(Eq,Show) + +data HsAssoc = HsAssocNone | HsAssocLeft | HsAssocRight + deriving(Eq,Show) + +instance HasLocation HsDecl where + srcLoc HsTypeDecl { hsDeclSrcLoc = sl } = sl + srcLoc HsTypeFamilyDecl { hsDeclSrcLoc = sl } = sl + srcLoc HsDeclDeriving { hsDeclSrcLoc = sl } = sl + srcLoc HsSpaceDecl { hsDeclSrcLoc = sl } = sl + srcLoc HsDataDecl { hsDeclSrcLoc = sl } = sl + srcLoc HsInfixDecl { hsDeclSrcLoc = sl } = sl + srcLoc HsPragmaSpecialize { hsDeclSrcLoc = sl } = sl + srcLoc (HsPragmaRules rs) = srcLoc rs + srcLoc HsForeignDecl { hsDeclSrcLoc = sl } = sl + srcLoc HsActionDecl { hsDeclSrcLoc = sl } = sl + srcLoc (HsForeignExport sl _ _ _) = sl + srcLoc (HsClassDecl sl _ _) = sl + srcLoc HsClassAliasDecl { hsDeclSrcLoc = sl } = sl + srcLoc (HsInstDecl sl _ _) = sl + srcLoc (HsDefaultDecl sl _) = sl + srcLoc (HsTypeSig sl _ _) = sl + srcLoc (HsFunBind ms) = srcLoc ms + srcLoc (HsPatBind sl _ _ _) = sl + srcLoc (HsPragmaProps sl _ _) = sl + +instance HasLocation HsRule where + srcLoc HsRule { hsRuleSrcLoc = sl } = sl + +hsDataDecl = HsDataDecl { + hsDeclDeclType = DeclTypeData, + hsDeclSrcLoc = bogusASrcLoc, + hsDeclContext = [], + hsDeclName = error "hsDataDecl.hsDeclName", + hsDeclArgs = [], + hsDeclCons = [], + hsDeclHasKind = Nothing, + hsDeclCTYPE = Nothing, + hsDeclDerives = [] + } + +hsNewTypeDecl = hsDataDecl { + hsDeclDeclType = DeclTypeNewtype, + hsDeclName = error "hsNewTypeDecl.hsDeclName" + } + +data DeclType = DeclTypeData | DeclTypeNewtype | DeclTypeKind + deriving(Eq,Show) + +data HsDecl + = HsTypeFamilyDecl { + hsDeclSrcLoc :: SrcLoc, + hsDeclData :: !Bool, + hsDeclName :: HsName, + hsDeclTArgs :: [HsType], + hsDeclHasKind :: Maybe HsKind + } + | HsTypeDecl { + hsDeclSrcLoc :: SrcLoc, + hsDeclName :: HsName, + hsDeclTArgs :: [HsType], + hsDeclType :: HsType + } + | HsDataDecl { + hsDeclDeclType :: !DeclType, + hsDeclSrcLoc :: SrcLoc, + hsDeclContext :: HsContext, + hsDeclName :: HsName, + hsDeclArgs :: [Name], + hsDeclCons :: [HsConDecl], + hsDeclHasKind :: Maybe HsKind, + hsDeclCTYPE :: Maybe String, + {- deriving -} hsDeclDerives :: [HsName] + } + | HsInfixDecl { + hsDeclSrcLoc :: SrcLoc, + hsDeclAssoc :: HsAssoc, + hsDeclInt :: !Int, + hsDeclNames :: [HsName] + } + | HsClassDecl { + hsDeclSrcLoc :: SrcLoc, + hsDeclClassHead :: HsClassHead, + hsDeclDecls :: [HsDecl] + } + | HsClassAliasDecl { + hsDeclSrcLoc :: SrcLoc, + hsDeclName :: HsName, + hsDeclTypeArgs :: [HsType], + {- rhs -} hsDeclContext :: HsContext, + hsDeclClasses :: HsContext, + hsDeclDecls :: [HsDecl] + } + | HsInstDecl { + hsDeclSrcLoc :: SrcLoc, + hsDeclClassHead :: HsClassHead, + hsDeclDecls :: [HsDecl] + } + | HsDefaultDecl SrcLoc HsType + | HsTypeSig SrcLoc [HsName] HsQualType + | HsFunBind [HsMatch] + | HsPatBind SrcLoc HsPat HsRhs {-where-} [HsDecl] + | HsActionDecl { + hsDeclSrcLoc :: SrcLoc, + hsDeclPat :: HsPat, + hsDeclExp :: HsExp + } + | HsSpaceDecl { + hsDeclSrcLoc :: SrcLoc, + hsDeclName :: HsName, + hsDeclExp :: HsExp, + hsDeclCName :: Maybe String, + hsDeclCount :: Int, + hsDeclQualType :: HsQualType + } + | HsForeignDecl { + hsDeclSrcLoc :: SrcLoc, + hsDeclForeign :: FfiSpec, + hsDeclName :: HsName, + hsDeclQualType :: HsQualType + } + | HsForeignExport { + hsDeclSrcLoc :: SrcLoc, + hsDeclFFIExport :: FfiExport, + hsDeclName :: HsName, + hsDeclQualType ::HsQualType + } + | HsPragmaProps SrcLoc String [HsName] + | HsPragmaRules [HsRule] + | HsPragmaSpecialize { + hsDeclUniq :: (Module,Int), + hsDeclSrcLoc :: SrcLoc, + hsDeclBool :: Bool, + hsDeclName :: HsName, + hsDeclType :: HsType + } + | HsDeclDeriving { + hsDeclSrcLoc :: SrcLoc, + hsDeclClassHead :: HsClassHead + } + deriving(Eq,Show) + +data HsRule = HsRule { + hsRuleUniq :: (Module,Int), + hsRuleSrcLoc :: SrcLoc, + hsRuleIsMeta :: Bool, + hsRuleString :: String, + hsRuleFreeVars :: [(HsName,Maybe HsType)], + hsRuleLeftExpr :: HsExp, + hsRuleRightExpr :: HsExp + } + deriving(Eq,Show) + +data HsPragmaExp = HsPragmaExp String [HsExp] + +instance HasLocation HsMatch where + srcLoc (HsMatch sl _ _ _ _) = sl + +data HsMatch = HsMatch { + hsMatchSrcLoc :: SrcLoc, + hsMatchName :: HsName, + hsMatchPats :: [HsPat], + hsMatchRhs :: HsRhs, + {-where-} hsMatchDecls :: [HsDecl] + } + deriving(Eq,Show) + +data HsConDecl + = HsConDecl { + hsConDeclSrcLoc :: SrcLoc, + hsConDeclExists :: [HsTyVarBind], + hsConDeclName :: HsName, + hsConDeclConArg :: [HsBangType] + } + | HsRecDecl { + hsConDeclSrcLoc :: SrcLoc, + hsConDeclExists :: [HsTyVarBind], + hsConDeclName :: HsName, + hsConDeclRecArg :: [([HsName],HsBangType)] + } + deriving(Eq,Show) + +hsConDeclArgs HsConDecl { hsConDeclConArg = as } = as +hsConDeclArgs HsRecDecl { hsConDeclRecArg = as } = concat [ replicate (length ns) t | (ns,t) <- as] + +data HsBangType + = HsBangedTy { hsBangType :: HsType } + | HsUnBangedTy { hsBangType :: HsType } + deriving(Eq,Show) + +data HsRhs + = HsUnGuardedRhs HsExp + | HsGuardedRhss [HsGuardedRhs] + deriving(Eq,Show) + +data HsGuardedRhs = HsGuardedRhs SrcLoc HsExp HsExp + deriving(Eq,Show) + +data HsQualType = HsQualType { + hsQualTypeContext :: HsContext, + hsQualTypeType :: HsType + } deriving(Data,Typeable,Eq,Ord,Show) + +type LHsType = Located HsType + +data HsType + = HsTyFun HsType HsType + | HsTyTuple [HsType] + | HsTyUnboxedTuple [HsType] + | HsTyApp HsType HsType + | HsTyVar { hsTypeName :: HsName } + | HsTyCon { hsTypeName :: HsName } + | HsTyForall { + hsTypeVars :: [HsTyVarBind], + hsTypeType :: HsQualType } + | HsTyExists { + hsTypeVars :: [HsTyVarBind], + hsTypeType :: HsQualType } + | HsTyExpKind { + hsTyLType :: LHsType, + hsTyKind :: HsKind } + | HsTyStrictType { + hsTyStrict :: !Bool, + hsTyLType :: LHsType + } + -- the following is used internally + | HsTyAssoc + | HsTyEq HsType HsType + deriving(Data,Typeable,Eq,Ord,Show) + +data HsTyVarBind = HsTyVarBind { + hsTyVarBindSrcLoc :: SrcLoc, + hsTyVarBindName :: HsName, + hsTyVarBindKind :: Maybe HsKind } + deriving(Data,Typeable,Eq,Ord,Show) + +hsTyVarBind = HsTyVarBind { + hsTyVarBindSrcLoc = bogusASrcLoc, + hsTyVarBindName = undefined, + hsTyVarBindKind = Nothing + } + +instance HasLocation HsTyVarBind where + srcLoc = hsTyVarBindSrcLoc + +type HsContext = [HsAsst] + +data HsAsst = HsAsst HsName [HsName] | HsAsstEq HsType HsType + deriving(Data,Typeable,Eq,Ord, Show) + +data HsLiteral + = HsInt !Integer + | HsChar !Char + | HsString String + | HsFrac Rational + -- GHC unboxed literals: + | HsCharPrim Char + | HsStringPrim String + | HsIntPrim Integer + | HsFloatPrim Rational + | HsDoublePrim Rational + -- GHC extension: + | HsLitLit String + deriving(Eq,Ord, Show) + +hsParen x@HsVar {} = x +hsParen x@HsCon {} = x +hsParen x@HsParen {} = x +hsParen x@HsLit {} = x +hsParen x@HsTuple {} = x +hsParen x@HsUnboxedTuple {} = x +hsParen x = HsParen x + +data HsErrorType + = HsErrorPatternFailure + | HsErrorSource + | HsErrorFieldSelect + | HsErrorUnderscore + | HsErrorUninitializedField + | HsErrorRecordUpdate + deriving(Eq,Show) + +type LHsExp = Located HsExp + +data HsExp + = HsVar { {-hsExpSrcSpan :: SrcSpan,-} hsExpName :: HsName } + | HsCon { {-hsExpSrcSpan :: SrcSpan,-} hsExpName :: HsName } + | HsLit HsLiteral + | HsInfixApp HsExp HsExp HsExp + | HsApp HsExp HsExp + | HsNegApp HsExp + | HsLambda SrcLoc [HsPat] HsExp + | HsLet [HsDecl] HsExp + | HsIf HsExp HsExp HsExp + | HsCase HsExp [HsAlt] + | HsDo { hsExpStatements :: [HsStmt] } + | HsTuple [HsExp] + | HsUnboxedTuple [HsExp] + | HsList [HsExp] + | HsParen HsExp + | HsLeftSection HsExp HsExp + | HsRightSection HsExp HsExp + | HsRecConstr HsName [HsFieldUpdate] + | HsRecUpdate HsExp [HsFieldUpdate] + | HsEnumFrom HsExp + | HsEnumFromTo HsExp HsExp + | HsEnumFromThen HsExp HsExp + | HsEnumFromThenTo HsExp HsExp HsExp + | HsListComp HsExp [HsStmt] + | HsExpTypeSig SrcLoc HsExp HsQualType + | HsAsPat { hsExpName :: HsName, hsExpExp :: HsExp } + | HsError { hsExpSrcLoc :: SrcLoc, hsExpErrorType :: HsErrorType, hsExpString :: String } + | HsWildCard SrcLoc + | HsIrrPat { hsExpLExp :: LHsExp } + | HsBangPat { hsExpLExp :: LHsExp } + | HsLocatedExp LHsExp + deriving(Eq,Show) + +data HsClassHead = HsClassHead { + hsClassHeadContext :: HsContext, + hsClassHead :: HsName, + hsClassHeadArgs :: [HsType] } + deriving(Eq,Show) + +type LHsPat = Located HsPat + +data HsPat + = HsPVar { hsPatName :: HsName } + | HsPLit { hsPatLit :: HsLiteral } + | HsPNeg HsPat + | HsPInfixApp HsPat HsName HsPat + | HsPApp { hsPatName :: HsName, hsPatPats :: [HsPat] } + | HsPTuple [HsPat] + | HsPUnboxedTuple [HsPat] + | HsPList [HsPat] + | HsPParen HsPat + | HsPRec HsName [HsPatField] + | HsPAsPat { hsPatName :: HsName, hsPatPat :: HsPat } + | HsPWildCard + | HsPIrrPat { hsPatLPat :: LHsPat } + | HsPBangPat { hsPatLPat :: LHsPat } + | HsPTypeSig SrcLoc HsPat HsQualType -- scoped type variable extension + deriving(Eq,Ord,Show) + +data HsPatField = HsPFieldPat HsName HsPat + deriving(Eq,Ord,Show) + +data HsStmt + = HsGenerator SrcLoc HsPat HsExp -- srcloc added by bernie + | HsQualifier HsExp + | HsLetStmt [HsDecl] + deriving(Eq,Show) + +data HsFieldUpdate = HsFieldUpdate HsName HsExp + deriving(Eq,Show) + +data HsAlt = HsAlt SrcLoc HsPat HsRhs [HsDecl] + deriving(Eq,Show) + +data HsKind = HsKind HsName | HsKindFn HsKind HsKind + deriving(Data,Typeable,Eq,Ord,Show) + +hsKindStar = HsKind s_Star +hsKindHash = HsKind s_Hash +hsKindBang = HsKind s_Bang +hsKindQuest = HsKind s_Quest +hsKindQuestQuest = HsKind s_QuestQuest +hsKindStarBang = HsKind s_StarBang + +$(derive makeUpdate ''HsModule) +$(derive makeBinary ''HsAssoc) +$(derive makeIs ''HsDecl) +$(derive makeIs ''HsConDecl) +$(derive makeUpdate ''HsConDecl) +$(derive makeBinary ''HsQualType) +$(derive makeBinary ''HsType) +$(derive makeIs ''HsType) +$(derive makeBinary ''HsTyVarBind) +$(derive makeUpdate ''HsTyVarBind) +$(derive makeBinary ''HsAsst) +$(derive makeIs ''HsLiteral) +$(derive makeIs ''HsExp) +$(derive makeUpdate ''HsExp) +$(derive makeUpdate ''HsClassHead) +$(derive makeIs ''HsPat) +$(derive makeBinary ''HsKind) diff --git a/src/FrontEnd/KindInfer.hs b/src/FrontEnd/KindInfer.hs new file mode 100644 --- /dev/null +++ b/src/FrontEnd/KindInfer.hs @@ -0,0 +1,628 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS -funbox-strict-fields #-} +-- | +-- This module implements the Kind Inference algorithm, and the routines which +-- use the product of kind inference to convert haskell source types into the +-- simplified kind annotated types used by the rest of the FrontEnd. + +module FrontEnd.KindInfer ( + kiDecls, + KindEnv(), + hsQualTypeToSigma, + hsAsstToPred, + kiHsQualType, + kindOfClass, + kindOf, + restrictKindEnv, + hsTypeToType, + getConstructorKinds + ) where + +import Control.Monad.Identity +import Control.Monad.Reader +import Control.Monad.Writer +import Data.Binary +import Data.Generics(Typeable, everything, mkQ) +import Data.DeriveTH +import Data.IORef +import Data.List +import System.IO.Unsafe +import Util.Inst() +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Traversable as T + +import Doc.DocLike +import Doc.PPrint +import FrontEnd.HsSyn +import FrontEnd.SrcLoc +import FrontEnd.Tc.Kind +import FrontEnd.Tc.Type +import FrontEnd.Utils +import FrontEnd.Warning +import Name.Name +import Options +import Support.FreeVars +import Support.MapBinaryInstance +import Util.ContextMonad +import Util.HasSize +import qualified FlagDump as FD +import qualified Util.Seq as Seq + +data KindEnv = KindEnv { + kindEnv :: Map.Map Name Kind, + kindEnvAssocs :: Map.Map Name (Int,Int), + kindEnvClasses :: Map.Map Name [Kind] + } deriving(Typeable,Show) + +instance Binary KindEnv where + put KindEnv { kindEnv = a, kindEnvAssocs = b, kindEnvClasses = c } = + putMap a >> putMap b >> putMap c + get = do + a <- getMap + b <- getMap + c <- getMap + return KindEnv { kindEnv = a, kindEnvAssocs = b, kindEnvClasses = c } + +instance HasSize KindEnv where + size KindEnv { kindEnv = env } = size env + +instance FreeVars Kind (Set.Set Kindvar) where + freeVars (KVar kindvar) = Set.singleton kindvar + freeVars (kind1 `Kfun` kind2) = freeVars kind1 `Set.union` freeVars kind2 + freeVars KBase {} = mempty + +instance DocLike d => PPrint d KindEnv where + pprint KindEnv { kindEnv = m, kindEnvAssocs = ev, kindEnvClasses = cs } = vcat $ + [ pprint x <+> text "=>" <+> pprint y | (x,y) <- Map.toList m] ++ + [ text "associated type" <+> pprint n <+> pprint ab | (n,ab) <- Map.toList ev] ++ + [ text "class" <+> pprint n <+> pprint ab | (n,ab) <- Map.toList cs] ++ + [empty] + +-------------------------------------------------------------------------------- + +-- The kind inference monad + +data KiWhere = InClass | InInstance | Other + deriving(Eq) + +data KiEnv = KiEnv { + kiSrcLoc :: SrcLoc, + kiContext :: [String], + kiEnv :: !(IORef KindEnv), + kiWhere :: !KiWhere, + kiVarnum :: !(IORef Int) + } + +newtype Ki a = Ki (ReaderT KiEnv IO a) + deriving(Monad,MonadReader KiEnv,MonadIO,Functor,MonadWarn) + +instance MonadSrcLoc Ki where + getSrcLoc = asks kiSrcLoc +instance MonadSetSrcLoc Ki where + withSrcLoc sl = local (\s -> s { kiSrcLoc = sl }) + +restrictKindEnv :: (Name -> Bool) -> KindEnv -> KindEnv +restrictKindEnv f ke = ke { kindEnv = Map.filterWithKey (\k _ -> f k) (kindEnv ke) } + +findKind :: MonadIO m => Kind -> m Kind +findKind tv@(KVar Kindvar {kvarRef = r, kvarConstraint = con }) = liftIO $ do + rt <- readIORef r + case rt of + Nothing + | con == KindStar -> writeIORef r (Just kindStar) >> return kindStar + | otherwise -> return tv + Just t -> do + t' <- findKind t + writeIORef r (Just t') + return t' +findKind tv = return tv + +-- useful operations in the inference monad + +runKI :: KindEnv -> Ki a -> IO a +runKI env (Ki ki) = (kienv >>= ki') where + kienv = do + env <- newIORef env + varnum <- newIORef 0 + return KiEnv { + kiSrcLoc = bogusASrcLoc, + kiContext = [], + kiEnv = env, + kiVarnum = varnum, + kiWhere = Other } + ki' e = runReaderT ki e + +instance ContextMonad Ki where + type ContextOf Ki = String + withContext nc x = local (\s -> s { kiContext = nc :kiContext s }) x + +getEnv :: Ki KindEnv +getEnv = do asks kiEnv >>= liftIO . readIORef + +unify :: Kind -> Kind -> Ki () +unify k1 k2 = do + k1 <- flattenKind k1 + k2 <- flattenKind k2 + printRule $ "unify:" <+> pprint k1 <+> text "<->" <+> pprint k2 + mgu k1 k2 + +mgu :: Kind -> Kind -> Ki () +mgu (KBase a) (KBase b) | a == b = return () +mgu (Kfun a b) (Kfun a' b') = do + unify a a' + unify b b' +mgu (KVar u) k = varBind u k +mgu k (KVar u) = varBind u k +mgu k1 k2 = addWarn UnificationError $ + "kind unification error, attempt to unify (" ++ show k1 ++ ") with (" ++ show k2 ++ ")" + +varBind :: Kindvar -> Kind -> Ki () +varBind u k = do + k <- flattenKind k + printRule $ "varBind:" <+> pprint u <+> text ":=" <+> pprint k + if k == KVar u then return () else do + when (u `Set.member` freeVars k) $ addWarn OccursCheck $ "occurs check failed in kind inference: " ++ show u ++ " := " ++ show k + v <- liftIO $ readIORef (kvarRef u) + case v of + Just v -> fail $ "varBind unfree" + Nothing -> do + liftIO $ writeIORef (kvarRef u) (Just k) + constrain (kvarConstraint u) k + +zonkConstraint :: KindConstraint -> Kindvar -> Ki () +zonkConstraint nk mv = do + let fk = mappend nk (kvarConstraint mv) + if fk == kvarConstraint mv then return () else do + nref <- liftIO $ newIORef Nothing + let nmv = mv { kvarConstraint = fk, kvarRef = nref } + liftIO $ modifyIORef (kvarRef mv) (\Nothing -> Just $ KVar nmv) + +constrain KindAny k = return () +constrain KindStar (KBase Star) = return () +constrain KindQuest k@KBase {} = kindCombine kindFunRet k >> return () +constrain KindQuestQuest (KBase KQuest) = fail "cannot constrain ? to be ??" +constrain KindQuestQuest k@KBase {} = kindCombine kindArg k >> return () +constrain KindSimple (KBase Star) = return () +constrain KindSimple (a `Kfun` b) = do + a <- findKind a + b <- findKind b + constrain KindSimple a + constrain KindSimple b +constrain con (KVar v) = zonkConstraint con v +constrain con k = fail $ "constraining kind: " ++ show (con,k) + +flattenKind :: Kind -> Ki Kind +flattenKind k = f' k where + f (a `Kfun` b) = return Kfun `ap` f' a `ap` f' b + f k = return k + f' k = findKind k >>= f + +newKindVar :: KindConstraint -> Ki Kindvar +newKindVar con = do + KiEnv { kiVarnum = vr } <- ask + liftIO $ do + n <- readIORef vr + writeIORef vr $! (n + 1) + nr <- newIORef Nothing + return Kindvar { kvarUniq = n, kvarRef = nr, kvarConstraint = con } + +lookupKind :: KindConstraint -> Name -> Ki Kind +lookupKind con name = do + KindEnv { kindEnv = env } <- getEnv + case Map.lookup name env of + Just k -> do + k <- f k + k <- findKind k + constrain con k + findKind k + Nothing -> do + kv <- newKindVar con + extendEnv mempty { kindEnv = Map.singleton name (KVar kv) } + return (KVar kv) + where + -- ?? and ? aren't *really* kinds + f (KBase KQuestQuest) = liftM KVar $ newKindVar KindQuestQuest + f (KBase KQuest) = liftM KVar $ newKindVar KindQuest + f k@(KBase _) = return k + f (Kfun k1 k2) = liftM2 Kfun (f k1) (f k2) + f k@(KVar _) = return k + +extendEnv :: KindEnv -> Ki () +extendEnv newEnv = do + ref <- asks kiEnv + liftIO $ modifyIORef ref (mappend newEnv) -- (\ (KindEnv env x) -> KindEnv (env `Map.union` newEnv) (nx `mappend` x)) + +getConstructorKinds :: KindEnv -> Map.Map Name Kind +getConstructorKinds ke = kindEnv ke -- Map.fromList [ (toName TypeConstructor x,y) | (x,y)<- Map.toList m] + +-------------------------------------------------------------------------------- + +-- kind inference proper +-- this is what gets called from outside of this module + +printRule :: String -> Ki () +printRule s + | dump FD.KindSteps = liftIO $ putStrLn s + | otherwise = return () + +{-# NOINLINE kiDecls #-} +kiDecls :: KindEnv -> [HsDecl] -> IO KindEnv +kiDecls inputEnv classAndDataDecls = ans where + ans = do + ke <- run + return ke -- TODO (Map.fromList (concatMap kgAssocs kindGroups) `mappend` as)) + run = runKI inputEnv $ withContext ("kiDecls: " ++ show (map getDeclName classAndDataDecls)) $ do + kiInitClasses classAndDataDecls + mapM_ kiDecl classAndDataDecls + getEnv >>= postProcess + +postProcess ke = do + kindEnv <- T.mapM flattenKind (kindEnv ke) + kindEnvClasses <- T.mapM (mapM flattenKind) (kindEnvClasses ke) + let defs = Set.toList (freeVars (Map.elems kindEnv,Map.elems kindEnvClasses)) + printRule $ "defaulting the following kinds: " ++ pprint defs + mapM_ (flip varBind kindStar) defs + kindEnv <- T.mapM flattenKind kindEnv + kindEnvClasses <- T.mapM (mapM flattenKind) kindEnvClasses + return ke { kindEnvClasses = kindEnvClasses, kindEnv = kindEnv } + +kiType,kiType' :: Kind -> HsType -> Ki () +kiType' k t = do + k <- findKind k + kiType k t + +kiType k (HsTyTuple ts) = do + unify kindStar k + mapM_ (kiType' kindStar) ts +kiType k (HsTyUnboxedTuple ts) = do + unify kindUTuple k + flip mapM_ ts $ \t -> do + kt <- newKindVar KindQuestQuest + kiType (KVar kt) t +kiType k (HsTyFun a b) = do + unify kindStar k + ka <- newKindVar KindQuestQuest + kb <- newKindVar KindQuest + kiType (KVar ka) a + kiType (KVar kb) b +kiType k (HsTyApp a b) = do + kv <- newKindVar KindAny + kiType (KVar kv `Kfun` k) a + kiType' (KVar kv) b +kiType k (HsTyVar v) = do + kv <- lookupKind KindAny (toName TypeVal v) + unify k kv +kiType k (HsTyCon v) = do + kv <- lookupKind KindAny (toName TypeConstructor v) + unify k kv +kiType k HsTyAssoc = do + constrain KindSimple k +kiType _ HsTyEq {} = error "kiType.HsTyEq" +kiType k HsTyForall { hsTypeVars = vs, hsTypeType = HsQualType con t } = do + mapM_ initTyVarBind vs + mapM_ kiPred con + kiType' k t +kiType k HsTyExpKind { hsTyLType = Located _ t, hsTyKind = ek } = do + unify (hsKindToKind ek) k + kiType' k t +kiType k HsTyExists { hsTypeVars = vs, hsTypeType = HsQualType con t } = do + mapM_ initTyVarBind vs + mapM_ kiPred con + kiType' k t +kiType _ _ = error "KindInfer.kiType: bad." + +initTyVarBind HsTyVarBind { hsTyVarBindName = name, hsTyVarBindKind = kk } = do + nk <- lookupKind KindSimple (toName TypeVal name) + case kk of + Nothing -> return () + Just kk -> unify nk (hsKindToKind kk) + +hsKindToKind (HsKindFn a b) = hsKindToKind a `Kfun` hsKindToKind b +hsKindToKind a | a == hsKindStar = kindStar + | a == hsKindHash = kindHash + | a == hsKindQuest = kindFunRet + | a == hsKindQuestQuest = kindArg +hsKindToKind (HsKind n) = KBase (KNamed (toName SortName n)) +-- hsKindToKind (HsKind n) = toName SortName n + +kiApps :: Kind -> [HsType] -> Kind -> Ki () +kiApps ca args fk = f ca args fk where + f ca [] fk = unify ca fk + f (x `Kfun` y) (a:as) fk = do + kiType' x a + y <- findKind y + f y as fk + f (KVar var) as fk = do + x <- newKindVar KindAny + y <- newKindVar KindAny + let nv = (KVar x `Kfun` KVar y) + varBind var nv + f nv as fk + f _ _ _ = error "KindInfer.kiApps: bad." + +kiApps' :: Kind -> [Kind] -> Kind -> Ki () +kiApps' ca args fk = f ca args fk where + f ca [] fk = unify ca fk + f (x `Kfun` y) (a:as) fk = do + unify a x + y <- findKind y + f y as fk + f (KVar var) as fk = do + x <- newKindVar KindAny + y <- newKindVar KindAny + let nv = (KVar x `Kfun` KVar y) + varBind var nv + f nv as fk + f _ _ _ = error "KindInfer.kiApps': bad." + +kiPred :: HsAsst -> Ki () +kiPred asst@(HsAsst n ns) = do + env <- getEnv + let f k n = do + k' <- lookupKind KindAny (toName TypeVal n) + unify k k' + case Map.lookup n (kindEnvClasses env) of + Nothing -> do + addWarn (UndefinedName n) ("Incorrect number of class parameters for " ++ show asst) +-- ,fail $ "unknown class: " ++ show asst + Just ks -> do + when (length ks /= length ns) $ + addWarn InvalidDecl ("Incorrect number of class parameters for " ++ show n) + zipWithM_ f ks ns +kiPred (HsAsstEq a b) = do + mv <- newKindVar KindSimple + kiType (KVar mv) a + kiType' (KVar mv) b + +-- first pass over declarations adds classes to environment. +kiInitClasses :: [HsDecl] -> Ki () +kiInitClasses ds = do mapM_ kiInitDecl ds + +kiInitDecl :: HsDecl -> Ki () +kiInitDecl d = withSrcLoc (srcLoc d) (f d) where + f HsClassDecl { .. } = do + args <- mapM (\_ -> newKindVar KindAny) (hsClassHeadArgs hsDeclClassHead) + extendEnv mempty { kindEnvClasses = + Map.singleton (hsClassHead hsDeclClassHead) (map KVar args) } + f _ = return () +kiDecl :: HsDecl -> Ki () +kiDecl d = withSrcLoc (srcLoc d) (f d) where + varLike HsTyVar {} = True + varLike HsTyExpKind { hsTyLType = Located _ t } = varLike t + varLike _ = False + consLike (HsTyFun a b) = varLike a && varLike b + consLike (HsTyTuple ts) = all varLike ts + consLike t = case fromHsTypeApp t of + (HsTyCon {},as) -> all varLike as + _ -> False + f HsTypeFamilyDecl { .. } = do + kc <- lookupKind KindSimple (toName TypeConstructor hsDeclName) + kiApps kc hsDeclTArgs (maybe kindStar hsKindToKind hsDeclHasKind) + f HsDataDecl { hsDeclDeclType = DeclTypeKind, .. } = kiDataKind hsDeclName hsDeclCons + f HsDataDecl { + hsDeclContext = context, + hsDeclName = tyconName, + hsDeclArgs = args, + hsDeclCons = [], + hsDeclHasKind = Just kk } = do + args <- mapM (lookupKind KindSimple . toName TypeVal) args + kc <- lookupKind KindAny (toName TypeConstructor tyconName) + kiApps' kc args (hsKindToKind kk) + mapM_ kiPred context + f HsDataDecl { hsDeclDeclType = DeclTypeNewtype, .. } = kiAlias hsDeclContext hsDeclName hsDeclArgs (head hsDeclCons) + f HsDataDecl { .. } = kiData hsDeclContext hsDeclName hsDeclArgs hsDeclCons + f HsTypeDecl { hsDeclName = name, hsDeclTArgs = args, hsDeclType = ty } = do + wh <- asks kiWhere + let theconstraint = if wh == Other then KindAny else KindSimple + kc <- lookupKind theconstraint (toName TypeConstructor name) + mv <- newKindVar theconstraint + kiApps kc args (KVar mv) + kiType' (KVar mv) ty + f (HsTypeSig _ _ (HsQualType ps t)) = do + mapM_ kiPred ps + kiType kindStar t + f (HsClassDecl _sloc HsClassHead { .. } sigsAndDefaults) = do + when (length hsClassHeadArgs /= 1) $ + addWarn UnsupportedFeature "Multi-parameter type classes not supported" + unless (all varLike hsClassHeadArgs) $ + addWarn InvalidDecl "Class parameters must be variables" + env <- getEnv + let ks = kindOfClass hsClassHead env + [fromHsTyVar -> Just classArg] = hsClassHeadArgs + zipWithM_ kiType' ks hsClassHeadArgs + mapM_ kiPred hsClassHeadContext + let rn = Seq.toList $ everything (Seq.<>) (mkQ Seq.empty g) newClassBodies + newClassBodies = map typeFromSig $ filter isHsTypeSig sigsAndDefaults + typeFromSig (HsTypeSig _sloc _names qualType) = qualType + typeFromSig _ = error "KindInfer.typeFromSig: bad." + g (HsTyVar n') | hsNameToOrig n' == hsNameToOrig classArg = Seq.single (toName TypeVal n') + g _ = Seq.empty + carg <- lookupKind KindSimple (toName TypeVal classArg) + mapM_ (\n -> lookupKind KindSimple n >>= unify carg ) rn + local (\e -> e { kiWhere = InClass }) $ mapM_ kiDecl sigsAndDefaults + f HsDeclDeriving { hsDeclClassHead = ch } = checkInstance ch + f HsInstDecl { hsDeclClassHead = ch } = checkInstance ch + f _ = return () + checkInstance HsClassHead { .. } = do + unless (all consLike hsClassHeadArgs) $ + addWarn InvalidDecl "Instance parameters must be of the form 'C v1 v2'" + mapM_ kiPred hsClassHeadContext + env <- getEnv + let ks = kindOfClass hsClassHead env + when (length ks /= length hsClassHeadArgs) $ + addWarn InvalidDecl "Incorrect number of class parameters in instance head" + zipWithM_ kiType' ks hsClassHeadArgs + -- HsQualType contxt (HsTyApp (HsTyCon _className) (HsTyVar classArg)) = qualType + -- ans = do + -- carg <- lookupKind KindSimple (toName TypeVal classArg) + -- mapM_ kiPred contxt +-- extendEnv mempty { kindEnvAssocs = Map.fromList assocs } +-- mapM_ (\n -> lookupKind KindSimple n >>= unify carg ) rn +-- local (\e -> e { kiWhere = InClass }) $ mapM_ kiDecl sigsAndDefaults + +-- numClassArgs = 1 +-- newAssocs = [ (name,[ n | ~(HsTyVar n) <- names],t,names) | HsTypeDecl _sloc name names t <- sigsAndDefaults ] +-- assocs = [ (toName TypeConstructor n,(numClassArgs,length names - numClassArgs)) | (n,names,_,_) <- newAssocs ] +-- rn = Seq.toList $ everything (Seq.<>) (mkQ Seq.empty f) (newClassBodies,newAssocs) +-- newClassBodies = map typeFromSig $ filter isHsTypeSig sigsAndDefaults +-- f (HsTyVar n') | hsNameToOrig n' == hsNameToOrig classArg = Seq.single (toName TypeVal n') +-- f _ = Seq.empty +-- typeFromSig :: HsDecl -> HsQualType +-- typeFromSig (HsTypeSig _sloc _names qualType) = qualType + +fromHsTypeApp t = f t [] where + f (HsTyApp a b) rs = f a (b:rs) + f t rs = (t,rs) + +kiAlias context tyconName args condecl = do + args <- mapM (lookupKind KindSimple . toName TypeVal) args + kc <- lookupKind KindAny (toName TypeConstructor tyconName) + let [a] = hsConDeclArgs condecl + va <- newKindVar KindQuestQuest + kiApps' kc args (KVar va) + kiType (KVar va) (hsBangType a) + mapM_ kiPred context + +kiData context tyconName args condecls = do + args <- mapM (lookupKind KindSimple . toName TypeVal) args + kc <- lookupKind KindSimple (toName TypeConstructor tyconName) + kiApps' kc args kindStar + mapM_ kiPred context + flip mapM_ (concatMap (map hsBangType . hsConDeclArgs) condecls) $ \t -> do + v <- newKindVar KindQuestQuest + kiType (KVar v) t + +kiDataKind tyconName condecls = do + unless (nameType tyconName == SortName) $ fail "tycon isn't sort" + flip mapM_ condecls $ \ HsConDecl { .. } -> do + kc <- lookupKind KindAny (toName TypeConstructor hsConDeclName) + let args = [ KBase (KNamed t) | HsTyCon t <- map hsBangType hsConDeclConArg ] + kiApps' kc args (KBase (KNamed tyconName)) + +kiHsQualType :: KindEnv -> HsQualType -> KindEnv +kiHsQualType inputEnv qualType@(HsQualType ps t) = newState where + newState = unsafePerformIO $ runKI inputEnv $ withContext ("kiHsQualType: " ++ show qualType) $ do + kiType kindStar t + mapM_ kiPred ps + getEnv >>= postProcess + +-------------------------------------------------------------------------------- + +kindOf :: Name -> KindEnv -> Kind +kindOf name KindEnv { kindEnv = env } = case Map.lookup name env of +-- Nothing | nameType name `elem` [TypeConstructor,TypeVal] -> kindStar + Just k -> k + _ -> error $ "kindOf: could not find kind of : " ++ show (nameType name,name) + +kindOfClass :: Name -> KindEnv -> [Kind] +kindOfClass name KindEnv { kindEnvClasses = cs } = case Map.lookup name cs of + --Nothing -> Star + --Nothing -> error $ "kindOf: could not find kind of class : " ++ show (nameType name,name) + Nothing -> [] -- error $ "kindOf: could not find kind of class : " ++ show (nameType name,name) + Just k -> k + +---------------------- +-- Conversion of Types +---------------------- + +fromTyApp t = f t [] where + f (HsTyApp a b) rs = f a (b:rs) + f t rs = (t,rs) + +aHsTypeToType :: KindEnv -> HsType -> Type +aHsTypeToType kt@KindEnv { kindEnvAssocs = at } t | (HsTyCon con,xs) <- fromTyApp t, let nn = toName TypeConstructor con, Just (n1,n2) <- Map.lookup nn at = + TAssoc { + typeCon = Tycon nn (kindOf nn kt), + typeClassArgs = map (aHsTypeToType kt) (take n1 xs), + typeExtraArgs = map (aHsTypeToType kt) (take n2 $ drop n1 xs) + } +aHsTypeToType kt (HsTyFun t1 t2) = aHsTypeToType kt t1 `fn` aHsTypeToType kt t2 +aHsTypeToType kt HsTyExpKind { hsTyLType = Located _ t } = aHsTypeToType kt t +aHsTypeToType kt tuple@(HsTyTuple types) = tTTuple $ map (aHsTypeToType kt) types +aHsTypeToType kt tuple@(HsTyUnboxedTuple types) = tTTuple' $ map (aHsTypeToType kt) types +aHsTypeToType kt (HsTyApp t1 t2) = tAp (aHsTypeToType kt t1) (aHsTypeToType kt t2) + +-- variables, we must know the kind of the variable here! +-- they are assumed to already exist in the kindInfoTable +-- which was generated by the process of KindInference + +aHsTypeToType kt (HsTyVar name) = TVar $ toTyvar kt name -- tyvar name (kindOf name kt) Nothing + +-- type constructors, we must know the kind of the constructor. +-- here we also qualify the type constructor if it is +-- currently unqualified + +aHsTypeToType kt (HsTyCon name) = TCon $ Tycon nn (kindOf nn kt) where + nn = (toName TypeConstructor name) + +aHsTypeToType kt (HsTyForall vs qt) = TForAll (map (toTyvar kt . hsTyVarBindName) vs) (aHsQualTypeToQualType kt qt) +aHsTypeToType kt (HsTyExists vs qt) = TExists (map (toTyvar kt . hsTyVarBindName) vs) (aHsQualTypeToQualType kt qt) + +aHsTypeToType _ t = error $ "aHsTypeToType: " ++ show t + +toTyvar kt name = tyvar nn (kindOf nn kt) where + nn = toName TypeVal name + +aHsQualTypeToQualType :: KindEnv -> HsQualType -> Qual Type +aHsQualTypeToQualType kt (HsQualType cntxt t) = map (hsAsstToPred kt) cntxt :=> aHsTypeToType kt t + +hsAsstToPred :: KindEnv -> HsAsst -> Pred +hsAsstToPred kt (HsAsst className [varName]) + -- = IsIn className (TVar $ Tyvar varName (kindOf varName kt)) + | isConstructorLike varName = IsIn (toName ClassName className) (TCon (Tycon (toName TypeConstructor varName) (head $ kindOfClass (toName ClassName className) kt))) + | otherwise = IsIn (toName ClassName className) (TVar $ tyvar (toName TypeVal varName) (head $ kindOfClass (toName ClassName className) kt)) +hsAsstToPred kt (HsAsstEq t1 t2) = IsEq (runIdentity $ hsTypeToType' kt t1) (runIdentity $ hsTypeToType' kt t2) +hsAsstToPred _ _ = error "KindInfer.hsAsstToPred: bad." + +hsQualTypeToSigma kt qualType = hsQualTypeToType kt (Just []) qualType + +hsTypeToType :: Monad m => KindEnv -> HsType -> m Type +hsTypeToType kt t = return $ unsafePerformIO $ runKI kt $ + do kv <- newKindVar KindAny + kiType (KVar kv) t + kt' <- postProcess =<< getEnv + hsTypeToType' kt' t + +hsTypeToType' :: Monad m => KindEnv -> HsType -> m Type +hsTypeToType' kt t = return $ hoistType $ aHsTypeToType kt t -- (forallHoist t) + +hsQualTypeToType :: Monad m => + KindEnv -- ^ the kind environment + -> Maybe [HsName] -- ^ universally quantify free variables excepting those in list. + -> HsQualType -- ^ the type to convert + -> m Sigma +hsQualTypeToType kindEnv qs qualType = return $ hoistType $ tForAll quantOver ( ps' :=> t') where + newEnv = kiHsQualType kindEnv qualType + --newEnv = kindEnv + Just t' = hsTypeToType' newEnv (hsQualTypeType qualType) + ps = hsQualTypeContext qualType + ps' = map (hsAsstToPred newEnv) ps + quantOver = nub $ freeVars ps' ++ fvs + fvs = case qs of + Nothing -> [] + Just xs -> [ v | v <- freeVars t', nameName (tyvarName v) `notElem` xs] + +hoistType :: Type -> Type +hoistType t = f t where + f t@TVar {} = t + f t@TCon {} = t + f t@TMetaVar {} = t + f t@TAssoc {} = t { typeClassArgs = map f (typeClassArgs t), typeExtraArgs = map f (typeExtraArgs t) } + f (TAp a b) = TAp (f a) (f b) + f (TForAll vs (ps :=> (f -> nt))) + | (TForAll vs' (ps' :=> t')) <- nt = f $ TForAll (vs ++ vs') ((ps ++ ps') :=> t') + | otherwise = TForAll vs (ps :=> nt) + f (TExists vs (ps :=> (f -> nt))) + | (TExists vs' (ps' :=> t')) <- nt = f $ TExists (vs ++ vs') ((ps ++ ps') :=> t') + | otherwise = TExists vs (ps :=> nt) + f (TArrow (f -> na) (f -> nb)) + | TForAll vs (ps :=> t) <- nb = f $ TForAll vs (ps :=> TArrow na t) + | TExists vs (ps :=> t) <- na = f $ TForAll vs (ps :=> TArrow t nb) + | otherwise = TArrow na nb + +fromHsTyVar (HsTyVar v) = return v +fromHsTyVar (HsTyExpKind (Located _ t) _) = fromHsTyVar t +fromHsTyVar _ = fail "fromHsTyVar" + +$(derive makeMonoid ''KindEnv) diff --git a/src/FrontEnd/ParseUtils.hs b/src/FrontEnd/ParseUtils.hs --- a/src/FrontEnd/ParseUtils.hs +++ b/src/FrontEnd/ParseUtils.hs @@ -407,6 +407,7 @@ pconv rs = g Safe CCall rs where g _ cc ("safe":rs) = g Safe cc rs g _ cc ("unsafe":rs) = g Unsafe cc rs + g _ cc ("jhc_context":rs) = g JhcContext cc rs g s _ ("ccall":rs) = g s CCall rs g s _ ("capi":rs) = g s CApi rs g s _ ("stdcall":rs) = g s StdCall rs diff --git a/src/FrontEnd/Representation.hs b/src/FrontEnd/Representation.hs new file mode 100644 --- /dev/null +++ b/src/FrontEnd/Representation.hs @@ -0,0 +1,320 @@ +{-# LANGUAGE TemplateHaskell #-} +module FrontEnd.Representation( + Type(..), + Tyvar(..), + tyvar, + Tycon(..), + fn, + Pred(..), + Qual(..), + Class, + tForAll, + tExists, + MetaVarType(..), + prettyPrintType, + fromTAp, + fromTArrow, + tassocToAp, + MetaVar(..), + tTTuple, + tTTuple', + tList, + tArrow, + tAp + )where + +import Control.Monad.Identity +import Data.IORef + +import Data.Binary +import Data.DeriveTH +import Doc.DocLike +import Doc.PPrint +import FrontEnd.Tc.Kind +import Name.Name +import Name.Names +import Name.VConsts +import Support.CanType +import Support.Unparse +import Util.VarName + +-- Types + +data MetaVarType = Tau | Rho | Sigma + deriving(Eq,Ord) + +data Type = TVar { typeVar :: !Tyvar } + | TCon { typeCon :: !Tycon } + | TAp Type Type + | TArrow Type Type + | TForAll { typeArgs :: [Tyvar], typeBody :: (Qual Type) } + | TExists { typeArgs :: [Tyvar], typeBody :: (Qual Type) } + | TMetaVar { metaVar :: MetaVar } + | TAssoc { typeCon :: !Tycon, typeClassArgs :: [Type], typeExtraArgs :: [Type] } + deriving(Ord,Show) + +-- | metavars are used in type checking +data MetaVar = MetaVar { + metaUniq :: {-# UNPACK #-} !Int, + metaKind :: Kind, + metaRef :: {-# UNPACK #-} !(IORef (Maybe Type)), + metaType :: !MetaVarType + } + +instance Eq MetaVar where + a == b = metaUniq a == metaUniq b + +instance Ord MetaVar where + compare a b = compare (metaUniq a) (metaUniq b) + +instance TypeNames Type where + tBool = TCon (Tycon tc_Bool kindStar) + tString = TAp tList tChar + tChar = TCon (Tycon tc_Char kindStar) + tUnit = TCon (Tycon tc_Unit kindStar) + tCharzh = TCon (Tycon tc_Char_ kindHash) + +instance Ord (IORef a) +instance Binary (IORef a) where + put = error "Binary.put: not impl." + get = error "Binary.get: not impl." + +tList :: Type +tList = TCon (Tycon tc_List (Kfun kindStar kindStar)) + +-- | The @(->)@ type constructor. Invariant: @tArrow@ shall not be fully applied. To this end, see 'tAp'. +tArrow :: Type +tArrow = TCon (Tycon tc_Arrow (kindArg `Kfun` (kindFunRet `Kfun` kindStar))) + +-- | Type application, enforcing the invariant that there be no fully-applied 'tArrow's +tAp :: Type -> Type -> Type +tAp (TAp c@TCon{} a) b | c == tArrow = TArrow a b +tAp a b = TAp a b + +instance Eq Type where + (TVar a) == (TVar b) = a == b + (TMetaVar a) == (TMetaVar b) = a == b + (TCon a) == (TCon b) = a == b + (TAp a' a) == (TAp b' b) = a' == b' && b == a + (TArrow a' a) == (TArrow b' b) = a' == b' && b == a + _ == _ = False + +tassocToAp TAssoc { typeCon = con, typeClassArgs = cas, typeExtraArgs = eas } = foldl tAp (TCon con) (cas ++ eas) +tassocToAp _ = error "Representation.tassocToAp: bad." + +-- Unquantified type variables + +data Tyvar = Tyvar { tyvarName :: {-# UNPACK #-} !Name, tyvarKind :: Kind } + +instance Show Tyvar where + showsPrec _ Tyvar { tyvarName = hn, tyvarKind = k } = shows hn . ("::" ++) . shows k + +tForAll [] ([] :=> t) = t +tForAll vs (ps :=> TForAll vs' (ps' :=> t)) = tForAll (vs ++ vs') ((ps ++ ps') :=> t) +tForAll x y = TForAll x y + +tExists [] ([] :=> t) = t +tExists vs (ps :=> TExists vs' (ps' :=> t)) = tExists (vs ++ vs') ((ps ++ ps') :=> t) +tExists x y = TExists x y + +tyvar n k = Tyvar n k + +instance Eq Tyvar where + Tyvar { tyvarName = x } == Tyvar { tyvarName = y } = x == y + Tyvar { tyvarName = x } /= Tyvar { tyvarName = y } = x /= y + +instance Ord Tyvar where + compare (Tyvar { tyvarName = x }) (Tyvar { tyvarName = y }) = compare x y + (Tyvar { tyvarName = x }) <= (Tyvar { tyvarName = y }) = x <= y + (Tyvar { tyvarName = x }) >= (Tyvar { tyvarName = y }) = x >= y + (Tyvar { tyvarName = x }) < (Tyvar { tyvarName = y }) = x < y + (Tyvar { tyvarName = x }) > (Tyvar { tyvarName = y }) = x > y + +-- Type constructors + +data Tycon = Tycon { tyconName :: Name, tyconKind :: Kind } + deriving(Eq, Show,Ord) + +instance ToTuple Tycon where + toTuple n = Tycon (nameTuple TypeConstructor n) (foldr Kfun kindStar $ replicate n kindStar) +instance ToTuple Type where + toTuple n = TCon $ toTuple n + +instance DocLike d => PPrint d Tycon where + pprint (Tycon i _) = pprint i + +infixr 4 `fn` +fn :: Type -> Type -> Type +a `fn` b = TArrow a b + +-------------------------------------------------------------------------------- + +-- Predicates +data Pred = IsIn Class Type | IsEq Type Type + deriving(Show, Eq,Ord) + +-- Qualified entities +data Qual t = [Pred] :=> t + deriving(Show, Eq,Ord) + +instance (DocLike d,PPrint d t) => PPrint d (Qual t) where + pprint ([] :=> r) = pprint r + pprint ([x] :=> r) = pprint x <+> text "=>" <+> pprint r + pprint (xs :=> r) = tupled (map pprint xs) <+> text "=>" <+> pprint r + +instance DocLike d => PPrint d Tyvar where + pprint tv = tshow (tyvarName tv) + +instance Binary Tyvar where + put (Tyvar aa ab) = do + put aa + put ab + get = do + aa <- get + ab <- get + return (Tyvar aa ab) + +instance DocLike d => PPrint d Module where + pprint (Module s) = tshow s + +withNewNames ts action = subVarName $ do + ts' <- mapM newTyvarName ts + action ts' + +newTyvarName t = case tyvarKind t of + x@(KBase Star) -> newLookupName (map (:[]) ['a' ..]) x t + y@(KBase Star `Kfun` KBase Star) -> newLookupName (map (('f':) . show) [0 :: Int ..]) y t + z@(KBase KUTuple) -> newLookupName (map (('u':) . show) [0 :: Int ..]) z t + z@(KBase KQuest) -> newLookupName (map (('q':) . show) [0 :: Int ..]) z t + z@(KBase KQuestQuest) -> newLookupName (map (('q':) . ('q':) . show) [0 :: Int ..]) z t + z -> newLookupName (map (('t':) . show) [0 :: Int ..]) z t + +prettyPrintType :: DocLike d => Type -> d +prettyPrintType = pprint + +instance DocLike d => PPrint d Type where + pprintAssoc _ n t = prettyPrintTypePrec n t + +prettyPrintTypePrec :: DocLike d => Int -> Type -> d +prettyPrintTypePrec n t = unparse $ zup (runIdentity (runVarNameT (f t))) where + zup = if n >= 10 then pop empty else id + arr = bop (R,0) (space <> text "->" <> space) + app = bop (L,100) (text " ") + fp (IsIn cn t) = do + t' <- f t + return (atom (text $ show cn) `app` t') + fp (IsEq t1 t2) = do + t1' <- f t1 + t2' <- f t2 + return (atom (parens $ unparse t1' <+> text "=" <+> unparse t2')) + f (TForAll [] ([] :=> t)) = f t + f (TForAll vs (ps :=> t)) = do + withNewNames vs $ \ts' -> do + t' <- f t + ps' <- mapM fp ps + return $ case ps' of + [] -> fixitize (N,-3) $ pop (text "forall" <+> hsep (map text ts') <+> text ". ") (atomize t') + [p] -> fixitize (N,-3) $ pop (text "forall" <+> hsep (map text ts') <+> text "." <+> unparse p <+> text "=> ") (atomize t') + ps -> fixitize (N,-3) $ pop (text "forall" <+> hsep (map text ts') <+> text "." <+> tupled (map unparse ps) <+> text "=> ") (atomize t') + f (TExists [] ([] :=> t)) = f t + f (TExists vs (ps :=> t)) = do + withNewNames vs $ \ts' -> do + t' <- f t + ps' <- mapM fp ps + return $ case ps' of + [] -> fixitize (N,-3) $ pop (text "exists" <+> hsep (map text ts') <+> text ". ") (atomize t') + [p] -> fixitize (N,-3) $ pop (text "exists" <+> hsep (map text ts') <+> text "." <+> unparse p <+> text "=> ") (atomize t') + ps -> fixitize (N,-3) $ pop (text "exists" <+> hsep (map text ts') <+> text "." <+> tupled (map unparse ps) <+> text "=> ") (atomize t') + f (TCon tycon) = return $ atom (pprint tycon) + f (TVar tyvar) = do + vo <- maybeLookupName tyvar + case vo of + Just c -> return $ atom $ text c + Nothing -> return $ atom $ tshow (tyvarName tyvar) + f (TAp (TCon (Tycon n _)) x) | n == tc_List = do + x <- f x + return $ atom (char '[' <> unparse x <> char ']') + f TAssoc { typeCon = con, typeClassArgs = cas, typeExtraArgs = eas } = do + let x = atom (pprint con) + xs <- mapM f (cas ++ eas) + return $ foldl app x xs + f ta@(TAp {}) | (TCon (Tycon c _),xs) <- fromTAp ta, Just _ <- fromTupname c = do + xs <- mapM f xs + return $ atom (tupled (map unparse xs)) + f (TAp t1 t2) = do + t1 <- f t1 + t2 <- f t2 + return $ t1 `app` t2 + f (TArrow t1 t2) = do + t1 <- f t1 + t2 <- f t2 + return $ t1 `arr` t2 + f (TMetaVar mv) = return $ atom $ pprint mv + --f tv = return $ atom $ parens $ text ("FrontEnd.Tc.Type.pp: " ++ show tv) + +instance DocLike d => PPrint d MetaVarType where + pprint t = case t of + Tau -> char 't' + Rho -> char 'r' + Sigma -> char 's' + +instance DocLike d => PPrint d Pred where + pprint (IsIn c t) = tshow c <+> pprintParen t + pprint (IsEq t1 t2) = parens $ prettyPrintType t1 <+> text "=" <+> prettyPrintType t2 + +instance DocLike d => PPrint d MetaVar where + pprint MetaVar { metaUniq = u, metaKind = k, metaType = t } + | KBase Star <- k = pprint t <> tshow u + | otherwise = parens $ pprint t <> tshow u <> text " :: " <> pprint k + +instance Show MetaVarType where + show mv = pprint mv + +instance Show MetaVar where + show mv = pprint mv + +fromTAp t = f t [] where + f (TAp a b) rs = f a (b:rs) + f t rs = (t,rs) + +fromTArrow t = f t [] where + f (TArrow a b) rs = f b (a:rs) + f t rs = (reverse rs,t) + +instance CanType MetaVar where + type TypeOf MetaVar = Kind + getType mv = metaKind mv + +instance CanType Tycon where + type TypeOf Tycon = Kind + getType (Tycon _ k) = k + +instance CanType Tyvar where + type TypeOf Tyvar = Kind + getType = tyvarKind + +instance CanType Type where + type TypeOf Type = Kind + getType (TCon tc) = getType tc + getType (TVar u) = getType u + getType typ@(TAp t _) = case (getType t) of + (Kfun _ k) -> k + x -> error $ "Representation.getType: kind error in: " ++ (show typ) + getType (TArrow _l _r) = kindStar + getType (TForAll _ (_ :=> t)) = getType t + getType (TExists _ (_ :=> t)) = getType t + getType (TMetaVar mv) = getType mv + getType ta@TAssoc {} = getType (tassocToAp ta) + +tTTuple ts | length ts < 2 = error "tTTuple" +tTTuple ts = foldl TAp (toTuple (length ts)) ts + +tTTuple' ts = foldl TAp (TCon $ Tycon (unboxedNameTuple TypeConstructor n) (foldr Kfun kindUTuple $ replicate n kindStar)) ts where + n = length ts + +$(derive makeBinary ''MetaVarType) +$(derive makeBinary ''Type) +$(derive makeBinary ''MetaVar) +$(derive makeBinary ''Tycon) +$(derive makeBinary ''Pred) +$(derive makeBinary ''Qual) diff --git a/src/FrontEnd/SrcLoc.hs b/src/FrontEnd/SrcLoc.hs new file mode 100644 --- /dev/null +++ b/src/FrontEnd/SrcLoc.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE TemplateHaskell #-} +module FrontEnd.SrcLoc where + +import Control.Applicative +import Control.Monad.Identity +import Control.Monad.Writer +import Data.Foldable +import Data.Traversable +import Data.Binary +import Data.Generics +import Data.DeriveTH + +import PackedString + +data SrcLoc = SrcLoc { + srcLocFileName :: PackedString, + srcLocLine :: {-# UNPACK #-} !Int, + srcLocColumn :: {-# UNPACK #-} !Int + } + deriving(Data,Typeable,Eq,Ord) + +data SrcSpan = SrcSpan { srcSpanBegin :: !SrcLoc, srcSpanEnd :: !SrcLoc } + deriving(Data,Typeable,Eq,Ord) + +-- Useful bogus file names used to indicate where non file based errors are. +fileNameCommandLine = packString "(command line)" +fileNameUnknown = packString "(unknown)" +fileNameGenerated = packString "(generated)" + +bogusASrcLoc = SrcLoc fileNameUnknown (-1) (-1) +bogusSrcSpan = SrcSpan bogusASrcLoc bogusASrcLoc + +instance Monoid SrcLoc where + mempty = bogusASrcLoc + mappend a b + | a == bogusASrcLoc = b + | otherwise = a + +-------------------- +-- haslocation class +-------------------- + +class HasLocation a where + srcLoc :: a -> SrcLoc + srcSpan :: a -> SrcSpan + srcSpan x = bogusSrcSpan { srcSpanBegin = slx, srcSpanEnd = slx } where slx = srcLoc x + srcLoc x = srcSpanBegin (srcSpan x) + +instance HasLocation a => HasLocation [a] where + srcLoc xs = mconcat (map srcLoc xs) + +instance HasLocation SrcLoc where + srcLoc x = x + +instance HasLocation SrcSpan where + srcSpan x = x + +instance HasLocation (SrcLoc,SrcLoc) where + srcSpan (x,y) = SrcSpan x y + +instance HasLocation (Located a) where + srcSpan (Located x _) = x + +data Located x = Located SrcSpan x + deriving(Ord,Show,Data,Typeable,Eq) + +fromLocated :: Located x -> x +fromLocated (Located _ x) = x + +instance Functor Located where + fmap f (Located l x) = Located l (f x) + +instance Foldable Located where + foldMap f (Located l x) = f x + +instance Traversable Located where + traverse f (Located l x) = Located l <$> f x + +located ss x = Located (srcSpan ss) x + +----------------------- +-- srcloc monad classes +----------------------- + +class Monad m => MonadSrcLoc m where + getSrcLoc :: m SrcLoc + getSrcSpan :: m SrcSpan + getSrcSpan = getSrcLoc >>= return . srcSpan + getSrcLoc = getSrcSpan >>= return . srcLoc + +class MonadSrcLoc m => MonadSetSrcLoc m where + withSrcLoc :: SrcLoc -> m a -> m a + withSrcSpan :: SrcSpan -> m a -> m a + withSrcLoc sl a = withSrcSpan (srcSpan sl) a + withSrcSpan ss a = withSrcLoc (srcLoc ss) a + +withLocation :: (HasLocation l,MonadSetSrcLoc m) => l -> m a -> m a +withLocation l = withSrcSpan (srcSpan l) + +instance Monoid w => MonadSrcLoc (Writer w) where + getSrcLoc = return mempty +instance Monoid w => MonadSetSrcLoc (Writer w) where + withSrcLoc _ a = a + +instance MonadSrcLoc Identity where + getSrcLoc = return mempty +instance MonadSetSrcLoc Identity where + withSrcLoc _ a = a + +----------------- +-- show instances +----------------- + +instance Show SrcLoc where + show (SrcLoc fn l c) = unpackPS fn ++ f l ++ f c where + f (-1) = "" + f n = ':':show n + +instance Show SrcSpan where + show SrcSpan { srcSpanBegin = sl1, srcSpanEnd = sl2 } + | sl1 == sl2 = show sl1 + | otherwise = show sl1 ++ "-" ++ show sl2 + +$(derive makeUpdate ''SrcLoc) +$(derive makeBinary ''SrcLoc) +$(derive makeUpdate ''SrcSpan) +$(derive makeBinary ''SrcSpan) +$(derive makeBinary ''Located) diff --git a/src/FrontEnd/Tc/Kind.hs b/src/FrontEnd/Tc/Kind.hs new file mode 100644 --- /dev/null +++ b/src/FrontEnd/Tc/Kind.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE TemplateHaskell #-} +module FrontEnd.Tc.Kind( + Kind(..), + KBase(..), + Kindvar(..), + KindConstraint(..), + kindCombine, + kindStar, + kindUTuple, + kindFunRet, + kindHash, + kindArg, + isSubsumedBy, + unfoldKind + ) where + +import Control.Monad +import Data.IORef +import Data.Monoid +import Data.Binary +import Data.DeriveTH + +import Doc.DocLike +import Doc.PPrint(pprint,pprintPrec,pprintAssoc,Assoc(..),PPrint,pprintBinary) +import Name.Name + +{- + + KQuest = ? star or hash or unboxed tuple + KQuestQuest = ?? star or hash + KUTuple = (#) unboxed tuple + Star = * boxed value + KHash = # unboxed value + Kfun = (->) + KNamed Foo = Foo named kind + + we have the following subkinding going on + + ? + / \ + ?? (#) + /\ + * # + +in addition, user defined named kinds are allowed. these can only occur via +kind annotations, and only unify with themselves + +-} + +data KBase = + Star + | KHash + | KUTuple + | KQuestQuest + | KQuest + | KNamed Name + deriving(Eq, Ord) -- but we need them for kind inference + +KNamed s1 `isSubsumedBy2` KNamed s2 = s1 == s2 +_ `isSubsumedBy2` KQuest = True +Star `isSubsumedBy2` KQuestQuest = True +KHash `isSubsumedBy2` KQuestQuest = True +k1 `isSubsumedBy2` k2 = k1 == k2 + +kindStar = KBase Star +kindHash = KBase KHash +kindUTuple = KBase KUTuple +kindFunRet = KBase KQuest +kindArg = KBase KQuestQuest + +infixr 5 `Kfun` + +data Kind = KBase KBase + | Kfun Kind Kind + | KVar Kindvar -- variables aren't really allowed in haskell in kinds + deriving(Eq, Ord) -- but we need them for kind inference + +KBase kb `isSubsumedBy` KBase kb' = isSubsumedBy2 kb kb' +Kfun k1 k2 `isSubsumedBy` Kfun k1' k2' = isSubsumedBy k1 k1' && isSubsumedBy k2 k2' +_ `isSubsumedBy` _ = False + +kindCombine :: Monad m => Kind -> Kind -> m Kind +kindCombine x y = g x y where + f x y | x == y = return x + + f KQuest x = fquest x + f x KQuest = fquest x + f KQuestQuest x = fquest2 x + f x KQuestQuest = fquest2 x + f x y = fail $ "kindCombine: " ++ show (x,y) + fquest (KNamed n) = fail $ "Attempt to unify named kind" <+> tshow n <+> "with ?" + fquest x = return x + fquest2 (KNamed n) = fail $ "Attempt to unify named kind" <+> tshow n <+> "with ??" + fquest2 KUTuple = fail $ "Attempt to unify unboxed tuple with ??" + fquest2 KQuest = return KQuestQuest + fquest2 x = return x + g (KBase x) (KBase y) = f x y >>= return . KBase + g (Kfun a b) (Kfun a' b') = return Kfun `ap` g a a' `ap` g b b' + g x y = fail $ "kindCombine: " ++ show (x,y) + +data KindConstraint + = KindSimple -- ^ * | kindSimple -> kindSimple + | KindQuest -- ^ ?, so * or (#) or # + | KindQuestQuest -- ^ ??, * or # + | KindStar -- ^ must be * + | KindAny -- ^ may be anything + deriving(Eq,Ord,Show) + +-- note that named kinds are never infered, so we don't need constraints +-- mentioning them. + +instance Monoid KindConstraint where + mempty = KindAny + mappend a b | a == b = a + mappend KindAny k = k + mappend KindStar _ = KindStar + mappend KindSimple KindQuest = KindStar + mappend KindSimple KindQuestQuest = KindStar + mappend KindQuest KindQuestQuest = KindQuestQuest + mappend k1 k2 = mappend k2 k1 + +data Kindvar = Kindvar { + kvarUniq :: {-# UNPACK #-} !Int, + kvarRef :: {-# UNPACK #-} !(IORef (Maybe Kind)), + kvarConstraint :: !KindConstraint + } + +instance Binary Kindvar where + put _ = return () + get = return (error "Binary.Kindvar.get") + +instance Eq Kindvar where + a == b = kvarUniq a == kvarUniq b + +instance Ord Kindvar where + a `compare` b = kvarUniq a `compare` kvarUniq b + +instance Show Kind where + showsPrec n k = pprintPrec n k + +instance Show Kindvar where + showsPrec n k = pprintPrec n k + +instance Show KBase where + showsPrec _ Star = showString "*" + showsPrec _ KUTuple = showString "(#)" + showsPrec _ KHash = showString "#" + showsPrec _ KQuest = showString "?" + showsPrec _ KQuestQuest = showString "??" + showsPrec _ (KNamed n) = shows n + +instance DocLike d => PPrint d KBase where + pprint kb = text (show kb) + +instance DocLike d => PPrint d Kind where + pprintAssoc _ _ (KBase b) = pprint b + pprintAssoc _ _ (KVar kindVar) = pprint kindVar + pprintAssoc a n (Kfun k1 k2) = pprintBinary AssocRight 5 a n k1 (text "->") k2 -- checkAssoc AssocRight 5 a n $ pprintPrec 5 k1 <+> text "->" <+> pprintAssoc AssocRight 5 k2 + +instance DocLike d => PPrint d Kindvar where + pprint Kindvar { kvarUniq = s } = text $ 'k':show s + +-- * -> * == [*,*] +-- (*->*->*) -> * -> * == [(*->*->*), *, *] +unfoldKind :: Kind -> [Kind] +unfoldKind (Kfun k1 k2) = k1 : unfoldKind k2 +unfoldKind v = [v] + +$(derive makeBinary ''KBase) +$(derive makeBinary ''Kind) diff --git a/src/FrontEnd/Tc/Monad.hs b/src/FrontEnd/Tc/Monad.hs new file mode 100644 --- /dev/null +++ b/src/FrontEnd/Tc/Monad.hs @@ -0,0 +1,565 @@ +{-# LANGUAGE ImpredicativeTypes, TemplateHaskell #-} +module FrontEnd.Tc.Monad( + CoerceTerm(..), + Tc(), + TcInfo(..), + TypeEnv(), + TcEnv(..), + tcRecursiveCalls_u, + Output(..), + addCoerce, + addPreds, + composeCoerce, + addRule, + addToCollectedEnv, + boxyInstantiate, + boxySpec, + deconstructorInstantiate, + freeMetaVarsEnv, + freshInstance, + freshSigma, + getClassHierarchy, + getCollectedEnv, + getCollectedCoerce, + getDeName, + getKindEnv, + getSigEnv, + evalFullType, + inst, + listenCheckedRules, + listenPreds, + listenCPreds, + localEnv, + lookupName, + newBox, + newMetaVar, + newVar, + quantify, + quantify_n, + runTc, + skolomize, + tcInfoEmpty, + toSigma, + unBox, + evalType, + unificationError, + varBind, + zonkKind, + withContext, + withMetaVars + ) where + +import Control.Monad.Error +import Control.Monad.Reader +import Control.Monad.Writer.Strict +import Data.IORef +import Data.List +import Data.DeriveTH +--import Text.PrettyPrint.HughesPJ(Doc) +import qualified Data.Foldable as T +import qualified Data.Map as Map +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import qualified Data.Traversable as T + +import Doc.DocLike +import Doc.PPrint +import FrontEnd.Class +import FrontEnd.Diagnostic +import FrontEnd.KindInfer +import FrontEnd.Rename(DeNameable(..)) +import FrontEnd.SrcLoc(bogusASrcLoc,MonadSrcLoc(..)) +import FrontEnd.Tc.Kind +import FrontEnd.Tc.Type +import FrontEnd.Warning +import GenUtil +import Name.Name +import Name.Names +import Options +import Support.CanType +import Support.FreeVars +import Support.Tickle +import qualified FlagDump as FD +import {-# SOURCE #-} FrontEnd.Tc.Class(simplify) + +-- data BindingType = RecursiveInfered | Supplied +type TypeEnv = Map.Map Name Sigma + +-- | information that is passed into the type checker. +data TcInfo = TcInfo { + tcInfoEnv :: TypeEnv, -- initial typeenv, data constructors, and previously infered types + tcInfoSigEnv :: TypeEnv, -- type signatures used for binding analysis + tcInfoModName :: Module, + tcInfoKindInfo :: KindEnv, + tcInfoClassHierarchy :: ClassHierarchy + } + +-- read only environment, set up before type checking. +data TcEnv = TcEnv { + tcInfo :: TcInfo, + tcDiagnostics :: [Diagnostic], -- list of information that might help diagnosis + tcVarnum :: {-# UNPACK #-} !(IORef Int), + tcCollectedEnv :: {-# UNPACK #-} !(IORef (Map.Map Name Sigma)), + tcCollectedCoerce :: {-# UNPACK #-} !(IORef (Map.Map Name CoerceTerm)), + tcConcreteEnv :: Map.Map Name Sigma, + tcMutableEnv :: Map.Map Name Sigma, + tcCurrentScope :: Set.Set MetaVar, + tcRecursiveCalls :: Set.Set Name, + tcInstanceEnv :: InstanceEnv, + tcOptions :: Opt -- module specific options + } + +tcConcreteEnv_u f r@TcEnv{tcConcreteEnv = x} = r{tcConcreteEnv = f x} +tcDiagnostics_u f r@TcEnv{tcDiagnostics = x} = r{tcDiagnostics = f x} +tcMutableEnv_u f r@TcEnv{tcMutableEnv = x} = r{tcMutableEnv = f x} +tcRecursiveCalls_u f r@TcEnv{tcRecursiveCalls = x} = r{tcRecursiveCalls = f x} + +data Output = Output { + collectedPreds :: !Preds, + existentialPreds :: !Preds, + constraints :: !(Seq.Seq Constraint), + checkedRules :: !(Seq.Seq Rule), + existentialVars :: [Tyvar], + tcWarnings :: !(Seq.Seq Warning), + outKnots :: [(Name,Name)] + } + +$(derive makeMonoid ''Output) + +newtype Tc a = Tc (ReaderT TcEnv (WriterT Output IO) a) + deriving(MonadFix,MonadIO,MonadReader TcEnv,MonadWriter Output,Functor) + +getDeName :: DeNameable n => Tc (n -> n) +getDeName = do + mn <- asks (tcInfoModName . tcInfo) + return (\n -> deName mn n) + +-- | run a computation with a local environment +localEnv :: TypeEnv -> Tc a -> Tc a +localEnv te act = do + te' <- T.mapM flattenType te + let (cenv,menv) = Map.partition (Set.null . freeMetaVars) te' + --if any isBoxy (Map.elems te') then + -- fail $ "localEnv error!\n" ++ show te + local (tcConcreteEnv_u (cenv `Map.union`) . tcMutableEnv_u ((menv `Map.union`) . + Map.filterWithKey (\k _ -> k `Map.notMember` cenv))) act + +-- | add to the collected environment which will be used to annotate uses of +-- variables with their instantiated types. should contain @-aliases for each +-- use of a polymorphic variable or pattern match. + +addToCollectedEnv :: TypeEnv -> Tc () +addToCollectedEnv te = do + v <- asks tcCollectedEnv + liftIO $ modifyIORef v (te `Map.union`) + +addCoerce :: Name -> CoerceTerm -> Tc () +addCoerce n te = do + v <- asks tcCollectedCoerce + liftIO $ modifyIORef v (Map.insert n te) + +getCollectedEnv :: Tc TypeEnv +getCollectedEnv = do + v <- asks tcCollectedEnv + r <- liftIO $ readIORef v + r <- T.mapM flattenType r + return r + +getCollectedCoerce :: Tc (Map.Map Name CoerceTerm) +getCollectedCoerce = do + v <- asks tcCollectedCoerce + r <- liftIO $ readIORef v + r <- T.mapM flattenType r + return r + +runTc :: (MonadIO m,OptionMonad m) => TcInfo -> Tc a -> m a +runTc tcInfo (Tc tim) = do + opt <- getOptions + liftIO $ do + vn <- newIORef 0 + ce <- newIORef mempty + cc <- newIORef mempty + (a,out) <- runWriterT $ runReaderT tim TcEnv { + tcCollectedEnv = ce, + tcCollectedCoerce = cc, + tcConcreteEnv = tcInfoEnv tcInfo `mappend` tcInfoSigEnv tcInfo, + tcMutableEnv = mempty, + tcVarnum = vn, + tcDiagnostics = [Msg Nothing $ + "Compilation of module: " ++ show (tcInfoModName tcInfo)], + tcInfo = tcInfo, + tcRecursiveCalls = mempty, + tcInstanceEnv = makeInstanceEnv (tcInfoClassHierarchy tcInfo), + tcCurrentScope = mempty, + tcOptions = opt + } + liftIO $ processErrors (T.toList $ tcWarnings out) + return a + +instance OptionMonad Tc where + getOptions = asks tcOptions + +-- | given a diagnostic and a computation to take place inside the TI-monad, +-- run the computation but during it have the diagnostic at the top of the +-- stack + +withContext :: Diagnostic -> Tc a -> Tc a +withContext diagnostic comp = do + local (tcDiagnostics_u (diagnostic:)) comp + +addRule :: Rule -> Tc () +addRule r = tell mempty { checkedRules = Seq.singleton r } + +getErrorContext :: Tc [Diagnostic] +getErrorContext = asks tcDiagnostics + +getClassHierarchy :: Tc ClassHierarchy +getClassHierarchy = asks (tcInfoClassHierarchy . tcInfo) + +getKindEnv :: Tc KindEnv +getKindEnv = asks (tcInfoKindInfo . tcInfo) + +getSigEnv :: Tc TypeEnv +getSigEnv = asks (tcInfoSigEnv . tcInfo) + +askCurrentEnv = do + env1 <- asks tcConcreteEnv + env2 <- asks tcMutableEnv + return (env2 `Map.union` env1) + +{- +dConScheme :: Name -> Tc Sigma +dConScheme conName = do + env <- askCurrentEnv + case Map.lookup conName env of + Just s -> return s + Nothing -> error $ "dConScheme: constructor not found: " ++ show conName ++ + "\nin this environment:\n" ++ show env +-} + +-- | returns a new box and a function to read said box. + +newBox :: Kind -> Tc Type +newBox k = newMetaVar Sigma k + +unificationError t1 t2 = do + t1 <- evalFullType t1 + t2 <- evalFullType t2 + diagnosis <- getErrorContext + let Left msg = typeError (Unification $ "attempted to unify " ++ + prettyPrintType t1 ++ " with " ++ prettyPrintType t2) diagnosis + liftIO $ processIOErrors + liftIO $ putErrLn msg + liftIO $ exitFailure + +lookupName :: Name -> Tc Sigma +lookupName n = do + env <- askCurrentEnv + case Map.lookup n env of + Just x -> freshSigma x + Nothing | Just 0 <- fromUnboxedNameTuple n -> do + return (tTTuple' []) + Nothing | Just num <- fromUnboxedNameTuple n -> do + nvs <- mapM newVar (replicate num kindArg) + let nvs' = map TVar nvs + return (TForAll nvs $ [] :=> foldr TArrow (tTTuple' nvs') nvs') + Nothing -> fail $ "Could not find var in tcEnv:" ++ show (nameType n,n) + +newMetaVar :: MetaVarType -> Kind -> Tc Type +newMetaVar t k = do + te <- ask + n <- newUniq + r <- liftIO $ newIORef Nothing + return $ TMetaVar MetaVar { metaUniq = n, metaKind = k, metaRef = r, metaType = t } + +class Instantiate a where + inst:: Map.Map Int Type -> Map.Map Name Type -> a -> a + +instance Instantiate Type where + inst mm ts (TAp l r) = tAp (inst mm ts l) (inst mm ts r) + inst mm ts (TArrow l r) = TArrow (inst mm ts l) (inst mm ts r) + inst mm _ t@TCon {} = t + inst mm ts (TVar tv ) = case Map.lookup (tyvarName tv) ts of + Just t' -> t' + Nothing -> (TVar tv) + inst mm ts (TForAll as qt) = TForAll as (inst mm (foldr Map.delete ts (map tyvarName as)) qt) + inst mm ts (TExists as qt) = TExists as (inst mm (foldr Map.delete ts (map tyvarName as)) qt) + inst mm ts (TMetaVar mv) | Just t <- Map.lookup (metaUniq mv) mm = t + inst mm ts (TMetaVar mv) = TMetaVar mv + inst mm ts (TAssoc tc as bs) = TAssoc tc (map (inst mm ts) as) (map (inst mm ts) bs) + --inst mm _ t = error $ "inst: " ++ show t + +instance Instantiate a => Instantiate [a] where + inst mm ts = map (inst mm ts) + +instance Instantiate t => Instantiate (Qual t) where + inst mm ts (ps :=> t) = inst mm ts ps :=> inst mm ts t + +instance Instantiate Pred where + inst mm ts is = tickle (inst mm ts :: Type -> Type) is + +freshInstance :: MetaVarType -> Sigma -> Tc ([Type],Rho) +freshInstance typ (TForAll as qt) = do + ts <- mapM (newMetaVar typ) (map tyvarKind as) + let (ps :=> t) = (applyTyvarMapQT (zip as ts) qt) + addPreds ps + return (ts,t) +freshInstance _ x = return ([],x) + +addPreds :: Preds -> Tc () +addPreds ps = do + sl <- getSrcLoc + Tc $ tell mempty { collectedPreds = [ p | p@IsIn {} <- ps ], + constraints = Seq.fromList [ Equality { constraintSrcLoc = sl, + constraintType1 = a, constraintType2 = b } | IsEq a b <- ps ] } + +--addConstraints :: [Constraint] -> Tc () +--addConstraints ps = Tc $ tell mempty { constraints = Seq.fromList ps } + +listenPreds :: Tc a -> Tc (a,Preds) +listenPreds action = censor (\x -> x { collectedPreds = mempty }) $ + listens collectedPreds action + +listenCPreds :: Tc a -> Tc (a,(Preds,[Constraint])) +listenCPreds action = censor (\x -> x { constraints = mempty, collectedPreds = mempty }) $ + listens (\x -> (collectedPreds x,T.toList $ constraints x)) action + +listenCheckedRules :: Tc a -> Tc (a,[Rule]) +listenCheckedRules action = do + (a,r) <- censor (\x -> x { checkedRules = mempty }) $ listens checkedRules action + return (a,T.toList r) + +newVar :: Kind -> Tc Tyvar +newVar k = do + te <- ask + n <- newUniq + let ident = toName TypeVal (tcInfoModName $ tcInfo te,'v':show n) + v = tyvar ident k + return v + +-- rename the bound variables of a sigma, just in case. +freshSigma :: Sigma -> Tc Sigma +freshSigma (TForAll [] ([] :=> t)) = return t +freshSigma (TForAll vs qt) = do + nvs <- mapM (newVar . tyvarKind) vs + return (TForAll nvs $ applyTyvarMapQT (zip vs (map TVar nvs)) qt) +freshSigma x = return x + +toSigma :: Sigma -> Sigma +toSigma t@TForAll {} = t +toSigma t = TForAll [] ([] :=> t) + +-- | replace bound variables with arbitrary new ones and drop the binding +-- TODO predicates? + +skolomize :: Sigma -> Tc ([Tyvar],[Pred],Type) +skolomize s = freshSigma s >>= return . fromType + +boxyInstantiate :: Sigma -> Tc ([Type],Rho') +boxyInstantiate = freshInstance Sigma + +deconstructorInstantiate :: Sigma -> Tc Rho' +deconstructorInstantiate tfa@TForAll {} = do + TForAll vs qt@(_ :=> t) <- freshSigma tfa + let f (_ `TArrow` b) = f b + f b = b + eqvs = vs Data.List.\\ freeVars (f t) + tell mempty { existentialVars = eqvs } + (_,t) <- freshInstance Sigma (TForAll (vs Data.List.\\ eqvs) qt) + return t +deconstructorInstantiate x = return x + +boxySpec :: Sigma -> Tc ([(BoundTV,[Sigma'])],Rho') +boxySpec (TForAll as qt@(ps :=> t)) = do + let f (TVar t) vs | t `elem` vs = do + b <- lift (newBox $ tyvarKind t) + tell [(t,b)] + return b + f e@TCon {} _ = return e + f (TAp a b) vs = liftM2 tAp (f a vs) (f b vs) + f (TArrow a b) vs = liftM2 TArrow (f a vs) (f b vs) + f (TForAll as (ps :=> t)) vs = do + t' <- f t (vs Data.List.\\ as) + return (TForAll as (ps :=> t')) + f t _ = return t + -- f t _ = error $ "boxySpec: " ++ show t + (t',vs) <- runWriterT (f t as) + addPreds $ inst mempty (Map.fromList [ (tyvarName bt,s) | (bt,s) <- vs ]) ps + return (sortGroupUnderFG fst snd vs,t') +boxySpec _ = error "boxySpec: bad." + +freeMetaVarsEnv :: Tc (Set.Set MetaVar) +freeMetaVarsEnv = do + env <- asks tcMutableEnv + xs <- flip mapM (Map.elems env) $ \ x -> do + x <- flattenType x + return $ freeMetaVars x + return (Set.unions xs) + +quantify_n :: [MetaVar] -> [Pred] -> [Rho] -> Tc [Sigma] +quantify_n vs ps rs | not $ any isBoxyMetaVar vs = do + -- we bind the quantified variables to fresh tvars + vs <- mapM groundKind vs + nvs <- mapM (newVar . fixKind . metaKind) vs + sequence_ [ varBind mv (TVar v) | v <- nvs | mv <- vs ] + + ps <- flattenType ps + rs <- flattenType rs + + ch <- getClassHierarchy + return $ [TForAll nvs (FrontEnd.Tc.Class.simplify ch ps :=> r) | r <- rs ] + | otherwise = error "quantify_n: bad." + +quantify :: [MetaVar] -> [Pred] -> Rho -> Tc Sigma +quantify vs ps r = do [s] <- quantify_n vs ps [r]; return s + +-- turn all ?? into * types, as we can't abstract over unboxed types +fixKind :: Kind -> Kind +fixKind (KBase KQuestQuest) = KBase Star +fixKind (KBase KQuest) = KBase Star +fixKind (a `Kfun` b) = fixKind a `Kfun` fixKind b +fixKind x = x + +groundKind mv = zonkKind (fixKind $ metaKind mv) mv + +-- this removes all boxes, replacing them with tau vars +unBox :: Type -> Tc Type +unBox tv = ft' tv where + ft t@(TMetaVar mv) + | isBoxyMetaVar mv = do + tmv <- newMetaVar Tau (getType mv) + varBind mv tmv + return tmv + | otherwise = return t + ft t = tickleM ft' t + ft' t = evalType t >>= ft + +evalType t = findType t >>= evalTAssoc >>= evalArrowApp +evalFullType t = f' t where + f t = tickleM f' t + f' t = evalType t >>= f + +evalTAssoc ta@TAssoc { typeCon = Tycon { tyconName = n1 }, typeClassArgs = ~[carg], typeExtraArgs = eas } = do + carg' <- evalType carg + case fromTAp carg' of + (TCon Tycon { tyconName = n2 }, as) -> do + InstanceEnv ie <- asks tcInstanceEnv + case Map.lookup (n1,n2) ie of + Just (aa,bb,tt) -> evalType (applyTyvarMap (zip aa as ++ zip bb eas) tt) + _ -> fail "no instance for associated type" + _ -> return ta { typeClassArgs = [carg'] } +evalTAssoc t = return t + +evalArrowApp (TAp (TAp (TCon tcon) ta) tb) + | tyconName tcon == tc_Arrow = return (TArrow ta tb) + +evalArrowApp t = return t + +-- Bind mv to type, first filling in any boxes in type with tau vars +varBind :: MetaVar -> Type -> Tc () +varBind u t +-- | getType u /= getType t = error $ "varBind: kinds do not match:" ++ show (u,t) + | otherwise = do + kindCombine (getType u) (getType t) + tt <- unBox t + --(t,be,_) <- unbox t + --when be $ error $ "binding boxy: " ++ tupled [pprint u,prettyPrintType t] + tt <- evalFullType tt + when (dump FD.BoxySteps) $ liftIO $ putStrLn $ "varBind: " ++ pprint u <+> + text ":=" <+> prettyPrintType tt + when (u `Set.member` freeMetaVars tt) $ do + unificationError (TMetaVar u) tt -- occurs check + let r = metaRef u + x <- liftIO $ readIORef r + case x of + Just r -> fail $ "varBind: binding unfree: " ++ + tupled [pprint u,prettyPrintType tt,prettyPrintType r] + Nothing -> liftIO $ do + --when (dump FD.BoxySteps) $ putStrLn $ "varBind: " ++ pprint u <+> text ":=" <+> prettyPrintType t + writeIORef r (Just tt) + +zonkKind :: Kind -> MetaVar -> Tc MetaVar +zonkKind nk mv = do + fk <- kindCombine nk (metaKind mv) + if fk == metaKind mv then return mv else do + nref <- liftIO $ newIORef Nothing + let nmv = mv { metaKind = fk, metaRef = nref } + liftIO $ modifyIORef (metaRef mv) (\Nothing -> Just $ TMetaVar nmv) + return nmv + +zonkBox :: MetaVar -> Tc Type +zonkBox mv | isBoxyMetaVar mv = findType (TMetaVar mv) +zonkBox mv = fail $ "zonkBox: nonboxy" ++ show mv + +readFilledBox :: MetaVar -> Tc Type +readFilledBox mv | isBoxyMetaVar mv = zonkBox mv >>= \v -> case v of + TMetaVar mv' | mv == mv' -> fail $ "readFilledBox: " ++ show mv + t -> return t +readFilledBox mv = error $ "readFilledBox: nonboxy" ++ show mv + +{- +elimBox :: MetaVar -> Tc Type +elimBox mv | isBoxyMetaVar mv = do + t <- readMetaVar mv + case t of + Just t -> return t + Nothing -> newMetaVar Tau (getType mv) + +elimBox mv = error $ "elimBox: nonboxy" ++ show mv +-} + +---------------------------------------- +-- Declaration of instances, boilerplate +---------------------------------------- + +--pretty :: PPrint Doc a => a -> String +--pretty x = show (pprint x :: Doc) + +instance Monad Tc where + return a = Tc $ return a + Tc comp >>= fun = Tc $ do x <- comp; case fun x of Tc m -> m + Tc a >> Tc b = Tc $ a >> b + fail s = Tc $ do + st <- ask + liftIO $ processIOErrors + Left x <- typeError (Failure s) (tcDiagnostics st) + liftIO $ fail x + +instance MonadWarn Tc where + addWarning w = tell mempty { tcWarnings = Seq.singleton w } + +instance MonadSrcLoc Tc where + getSrcLoc = do + xs <- asks tcDiagnostics + case xs of + (Msg (Just sl) _:_) -> return sl + _ -> return bogusASrcLoc + +instance UniqueProducer Tc where + newUniq = do + v <- asks tcVarnum + n <- liftIO $ do + n <- readIORef v + writeIORef v $! n + 1 + return n + return n + +tcInfoEmpty = TcInfo { + tcInfoEnv = mempty, + tcInfoModName = toModule "(unknown)", + tcInfoKindInfo = mempty, + tcInfoClassHierarchy = mempty, + tcInfoSigEnv = mempty +} + +withMetaVars :: MetaVar -> [Kind] -> ([Sigma] -> Sigma) -> ([Sigma'] -> Tc a) -> Tc a +withMetaVars mv ks sfunc bsfunc | isBoxyMetaVar mv = do + boxes <- mapM newBox ks + res <- bsfunc boxes + tys <- mapM readFilledBox [ mv | ~(TMetaVar mv) <- boxes] + varBind mv (sfunc tys) + return res +withMetaVars mv ks sfunc bsfunc = do + taus <- mapM (newMetaVar Tau) ks + varBind mv (sfunc taus) + bsfunc taus diff --git a/src/Grin/FromE.hs b/src/Grin/FromE.hs --- a/src/Grin/FromE.hs +++ b/src/Grin/FromE.hs @@ -362,6 +362,13 @@ cc, ce, cr :: E -> C Exp cr x = ce x + stripBang :: E -> E + stripBang e = f e where + f (EAp p a) = g p a + f e = e + g (EPrim (PrimPrim "fromBang_") [b] _) a = EAp b a + g e a = EAp e a + -- | ce evaluates something in strict context returning the evaluated result of its argument. ce (ELetRec ds e) = doLet ds (ce e) ce (EError s e) = return (Error s (toTypes TyNode e)) @@ -371,7 +378,7 @@ mtick' "Grin.FromE.strict-unlifted" return (Return $ keepIts [toVal tvr]) --return (Fetch (toVal tvr)) - ce e | (EVar tvr,as) <- fromAp e = do + ce e | (EVar tvr,as) <- fromAp . stripBang $ e = do as <- return $ args as lfunc <- asks lfuncMap let fty = toTypes TyNode (getType e) diff --git a/src/Grin/Main.hs b/src/Grin/Main.hs --- a/src/Grin/Main.hs +++ b/src/Grin/Main.hs @@ -99,6 +99,7 @@ (cc,args) <- fetchCompilerFlags forM_ [("rts/constants.h",constants_h), ("rts/stableptr.c",stableptr_c), + ("rts/stableptr.h",stableptr_h), ("rts/slub.c",slub_c), ("rts/profile.c",profile_c), ("rts/profile.h",profile_h), @@ -119,11 +120,13 @@ ("rts/gc_jgc_internal.h",gc_jgc_internal_h), ("rts/gc_none.c",gc_none_c), ("rts/gc_none.h",gc_none_h), + ("rts/conc.c",conc_c), + ("rts/conc.h",conc_h), ("sys/bitarray.h",bitarray_h)] $ \ (fn,bs) -> do fileInTempDir fn $ flip BS.writeFile bs let cFiles = ["rts/profile.c", "rts/rts_support.c", "rts/gc_none.c", "rts/jhc_rts.c", "lib/lib_cbits.c", "rts/gc_jgc.c", - "rts/stableptr.c"] + "rts/stableptr.c", "rts/conc.c"] tdir <- getTempDir ds <- iocatch (getDirectoryContents (tdir FP. "cbits")) (\_ -> return []) let extraCFiles = map noEscapePath $ map (tdir FP.) cFiles ++ ["-I" ++ tdir ++ "/cbits", "-I" ++ tdir ] ++ [ tdir FP. "cbits" FP. fn | fn@(reverse -> 'c':'.':_) <- ds ] diff --git a/src/Grin/SSimplify.hs b/src/Grin/SSimplify.hs new file mode 100644 --- /dev/null +++ b/src/Grin/SSimplify.hs @@ -0,0 +1,435 @@ +{-# LANGUAGE TemplateHaskell #-} +module Grin.SSimplify(simplify,explicitRecurse) where + +import Control.Monad.Identity +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Writer +import Data.Maybe +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.DeriveTH + +import Grin.Grin +import Grin.Noodle +import Stats(mtick) +import StringTable.Atom +import Support.CanType +import Support.FreeVars +import Support.Tickle +import Util.GMap +import Util.Gen +import Util.HasSize +import Util.RWS +import Util.SetLike +import qualified Stats + +-- This goes through and puts grin into a normal form, in addition, it carries out some straightforward +-- simplifications. +-- +-- normalized form has the following properties +-- +-- :>>= only appears in trailing position +-- Return [v0 .. vn] for n > 1 only appears in trailing position +-- +-- all variables and function names are unique in their scope. + +data SEnv = SEnv { + envSubst :: IM.IntMap Val, -- renaming substitution + envCSE :: Map.Map Exp (Atom,Exp), + envPapp :: IM.IntMap (Atom,[Val]) + --envPush :: IM.IntMap Exp + } + +newtype SState = SState { usedVars :: IS.IntSet } + +data SCol = SCol { + colStats :: Stats.Stat, + colFreeVars :: GSet Var + } + +$(derive makeMonoid ''SCol) + +{- +data ExpInfo = ExpInfo { + expFreeVars :: GSet Var, + expUnboxing :: UnboxingResult, + expType :: [Ty] + } +-} + +newtype S a = S (RWS SEnv SCol SState a) + deriving(Monad,Functor,MonadWriter SCol, MonadReader SEnv,MonadState SState) + +instance Stats.MonadStats S where + mtickStat s = S (tell mempty { colStats = s }) + mticks' n a = S (tell mempty { colStats = Stats.singleStat n a }) + +tellFV v = tell mempty { colFreeVars = freeVars v } + +simplify :: Grin -> IO Grin +simplify grin = do + let (fs,_,SCol { colStats = stats}) = runRWS fun mempty SState { usedVars = mempty } + S fun = simpFuncs (grinFunctions grin) + return grin { grinFunctions = fs, grinStats = grinStats grin `mappend` stats } + +simpFuncs :: [FuncDef] -> S [FuncDef] +simpFuncs fd = do + let f fd@FuncDef { funcDefBody = body } = do + body' <- simpLam body + return $ updateFuncDefProps fd { funcDefBody = body' } + mapM f fd + +simpLam :: Lam -> S Lam +simpLam (ps :-> e) = do + (ps,env') <- renamePattern ps + let f col = col { colFreeVars = colFreeVars col \\ freeVars ps } + (e,col) <- censor f $ listen $ local (env' `mappend`) $ simpExp e + ps <- mapM (zeroVars (`member` colFreeVars col)) ps + return (ps :-> e) + +dstore x = BaseOp (StoreNode True) [x] + +simpDone :: Exp -> S Exp +simpDone e = do + pmap <- asks envPapp + case e of + (BaseOp (Apply ty) (Var (V vn) _:fs)) | Just (tl,gs) <- IM.lookup vn pmap -> do + (cl,fn) <- tagUnfunction tl + mtick $ if cl == 1 then "Simplify.Apply.Papp.{" ++ show tl else ("Simplify.Apply.App.{" ++ show fn) + return $ if cl == 1 + then App fn (gs ++ fs) ty + else dstore (NodeC (partialTag fn (cl - 1)) (gs ++ fs)) + (Case v ls) | isJust utypes -> ans where + utypes@(~(Just ts)) = unboxTypes ur + ur = foldr1 combineUnboxing [ getUnboxing e | _ :-> e <- ls ] + ans = do + mtick "Grin.Simplify.Unbox.case-return" + let vs = zipWith Var [v1 ..] ts + return (unboxModify ur (Case v ls) :>>= vs :-> (unboxRet ur vs)) + (Case v1 ls) | [v1'] :-> Case v2 ls' <- last ls, v1' == v2 || v1 == v2 -> do + let f (p :-> e) = p :-> Return [v1] :>>= [v1'] :-> e + mtick "Grin.Simplify.case-merge" + return $ Case v1 (init ls ++ map f ls') + --(e :>>= p :-> Return p') | p == p' -> do + -- mtick "Grin.Simplify.tail-return-omit" + -- return e + _ -> do + cmap <- asks envCSE + case Map.lookup e cmap of + Just (n,e') -> do mtick n; tellFV e'; return e' + Nothing -> return e + +simpBind :: [Val] -> Exp -> S Exp -> S Exp +simpBind p e cont = f p e where + cse name xs = do + (z,col) <- listen $ local (\s -> s { envCSE = Map.fromList [ (x,(toAtom name,y)) | (x,y) <- xs] `Map.union` envCSE s }) cont + e <- simpDone e + if isOmittable e && isEmpty (freeVars p `intersection` colFreeVars col) then do + mtick "Simplify.Omit.Bind" + return z + else return $ e :>>= (p :-> z) + cse' name xs = cse name ((e,Return p):xs) + f p app@(BaseOp Eval [v]) = cse' "Simplify.CSE.eval" [(BaseOp Promote [v],Return p)] + f p (BaseOp Promote [v@Var {}]) = cse' "Simplify.CSE.promote" [(gEval v,Return p)] + f [p] (BaseOp Demote [v@Var {}]) = cse' "Simplify.CSE.demote" [(BaseOp Promote [p],Return [v]),(gEval p,Return [v])] + f [p@(Var (V vn) _)] (BaseOp (StoreNode isD) [v@(NodeC t vs)]) | not (isHoly v) = case (isD,tagUnfunction t,tagIsWHNF t) of + (True,Nothing,_) -> cse' "Simplify.CSE.return-node" [] + (True,Just (n,fn),_) -> local (\s -> s { envPapp = IM.insert vn (t,vs) (envPapp s) }) $ cse' "Simplify.CSE.return-node-func" [] + --(False,_,True) -> local (\s -> s { envPush = IM.insert vn (Store v) (envPush s) }) $ cse "Simplify.CSE.store-whnf" [] + --(False,_,False) -> cse' "Simplify.CSE.store" [] + _ -> cse' "Simplify.CSE.store" [] +-- f [p@(Var (V vn) _)] (Return [v@(NodeC t vs)]) | not (isHoly v) = case tagUnfunction t of +-- Nothing -> cse "Simplify.CSE.return-node" [(Return [p],Return [v]),(Store p,Store v)] +-- Just (n,fn) -> local (\s -> s { envPapp = IM.insert vn (t,vs) (envPapp s) }) $ cse' "Simplify.CSE.return-node" [(Return [p],Return [v]),(Store p,Store v)] +-- f [p@(Var (V vn) _)] (Store v@(NodeC t vs)) | not (isHoly v) = case tagIsWHNF t of +-- True -> local (\s -> s { envPush = IM.insert vn (Store v) (envPush s) }) $ cse "Simplify.CSE.store-whnf" [(BaseOp Promote [p],Return [v]),(gEval p,Return [v])] +-- False -> cse' "Simplify.CSE.store" [] + f _ _ = cse "Simplify.CSE.NOT" [] + +extEnv :: Var -> Val -> SEnv -> SEnv +extEnv (V vn) v s = s { envSubst = IM.insert vn v (envSubst s) } + +simpExp :: Exp -> S Exp +simpExp e = f e [] where + f (e :>>= p :-> Return p') rs | p == p' = do + mtick "Grin.Simplify.tail-return-omit" + f e rs + f (a :>>= (v :-> b)) xs = do + env <- ask + f a ((env,v,b):xs) + + -- simple transforms + f (BaseOp Promote [Const x]) rs = do + mtick "Grin.Simplify.fetch-const" + f (Return [x]) rs +-- f (Store x) rs | valIsNF x = do +-- mtick "Grin.Simplify.store-normalform" +-- f (Return [Const x]) rs + f (BaseOp Eval [Const n]) rs = do + mtick "Grin.Simplify.eval-const" + f (Return [n]) rs + f (Error s t) rs@(_:_) = do + mtick "Grin.Simplify.error-discard" + let (_,_,b) = last rs + f (Error s (getType b)) [] + f (Return [v]) ((senv,[Var vn _],b):rs) | valIsConstant v = do + mtick "Grin.Simplify.Subst.const" + fbind vn v senv b rs + f (Return [v@ValUnknown {}]) ((senv,[Var vn _],b):rs) = do + mtick "Grin.Simplify.Subst.unknown" + fbind vn v senv b rs + f (Return [v@Var {}]) ((senv,[Var vn _],b):rs) = do + mtick "Grin.Simplify.Subst.var" + fbind vn v senv b rs +-- f a@(Return [NodeC t xs]) ((senv,[NodeC t' ys],b):rs) | t == t' = do +-- mtick "Grin.Simplify.Assign.node-node" +-- dtup xs ys senv b rs + f (Return []) ((senv,[],b):rs) = do + mtick "Grin.Simplify.Assign.unit-unit" + dtup [] [] senv b rs + f a@(Return (xs@(_:_:_))) ((senv,ys,b):rs) = do + mtick "Grin.Simplify.Assign.tuple-tuple" + dtup xs ys senv b rs + f (Case v@Var {} [l]) rs = do + f (Return [v] :>>= l) rs +-- f e@(Case v ls) rs | isJust utypes = ans where +-- utypes@(~(Just ts)) = unboxTypes ur +-- ur = foldr1 combineUnboxing [ getUnboxing e | _ :-> e <- ls ] +-- ans = do +-- mtick "Grin.Simplify.Unbox.case-return" +-- let vs = zipWith Var [v1 ..] ts +-- f (unboxModify ur (Case v ls) :>>= vs :-> Return (unboxRet ur vs)) rs + f a ((senv,p,b):xs) = do + a <- g a + (p,env') <- renamePattern p + let env'' = env' `mappend` senv + local (const env'') $ simpBind p a (f b xs) + f x [] = do + e <- g x + simpDone e + fbind vn v senv b rs = do + v' <- applySubst v + local (\_ -> extEnv vn v' senv) $ f b rs + + dtup xs ys senv b rs | sameLength xs ys = do + xs <- mapM applySubst xs + (ys,env') <- renamePattern ys + let env'' = env' `mappend` senv + z <- local (const env'') $ f b rs + ts <- mapM (return . Just) [([y],Return [x]) | x <- xs | y <- ys ] + let h [] = z + h ((p,v):rs) = v :>>= p :-> h rs + return $ h [ (p,v) | Just (p,v) <- ts] + dtup _ _ _ _ _ = error "dtup: attempt to bind unequal lists" + g (Case v as) = do + v <- applySubst v + as <- mapM simpLam as + return $ Case v as + g lt@Let { expDefs = defs, expBody = body } = do + body <- f body [] + defs <- simpFuncs defs + let dnames = fromList $ map funcDefName defs :: GSet Atom + isInvalid e = isEmpty (freeVars e `intersection` dnames) + case body of + e :>>= l :-> r | isInvalid e -> do + mtick "Simplify.simplify.let-shrink-head" + return $ e :>>= l :-> updateLetProps lt { expBody = r, expDefs = defs } + e :>>= l :-> r | isInvalid r -> do + mtick "Simplify.simplify.let-shrink-tail" + return (updateLetProps lt { expBody = e, expDefs = defs } :>>= l :-> r) + App f as ts | f `elem` map funcDefName defs, f `Set.notMember` freeVars (map funcDefBody defs) -> do + mtick "Simplify.simplify.let-inline-body" + let [fbody] = [ funcDefBody fd | fd <- defs, funcDefName fd == f] + return $ updateLetProps lt { expDefs = defs, expBody = Return as :>>= fbody } + _ -> return $ updateLetProps lt { expBody = body, expDefs = defs } + g x = applySubstE x + +applySubstE :: Exp -> S Exp +applySubstE x = mapExpVal applySubst x + +applySubst x = f x where + f var@(Var (V v) _) = do + env <- asks envSubst + case IM.lookup v env of + Just n -> tellFV n >> return n + Nothing -> tellFV var >> return var + f x = mapValVal f x + +zeroVars fn x = f x where + f (Var v ty) | fn v || v == v0 = return (Var v ty) + | otherwise = do mtick $ "Simplify.ZeroVar.{" ++ show (Var v ty); return (Var v0 ty) + f x = mapValVal f x + +renamePattern :: [Val] -> S ([Val],SEnv) +renamePattern x = runWriterT (mapM f x) where + f :: Val -> WriterT SEnv S Val + f (Var v@(V vn) t) = do + v' <- lift $ newVarName v + let nv = Var v' t + tell (mempty { envSubst = IM.singleton vn nv }) + return nv + f x = mapValVal f x + +newVarName :: Var -> S Var +newVarName (V 0) = return (V 0) +newVarName (V sv) = do + s <- gets usedVars + let nv = v sv + v n | n `IS.member` s = v (1 + n + IS.size s) + | otherwise = n + modify (\e -> e { usedVars = IS.insert nv s }) + return (V nv) + +isHoly (NodeC _ as) | any isValUnknown as = True +isHoly n = False + +data UnboxingResult + = UnErr [Ty] + | UnStore !Bool !Atom [Unbox] + | UnDemote Unbox + | UnReturn [Unbox] + | UnTail (Set.Set Atom) [Ty] [Ty] + +data Unbox = UnConst Val | UnUnknown Ty | UnBaseOp BaseOp [Unbox] + deriving(Eq,Ord) + +isUnUnknown UnUnknown {} = True +isUnUnknown _ = False + +instance CanType UnboxingResult where + type TypeOf UnboxingResult = [Ty] + getType (UnErr tys) = tys + getType (UnReturn us) = map getType us + getType (UnStore b _ _) = [bool b tyDNode tyINode] + getType (UnDemote _) = [tyINode] + getType (UnTail _ tys _) = tys + +instance CanType Unbox where + type TypeOf Unbox = Ty + getType (UnConst v) = getType v + getType (UnUnknown t) = t + getType _ = error "getType: bad." + +unboxRet :: UnboxingResult -> [Val] -> Exp +unboxRet ur vs = f ur vs where + f (UnReturn xs) vs = Return $ let (r,[]) = g xs vs in r + f (UnStore b c xs) vs = let (xs',[]) = g xs vs in BaseOp (StoreNode b) [NodeC c xs'] + f (UnDemote u) vs = let ([u'],[]) = g [u] vs in BaseOp Demote [u'] + f (UnTail a _ tys) vs | [f] <- Set.toList a = App f vs tys + f UnErr {} _ = Return [] + f _ vs = Return vs + g [] vs = ([],vs) + g (UnUnknown _:xs) (v:vs) = let (r,y) = g xs vs in (v:r,y) + g (UnConst v:xs) vs = let (r,y) = g xs vs in (v:r,y) + g _ _ = error "SSimplify.unboxRet: bad." + +unboxTypes :: UnboxingResult -> Maybe [Ty] +unboxTypes ur = f ur where + f (UnTail ts tys _) | Set.size ts == 1 = Just tys + f (UnTail {}) = Nothing + f (UnErr []) = Nothing + f (UnErr (_:_)) = Just [] + f (UnReturn us) | all isUnUnknown us = Nothing + f (UnReturn xs) = Just $ concatMap h xs + f (UnStore _ _ ts) = Just $ concatMap h ts + f (UnDemote _) = Just [tyDNode] + h (UnUnknown t) = [t] + h (UnConst {}) = [] + h _ = error "SSimplify.unboxTypes: bad." + +unboxModify :: UnboxingResult -> Exp -> Exp +unboxModify ur = f ur where + Just nty = unboxTypes ur + f UnErr {} = id + f (UnTail a tys _) | [f] <- Set.toList a = runIdentity . editTail tys (mApp f) + f (UnReturn us) | all isUnUnknown us = id + f (UnReturn xs) = runIdentity . editTail nty (g xs) + f (UnStore _ _ us) =runIdentity . editTail nty (z us) + f (UnDemote _) =runIdentity . editTail nty y + f _ = error "SSimplify.unboxModify: bad1." + g xs (Return ys) = return $ Return (concat $ zipWith h xs ys) + g _ _ = error "SSimplify.unboxModify: bad2." + h (UnUnknown _) y = [y] + h (UnConst {}) _ = [] + h _ _ = error "SSimplify.unboxModify: bad3." + z xs (BaseOp (StoreNode _) [NodeC _ ts]) = return . Return . concat $ zipWith h xs ts + z _ _ = error "SSimplify.unboxModify: bad4." + y (BaseOp Demote [x]) = return $ Return [x] + y (Return [Const v]) = return $ Return [v] + y _ = error "SSimplify.unboxModify: bad5." + mApp f (App f' as tys) | f == f' = return $ Return as + mApp f e = error $ "mApp: " ++ show (f,e) + +combineUnboxing :: UnboxingResult -> UnboxingResult -> UnboxingResult +combineUnboxing ub1 ub2 = f ub1 ub2 where + f UnErr {} x = x + f x UnErr {} = x + f (UnTail t1 a1 u1) (UnTail t2 a2 u2) | u1 == u2, a1 == a2 = UnTail (t1 `union` t2) a1 u1 + f (UnReturn xs) (UnReturn ys) = UnReturn (zipWith g xs ys) + f (UnStore b1 a1 xs1) (UnStore b2 a2 xs2) | a1 == a2 = UnStore b1 a1 (zipWith g xs1 xs2) + | otherwise = UnReturn [UnUnknown (bool b1 tyDNode tyINode)] + f (UnDemote u1) (UnDemote u2) = UnDemote (g u1 u2) + f (UnDemote u1) (UnReturn [UnConst (Const v)]) = UnDemote (UnUnknown tyDNode) + f (UnReturn [UnConst (Const v)]) (UnDemote u1) = UnDemote (UnUnknown tyDNode) + f x _ = UnReturn (map UnUnknown (getType x)) + g (UnConst v1) (UnConst v2) | v1 == v2 = UnConst v1 + | otherwise = UnUnknown (getType v1) + g x _ = UnUnknown (getType x) + +getUnboxing :: Exp -> UnboxingResult +getUnboxing e = f e where + f (Return rs) = UnReturn (map g rs) + f (BaseOp (StoreNode b) [NodeC c xs]) = UnStore b c (map g xs) + f (BaseOp Demote [v]) = UnDemote (g v) + f (Error _ tys) = UnErr tys + f (App f vs ts) = UnTail (singleton f) (getType vs) ts + f (Case _ ls) = foldr1 combineUnboxing [ f e | _ :-> e <- ls ] + f Let { expDefs = defs, expBody = body, expIsNormal = False } = case f body of + UnTail fs _ ntys | not $ Set.null (fs `Set.intersection` (Set.fromList $ map funcDefName defs)) -> UnReturn (map UnUnknown ntys) + e -> e + f (_ :>>= _ :-> e) = f e + f e = UnReturn (map UnUnknown $ getType e) + g v | valIsConstant v = UnConst v + g v = UnUnknown (getType v) + +editTail :: Monad m => [Ty] -> (Exp -> m Exp) -> Exp -> m Exp +editTail nty mt te = f (sempty :: GSet Atom) te where + f _ (Error s ty) = return $ Error s nty + f lf (Case x ls) = return (Case x) `ap` mapM (g lf) ls + f lf lt@Let {expIsNormal = False, expBody = body } = do + body <- f lf body + return $ updateLetProps lt { expBody = body } + f lf lt@Let {expDefs = defs, expIsNormal = True } = do + let nlf = lf `union` fromList (map funcDefName defs) + mapExpExp (f nlf) lt + f lf lt@MkCont {expLam = lam, expCont = cont } = do + a <- g lf lam + b <- g lf cont + return $ lt { expLam = a, expCont = b } + f lf (e1 :>>= p :-> e2) = do + e2 <- f lf e2 + return $ e1 :>>= p :-> e2 + f lf e@(App a as t) | a `member` lf = return $ App a as nty + f lf e = mt e + g lf (p :-> e) = do e <- f lf e; return $ p :-> e + +bool b x y = if b then x else y + +-- this finds top level functions that call themselves recursively and turns the recursive call into a +-- local definition, allowing it to be compiled to a direct loop. + +explicitRecurse + :: Grin + -> IO Grin +explicitRecurse grin = mapGrinFuncsM f grin where + f name lam | name `notMember` (freeVars lam :: GSet Atom) = return lam + f name (as :-> e) = do + let nname = toAtom $ "bR" ++ fromAtom name + g (App n rs t) | n == name = App nname rs t + g e = tickle g e + return $ as :-> grinLet [createFuncDef True nname (as :-> g e) ] (App nname as (getType e)) + +$(derive makeMonoid ''SEnv) diff --git a/src/Ho/Build.hs b/src/Ho/Build.hs new file mode 100644 --- /dev/null +++ b/src/Ho/Build.hs @@ -0,0 +1,854 @@ +{-# LANGUAGE DoRec #-} +module Ho.Build ( + module Ho.Type, + dumpHoFile, + parseFiles, + preprocess, + preprocessHs, + buildLibrary + ) where + +import Control.Concurrent +import Control.Monad.Identity +import Data.IORef +import Data.List hiding(union) +import Data.Maybe +import Data.Monoid(Monoid(..)) +import Data.Tree +import Data.Version(Version,parseVersion,showVersion) +import System.FilePath as FP +import System.Mem +import Text.Printf +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.UTF8 as LBSU +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Text.PrettyPrint.HughesPJ as PPrint + +import DataConstructors +import Doc.DocLike +import Doc.PPrint +import Doc.Pretty +import E.E +import E.Rules +import E.Show +import E.Traverse(emapE) +import E.TypeCheck() +import FrontEnd.Class +import FrontEnd.FrontEnd +import FrontEnd.HsSyn +import FrontEnd.Infix +import FrontEnd.SrcLoc +import FrontEnd.Warning(warn,processIOErrors,WarnType(..)) +import Ho.Binary +import Ho.Collected() +import Ho.Library +import Ho.ReadSource +import Ho.Type +import Name.Name +import Options +import PackedString(PackedString,packString,unpackPS) +import Support.TempDir +import Util.Gen +import Util.SetLike +import Util.YAML +import Version.Config(version) +import Version.Version(versionString) +import qualified FlagDump as FD +import qualified FlagOpts as FO +import qualified Support.MD5 as MD5 +import qualified Util.Graph as G + +-- Ho File Format +-- +-- ho files are standard CFF format files (PNG-like) as described in the Support.CFF modules. +-- +-- the CFF magic for the files is the string "JHC" +-- +-- JHDR - header info, contains a list of modules contained and dependencies that need to be checked to read the file +-- LIBR - only present if this is a library, contains library metainfo +-- IDEP - immutable import information, needed to tell if ho files are up to date +-- LINK - redirect to another file for file systems without symlinks +-- DEFS - definitions type checking information +-- CORE - compiled core and associated data +-- LDEF - library map of module group name to DEFS +-- LCOR - library map of module group name to CORE +-- GRIN - compiled grin code +-- FILE - Extra file, such as embedded c code. + +{- + - We separate the data into various chunks for logical layout as well as the + - important property that each chunk is individually compressed and accessable. + - What this means is that we can skip chunks we don't need. for instance, + - during the final link we have no need of the haskell type checking + - information, we are only interested in the compiled code, so we can jump + - directly to it. If we relied on straight serialization, we would have to + - parse all preceding information just to discard it right away. We also lay + - them out so that we can generate error messages quickly. for instance, we can + - determine if a symbol is undefined quickly, before it has to load the + - typechecking data. + -} + +type LibraryName = PackedString + +findFirstFile :: [FilePath] -> IO (LBS.ByteString,FilePath) +findFirstFile [] = fail "findFirstFile: file not found" +findFirstFile (x:xs) = flip iocatch (\e -> findFirstFile xs) $ do + bs <- LBS.readFile x + return (bs,x) + +data ModDone + = ModNotFound + | ModLibrary !Bool ModuleGroup Library + | Found SourceCode + +data Done = Done { + hoCache :: Maybe FilePath, + knownSourceMap :: Map.Map SourceHash (Module,[(Module,SrcLoc)]), + validSources :: Set.Set SourceHash, + loadedLibraries :: Map.Map LibraryName Library, + hosEncountered :: Map.Map HoHash (FilePath,HoHeader,HoIDeps,Ho), + modEncountered :: Map.Map Module ModDone + } + +hosEncountered_u f r@Done{hosEncountered = x} = r{hosEncountered = f x} +knownSourceMap_u f r@Done{knownSourceMap = x} = r{knownSourceMap = f x} +loadedLibraries_u f r@Done{loadedLibraries = x} = r{loadedLibraries = f x} +modEncountered_u f r@Done{modEncountered = x} = r{modEncountered = f x} +validSources_u f r@Done{validSources = x} = r{validSources = f x} + +replaceSuffix suffix fp = reverse (dropWhile ('.' /=) (reverse fp)) ++ suffix + +hoFile :: Maybe FilePath -> FilePath -> Maybe Module -> SourceHash -> FilePath +hoFile cacheDir fp mm sh = case (cacheDir,optHoDir options) of + (Nothing,Nothing) -> replaceSuffix "ho" fp + (Nothing,Just hdir) -> case mm of + Nothing -> hdir ++ "/" ++ MD5.md5show32 sh ++ ".ho" + Just m -> hdir ++ "/" ++ map ft (show m) ++ ".ho" where + ft '/' = '.' + ft x = x + (Just hdir,_) -> hdir ++ "/" ++ MD5.md5show32 sh ++ ".ho" + +findHoFile :: IORef Done -> FilePath -> Maybe Module -> SourceHash -> IO (Bool,FilePath) +findHoFile done_ref fp mm sh = do + done <- readIORef done_ref + let honame = hoFile (hoCache done) fp mm sh + writeIORef done_ref (done { validSources = Set.insert sh (validSources done) }) + if sh `Set.member` validSources done || optIgnoreHo options then return (False,honame) else do + onErr (return (False,honame)) (readHoFile honame) $ \ (hoh,hidep,ho) -> + case hohHash hoh `Map.lookup` hosEncountered done of + Just (fn,_,_,a) -> return (True,fn) + Nothing -> do + modifyIORef done_ref (knownSourceMap_u $ (`mappend` (hoIDeps hidep))) + modifyIORef done_ref (validSources_u $ Set.union (Set.fromList . map snd $ hoDepends hidep)) + modifyIORef done_ref (hosEncountered_u $ Map.insert (hohHash hoh) (honame,hoh,hidep,ho)) + return (True,honame) + +onErr :: IO a -> IO b -> (b -> IO a) -> IO a +onErr err good cont = join $ iocatch (good >>= return . cont) (\_ -> return err) + +fetchSource :: Opt -> IORef Done -> [FilePath] -> Maybe (Module,SrcLoc) -> IO Module +fetchSource _ _ [] _ = fail "No files to load" +fetchSource modOpt done_ref fs mm = do + let killMod = case mm of + Nothing -> fail $ "Could not load file: " ++ show fs + Just (m,sloc) -> do + warn sloc (MissingModule m) $ printf "Module '%s' not found." (show m) + modifyIORef done_ref (modEncountered_u $ Map.insert m ModNotFound) >> return m + onErr killMod (findFirstFile fs) $ \ (lbs,fn) -> do + let hash = MD5.md5lazy $ (LBSU.fromString version) `mappend` lbs + (foundho,mho) <- findHoFile done_ref fn (fmap fst mm) hash + done <- readIORef done_ref + (mod,m,ds) <- case mlookup hash (knownSourceMap done) of + Just (m,ds) -> return (Left lbs,m,ds) + Nothing -> do + (hmod,_) <- parseHsSource modOpt fn lbs + let m = hsModuleName hmod + ds = hsModuleRequires hmod + writeIORef done_ref (knownSourceMap_u (Map.insert hash (m,ds)) done) + case optAnnotate options of + Just _ -> return (Left lbs,m,ds) + _ -> return (Right hmod,m,ds) + case mm of + Just (m',_) | m /= m' -> do + putErrLn $ "Skipping file" <+> fn <+> "because its module declaration of" <+> show m <+> "does not equal the expected" <+> show m' + killMod + _ -> do + let sc (Right mod) = SourceParsed sinfo mod + sc (Left lbs) = SourceRaw sinfo lbs + sinfo = SI { sourceHash = hash, sourceDeps = ds, sourceFP = fn, sourceHoName = mho, sourceModName = m } + modifyIORef done_ref (modEncountered_u $ Map.insert m (Found (sc mod))) + fn' <- shortenPath fn + mho' <- shortenPath mho + putProgressLn $ if foundho + then printf "%-23s [%s] <%s>" (show m) fn' mho' + else printf "%-23s [%s]" (show m) fn' + mapM_ (resolveDeps modOpt done_ref) ds + return m + +resolveDeps :: Opt -> IORef Done -> (Module,SrcLoc) -> IO () +resolveDeps modOpt done_ref (m,sloc) = do + done <- readIORef done_ref + case m `mlookup` modEncountered done of + Just (ModLibrary False _ lib) | not ("jhc-prim-" `isPrefixOf` libName lib) -> putErrDie $ printf "ERROR: Attempt to import module '%s' which is a member of the library '%s'.\nPerhaps you need to add '-p%s' to the command line?" (show m) (libName lib) (libName lib) + Just _ -> return () + Nothing -> fetchSource modOpt done_ref (map fst $ searchPaths modOpt (show m)) (Just (m,sloc)) >> return () + +type LibInfo = (Map.Map Module ModuleGroup, Map.Map ModuleGroup [ModuleGroup], Set.Set Module,Map.Map ModuleGroup HoBuild,Map.Map ModuleGroup HoTcInfo) + +data CompNode = CompNode !HoHash [CompNode] {-# UNPACK #-} !(IORef CompLink) +data CompLink + = CompLinkUnit CompUnit + | CompCollected CollectedHo CompUnit + | CompTcCollected HoTcInfo CompUnit + | CompLinkLib (ModuleGroup,LibInfo) CompUnit + +compLinkCompUnit (CompLinkUnit cu) = cu +compLinkCompUnit (CompCollected _ cu) = cu +compLinkCompUnit (CompTcCollected _ cu) = cu +compLinkCompUnit (CompLinkLib _ cu) = cu + +instance MapKey Module where + showMapKey = show +instance MapKey MD5.Hash where + showMapKey = show + +dumpDeps targets memap cug = case optDeps options of + Nothing -> return () + Just fp -> do + let (sfps,sdps,ls) = collectDeps memap cug + let yaml = Map.fromList [ + ("Target",toNode targets), + ("LibraryDesc",toNode [ fp | BuildHl fp <- [optMode options]]), + ("LibraryDeps",toNode ls), + ("ModuleSource",toNode sfps), + ("ModuleDeps",toNode sdps) + ] + writeFile fp (showYAML yaml) + +collectDeps memap cs = mconcatMap f [ cu | (_,(_,cu)) <- cs] where + f (CompSources ss) = mconcat [ (Map.singleton (sourceModName s) (sourceFP s),Map.singleton (sourceModName s) (fsts $ sourceDeps s),mempty) | s <- map sourceInfo ss ] + f (CompLibrary _ lib) = (mempty,mempty,Map.singleton (libHash lib) (libFileName lib)) + f (CompHo _hoh idep _ho) = (Map.fromList [ (sourceModName $ sourceInfo src, sourceFP $ sourceInfo src) | s <- fsts ss, Just (Found src) <- [Map.lookup s memap] ],Map.fromList [ (mms,fsts mms') | s <- snds ss, Just (mms,mms') <- [Map.lookup s (hoIDeps idep)] ],mempty) where + ss = [ s | s <- hoDepends idep ] + f _ = mempty + +type CompUnitGraph = [(HoHash,([HoHash],CompUnit))] + +data CompUnit + = CompHo HoHeader HoIDeps Ho + | CompSources [SourceCode] + | CompTCed ((HoTcInfo,TiData,[(HoHash,HsModule)],[String])) + | CompDummy + | CompLibrary Ho Library + +instance Show CompUnit where + showsPrec _ = shows . providesModules + +data SourceInfo = SI { + sourceHash :: SourceHash, + sourceDeps :: [(Module,SrcLoc)], + sourceFP :: FilePath, + sourceModName :: Module, + sourceHoName :: FilePath + } + +data SourceCode + = SourceParsed { sourceInfo :: !SourceInfo, sourceModule :: HsModule } + | SourceRaw { sourceInfo :: !SourceInfo, sourceLBS :: LBS.ByteString } + +sourceIdent = show . sourceModName . sourceInfo + +class ProvidesModules a where + providesModules :: a -> [Module] + providesModules _ = [] + +instance ProvidesModules HoIDeps where + providesModules = fsts . hoDepends + +instance ProvidesModules HoLib where + providesModules = Map.keys . hoModuleMap + +instance ProvidesModules CompUnit where + providesModules (CompHo _ hoh _) = providesModules hoh + providesModules (CompSources ss) = concatMap providesModules ss + providesModules (CompLibrary ho libr) = libProvides (hoModuleGroup ho) libr + providesModules CompDummy = [] + providesModules (CompTCed _) = error "providesModules: bad1." + +instance ProvidesModules CompLink where + providesModules (CompLinkUnit cu) = providesModules cu + providesModules (CompCollected _ cu) = providesModules cu + providesModules (CompTcCollected _ cu) = providesModules cu + providesModules (CompLinkLib _ _) = error "providesModules: bad2c." + +instance ProvidesModules SourceCode where + providesModules sp = [sourceModName (sourceInfo sp)] + +-- | this walks the loaded modules and ho files, discarding out of +-- date ho files and organizing modules into their binding groups. +-- the result is an acyclic graph where the nodes are ho files, sets +-- of mutually recursive modules, or libraries. +-- there is a strict ordering of +-- source >= ho >= library +-- in terms of dependencies + +toCompUnitGraph :: Done -> [Module] -> IO (HoHash,CompUnitGraph) +toCompUnitGraph done roots = do + let fs m = map inject $ maybe (error $ "can't find deps for: " ++ show m) (fsts . snd) (Map.lookup m (knownSourceMap done)) + fs' m libr = fromMaybe (error $ "can't find deps for: " ++ show m) (Map.lookup m (hoModuleDeps $ libHoLib libr)) + foundMods = [ ((m,Left (sourceHash $ sourceInfo sc)),fs (sourceHash $ sourceInfo sc)) | (m,Found sc) <- Map.toList (modEncountered done)] + foundMods' = Map.elems $ Map.fromList [ (mg,((mg,Right lib),fs' mg lib)) | (_,ModLibrary _ mg lib) <- Map.toList (modEncountered done)] + fullModMap = Map.unions (map libModMap $ Map.elems (loadedLibraries done)) + inject m = Map.findWithDefault m m fullModMap + gr = G.newGraph (foundMods ++ foundMods') (fst . fst) snd + gr' = G.sccGroups gr + phomap = Map.fromListWith (++) (concat [ [ (m,[hh]) | (m,_) <- hoDepends idep ] | (hh,(_,_,idep,_)) <- Map.toList (hosEncountered done)]) + sources = Map.fromList [ (m,sourceHash $ sourceInfo sc) | (m,Found sc) <- Map.toList (modEncountered done)] + + when (dump FD.SccModules) $ do + mapM_ (putErrLn . show) $ map (map $ fst . fst) gr' + putErrLn $ drawForest (map (fmap (show . fst . fst)) (G.dff gr)) + + cug_ref <- newIORef [] + hom_ref <- newIORef (Map.map ((,) False) $ hosEncountered done) + ms <- forM gr' $ \ns -> do + r <- newIORef (Left ns) + return (Map.fromList [ (m,r) | ((m,_),_) <- ns ]) + let mods = Map.unions ms + lmods m = fromMaybe (error $ "modsLookup: " ++ show m) (Map.lookup m mods) + let f m = do + rr <- readIORef (lmods m) + case rr of + Right hh -> return hh + Left ns -> g ns + + g ms@(((m,Left _),_):_) = do + let amods = map (fst . fst) ms + pm (fromMaybe [] (Map.lookup m phomap)) $ do + let deps = Set.toList $ Set.fromList (concat $ snds ms) `Set.difference` (Set.fromList amods) + deps' <- snub `fmap` mapM f deps + let mhash = MD5.md5String (concatMap (show . fst) ms ++ show deps') + writeIORef (lmods m) (Right mhash) + modifyIORef cug_ref ((mhash,(deps',CompSources $ map fs amods)):) + return mhash + g [((mg,Right lib),ds)] = do + let Just hob = Map.lookup mg $ libBuildMap lib + Just hot = Map.lookup mg $ libTcMap lib + ho = Ho { hoModuleGroup = mg, hoBuild = hob, hoTcInfo = hot } + myHash = libMgHash mg lib + deps <- snub `fmap` mapM f ds + writeIORef (lmods mg) (Right myHash) + modifyIORef cug_ref ((myHash,(deps,CompLibrary ho lib)):) + return myHash + g _ = error "Build.toCompUnitGraph: bad." + pm :: [HoHash] -> IO HoHash -> IO HoHash + pm [] els = els + pm (h:hs) els = hvalid h `iocatch` (\_ -> pm hs els) + hvalid h = do + ll <- Map.lookup h `fmap` readIORef hom_ref + case ll of + Nothing -> fail "Don't know anything about this hash" + Just (True,_) -> return h + Just (False,af@(fp,hoh,idep,ho)) -> do + fp <- shortenPath fp + isGood <- iocatch ( mapM_ cdep (hoDepends idep) >> mapM_ hvalid (hoModDepends idep) >> return True) (\_ -> return False) + let isStale = not . null $ map (show . fst) (hoDepends idep) `intersect` optStale options + libsGood = all (\ (p,h) -> fmap (libHash) (Map.lookup p (loadedLibraries done)) == Just h) (hohLibDeps hoh) + noGood forced = do + putProgressLn $ printf "Stale: <%s>%s" fp forced + modifyIORef hom_ref (Map.delete h) + fail "stale file" + case (isStale,isGood && libsGood) of + (False,True) -> do + putProgressLn $ printf "Fresh: <%s>" fp + hs <- mapM f (hoModuleGroupNeeds idep) + modifyIORef cug_ref ((h,(hs ++ hoModDepends idep,CompHo hoh idep ho)):) + modifyIORef hom_ref (Map.insert h (True,af)) + return h + (True,_) -> noGood " (forced)" + (_,False) -> noGood "" + cdep (_,hash) | hash == MD5.emptyHash = return () + cdep (mod,hash) = case Map.lookup mod sources of + Just hash' | hash == hash' -> return () + _ -> fail "Can't verify module up to date" + fs m = case Map.lookup m (modEncountered done) of + Just (Found sc) -> sc + _ -> error $ "fs: " ++ show m + mapM_ f (map inject roots) + cug <- readIORef cug_ref + let (rhash,cug') = mkPhonyCompUnit roots cug + let gr = G.newGraph cug' fst (fst . snd) + gr' = G.transitiveReduction gr + when (dump FD.SccModules) $ do + putErrLn "ComponentsDeps:" + mapM_ (putErrLn . show) [ (snd $ snd v, map (snd . snd) vs) | (v,vs) <- G.fromGraph gr'] + return (rhash,[ (h,([ d | (d,_) <- ns ],cu)) | ((h,(_,cu)),ns) <- G.fromGraph gr' ]) + +parseFiles + :: Opt -- ^ Options to use when parsing files + -> [FilePath] -- ^ Targets we are building, used when dumping dependencies + -> [String] -- ^ Extra libraries to load + -> [Either Module FilePath] -- ^ Either a module or filename to find + -> (CollectedHo -> Ho -> IO CollectedHo) -- ^ Process initial ho loaded from file + -> (CollectedHo -> Ho -> TiData -> IO (CollectedHo,Ho)) -- ^ Process set of mutually recursive modules to produce final Ho + -> IO (CompNode,CollectedHo) -- ^ Final accumulated ho +parseFiles options targets elibs need ifunc func = do + putProgressLn "Finding Dependencies..." + (ksm,chash,cug) <- loadModules options targets (snub $ + if optNoAuto options then optHls options ++ elibs else + optAutoLoads options ++ optHls options ++ elibs) bogusASrcLoc need + cnode <- processCug cug chash + when (optStop options == StopParse) exitSuccess + performGC + putProgressLn "Typechecking..." + typeCheckGraph options cnode + if isJust (optAnnotate options) then exitSuccess else do + when (optStop options == StopTypeCheck) exitSuccess + performGC + putProgressLn "Compiling..." + cho <- compileCompNode ifunc func ksm cnode + return (cnode,cho) + +-- this takes a list of modules or files to load, and produces a compunit graph +loadModules + :: Opt -- ^ Options to use when parsing files + -> [FilePath] -- ^ targets + -> [String] -- ^ libraries to load + -> SrcLoc -- ^ where these files are requsted from + -> [Either Module FilePath] -- ^ a list of modules or filenames + -> IO (Map.Map SourceHash (Module,[(Module,SrcLoc)]),HoHash,CompUnitGraph) -- ^ the resulting acyclic graph of compilation units +loadModules modOpt targets libs sloc need = do + theCache <- findHoCache + case theCache of + Just s -> putProgressLn $ printf "Using Ho Cache: '%s'" s + Nothing -> return () + done_ref <- newIORef Done { + hoCache = theCache, + knownSourceMap = Map.empty, + validSources = Set.empty, + loadedLibraries = Map.empty, + hosEncountered = Map.empty, + modEncountered = Map.empty + } + (es,is) <- collectLibraries libs + let combModMap es = Map.unions [ Map.map ((,) l) (hoModuleMap $ libHoLib l) | l <- es] + explicitModMap = combModMap es + implicitModMap = combModMap is + reexported = Set.fromList [ m | l <- es, (m,_) <- Map.toList $ hoReexports (libHoLib l) ] + modEnc exp emap = Map.fromList [ (m,ModLibrary (exp || Set.member m reexported) mg l) | (m,(l,mg)) <- Map.toList emap ] + + modifyIORef done_ref (loadedLibraries_u $ Map.union $ Map.fromList [ (libBaseName lib,lib) | lib <- es ++ is]) + modifyIORef done_ref (modEncountered_u $ Map.union (modEnc True explicitModMap)) + modifyIORef done_ref (modEncountered_u $ Map.union (modEnc False implicitModMap)) + + forM_ (concatMap libExtraFiles (es ++ is)) $ \ef -> do + fileInTempDir ("cbits/" ++ unpackPS (extraFileName ef)) $ \fn -> BS.writeFile fn (extraFileData ef) + + done <- readIORef done_ref + forM_ (Map.elems $ loadedLibraries done) $ \ lib -> do + let libsBad = filter (\ (p,h) -> fmap (libHash) (Map.lookup p (loadedLibraries done)) /= Just h) (hohLibDeps $ libHoHeader lib) + unless (null libsBad) $ do + putErr $ printf "Library Dependencies not met. %s needs\n" (libName lib) + forM_ libsBad $ \ (p,h) -> putErr $ printf " %s (hash:%s)\n" (unpackPS p) (show h) + putErrDie "\n" + ms1 <- forM (rights need) $ \fn -> do + fetchSource modOpt done_ref [fn] Nothing + forM_ (map (,sloc) $ lefts need) $ resolveDeps modOpt done_ref + processIOErrors + done <- readIORef done_ref + let needed = (ms1 ++ lefts need) + (chash,cug) <- toCompUnitGraph done needed + dumpDeps targets (modEncountered done) cug + return (Map.filterWithKey (\k _ -> k `Set.member` validSources done) (knownSourceMap done),chash,cug) + +-- turn the list of CompUnits into a true mutable graph. +processCug :: CompUnitGraph -> HoHash -> IO CompNode +processCug cug root = mdo + let mmap = Map.fromList xs + lup x = maybe (error $ "processCug: " ++ show x) id (Map.lookup x mmap) + f (h,(ds,cu)) = do + cur <- newIORef (CompLinkUnit cu) + return $ (h,CompNode h (map lup ds) cur) + xs <- mapM f cug + Just x <- return $ Map.lookup root mmap + return $ x + +mkPhonyCompUnit :: [Module] -> CompUnitGraph -> (HoHash,CompUnitGraph) +mkPhonyCompUnit need cs = (fhash,(fhash,(fdeps,CompDummy)):cs) where + fhash = MD5.md5String $ show (sort fdeps) + fdeps = [ h | (h,(_,cu)) <- cs, not . null $ providesModules cu `intersect` need ] + +printModProgress :: Int -> Int -> IO Int -> [HsModule] -> IO () +printModProgress _ _ _ [] = return () +printModProgress _ _ tickProgress ms | not progress = mapM_ (const tickProgress) ms +printModProgress fmtLen maxModules tickProgress ms = f "[" ms where + f bl ms = do + curModule <- tickProgress + case ms of + [x] -> g curModule bl "]" x + (x:xs) -> do g curModule bl "-" x; putErrLn ""; f "-" xs + _ -> error "Build.printModProgress: bad." + g curModule bl el modName = putErr $ printf "%s%*d of %*d%s %-17s" bl fmtLen curModule fmtLen maxModules el (show $ hsModuleName modName) + +countNodes cn = do + seen <- newIORef Set.empty + let h (CompNode hh deps ref) = do + s <- readIORef seen + if hh `Set.member` s then return Set.empty else do + writeIORef seen (Set.insert hh s) + ds <- mapM h deps + cm <- readIORef ref >>= g + return (Set.unions (cm:ds)) + g cn = case cn of + CompLinkUnit cu -> return $ f cu + CompTcCollected _ cu -> return $ f cu + CompCollected _ cu -> return $ f cu + CompLinkLib _ _ -> error "Build.countNodes: bad." + f cu = case cu of + CompTCed (_,_,_,ss) -> Set.fromList ss + CompSources sc -> Set.fromList (map sourceIdent sc) + _ -> Set.empty + h cn + +typeCheckGraph :: Opt -> CompNode -> IO () +typeCheckGraph modOpt cn = do + cur <- newMVar (1::Int) + maxModules <- Set.size `fmap` countNodes cn + let f (CompNode hh deps ref) = readIORef ref >>= \cn -> case cn of + CompTcCollected ctc _ -> return ctc + CompLinkUnit lu -> do + deps' <- randomPermuteIO deps + ctc <- mconcat `fmap` mapM f deps' + case lu of + CompDummy -> do + writeIORef ref (CompTcCollected ctc CompDummy) + return ctc + CompHo hoh idep ho -> do + let ctc' = hoTcInfo ho `mappend` ctc + writeIORef ref (CompTcCollected ctc' lu) + return ctc' + CompLibrary ho _libr -> do + let ctc' = hoTcInfo ho `mappend` ctc + writeIORef ref (CompTcCollected ctc' lu) + return ctc' + CompSources sc -> do + let mods = sort $ map (sourceModName . sourceInfo) sc + modules <- forM sc $ \x -> case x of + SourceParsed { sourceInfo = si, sourceModule = sm } -> + return (sourceHash si, sm, error "SourceParsed in AnnotateSource") + SourceRaw { sourceInfo = si, sourceLBS = lbs } -> do + (mod,lbs') <- parseHsSource modOpt (sourceFP si) lbs + case optAnnotate modOpt of + Just fp -> do + let ann = LBSU.fromString $ unlines [ + "{- --ANNOTATE--", + "Module: " ++ show (sourceModName si), + "Deps: " ++ show (sort $ fsts $ sourceDeps si), + "Siblings: " ++ show mods, + "-}"] + LBS.writeFile (fp ++ "/" ++ show (hsModuleName mod) ++ ".hs") (ann `LBS.append` lbs') + _ -> return () + return (sourceHash si,mod,lbs') + showProgress (map snd3 modules) + (htc,tidata) <- doModules ctc (map snd3 modules) + let ctc' = htc `mappend` ctc + writeIORef ref (CompTcCollected ctc' (CompTCed ((htc,tidata,[ (x,y) | (x,y,_) <- modules],map (sourceHoName . sourceInfo) sc)))) + return ctc' + _ -> error "Build.typeCheckGraph: bad1." + _ -> error "Build.typeCheckGraph: bad2." + showProgress ms = printModProgress fmtLen maxModules tickProgress ms + fmtLen = ceiling (logBase 10 (fromIntegral maxModules+1) :: Double) :: Int + tickProgress = modifyMVar cur $ \val -> return (val+1,val) + f cn + return () + +compileCompNode :: (CollectedHo -> Ho -> IO CollectedHo) -- ^ Process initial ho loaded from file + -> (CollectedHo -> Ho -> TiData -> IO (CollectedHo,Ho)) -- ^ Process set of mutually recursive modules to produce final Ho + -> Map.Map SourceHash (Module,[(Module,SrcLoc)]) + -> CompNode + -> IO CollectedHo +compileCompNode ifunc func ksm cn = do + cur <- newMVar (1::Int) + ksm_r <- newIORef ksm + let tickProgress = modifyMVar cur $ \val -> return (val+1,val) + maxModules <- Set.size `fmap` countNodes cn + let showProgress ms = printModProgress fmtLen maxModules tickProgress ms + fmtLen = ceiling (logBase 10 (fromIntegral maxModules+1) :: Double) :: Int + let f (CompNode hh deps ref) = readIORef ref >>= g where + g cn = case cn of + CompCollected ch _ -> return ch + CompTcCollected _ cl -> h cl + CompLinkUnit cu -> h cu + _ -> error "Build.compileCompNode: bad." + h cu = do + deps' <- randomPermuteIO deps + cho <- mconcat `fmap` mapM f deps' + + case cu of + CompDummy -> do + writeIORef ref (CompCollected cho CompDummy) + return cho + (CompHo hoh idep ho) -> do + cho <- choLibDeps_u (Map.union $ Map.fromList (hohLibDeps hoh)) `fmap` ifunc cho ho + writeIORef ref (CompCollected cho cu) + return cho + (CompLibrary ho Library { libHoHeader = hoh }) -> do + cho <- ifunc cho ho + let Right (ln,_) = hohName hoh + lh = hohHash hoh + cho' = (choLibDeps_u (Map.insert ln lh) cho) + writeIORef ref (CompCollected cho' cu) + return cho' + CompTCed ((htc,tidata,modules,shns)) -> do + (hdep,ldep) <- fmap mconcat . forM deps $ \ (CompNode h _ ref) -> do + cl <- readIORef ref + case compLinkCompUnit cl of + CompLibrary ho _ -> return ([],[hoModuleGroup ho]) + CompDummy {} -> return ([],[]) + _ -> return ([h],[]) + showProgress (snds modules) + let (mgName:_) = sort $ map (hsModuleName . snd) modules + (cho',newHo) <- func cho mempty { hoModuleGroup = mgName, hoTcInfo = htc } tidata + modifyIORef ksm_r (Map.union $ Map.fromList [ (h,(hsModuleName mod, hsModuleRequires mod)) | (h,mod) <- modules]) + ksm <- readIORef ksm_r + let hoh = HoHeader { + hohVersion = error "hohVersion", + hohName = Left mgName, + hohHash = hh, + hohArchDeps = [], + hohLibDeps = Map.toList (choLibDeps cho') + } + idep = HoIDeps { + hoIDeps = ksm, + hoDepends = [ (hsModuleName mod,h) | (h,mod) <- modules], + hoModDepends = hdep, + hoModuleGroupNeeds = ldep + } + recordHoFile (mapHoBodies eraseE newHo) idep shns hoh + writeIORef ref (CompCollected cho' (CompHo hoh idep newHo)) + return cho' + CompSources _ -> error "sources still exist!?" + f cn + +hsModuleRequires x = snub ((toModule "Jhc.Prim.Prim",bogusASrcLoc):ans) where + noPrelude = FO.Prelude `Set.notMember` optFOptsSet (hsModuleOpt x) + ans = (if noPrelude then id else ((preludeModule,bogusASrcLoc):)) [ (hsImportDeclModule y,hsImportDeclSrcLoc y) | y <- hsModuleImports x] + +searchPaths :: Opt -> String -> [(String,String)] +searchPaths modOpt m = ans where + f m | (xs,'.':ys) <- span (/= '.') m = let n = (xs ++ "/" ++ ys) in m:f n + | otherwise = [m] + ans = [ (root ++ suf,root ++ ".ho") | i <- optIncdirs modOpt, n <- f m, suf <- [".hs",".lhs",".hsc"], let root = i ++ "/" ++ n] + +mapHoBodies :: (E -> E) -> Ho -> Ho +mapHoBodies sm ho = ho { hoBuild = g (hoBuild ho) } where + g ho = ho { hoEs = map f (hoEs ho) , hoRules = runIdentity (E.Rules.mapBodies (return . sm) (hoRules ho)) } + f (t,e) = (t,sm e) + +eraseE :: E -> E +eraseE e = runIdentity $ f e where + f (EVar tv) = return $ EVar tvr { tvrIdent = tvrIdent tv } + f e = emapE f e + +--------------------------------- +-- library specific routines +--------------------------------- + +buildLibrary :: (CollectedHo -> Ho -> IO CollectedHo) + -> (CollectedHo -> Ho -> TiData -> IO (CollectedHo,Ho)) -- ^ Process set of mutually recursive modules to produce final Ho + -> FilePath + -> IO () +buildLibrary ifunc func = ans where + ans fp = do + (desc,name,vers,hmods,emods,modOpts,sources) <- parse fp + vers <- runReadP parseVersion vers + let allMods = emodSet `Set.union` hmodSet + emodSet = Set.fromList emods + hmodSet = Set.fromList hmods + let outName = case optOutName modOpts of + Nothing -> name ++ "-" ++ showVersion vers ++ ".hl" + Just fn -> fn + -- TODO - must check we depend only on libraries + (rnode@(CompNode lhash _ _),cho) <- parseFiles modOpts [outName] [] (map Left $ Set.toList allMods) ifunc func + (_,(mmap,mdeps,prvds,lcor,ldef)) <- let + f (CompNode hs cd ref) = do + cl <- readIORef ref + case cl of + CompLinkLib l _ -> return l + CompCollected _ y -> g hs cd ref y + _ -> error "Build.buildLibrary: bad1." + g hh deps ref cn = do + deps <- mapM f deps + let (mg,mll) = case cn of + CompDummy -> (error "modgroup of dummy",mempty) + CompLibrary ho lib -> (hoModuleGroup ho,mempty) + CompHo hoh hidep ho -> (mg,( + Map.fromList $ zip (providesModules hidep) (repeat mg), + Map.singleton mg (sort $ fsts deps), + Set.fromList $ providesModules hidep, + Map.singleton mg (hoBuild ho'), + Map.singleton mg (hoTcInfo ho') + )) where + mg = hoModuleGroup ho + ho' = mapHoBodies eraseE ho + _ -> error "Build.buildLibrary: bad2." + res = (mg,mconcat (snds deps) `mappend` mll) + writeIORef ref (CompLinkLib res cn) + return res + in f rnode + let unknownMods = Set.toList $ Set.filter (`Set.notMember` allMods) prvds + mapM_ ((putStrLn . ("*** Module depended on in library that is not in export list: " ++)) . show) unknownMods + mapM_ ((putStrLn . ("*** We are re-exporting the following modules from other libraries: " ++)) . show) $ Set.toList (allMods Set.\\ prvds) + let hoh = HoHeader { + hohHash = lhash, + hohName = Right (packString name,vers), + hohLibDeps = Map.toList (choLibDeps cho), + hohArchDeps = [], + hohVersion = error "hohVersion" + } + let pdesc = [(packString n, packString v) | (n,v) <- ("jhc-hl-filename",outName):("jhc-description-file",fp):("jhc-compiled-by",versionString):desc, n /= "exposed-modules" ] + libr = HoLib { + hoReexports = Map.fromList [ (m,m) | m <- Set.toList $ allMods Set.\\ prvds ], + hoMetaInfo = pdesc, + hoModuleMap = mmap, + hoModuleDeps = mdeps + } + putProgressLn $ "Writing Library: " ++ outName + efs <- mapM fetchExtraFile sources + recordHlFile Library { libHoHeader = hoh, libHoLib = libr, libTcMap = ldef, + libBuildMap = lcor, libFileName = outName, libExtraFiles = efs } + -- parse library description file + parse fp = do + putProgressLn $ "Creating library from description file: " ++ show fp + LibDesc dlist dsing <- readDescFile fp + when verbose2 $ do + mapM_ print (Map.toList dlist) + mapM_ print (Map.toList dsing) + let jfield x = maybe (fail $ "createLibrary: description lacks required field " ++ show x) return $ Map.lookup x dsing + mfield x = maybe [] id $ Map.lookup x dlist + --mfield x = maybe [] (words . map (\c -> if c == ',' then ' ' else c)) $ Map.lookup x dlist + name <- jfield "name" + vers <- jfield "version" + let (modOpts,flags) = (lproc bopt,modOptions) where + Just bopt = fileOptions options modOptions `mplus` Just options + (pfs,nfs,_) = languageFlags (mfield "extensions") + lproc opt = opt { optFOptsSet = Set.union pfs (optFOptsSet opt) Set.\\ nfs } + dirs = [ "-i" ++ dd x | x <- mfield "hs-source-dirs" ] + ++ [ "-I" ++ dd x | x <- mfield "include-dirs" ] + ++ [ "-p" ++ x | x <- mfield "build-depends" ] + modOptions = (mfield "options" ++ dirs) + dd "." = FP.takeDirectory fp + dd ('.':'/':x) = dd x + dd x = FP.takeDirectory fp FP. x + when verbose $ + print (flags,optFOptsSet modOpts) + let hmods = map toModule $ snub $ mfield "hidden-modules" + emods = map toModule $ snub $ mfield "exposed-modules" + sources = map (FP.takeDirectory fp FP.) $ snub $ mfield "c-sources" ++ mfield "include-sources" + return (Map.toList dsing,name,vers,hmods,emods,modOpts,sources) + +fetchExtraFile fp = do + c <- BS.readFile fp + return ExtraFile { extraFileName = packString (FP.takeFileName fp), + extraFileData = c } + +------------------------------------ +-- dumping contents of a ho file +------------------------------------ + +instance DocLike d => PPrint d MD5.Hash where + pprint h = tshow h + +instance DocLike d => PPrint d SrcLoc where + pprint sl = tshow sl + +instance DocLike d => PPrint d Version where + pprint sl = text $ showVersion sl + +instance DocLike d => PPrint d PackedString where + pprint sl = text (unpackPS sl) + +{-# NOINLINE dumpHoFile #-} +dumpHoFile :: String -> IO () +dumpHoFile fn = ans where + ans = do + putStrLn fn + case reverse fn of + 'l':'h':'.':_ -> doHl fn + 'o':'h':'.':_ -> doHo fn + _ -> putErrDie "Error: --show-ho requires a .hl or .ho file" + vindent xs = vcat (map (" " ++) xs) + showList nm xs = when (not $ null xs) $ putStrLn $ (nm ++ ":\n") <> vindent xs + doHoh hoh = do + putStrLn $ "Version:" <+> pprint (hohVersion hoh) + putStrLn $ "Hash:" <+> pprint (hohHash hoh) + putStrLn $ "Name:" <+> pprint (hohName hoh) + showList "LibDeps" (map pprint . sortUnder fst $ hohLibDeps hoh) + showList "ArchDeps" (map pprint . sortUnder fst $ hohArchDeps hoh) + doHl fn = do + l <- readHlFile fn + doHoh $ libHoHeader l + showList "MetaInfo" (sort [text (unpackPS k) <> char ':' <+> show v | + (k,v) <- hoMetaInfo (libHoLib l)]) + showList "ModuleMap" (map pprint . sortUnder fst $ Map.toList $ hoModuleMap $ libHoLib l) + showList "ModuleDeps" (map pprint . sortUnder fst $ Map.toList $ hoModuleDeps $ libHoLib l) + showList "ModuleReexports" (map pprint . sortUnder fst $ Map.toList $ hoReexports $ libHoLib l) + forM_ (Map.toList $ libBuildMap l) $ \ (g,hoB) -> do + print g + doHoB hoB + doHo fn = do + (hoh,idep,ho) <- readHoFile fn + doHoh hoh + let hoB = hoBuild ho + hoE = hoTcInfo ho + showList "Dependencies" (map pprint . sortUnder fst $ hoDepends idep) + showList "ModDependencies" (map pprint $ hoModDepends idep) + showList "IDepCache" (map pprint . sortUnder fst $ Map.toList $ hoIDeps idep) + putStrLn $ "Modules contained:" <+> tshow (keys $ hoExports hoE) + putStrLn $ "number of definitions:" <+> tshow (size $ hoDefs hoE) + putStrLn $ "hoAssumps:" <+> tshow (size $ hoAssumps hoE) + putStrLn $ "hoFixities:" <+> tshow (size $ hoFixities hoE) + putStrLn $ "hoKinds:" <+> tshow (size $ hoKinds hoE) + putStrLn $ "hoClassHierarchy:" <+> tshow (length $ classRecords $ hoClassHierarchy hoE) + putStrLn $ "hoTypeSynonyms:" <+> tshow (size $ hoTypeSynonyms hoE) + wdump FD.Exports $ do + putStrLn "---- exports information ----"; + putStrLn $ (pprint $ hoExports hoE :: String) + wdump FD.Defs $ do + putStrLn "---- defs information ----"; + putStrLn $ (pprint $ hoDefs hoE :: String) + when (dump FD.Kind) $ do + putStrLn "---- kind information ----"; + putStrLn $ (pprint $ hoKinds hoE :: String) + when (dump FD.ClassSummary) $ do + putStrLn "---- class summary ---- " + printClassSummary (hoClassHierarchy hoE) + when (dump FD.Class) $ + do {putStrLn "---- class hierarchy ---- "; + printClassHierarchy (hoClassHierarchy hoE)} + wdump FD.Types $ do + putStrLn " ---- the types of identifiers ---- " + putStrLn $ PPrint.render $ pprint (hoAssumps hoE) + doHoB hoB + doHoB hoB = do + putStrLn $ "hoDataTable:" <+> tshow (size $ hoDataTable hoB) + putStrLn $ "hoEs:" <+> tshow (size $ hoEs hoB) + putStrLn $ "hoRules:" <+> tshow (size $ hoRules hoB) + let rules = hoRules hoB + wdump FD.Rules $ putStrLn " ---- user rules ---- " >> printRules RuleUser rules + wdump FD.Rules $ putStrLn " ---- user catalysts ---- " >> printRules RuleCatalyst rules + wdump FD.RulesSpec $ putStrLn " ---- specializations ---- " >> printRules RuleSpecialization rules + wdump FD.Datatable $ do + putStrLn " ---- data table ---- " + putDocM putStr (showDataTable (hoDataTable hoB)) + putChar '\n' + wdump FD.Core $ do + putStrLn " ---- lambdacube ---- " + mapM_ (\ (v,lc) -> putChar '\n' >> printCheckName'' (hoDataTable hoB) v lc) (hoEs hoB) + printCheckName'' :: DataTable -> TVr -> E -> IO () + printCheckName'' _dataTable tvr e = do + when (dump FD.EInfo || verbose2) $ putStrLn (show $ tvrInfo tvr) + putStrLn (render $ hang 4 (pprint tvr <+> text "::" <+> pprint (tvrType tvr))) + putStrLn (render $ hang 4 (pprint tvr <+> equals <+> pprint e)) diff --git a/src/Ho/ReadSource.hs b/src/Ho/ReadSource.hs --- a/src/Ho/ReadSource.hs +++ b/src/Ho/ReadSource.hs @@ -137,6 +137,9 @@ | otherwise = [] profileOpts | fopts FO.Profile || lup "profile" == "true" = ["-D_JHC_PROFILE=1"] | otherwise = [] + threadOpts | fopts FO.Pthread = ["-D_JHC_CONC=_JHC_CONC_PTHREAD", "-pthread"] + | fopts FO.Customthread = ["-D_JHC_CONC=_JHC_CONC_CUSTOM"] + | otherwise = ["-D_JHC_CONC=_JHC_CONC_NONE"] debug = if fopts FO.Debug then words (lup "cflags_debug") else words (lup "cflags_nodebug") cc = lup "cc" - args = words (lup "cflags") ++ debug ++ optCCargs options ++ boehmOpts ++ profileOpts + args = words (lup "cflags") ++ debug ++ optCCargs options ++ boehmOpts ++ profileOpts ++ threadOpts diff --git a/src/Ho/Type.hs b/src/Ho/Type.hs new file mode 100644 --- /dev/null +++ b/src/Ho/Type.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE TemplateHaskell #-} +module Ho.Type where + +import Data.Monoid +import qualified Data.ByteString as BS +import Data.Map +import Data.DeriveTH + +import Data.Version +import DataConstructors(DataTable) +import E.Rules(Rules) +import E.Type +import E.TypeCheck() +import FrontEnd.Class(ClassHierarchy) +import FrontEnd.Infix(FixityMap) +import FrontEnd.KindInfer(KindEnv) +import FrontEnd.Rename(FieldMap()) +import FrontEnd.SrcLoc(SrcLoc) +import FrontEnd.Tc.Type(Type()) +import FrontEnd.TypeSynonyms(TypeSynonyms) +import Name.Id +import Name.Name(Name,Module) +import PackedString +import Util.SetLike +import Support.CFF +import Support.MapBinaryInstance() +import Support.MD5 + +cff_magic = chunkType "JHC" +cff_link = chunkType "LINK" +cff_libr = chunkType "LIBR" +cff_jhdr = chunkType "JHDR" +cff_core = chunkType "CORE" +cff_defs = chunkType "DEFS" +cff_lcor = chunkType "LCOR" +cff_ldef = chunkType "LDEF" +cff_idep = chunkType "IDEP" +cff_file = chunkType "FILE" + +-- | A SourceHash is the hash of a specific file, it is associated with a +-- specific 'Module' that said file implements. +type SourceHash = Hash +-- | HoHash is a unique identifier for a ho file or library. +type HoHash = Hash + +-- | while a 'Module' is a single Module associated with a single haskell source +-- file, a 'ModuleGroup' identifies a group of mutually recursive modules. +-- Generally it is chosen from among the Modules making up the group, but the +-- specific choice has no other meaning. We could use the HoHash, but for readability +-- reasons when debugging it makes more sense to choose an arbitrary Module. +type ModuleGroup = Module + +-- | the collected information that is passed around +-- this is not stored in any file, but is what is collected from the ho files. +data CollectedHo = CollectedHo { + -- | this is a list of external names that are valid but that we may not know + -- anything else about it is used to recognize invalid ids. + choExternalNames :: IdSet, + -- | these are the functions in Comb form. + choCombinators :: IdMap Comb, + -- | these are rules that may need to be retroactively applied to other + -- modules + choOrphanRules :: Rules, + -- | the hos + choHoMap :: Map ModuleGroup Ho, + -- | libraries depended on + choLibDeps :: Map PackedString HoHash, + -- | these are caches of pre-computed values + choHo :: Ho, -- ^ cache of combined and renamed ho + choVarMap :: IdMap (Maybe E) -- ^ cache of variable substitution map + } + +-- | The header contains basic information about the file, it should be enough to determine whether +-- we can discard the file right away or consider it further. +data HoHeader = HoHeader { + -- | the version of the file format. it comes first so we don't try to read data that may be in a different format. + hohVersion :: Int, + -- | my sha1 id + hohHash :: HoHash, + -- | the human readable name, either the ModuleGroup or the library name and version. + hohName :: Either ModuleGroup (PackedString,Version), + -- | library dependencies + hohLibDeps :: [(PackedString,HoHash)], + -- | arch dependencies, these say whether the file is specialized for a + -- given arch. + hohArchDeps :: [(PackedString,PackedString)] + } + +-- | These are the dependencies needed to check if a ho file is up to date. it +-- only appears in ho files as hl files do not have source code to check +-- against or depend on anything but other libraries. +data HoIDeps = HoIDeps { + -- | modules depended on indexed by a hash of the source. + hoIDeps :: Map SourceHash (Module,[(Module,SrcLoc)]), + -- | Haskell Source files depended on + hoDepends :: [(Module,SourceHash)], + -- | Other objects depended on to be considered up to date. + hoModDepends :: [HoHash], + -- | library module groups needed + hoModuleGroupNeeds :: [ModuleGroup] + } + +data HoLib = HoLib { + -- | arbitrary metainformation such as library author, web site, etc. + hoModuleMap :: Map Module ModuleGroup, + hoReexports :: Map Module Module, + hoModuleDeps :: Map ModuleGroup [ModuleGroup], + hoMetaInfo :: [(PackedString,PackedString)] + } + +data Library = Library { + libHoHeader :: HoHeader, + libHoLib :: HoLib, + libTcMap :: (Map ModuleGroup HoTcInfo), + libBuildMap :: (Map ModuleGroup HoBuild), + libExtraFiles :: [ExtraFile], + libFileName :: FilePath + } + +instance Show Library where + showsPrec n lib = showsPrec n (hohHash $ libHoHeader lib) + +-- | data only needed for type checking. +data HoTcInfo = HoTcInfo { + hoExports :: Map Module [Name], + hoDefs :: Map Name (SrcLoc,[Name]), + hoAssumps :: Map Name Type, -- ^ used for typechecking + hoFixities :: FixityMap, + hoKinds :: KindEnv, -- ^ used for typechecking + hoTypeSynonyms :: TypeSynonyms, + hoClassHierarchy :: ClassHierarchy, + hoFieldMap :: FieldMap + } + +data HoBuild = HoBuild { + -- | Filled in by E generation + hoDataTable :: DataTable, + hoEs :: [(TVr,E)], + hoRules :: Rules + } + +data Ho = Ho { + hoModuleGroup :: ModuleGroup, + hoTcInfo :: HoTcInfo, + hoBuild :: HoBuild + } + +instance Monoid Ho where + mempty = Ho (error "unknown module group") mempty mempty + mappend ha hb = Ho (hoModuleGroup ha) (hoTcInfo ha `mappend` hoTcInfo hb) (hoBuild ha `mappend` hoBuild hb) + +data ExtraFile = ExtraFile { + extraFileName :: PackedString, + extraFileData :: BS.ByteString + } + +{- +instance Monoid Ho where + mempty = Ho mempty mempty + mappend a b = Ho { + hoTcInfo = hoTcInfo a `mappend` hoTcInfo b, + hoBuild = hoBuild a `mappend` hoBuild b + } + +instance Monoid HoTcInfo where + mempty = HoTcInfo mempty mempty + mappend a b = HoTcInfo { + hoExports = hoExports a `mappend` hoExports b, + hoDefs = hoDefs a `mappend` hoDefs b + } + +instance Monoid HoBuild where + mempty = HoBuild mempty mempty mempty mempty mempty mempty mempty mempty + mappend a b = HoBuild { + hoAssumps = hoAssumps a `mappend` hoAssumps b, + hoFixities = hoFixities a `mappend` hoFixities b, + hoKinds = hoKinds a `mappend` hoKinds b, + hoClassHierarchy = hoClassHierarchy a `mappend` hoClassHierarchy b, + hoTypeSynonyms = hoTypeSynonyms a `mappend` hoTypeSynonyms b, + hoDataTable = hoDataTable a `mappend` hoDataTable b, + hoEs = hoEs a `mappend` hoEs b, + hoRules = hoRules a `mappend` hoRules b + } + + -} + +$(derive makeUpdate ''CollectedHo) +$(derive makeUpdate ''HoTcInfo) +$(derive makeMonoid ''HoTcInfo) +$(derive makeUpdate ''HoBuild) +$(derive makeMonoid ''HoBuild) +$(derive makeUpdate ''Ho) diff --git a/src/Name/VConsts.hs b/src/Name/VConsts.hs new file mode 100644 --- /dev/null +++ b/src/Name/VConsts.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE TemplateHaskell #-} +module Name.VConsts where + +import Control.Applicative +import Data.Foldable +import Data.Traversable +import Data.DeriveTH + +-- This is much more verbose/complicated than it needs be. + +class TypeNames a where + tInt :: a + tRational :: a + tChar :: a + tIntzh :: a + tEnumzh :: a + tCharzh :: a + tBool :: a + tUnit :: a + tString :: a + tInteger :: a + tWorld__ :: a + + tInt = error "tInt" + tRational = error "tRational" + tChar = error "tChar" + tIntzh = error "tIntzh" + tEnumzh = error "tEnumzh" + tCharzh = error "tCharzh" + tBool = error "tBool" + tUnit = error "tUnit" + tString = error "tString" + tInteger = error "tInteger" + tWorld__ = error "tWorld" + +class ConNames a where + vTrue :: a + vFalse :: a + vCons :: a + vUnit :: a + + vTrue = error "vTrue" + vFalse = error "vFalse" + vCons = error "vCons" + vUnit = error "vUnit" + +class FromTupname a where + fromTupname :: Monad m => a -> m Int + +instance FromTupname String where + fromTupname ('(':s) | (cs,")") <- span (== ',') s, lc <- length cs, lc > 0 = return $! (lc + 1) + fromTupname xs = fail $ "fromTupname: not tuple " ++ xs + +instance FromTupname (String,String) where + fromTupname ("Jhc.Prim.Prim",n) = fromTupname n + fromTupname xs = fail $ "fromTupname: not tuple " ++ show xs + +class ToTuple a where + toTuple :: Int -> a + +instance ToTuple String where + toTuple n = '(': replicate (n - 1) ',' ++ ")" + +instance ToTuple (String,String) where + toTuple n = ("Jhc.Prim.Prim",toTuple n) + +-- | various functions needed for desugaring. +data FuncNames a = FuncNames { + func_equals :: a, + func_fromInt :: a, + func_fromInteger :: a, + func_fromRational :: a, + func_negate :: a, + func_runExpr :: a, + func_runMain :: a, + func_runNoWrapper :: a, + func_runRaw :: a + } + +$(derive makeFunctor ''FuncNames) +$(derive makeTraversable ''FuncNames) +$(derive makeFoldable ''FuncNames) diff --git a/src/Options.hs b/src/Options.hs new file mode 100644 --- /dev/null +++ b/src/Options.hs @@ -0,0 +1,570 @@ +{-# OPTIONS -w -funbox-strict-fields #-} +module Options( + processOptions, + Opt(..), + options, + Mode(..), + StopCondition(..), + putVerbose, + putVerboseLn, + putProgress, + putProgressLn, + getArguments, + findHoCache, + verbose, + verbose2, + progress, + dump, + wdump, + fopts, + flint, + fileOptions, + withOptions, + withOptionsT, + getArgString, + outputName, + OptM(), + OptT(), + OptionMonad(..), + flagOpt + ) where + +import Control.Monad.Error() -- IO MonadPlus instance +import Control.Monad.Identity +import Control.Monad.Reader +import Data.List(nub) +import Data.Maybe +import System.Console.GetOpt +import System.Directory +import System.IO.Unsafe +import System.Environment (getArgs, getProgName, getEnv) +import System.Exit +import qualified Data.ByteString.UTF8 as BS +import qualified Data.Map as M +import qualified Data.Set as S + +import RawFiles(targets_ini) +import Support.IniParse +import Support.TempDir +import Support.Cabal +import Util.ExitCodes +import Util.Gen +import Util.YAML +import Version.Config +import Version.Version(versionString,versionContext) +import qualified FlagDump +import qualified FlagOpts +import qualified Version.Config as VC + +{-@CrossCompilation + +# Basics + +Unlike many other compilers, Ajhc is a native cross compiler. What this means is +that every compile of Ajhc is able to create code for all possible target +systems. This leads to many simplifications when it comes to cross compiling +with Ajhc. Basically in order to cross compile, you need only pass the flag +'--cross' to Ajhc, and pass an appropriate '-m' option to tell Ajhc what machine +you are targetting. An example would be + + ; ajhc --cross -mwin32 test/HelloWorld.hs + +The targets list is extensible at run-time via the targets.ini file explained +below. + +# targets.ini + +This file determines what targets are available. The format consists of entries as follows. + + [targetname] + key1=value + key2=value + key3+=value + merge=targetname2 + +merge is a special key meaning to merge the contents of another target into the +current one. The configuration file is read in order, and the final value set +for a given key is the one that is used. + +An example describing how to cross compile for windows is as follows: + + [win32] + cc=i386-mingw32-gcc + cflags+=-mwindows -mno-cygwin + executable_extension=.exe + merge=i686 + +This sets the compiler to use as well as a few other options then jumps to the +generic i686 routine. The special target [default] is always read before all +other targets. If '--cross' is specified on the command line then this is the +only implicitly included configuration, otherwise Ajhc will assume you are +compiling for the current architecture and choose an appropriate target to +include in addition to default. + +Ajhc will attempt to read several targets.ini files in order. they are + +$PREFIX/etc/ajhc-\$VERSION/targets.ini +: this is the targets.ini that is included with Ajhc and contains the default options. + +$PREFIX/etc/ajhc-\$VERSION/targets-local.ini +: Ajhc will read this if it exists, it is used to specify custom system wide configuration options, such as the name of local compilers. + +$HOME/.ajhc/targets.ini +: this is where a users local configuration information goes. + +$HOME/etc/ajhc/targets.ini +: this is simply for people that prefer to not use hidden directories for configuration + +The last value specified for an option is the one used, so a users local +configuration overrides the system local version which overrides the built in +options. + +# Options available + +Option Meaning +------ --------------------------------------------------------------------------- +_cc_ what c compiler to use. generally this will be gcc for local builds and something like $ARCH-$HOST-gcc for cross compiles +_byteorder_ one of *le* or *be* for little or big endian +_gc_ what garbage collector to use. It should be one of *static* or *boehm*. +_cflags_ options to pass to the c compiler +_cflags\_debug_ options to pass to the c compiler only when debugging is enabled +_cflags\_nodebug_ options to pass to the c compiler only when debugging is disabled +_profile_ whether to include profiling code in the generated executable +_autoload_ what haskell libraries to autoload, seperated by commas. +_executable\_extension_ specifies an extension that should be appended to executable files, (i.e. .EXE on windows) +_merge_ a special option that merges the contents of another configuration target into the currrent one. +_bits_ the number of bits a pointer contains on this architecture +_bits\_max_ the number of bits in the largest integral type. should be the number of bits in the 'intmax_t' C type. +_arch_ what to pass to gcc as the architecture + +# Special defines to set cflags + +Define Meaning +------ --------------------------------------------------------------------------- +\_JHC\_ARM\_STAY\_IN\_THUMB\_MODE set bit0 to any function pointers, for Cortex-M*. ([more detail](http://communities.mentor.com/community/cs/archives/arm-gnu/msg01904.html)) +\_JHC\_JGC\_NAIVEGC run gc when have no more blocks. +\_JHC\_JGC\_LIMITED\_NUM\_GC\_STACK number of limited gc_stack entries. +\_JHC\_JGC\_GC\_STACK\_SHIFT bit shift to specify gc_stack size. Use it internally like this: (1 << (\_JHC\_JGC\_GC\_STACK\_SHIFT)). +\_JHC\_JGC\_STACKGROW number of stack entry growed when run short of it. +\_JHC\_JGC\_LIMITED\_NUM\_MEGABLOCK number of limited megablock entries. +\_JHC\_JGC\_BLOCK\_SHIFT bit shift to specify block size. Use it internally like this: (1 << (\_JHC\_JGC\_BLOCK\_SHIFT)). +\_JHC\_JGC\_MEGABLOCK\_SHIFT bit shift to specify megablock size. Use it internally like this: (1 << (\_JHC\_JGC\_MEGABLOCK_SHIFT)). + +-} + +data Mode = BuildHl FilePath -- ^ Build the specified hl-file given a description file. + | Interactive -- ^ Run interactively. + | Version -- ^ Print version and die. + | VersionCtx -- ^ Print version context and die. + | ShowHelp -- ^ Show help message and die. + | ShowConfig -- ^ Show configuration info. + | CompileExe -- ^ Compile executable + | ShowHo String -- ^ Show ho-file. + | ListLibraries -- ^ List libraries + | PrintHscOptions -- ^ Print options for hsc2hs + | PurgeCache -- ^ Purge the cache + | Preprocess -- ^ Filter through preprocessor + deriving(Eq) + +data StopCondition + = StopError String -- ^ error + | StopParse -- ^ Just parse and rename modules then exit + | StopTypeCheck -- ^ Stop after type checking + | StopC -- ^ Stop after producing C code. + | CompileHo -- ^ Compile ho + | StopNot -- ^ Don't stop believing. + deriving(Eq) + +data Opt = Opt { + optMode :: Mode, -- ^ Mode of interaction + optColumns :: !Int, -- ^ Width of terminal. + optDump :: [String], -- ^ Dump options (raw). + optStmts :: [String], -- ^ statements to execute + optFOpts :: [String], -- ^ Flag options (raw). + optIncdirs :: [String], -- ^ Include directories. + optCCargs :: [String], -- ^ Optional arguments to the C compiler. + optHls :: [String], -- ^ Load the specified hl-files (haskell libraries). + optAutoLoads :: [String], -- ^ AutoLoaded haskell libraries. + optHlPath :: [String], -- ^ Path to look for libraries. + optIncs :: [String], + optDefs :: [String], + optExtensions :: [String], + optStop :: StopCondition, + optWorkDir :: Maybe FilePath, + optAnnotate :: Maybe FilePath, + optDeps :: Maybe FilePath, + optHoDir :: Maybe FilePath, + optHoCache :: Maybe FilePath, + optArgs :: [String], + optStale :: [String], -- ^ treat these modules as stale + optKeepGoing :: !Bool, -- ^ Keep going when encountering errors. + optMainFunc :: Maybe (Bool,String), -- ^ Entry point name for the main function. + optArch :: [String], -- ^ target architecture + optCross :: Bool, + optOutName :: Maybe String, -- ^ Name of output file. + optIgnoreHo :: !Bool, -- ^ Ignore ho-files. + optNoWriteHo :: !Bool, -- ^ Don't write ho-files. + optNoAuto :: !Bool, -- ^ Don't autoload packages + optVerbose :: !Int, -- ^ Verbosity + optStatLevel :: !Int, -- ^ Level to print statistics + optInis :: M.Map String String, -- ^ options read from ini files + optDumpSet :: S.Set FlagDump.Flag, -- ^ Dump flags. + optFOptsSet :: S.Set FlagOpts.Flag -- ^ Flag options (-f\). + } + +-- Derive +optAnnotate_s v = optAnnotate_u (const v) +optAnnotate_u f r@Opt{optAnnotate = x} = r{optAnnotate = f x} +optArch_u f r@Opt{optArch = x} = r{optArch = f x} +optCCargs_u f r@Opt{optCCargs = x} = r{optCCargs = f x} +optColumns_s v = optColumns_u (const v) +optColumns_u f r@Opt{optColumns = x} = r{optColumns = f x} +optCross_s v = optCross_u (const v) +optCross_u f r@Opt{optCross = x} = r{optCross = f x} +optDefs_u f r@Opt{optDefs = x} = r{optDefs = f x} +optDeps_s v = optDeps_u (const v) +optDeps_u f r@Opt{optDeps = x} = r{optDeps = f x} +optDump_u f r@Opt{optDump = x} = r{optDump = f x} +optExtensions_u f r@Opt{optExtensions = x} = r{optExtensions = f x} +optFOptsSet_u f r@Opt{optFOptsSet = x} = r{optFOptsSet = f x} +optFOpts_u f r@Opt{optFOpts = x} = r{optFOpts = f x} +optHlPath_u f r@Opt{optHlPath = x} = r{optHlPath = f x} +optHls_u f r@Opt{optHls = x} = r{optHls = f x} +optHoCache_s v = optHoCache_u (const v) +optHoCache_u f r@Opt{optHoCache = x} = r{optHoCache = f x} +optIgnoreHo_s v = optIgnoreHo_u (const v) +optIgnoreHo_u f r@Opt{optIgnoreHo = x} = r{optIgnoreHo = f x} +optIncdirs_u f r@Opt{optIncdirs = x} = r{optIncdirs = f x} +optIncs_u f r@Opt{optIncs = x} = r{optIncs = f x} +optKeepGoing_s v = optKeepGoing_u (const v) +optKeepGoing_u f r@Opt{optKeepGoing = x} = r{optKeepGoing = f x} +optMainFunc_s v = optMainFunc_u (const v) +optMainFunc_u f r@Opt{optMainFunc = x} = r{optMainFunc = f x} +optMode_s v = optMode_u (const v) +optMode_u f r@Opt{optMode = x} = r{optMode = f x} +optNoAuto_s v = optNoAuto_u (const v) +optNoAuto_u f r@Opt{optNoAuto = x} = r{optNoAuto = f x} +optNoWriteHo_s v = optNoWriteHo_u (const v) +optNoWriteHo_u f r@Opt{optNoWriteHo = x} = r{optNoWriteHo = f x} +optOutName_s v = optOutName_u (const v) +optOutName_u f r@Opt{optOutName = x} = r{optOutName = f x} +optStale_u f r@Opt{optStale = x} = r{optStale = f x} +optStatLevel_u f r@Opt{optStatLevel = x} = r{optStatLevel = f x} +optStop_s v = optStop_u (const v) +optStop_u f r@Opt{optStop = x} = r{optStop = f x} +optVerbose_u f r@Opt{optVerbose = x} = r{optVerbose = f x} +optWorkDir_s v = optWorkDir_u (const v) +optWorkDir_u f r@Opt{optWorkDir = x} = r{optWorkDir = f x} + +emptyOpt = Opt { + optMode = CompileExe, + optColumns = getColumns, + optCross = False, + optIncdirs = initialIncludes, + optAnnotate = Nothing, + optDeps = Nothing, + optHls = [], + optAutoLoads = [], + optHlPath = initialLibIncludes, + optIncs = [], + optDefs = [], + optExtensions = [], + optStop = StopNot, + optDump = [], + optStale = [], + optStmts = [], + optFOpts = ["default"], + optCCargs = [], + optWorkDir = Nothing, + optHoDir = Nothing, + optHoCache = Nothing, + optArgs = [], + optIgnoreHo = False, + optNoWriteHo = False, + optKeepGoing = False, + optMainFunc = Nothing, + optArch = ["default"], + optOutName = Nothing, + optVerbose = 0, + optStatLevel = 1, + optNoAuto = False, + optDumpSet = S.singleton FlagDump.Progress, + optFOptsSet = S.empty +} + +idu "-" _ = [] +idu d ds = ds ++ [d] + +theoptions :: [OptDescr (Opt -> Opt)] +theoptions = + [ Option ['V'] ["version"] (NoArg (optMode_s Version)) "print version info and exit" + , Option [] ["version-context"] (NoArg (optMode_s VersionCtx)) "print version context info and exit" + , Option [] ["help"] (NoArg (optMode_s ShowHelp)) "print help information and exit" + , Option [] ["info"] (NoArg (optMode_s ShowConfig)) "show compiler configuration information and exit" + , Option [] ["purge-cache"] (NoArg (optMode_s PurgeCache)) "clean out Ajhc compilation cache" + , Option ['v'] ["verbose"] (NoArg (optVerbose_u (+1))) "chatty output on stderr" + , Option ['z'] [] (NoArg (optStatLevel_u (+1))) "Increase verbosity of statistics" + , Option ['d'] [] (ReqArg (optDump_u . (:)) "[no-]flag") "dump specified data during compilation" + , Option ['f'] [] (ReqArg (optFOpts_u . (:)) "[no-]flag") "set or clear compilation options" + , Option ['X'] [] (ReqArg (optExtensions_u . (:)) "ExtensionName") "enable the given language extension" + , Option ['o'] ["output"] (ReqArg (optOutName_s . Just) "FILE") "output to FILE" + , Option ['i'] ["include"] (ReqArg (optIncdirs_u . idu) "DIR") "where to look for source files" + , Option ['I'] [] (ReqArg (optIncs_u . idu) "DIR") "add to preprocessor include path" + , Option ['D'] [] (ReqArg (optDefs_u . (:)) "NAME=VALUE") "add new definitions to set in preprocessor" + , Option [] ["optc"] (ReqArg (optCCargs_u . idu) "option") "extra options to pass to c compiler" + , Option ['c'] [] (NoArg (optStop_s CompileHo)) "just compile the modules, caching the results." + , Option ['C'] [] (NoArg (optStop_s StopC)) "compile to C code" + , Option ['E'] [] (NoArg (optMode_s Preprocess)) "preprocess the input and print result to stdout" + , Option ['k'] ["keepgoing"] (NoArg (optKeepGoing_s True)) "keep going on errors" + , Option [] ["cross"] (NoArg (optCross_s True)) "enable cross-compilation, choose target with the -m flag" + , Option [] ["stop"] (ReqArg (optStop_s . stop) "parse/typecheck/c") "stop after the given pass, parse/typecheck/c" + , Option [] ["width"] (ReqArg (optColumns_s . read) "COLUMNS") "width of screen for debugging output" + , Option [] ["main"] (ReqArg (optMainFunc_s . Just . (,) False) "Main.main") "main entry point" + , Option ['m'] ["arch"] (ReqArg (optArch_u . idu ) "arch") "target architecture options" + , Option [] ["entry"] (ReqArg (optMainFunc_s . Just . (,) True) "") "main entry point, showable expression" + -- , Option ['e'] [] (ReqArg (\d -> optStmts_u ( d:)) "") "run given statement as if on jhci prompt" + , Option [] ["show-ho"] (ReqArg (optMode_s . ShowHo) "file.ho") "Show ho file" + , Option [] ["noauto"] (NoArg (optNoAuto_s True)) "Don't automatically load base and haskell98 packages" + , Option ['p'] [] (ReqArg (optHls_u . (:)) "package") "Load given haskell library package" + , Option ['L'] [] (ReqArg (optHlPath_u . idu) "path") "Look for haskell libraries in the given directory" + , Option [] ["build-hl"] (ReqArg (optMode_s . BuildHl) "desc.yaml") "Build hakell library from given library description file" + , Option [] ["annotate-source"] (ReqArg (optAnnotate_s . Just) "") "Write preprocessed and annotated source code to the directory specified" + , Option [] ["deps"] (ReqArg (optDeps_s . Just) "") "Write dependency information to file specified" + , Option [] ["interactive"] (NoArg (optMode_s Interactive)) "run interactivly ( for debugging only)" + , Option [] ["ignore-cache"] (NoArg (optIgnoreHo_s True)) "Ignore existing compilation cache entries." + , Option [] ["readonly-cache"] (NoArg (optNoWriteHo_s True)) "Do not write new information to the compilation cache." + , Option [] ["no-cache"] (NoArg (optNoWriteHo_s True . optIgnoreHo_s True)) "Do not use or update the cache." + , Option [] ["cache-dir"] (ReqArg (optHoCache_s . Just ) "AJHC_CACHE") "Use a global cache located in the directory passed as an argument." +-- , Option [] ["ho-dir"] (ReqArg (optHoDir_s . Just ) "") "Where to place and look for ho files" + , Option [] ["stale"] (ReqArg (optStale_u . idu) "Module") "Treat these modules as stale, even if they exist in the cache" + , Option [] ["list-libraries"] (NoArg (optMode_s ListLibraries)) "List of installed libraries" + , Option [] ["tdir"] (ReqArg (optWorkDir_s . Just) "dir/") "specify the directory where all intermediate files/dumps will be placed." +-- , Option [] ["print-hsc-options"] (NoArg (optMode_s PrintHscOptions)) "print options to pass to hsc2hs" + ] + +stop "parse" = StopParse +stop "deps" = StopParse +stop "typecheck" = StopTypeCheck +stop "c" = StopC +stop s = StopError s + +-- | Width of terminal. +getColumns :: Int +getColumns = read $ unsafePerformIO (getEnv "COLUMNS" `mplus` return "80") + +postProcessFD :: Monad m => Opt -> m Opt +postProcessFD o = case FlagDump.process (optDumpSet o) (optDump o ++ vv) of + (s,[]) -> return $ o { optDumpSet = s, optDump = [] } + (_,xs) -> fail ("Unrecognized dump flag passed to '-d': " + ++ unwords xs ++ "\nValid dump flags:\n\n" ++ FlagDump.helpMsg) + where + vv | optVerbose o >= 2 = ["veryverbose"] + | optVerbose o >= 1 = ["verbose"] + | otherwise = [] + +postProcessFO :: Monad m => Opt -> m Opt +postProcessFO o = case FlagOpts.process (optFOptsSet o) (optFOpts o) of + (s,[]) -> return $ o { optFOptsSet = s, optFOpts = [] } + (_,xs) -> fail ("Unrecognized flag passed to '-f': " + ++ unwords xs ++ "\nValid flags:\n\n" ++ FlagOpts.helpMsg) + +getArguments = do + x <- lookupEnv "AJHC_OPTS" + let eas = maybe [] words x + as <- getArgs + return (eas ++ as) + +pfill :: + Int -- ^ maximum width + -> (a -> Int) -- ^ find width of any element + -> [a] -- ^ input elements + -> [[a]] -- ^ output element +pfill maxn length xs = f maxn xs [] [] where + f n (x:xs) ws ls | lx < n = f (n - lx) xs (x:ws) ls where + lx = length x + f _ (x:xs) [] ls = f (maxn - length x) xs [x] ls + f _ (x:xs) ws ls = f (maxn - length x) xs [x] (ws:ls) + f _ [] [] ls = reverse (map reverse ls) + f _ [] ws ls = reverse (map reverse (ws:ls)) + +helpUsage = usageInfo header theoptions ++ trailer where + header = "Usage: ajhc [OPTION...] Main.hs" + trailer = "\n" ++ mkoptlist "-d" FlagDump.helpFlags ++ "\n" ++ mkoptlist "-f" FlagOpts.helpFlags + mkoptlist d os = "valid " ++ d ++ " arguments: 'help' for more info\n " ++ intercalate "\n " (map (intercalate ", ") $ pfill 100 ((2 +) . length) os) ++ "\n" + +{-# NOINLINE processOptions #-} +-- | Parse commandline options. +processOptions :: IO Opt +processOptions = do + -- initial argument processing + argv <- getArguments + let (o,ns,rc) = getOpt Permute theoptions argv + o <- return (foldl (flip ($)) emptyOpt o) + when (rc /= []) $ putErrLn (concat rc ++ helpUsage) >> exitWith exitCodeUsage + case optStop o of + StopError s -> putErrLn "bad option passed to --stop should be one of parse, deps, typecheck, or c" >> exitWith exitCodeUsage + _ -> return () + case optMode o of + ShowHelp -> doShowHelp + ShowConfig -> doShowConfig + Version -> putStrLn versionString >> exitSuccess + VersionCtx -> putStrLn (versionString ++ BS.toString versionContext) >> exitSuccess + PrintHscOptions -> do + putStrLn $ "-I" ++ VC.datadir ++ "/" ++ VC.package ++ "-" ++ VC.shortVersion ++ "/include" + exitSuccess + _ -> return () + -- read targets.ini file + Just home <- fmap (`mplus` Just "/") $ lookupEnv "HOME" + inis <- parseIniFiles (optVerbose o > 0) (BS.toString targets_ini) [confDir ++ "/targets.ini", confDir ++ "/targets-local.ini", home ++ "/etc/ajhc/targets.ini", home ++ "/.ajhc/targets.ini"] (optArch o) + -- process dump flags + o <- either putErrDie return $ postProcessFD o + when (FlagDump.Ini `S.member` optDumpSet o) $ flip mapM_ (M.toList inis) $ \(a,b) -> putStrLn (a ++ "=" ++ b) + -- set flags based on ini options + let o1 = case M.lookup "gc" inis of + Just "jgc" -> optFOptsSet_u (S.insert FlagOpts.Jgc) o + Just "boehm" -> optFOptsSet_u (S.insert FlagOpts.Boehm) o + _ -> o + o2 <- either putErrDie return $ postProcessFO o1 + when (FlagDump.Ini `S.member` optDumpSet o) $ do + putStrLn (show $ optDumpSet o) + putStrLn (show $ optFOptsSet o) + -- add autoloads based on ini options + let autoloads = maybe [] (tokens (',' ==)) (M.lookup "autoload" inis) + return o2 { optArgs = ns, optInis = inis, optAutoLoads = autoloads } + +doShowHelp = do + putStrLn helpUsage + exitSuccess + +doShowConfig = do + --mapM_ (\ (x,y) -> putStrLn (x ++ ": " ++ y)) configs + putStrLn $ showYAML configs + exitSuccess + +findHoCache :: IO (Maybe FilePath) +findHoCache = do + cd <- lookupEnv "AJHC_CACHE" + case optHoCache options `mplus` cd of + Just s -> do return (Just s) + Just "-" -> do return Nothing + Nothing | isNothing (optHoDir options) -> do + Just home <- fmap (`mplus` Just "/") $ lookupEnv "HOME" + let cd = home ++ "/.ajhc/cache" + createDirectoryIfMissing True cd + return (Just cd) + _ -> return Nothing + +configs :: Node +configs = toNode [ + "jhclibpath" ==> initialLibIncludes, + "version" ==> version, + "package" ==> package, + "libdir" ==> libdir, + "datadir" ==> datadir, + "libraryInstall" ==> libraryInstall, + "host" ==> host + ] where + (==>) :: ToNode b => String -> b -> (String,Node) + a ==> b = (a,toNode b) + +{-# NOINLINE fileOptions #-} +fileOptions :: Monad m => Opt -> [String] -> m Opt +fileOptions options xs = case getOpt Permute theoptions xs of + (os,[],[]) -> postProcessFD (foldl (flip ($)) options os) >>= postProcessFO + (_,_,errs) -> fail (concat errs) + +{-# NOINLINE options #-} +-- | The global options currently used. +options :: Opt +options = unsafePerformIO processOptions + +-- | Put a string to stderr when running verbose. +putVerbose :: String -> IO () +putVerbose s = when (optVerbose options > 0) $ putErr s + +-- | Put a line to stderr when running verbose. +putVerboseLn :: String -> IO () +putVerboseLn s = putVerbose (s ++ "\n") + +putProgress :: String -> IO () +putProgress s = when progress $ putErr s + +-- | Put a line to stderr when running verbose. +putProgressLn :: String -> IO () +putProgressLn s = putProgress (s ++ "\n") + +-- | Is verbose > 0? +progress :: Bool +progress = dump FlagDump.Progress + +-- | Is verbose > 0? +verbose :: Bool +verbose = optVerbose options > 0 +-- | Is verbose > 1? +verbose2 :: Bool +verbose2 = optVerbose options > 1 + +-- | Test whether a dump flag is set. +dump :: FlagDump.Flag -> Bool +dump s = s `S.member` optDumpSet options +-- | Test whether an option flag is set. +fopts :: FlagOpts.Flag -> Bool +fopts s = s `S.member` optFOptsSet options +-- | Do the action when the suplied dump flag is set. +wdump :: (Monad m) => FlagDump.Flag -> m () -> m () +wdump f = when (dump f) + +-- | Is the \"lint\" option flag set? +flint :: Bool +flint = FlagOpts.Lint `S.member` optFOptsSet options + +-- | Include directories taken from JHCPATH enviroment variable. +initialIncludes :: [String] +initialIncludes = unsafePerformIO $ do + p <- lookupEnv "AJHC_PATH" + let x = fromMaybe "" p + return (".":(tokens (== ':') x)) + +-- | Include directories taken from JHCLIBPATH enviroment variable. +initialLibIncludes :: [String] +initialLibIncludes = unsafePerformIO $ do + ps <- lookupEnv "AJHC_LIBRARY_PATH" + h <- lookupEnv "HOME" + let paths = h ++ ["/usr/local","/usr"] + bases = ["/lib","/share"] + vers = ["/ajhc-" ++ shortVersion, "/ajhc"] + dat <- getDataFileNameMaybe "lib" + return $ nub $ maybe [] (tokens (':' ==)) ps ++ [ p ++ b ++ v | p <- paths, v <- vers, b <- bases ] + ++ [d ++ v | d <- [libdir,datadir], v <- vers] ++ [libraryInstall] ++ maybeToList dat + +class Monad m => OptionMonad m where + getOptions :: m Opt + getOptions = return options + +instance OptionMonad Identity + +newtype OptT m a = OptT (ReaderT Opt m a) + deriving(MonadIO,Monad,Functor,MonadTrans) + +type OptM = OptT Identity + +instance Monad m => OptionMonad (OptT m) where + getOptions = OptT ask + +withOptions :: Opt -> OptM a -> a +withOptions opt (OptT x) = runIdentity (runReaderT x opt) + +withOptionsT :: Opt -> OptT m a -> m a +withOptionsT opt (OptT x) = runReaderT x opt + +outputName = fromMaybe "hs.out" (optOutName options) + +flagOpt :: OptionMonad m => FlagOpts.Flag -> m Bool +flagOpt flag = do + opt <- getOptions + return (flag `S.member` optFOptsSet opt) + +getArgString = do + name <- getProgName + args <- getArguments + return (simpleQuote (name:args),head $ lines versionString) diff --git a/src/RawFiles.hs b/src/RawFiles.hs --- a/src/RawFiles.hs +++ b/src/RawFiles.hs @@ -152,7 +152,7 @@ \; cross compilation entries\n\ \\n\ \[win32]\n\ - \cc=i686-w64-mingw32-gcc\n\ + \cc=i386-mingw32-gcc\n\ \executable_extension=.exe\n\ \merge=i686\n\ \\n\ @@ -275,6 +275,7 @@ stableptr_c = unsafePerformIO $ unsafePackAddress "\ \#include \"sys/queue.h\"\n\ \#include \"jhc_rts_header.h\"\n\ + \#include \"rts/stableptr.h\"\n\ \\n\ \struct StablePtr_list root_StablePtrs = LIST_HEAD_INITIALIZER();\n\ \\n\ @@ -308,6 +309,24 @@ \*/\n\ \"# +-- | Generated from rts\/rts\/stableptr.h +{-# NOINLINE stableptr_h #-} +stableptr_h :: ByteString +stableptr_h = unsafePerformIO $ unsafePackAddress "\ + \#ifndef STABLEPTR_H\n\ + \#define STABLEPTR_H\n\ + \\n\ + \#include \"rts/jhc_rts.h\"\n\ + \\n\ + \wptr_t c_newStablePtr(sptr_t c);\n\ + \void c_freeStablePtr(wptr_t wp);\n\ + \sptr_t c_derefStablePtr(wptr_t wp);\n\ + \void hs_free_stable_ptr(HsStablePtr sp);\n\ + \void hs_free_fun_ptr(HsFunPtr fp);\n\ + \\n\ + \#endif /* STABLEPTR_H */\n\ + \"# + -- | Generated from rts\/sys\/queue.h {-# NOINLINE queue_h #-} queue_h :: ByteString @@ -1059,6 +1078,258 @@ {-# NOINLINE changelog #-} changelog :: ByteString changelog = unsafePerformIO $ unsafePackAddress "\ + \commit 2b5cacf5b5d9de9ee1c6b2dd843aa5a926a6db03\n\ + \Author: Kiwamu Okabe \n\ + \Date: Thu Jun 20 03:02:43 2013 +0900\n\ + \\n\ + \ Hide Paths_ajhc to pass runhaskell Setup.hs sdist.\n\ + \\n\ + \commit 097befc84ee4fbbcc26d83dd40bf297d64c6e8d7\n\ + \Author: Kiwamu Okabe \n\ + \Date: Thu Jun 20 02:46:28 2013 +0900\n\ + \\n\ + \ Update po/ja.po.\n\ + \\n\ + \commit e0b624ed7b28ac6783f004e11dd8ebf3b873002f\n\ + \Author: Kiwamu Okabe \n\ + \Date: Thu Jun 20 02:36:01 2013 +0900\n\ + \\n\ + \ Add Ajhc 0.8.0.6 Release Notes.\n\ + \\n\ + \commit 62c4dab28850927750932ebbb9ccc41445dafb09\n\ + \Author: Kiwamu Okabe \n\ + \Date: Thu Jun 20 01:09:11 2013 +0900\n\ + \\n\ + \ Need rts/conc.c file to compile rtstest.\n\ + \\n\ + \commit 3abbce795b41342818d6be1d67519d3cf32cdd49\n\ + \Author: Kiwamu Okabe \n\ + \Date: Thu Jun 20 01:03:19 2013 +0900\n\ + \\n\ + \ Lock jgc's critical sections with jhc_rts_lock().\n\ + \\n\ + \commit 1f96209b98924184764f0b789860702248be33a2\n\ + \Author: Kiwamu Okabe \n\ + \Date: Thu Jun 20 00:15:20 2013 +0900\n\ + \\n\ + \ Do not use xxx_unlocked API.\n\ + \\n\ + \commit c81a3ffec150e9f85f0e233e26d91b664fd675cd\n\ + \Author: Kiwamu Okabe \n\ + \Date: Thu Jun 20 00:07:28 2013 +0900\n\ + \\n\ + \ Add global mutex to lock RTS.\n\ + \\n\ + \commit ac0a0001bc2b1ef8b13928becc839b937f7f3c61\n\ + \Author: Kiwamu Okabe \n\ + \Date: Wed Jun 19 22:32:23 2013 +0900\n\ + \\n\ + \ Shape forkOS interface!\n\ + \\n\ + \commit 8c884f9f556a3815f0dddeb9df288c644e5b127b\n\ + \Author: Kiwamu Okabe \n\ + \Date: Wed Jun 19 19:37:48 2013 +0900\n\ + \\n\ + \ Apply EApp fromBang_. Ready to impl forkOS.\n\ + \\n\ + \commit 646a37c25c04042e543be888c82e51bf84e1b80e\n\ + \Author: Kiwamu Okabe \n\ + \Date: Mon Jun 17 19:40:55 2013 +0900\n\ + \\n\ + \ Update TODO.\n\ + \\n\ + \commit c22f497cfa2fac018c2ad508b271bdf06a413dbc\n\ + \Author: Kiwamu Okabe \n\ + \Date: Sat Jun 15 02:09:48 2013 +0900\n\ + \\n\ + \ Update README.md\n\ + \\n\ + \commit 667fc93703b9c10fea896321cd825d4f626f6610\n\ + \Author: Kiwamu Okabe \n\ + \Date: Thu Jun 13 20:27:14 2013 +0900\n\ + \\n\ + \ Fix mistake cleaning s_cache.\n\ + \\n\ + \commit f490d09bae59cd33bd6cc1d37fa197edf0655451\n\ + \Author: Kiwamu Okabe \n\ + \Date: Wed Jun 12 18:31:44 2013 +0900\n\ + \\n\ + \ Use _JHC_JGC_FIXED_MEGABLOCK option for limited megablock entries.\n\ + \\n\ + \commit 5affb16c00201504c1d1439c66a8471e3e6c798f\n\ + \Author: Kiwamu Okabe \n\ + \Date: Tue Jun 11 15:32:37 2013 +0900\n\ + \\n\ + \ Apt-get install libghc-uniplate-dev on travis-ci for get speed.\n\ + \\n\ + \commit 0785f7e76065453b6aff248f83b385207e7f7d77\n\ + \Author: Kiwamu Okabe \n\ + \Date: Tue Jun 11 00:10:08 2013 +0900\n\ + \\n\ + \ Fix miss commit.\n\ + \\n\ + \commit cdfebbd6e8de8549440da496a7c68bedc585447c\n\ + \Author: Kiwamu Okabe \n\ + \Date: Mon Jun 10 23:37:33 2013 +0900\n\ + \\n\ + \ Update manual.html to explain _JHC_JGC_LIMITED_NUM_GC_STACK cflag.\n\ + \\n\ + \commit 6cc57114e2e6361c70763f656bacca8127773ca1\n\ + \Author: Kiwamu Okabe \n\ + \Date: Mon Jun 10 22:57:57 2013 +0900\n\ + \\n\ + \ Add _JHC_JGC_LIMITED_NUM_GC_STACK cflag.\n\ + \\n\ + \commit 4cf9ace218e7475baf285000bd46b365ee0d1a09\n\ + \Author: Kiwamu Okabe \n\ + \Date: Mon Jun 10 22:55:34 2013 +0900\n\ + \\n\ + \ No need Data.Monoid.\n\ + \\n\ + \commit d9a96d5b90da74aeee7d9c8b2257a18f6c10d061\n\ + \Merge: 54d1b9f f8a9357\n\ + \Author: Kiwamu Okabe \n\ + \Date: Mon Jun 10 04:36:33 2013 -0700\n\ + \\n\ + \ Merge pull request #23 from master-q/feature/reentrant3\n\ + \ \n\ + \ Recycle gc_stack.\n\ + \\n\ + \commit f8a93578abb338984e6d11a63dfa96060391cbe1\n\ + \Author: Kiwamu Okabe \n\ + \Date: Mon Jun 10 12:16:34 2013 +0900\n\ + \\n\ + \ Recycle gc_stack.\n\ + \\n\ + \commit 54d1b9f6c7a5d644a9bf019e6871c46abace4a1a\n\ + \Merge: f81facf 9d8e5cc\n\ + \Author: Kiwamu Okabe \n\ + \Date: Sun Jun 9 16:25:29 2013 -0700\n\ + \\n\ + \ Merge pull request #22 from master-q/feature/reentrant2\n\ + \ \n\ + \ Feature/reentrant2: Remove saved_gc and saved_arena\n\ + \\n\ + \commit 9d8e5cc6d1f0655897c0d5959d281828290a8d4f\n\ + \Author: Kiwamu Okabe \n\ + \Date: Mon Jun 10 04:56:37 2013 +0900\n\ + \\n\ + \ Pass rtstest.\n\ + \\n\ + \commit b709b1655b3479b8f5de156cfb27287eb06b2b30\n\ + \Author: Kiwamu Okabe \n\ + \Date: Mon Jun 10 04:38:29 2013 +0900\n\ + \\n\ + \ The new_arena function takes a new arena from free_arena list.\n\ + \\n\ + \commit 15c0a1f4b298384db32c05a0865edc53112f035a\n\ + \Author: Kiwamu Okabe \n\ + \Date: Mon Jun 10 03:54:27 2013 +0900\n\ + \\n\ + \ Call jhc_alloc_fini at exported function's enter.\n\ + \\n\ + \commit fe31a9dd047ed0a564955a51ff51582f05f08b1f\n\ + \Author: Kiwamu Okabe \n\ + \Date: Mon Jun 10 03:01:27 2013 +0900\n\ + \\n\ + \ Remove saved_gc and saved_arena.\n\ + \\n\ + \commit 5b9b35cc1d4a51d95d309d501ff9f80747b43abe\n\ + \Author: Kiwamu Okabe \n\ + \Date: Mon Jun 10 02:02:27 2013 +0900\n\ + \\n\ + \ Call jhc_alloc_init and jhc_hs_init at exported function's enter.\n\ + \\n\ + \commit 889d2cf5d557b9d5b41a318efa8237d487de4142\n\ + \Author: Kiwamu Okabe \n\ + \Date: Sun Jun 9 23:34:45 2013 +0900\n\ + \\n\ + \ Add \"foreign import jhc_context ccall\" for pass gc and arena to RTS.\n\ + \\n\ + \commit 8de4ce48df5c56e554c15ad48c9bb88fb8f957cd\n\ + \Author: Kiwamu Okabe \n\ + \Date: Sun Jun 9 22:00:05 2013 +0900\n\ + \\n\ + \ Remove saved_arena. (cont.)\n\ + \\n\ + \commit 4a2edf6732fff649ec555d630ec446f58219384d\n\ + \Author: Kiwamu Okabe \n\ + \Date: Sun Jun 9 20:59:57 2013 +0900\n\ + \\n\ + \ Move s_cache defined in main_code.c to on s_arena.\n\ + \\n\ + \commit 2c898ff294f93a6bbd6ad58c7dc26ab2aa87d8d4\n\ + \Author: Kiwamu Okabe \n\ + \Date: Sun Jun 9 00:21:26 2013 +0900\n\ + \\n\ + \ Move array_caches[] to on s_arena.\n\ + \\n\ + \commit f81facf691586198955e9985a5e3299f9f2b9647\n\ + \Author: Kiwamu Okabe \n\ + \Date: Sat Jun 8 17:03:40 2013 +0900\n\ + \\n\ + \ Manually install derive.\n\ + \\n\ + \commit df841f488c9fac4cb54091aa0a2d7e104908e05f\n\ + \Author: Kiwamu Okabe \n\ + \Date: Sat Jun 8 16:55:39 2013 +0900\n\ + \\n\ + \ Do not install libghc-derive-dev what is not included by ubuntu.\n\ + \\n\ + \commit a5f708012ad48ddb30140a34484ebba81fb97028\n\ + \Author: Kiwamu Okabe \n\ + \Date: Sat Jun 8 16:49:18 2013 +0900\n\ + \\n\ + \ No more depend on DrIFT.\n\ + \\n\ + \commit 7cbc4a528a772bf7f3407ebe6225b66c568befd4\n\ + \Author: Kiwamu Okabe \n\ + \Date: Sat Jun 8 13:01:13 2013 +0900\n\ + \\n\ + \ Update README.md.\n\ + \\n\ + \commit 7f215deeadc65d3566f0001a1fbbec1dc8936d5b\n\ + \Author: Kiwamu Okabe \n\ + \Date: Sat Jun 8 12:05:26 2013 +0900\n\ + \\n\ + \ Need hscolour on travis-ci.\n\ + \\n\ + \commit 4eeb6a4b3793fb5128ed86f46d0a458d95620a61\n\ + \Author: Kiwamu Okabe \n\ + \Date: Sat Jun 8 11:35:47 2013 +0900\n\ + \\n\ + \ Only run haddock on travis-ci.\n\ + \\n\ + \commit 88ad44f26e3cc30b19fdd33bac91c3af88f6ebf1\n\ + \Author: Kiwamu Okabe \n\ + \Date: Sat Jun 8 10:42:59 2013 +0900\n\ + \\n\ + \ Export all modules.\n\ + \\n\ + \commit e56ab3927c0329621b546c23e07ace0a1452adf4\n\ + \Author: Kiwamu Okabe \n\ + \Date: Sat Jun 8 04:11:23 2013 +0900\n\ + \\n\ + \ Add publish_haddock target.\n\ + \\n\ + \commit 2c3511d7c0c6d8cc53b220b3c9482de2dac74bf1\n\ + \Author: Kiwamu Okabe \n\ + \Date: Sat Jun 8 03:07:38 2013 +0900\n\ + \\n\ + \ Update README.md\n\ + \\n\ + \commit bc4be9e5eaae791cc7db7320e72a6040a22b8209\n\ + \Author: Kiwamu Okabe \n\ + \Date: Sat Jun 8 03:01:33 2013 +0900\n\ + \\n\ + \ Add compile flow image (png).\n\ + \\n\ + \commit a8db1b0ec2f1af7af0a2b3d16a4c930338768aba\n\ + \Author: Kiwamu Okabe \n\ + \Date: Sat Jun 8 02:33:40 2013 +0900\n\ + \\n\ + \ Bump up version 0.8.0.6.\n\ + \\n\ \commit 702d796aea22d1129491bb49b66a8a9a4b8ef901\n\ \Author: Kiwamu Okabe \n\ \Date: Sat Jun 8 01:53:46 2013 +0900\n\ @@ -2173,7 +2444,7 @@ {-# NOINLINE shortchange_txt #-} shortchange_txt :: ByteString shortchange_txt = unsafePerformIO $ unsafePackAddress "\ - \702d796aea22d1129491bb49b66a8a9a4b8ef901\ + \2b5cacf5b5d9de9ee1c6b2dd843aa5a926a6db03\ \"# -- | Generated from rts\/rts\/slub.c @@ -2558,15 +2829,20 @@ \#include \"rts/cdefs.h\"\n\ \#include \"rts/constants.h\"\n\ \#include \"rts/gc_jgc_internal.h\"\n\ + \#include \"rts/conc.h\"\n\ \\n\ \#if _JHC_GC == _JHC_GC_JGC\n\ \\n\ - \#ifdef _JHC_JGC_FIXED_MEGABLOCK\n\ - \static char aligned_megablock_1[MEGABLOCK_SIZE] __attribute__ ((aligned(BLOCK_SIZE)));\n\ - \static char gc_stack_base_area[(1UL << 8)*sizeof(gc_t)];\n\ + \#if defined(_JHC_JGC_LIMITED_NUM_MEGABLOCK)\n\ + \static char aligned_megablock[(MEGABLOCK_SIZE)*(_JHC_JGC_LIMITED_NUM_MEGABLOCK)] __attribute__ ((aligned(BLOCK_SIZE)));\n\ \#endif\n\ - \gc_t saved_gc; /* xxx Remove me. */\n\ - \arena_t saved_arena; /* xxx Remove me. */\n\ + \#if defined(_JHC_JGC_LIMITED_NUM_GC_STACK)\n\ + \static char gc_stack_base_area[(GC_STACK_SIZE)*sizeof(gc_t)*(_JHC_JGC_LIMITED_NUM_GC_STACK)];\n\ + \#endif\n\ + \SLIST_HEAD(,s_arena) used_arenas;\n\ + \SLIST_HEAD(,s_arena) free_arenas;\n\ + \SLIST_HEAD(,s_megablock) free_megablocks;\n\ + \SLIST_HEAD(,s_block) free_monolithic_blocks;\n\ \\n\ \#define TO_GCPTR(x) (entry_t *)(FROM_SPTR(x))\n\ \\n\ @@ -2645,14 +2921,14 @@ \gc_perform_gc(gc_t gc, arena_t arena)\n\ \{\n\ \ profile_push(&gc_gc_time);\n\ - \ saved_arena->number_gcs++;\n\ + \ arena->number_gcs++;\n\ \\n\ \ unsigned number_redirects = 0;\n\ \ unsigned number_stack = 0;\n\ \ unsigned number_ptr = 0;\n\ \ struct stack stack = EMPTY_STACK;\n\ \\n\ - \ clear_used_bits(saved_arena);\n\ + \ clear_used_bits(arena);\n\ \\n\ \ debugf(\"Setting Roots:\");\n\ \ stack_check(&stack, root_stack.ptr);\n\ @@ -2669,12 +2945,12 @@ \\n\ \ debugf(\"\\n\");\n\ \ debugf(\"Trace:\");\n\ - \ stack_check(&stack, gc - saved_arena->gc_stack_base);\n\ - \ number_stack = gc - saved_arena->gc_stack_base;\n\ + \ stack_check(&stack, gc - arena->gc_stack_base);\n\ + \ number_stack = gc - arena->gc_stack_base;\n\ \ for(unsigned i = 0; i < number_stack; i++) {\n\ \ debugf(\" |\");\n\ \ // TODO - short circuit redirects on stack\n\ - \ sptr_t ptr = saved_arena->gc_stack_base[i];\n\ + \ sptr_t ptr = arena->gc_stack_base[i];\n\ \ if(1 && (IS_LAZY(ptr))) {\n\ \ assert(GET_PTYPE(ptr) == P_LAZY);\n\ \ VALGRIND_MAKE_MEM_DEFINED(FROM_SPTR(ptr), sizeof(uintptr_t));\n\ @@ -2723,67 +2999,113 @@ \ }\n\ \ }\n\ \ free(stack.stack);\n\ - \ s_cleanup_blocks(saved_arena);\n\ + \ s_cleanup_blocks(arena);\n\ \ if (JHC_STATUS) {\n\ \ fprintf(stderr, \"%3u - %6u Used: %4u Thresh: %4u Ss: %5u Ps: %5u Rs: %5u Root: %3u\\n\",\n\ - \ saved_arena->number_gcs,\n\ - \ saved_arena->number_allocs,\n\ - \ (unsigned)saved_arena->block_used,\n\ - \ (unsigned)saved_arena->block_threshold,\n\ + \ arena->number_gcs,\n\ + \ arena->number_allocs,\n\ + \ (unsigned)arena->block_used,\n\ + \ (unsigned)arena->block_threshold,\n\ \ number_stack,\n\ \ number_ptr,\n\ \ number_redirects,\n\ \ (unsigned)root_stack.ptr\n\ \ );\n\ - \ saved_arena->number_allocs = 0;\n\ + \ arena->number_allocs = 0;\n\ \ }\n\ \ profile_pop(&gc_gc_time);\n\ \}\n\ \\n\ - \// 7 to share caches with the first 7 tuples\n\ - \#define GC_STATIC_ARRAY_NUM 7\n\ - \#define GC_MAX_BLOCK_ENTRIES 150\n\ - \\n\ - \static struct s_cache *array_caches[GC_STATIC_ARRAY_NUM];\n\ - \static struct s_cache *array_caches_atomic[GC_STATIC_ARRAY_NUM];\n\ + \/* Enter with rts_lock. */\n\ + \static gc_t\n\ + \new_gc_stack(arena_t arena) {\n\ + \ if (!arena->gc_stack_base) {\n\ + \#if defined(_JHC_JGC_LIMITED_NUM_GC_STACK)\n\ + \ static int count = 0;\n\ + \ if (count >= _JHC_JGC_LIMITED_NUM_GC_STACK) {\n\ + \ abort();\n\ + \ }\n\ + \ arena->gc_stack_base = (void *) (gc_stack_base_area +\n\ + \ (GC_STACK_SIZE) * sizeof(gc_t) * count);\n\ + \ count++;\n\ + \#else\n\ + \ arena->gc_stack_base = malloc((GC_STACK_SIZE)*sizeof(arena->gc_stack_base[0]));\n\ + \#endif\n\ + \ }\n\ + \ return arena->gc_stack_base;\n\ + \}\n\ \\n\ + \static int jhc_alloc_init_count = 0;\n\ \void\n\ - \jhc_alloc_init(void) {\n\ + \jhc_alloc_init(gc_t *gc_p,arena_t *arena_p) {\n\ \ VALGRIND_PRINTF(\"Jhc-Valgrind mode active.\\n\");\n\ - \ saved_arena = new_arena();\n\ - \#ifdef _JHC_JGC_FIXED_MEGABLOCK\n\ - \ saved_gc = saved_arena->gc_stack_base = (void *) gc_stack_base_area;\n\ - \#else\n\ - \ saved_gc = saved_arena->gc_stack_base = malloc((1UL << 18)*sizeof(saved_arena->gc_stack_base[0]));\n\ - \#endif\n\ - \ if(nh_stuff[0]) {\n\ - \ nh_end = nh_start = nh_stuff[0];\n\ - \ for(int i = 1; nh_stuff[i]; i++) {\n\ - \ if(nh_stuff[i] < nh_start)\n\ - \ nh_start = nh_stuff[i];\n\ - \ if(nh_stuff[i] > nh_end)\n\ - \ nh_end = nh_stuff[i];\n\ + \\n\ + \ jhc_rts_lock();\n\ + \ if (!jhc_alloc_init_count++) {\n\ + \ SLIST_INIT(&used_arenas);\n\ + \ SLIST_INIT(&free_arenas);\n\ + \ SLIST_INIT(&free_megablocks);\n\ + \ SLIST_INIT(&free_monolithic_blocks);\n\ + \ if(nh_stuff[0]) {\n\ + \ nh_end = nh_start = nh_stuff[0];\n\ + \ for(int i = 1; nh_stuff[i]; i++) {\n\ + \ if(nh_stuff[i] < nh_start)\n\ + \ nh_start = nh_stuff[i];\n\ + \ if(nh_stuff[i] > nh_end)\n\ + \ nh_end = nh_stuff[i];\n\ + \ }\n\ \ }\n\ \ }\n\ + \ *arena_p = new_arena();\n\ + \ SLIST_INSERT_HEAD(&used_arenas, *arena_p, link);\n\ + \ *gc_p = new_gc_stack(*arena_p);\n\ + \ jhc_rts_unlock();\n\ \}\n\ \\n\ \void\n\ - \jhc_alloc_fini(void) {\n\ + \jhc_alloc_fini(gc_t gc,arena_t arena) {\n\ + \ struct s_block *pg;\n\ + \ struct s_megablock *mb;\n\ + \ struct s_cache *sc;\n\ + \\n\ \ if(_JHC_PROFILE || JHC_STATUS) {\n\ - \ fprintf(stderr, \"arena: %p\\n\", saved_arena);\n\ - \ fprintf(stderr, \" block_used: %i\\n\", saved_arena->block_used);\n\ - \ fprintf(stderr, \" block_threshold: %i\\n\", saved_arena->block_threshold);\n\ + \ fprintf(stderr, \"arena: %p\\n\", arena);\n\ + \ fprintf(stderr, \" block_used: %i\\n\", arena->block_used);\n\ + \ fprintf(stderr, \" block_threshold: %i\\n\", arena->block_threshold);\n\ \ struct s_cache *sc;\n\ - \ SLIST_FOREACH(sc,&saved_arena->caches,next)\n\ + \ SLIST_FOREACH(sc,&arena->caches,next)\n\ \ print_cache(sc);\n\ \ }\n\ + \\n\ + \ jhc_rts_lock();\n\ + \ SLIST_FOREACH(pg, &arena->monolithic_blocks, link) {\n\ + \ SLIST_INSERT_HEAD(&free_monolithic_blocks, pg, link);\n\ + \ }\n\ + \ SLIST_FOREACH(mb, &arena->megablocks, next) {\n\ + \ SLIST_INSERT_HEAD(&free_megablocks, mb, next);\n\ + \ }\n\ + \ if(arena->current_megablock) {\n\ + \ SLIST_INSERT_HEAD(&free_megablocks, arena->current_megablock, next);\n\ + \ }\n\ + \\n\ + \ SLIST_FOREACH(sc, &arena->caches, next) {\n\ + \ SLIST_INIT(&sc->blocks);\n\ + \ SLIST_INIT(&sc->full_blocks);\n\ + \#if _JHC_PROFILE\n\ + \ sc->allocations = 0;\n\ + \#endif\n\ + \ }\n\ + \\n\ + \ SLIST_REMOVE(&used_arenas, arena, s_arena, link);\n\ + \ SLIST_INSERT_HEAD(&free_arenas, arena, link);\n\ + \ jhc_rts_unlock();\n\ \}\n\ \\n\ \heap_t A_STD\n\ \(gc_alloc)(gc_t gc, arena_t arena, struct s_cache **sc, unsigned count, unsigned nptrs)\n\ \{\n\ \ assert(nptrs <= count);\n\ - \ entry_t *e = s_alloc(gc, arena, find_cache(sc, saved_arena, count, nptrs));\n\ + \ entry_t *e = s_alloc(gc, arena, find_cache(sc, arena, count, nptrs));\n\ \ VALGRIND_MAKE_MEM_UNDEFINED(e,sizeof(uintptr_t)*count);\n\ \ debugf(\"gc_alloc: %p %i %i\\n\",(void *)e, count, nptrs);\n\ \ return (void *)e;\n\ @@ -2791,7 +3113,15 @@ \\n\ \static heap_t A_STD\n\ \s_monoblock(arena_t arena, unsigned size, unsigned nptrs, unsigned flags) {\n\ - \ struct s_block *b = jhc_aligned_alloc(size * sizeof(uintptr_t));\n\ + \ jhc_rts_lock();\n\ + \ struct s_block *b = SLIST_FIRST(&free_monolithic_blocks);\n\ + \ if (b) {\n\ + \ SLIST_REMOVE(&free_monolithic_blocks, b, s_block, link);\n\ + \ } else {\n\ + \ b = jhc_aligned_alloc(size * sizeof(uintptr_t));\n\ + \ }\n\ + \ jhc_rts_unlock();\n\ + \\n\ \ b->flags = flags | SLAB_MONOLITH;\n\ \ b->color = (sizeof(struct s_block) + BITARRAY_SIZE_IN_BYTES(1) +\n\ \ sizeof(uintptr_t) - 1) / sizeof(uintptr_t);\n\ @@ -2809,10 +3139,10 @@ \ if (!count)\n\ \ return NULL;\n\ \ if (count <= GC_STATIC_ARRAY_NUM)\n\ - \ return (wptr_t)s_alloc(gc, arena,array_caches[count - 1]);\n\ + \ return (wptr_t)s_alloc(gc, arena, arena->array_caches[count - 1]);\n\ \ if (count < GC_MAX_BLOCK_ENTRIES)\n\ - \ return s_alloc(gc, arena, find_cache(NULL, saved_arena, count, count));\n\ - \ return s_monoblock(saved_arena, count, count, 0);\n\ + \ return s_alloc(gc, arena, find_cache(NULL, arena, count, count));\n\ + \ return s_monoblock(arena, count, count, 0);\n\ \ abort();\n\ \}\n\ \\n\ @@ -2824,10 +3154,10 @@ \ if (!count)\n\ \ return NULL;\n\ \ if (count <= GC_STATIC_ARRAY_NUM && !flags)\n\ - \ return (wptr_t)s_alloc(gc, arena, array_caches_atomic[count - 1]);\n\ + \ return (wptr_t)s_alloc(gc, arena, arena->array_caches_atomic[count - 1]);\n\ \ if (count < GC_MAX_BLOCK_ENTRIES && !flags)\n\ - \ return s_alloc(gc, arena, find_cache(NULL, saved_arena, count, 0));\n\ - \ return s_monoblock(saved_arena, count, count, flags);\n\ + \ return s_alloc(gc, arena, find_cache(NULL, arena, count, 0));\n\ + \ return s_monoblock(arena, count, count, flags);\n\ \ abort();\n\ \}\n\ \\n\ @@ -2877,17 +3207,25 @@ \struct s_megablock *\n\ \s_new_megablock(arena_t arena)\n\ \{\n\ - \ struct s_megablock *mb = malloc(sizeof(*mb));\n\ - \#ifdef _JHC_JGC_FIXED_MEGABLOCK\n\ + \ jhc_rts_lock();\n\ + \ struct s_megablock *mb = SLIST_FIRST(&free_megablocks);\n\ + \ if (mb) {\n\ + \ SLIST_REMOVE(&free_megablocks, mb, s_megablock, next);\n\ + \ } else {\n\ + \ mb = malloc(sizeof(*mb));\n\ + \ }\n\ + \#ifdef _JHC_JGC_LIMITED_NUM_MEGABLOCK\n\ \ static int count = 0;\n\ - \ if (count != 0) {\n\ + \ if (count >= _JHC_JGC_LIMITED_NUM_MEGABLOCK) {\n\ \ abort();\n\ \ }\n\ + \ mb->base = aligned_megablock + (MEGABLOCK_SIZE) * count;\n\ \ count++;\n\ - \ mb->base = aligned_megablock_1;\n\ \#else\n\ \ mb->base = jhc_aligned_alloc(MEGABLOCK_SIZE);\n\ \#endif\n\ + \ jhc_rts_unlock();\n\ + \\n\ \ VALGRIND_MAKE_MEM_NOACCESS(mb->base,MEGABLOCK_SIZE);\n\ \ mb->next_free = 0;\n\ \ return mb;\n\ @@ -3043,6 +3381,10 @@ \#endif\n\ \ bool retry = false;\n\ \ struct s_block *pg;\n\ + \ if (__predict_false(arena->force_gc_next_s_alloc)) {\n\ + \ arena->force_gc_next_s_alloc = 0;\n\ + \ gc_perform_gc(gc, arena);\n\ + \ }\n\ \retry_s_alloc:\n\ \ pg = SLIST_FIRST(&sc->blocks);\n\ \ if(__predict_false(!pg)) {\n\ @@ -3166,10 +3508,31 @@ \ return sc;\n\ \}\n\ \\n\ + \void\n\ + \alloc_public_caches(arena_t arena, size_t size) {\n\ + \ if (arena->public_caches_p == NULL) {\n\ + \ arena->public_caches_p = malloc(size);\n\ + \ }\n\ + \}\n\ + \\n\ + \struct s_caches_pub *\n\ + \public_caches(arena_t arena) {\n\ + \ return arena->public_caches_p;\n\ + \}\n\ + \\n\ + \/* Enter with rts_lock. */\n\ \arena_t\n\ \new_arena(void) {\n\ - \ arena_t arena = malloc(sizeof(struct s_arena));\n\ - \ SLIST_INIT(&arena->caches);\n\ + \ arena_t arena = SLIST_FIRST(&free_arenas);\n\ + \ if (arena) {\n\ + \ SLIST_REMOVE(&free_arenas, arena, s_arena, link);\n\ + \ } else {\n\ + \ arena = malloc(sizeof(struct s_arena));\n\ + \ memset(arena, 0, sizeof(*arena));\n\ + \ // Following menbers isn't clear at jhc_alloc_fini for keeping caches.\n\ + \ SLIST_INIT(&arena->caches);\n\ + \ arena->public_caches_p = NULL;\n\ + \ }\n\ \ SLIST_INIT(&arena->free_blocks);\n\ \ SLIST_INIT(&arena->megablocks);\n\ \ SLIST_INIT(&arena->monolithic_blocks);\n\ @@ -3178,8 +3541,8 @@ \ arena->current_megablock = NULL;\n\ \\n\ \ for (int i = 0; i < GC_STATIC_ARRAY_NUM; i++) {\n\ - \ find_cache(&array_caches[i], arena, i + 1, i + 1);\n\ - \ find_cache(&array_caches_atomic[i], arena, i + 1, 0);\n\ + \ find_cache(&arena->array_caches[i], arena, i + 1, i + 1);\n\ + \ find_cache(&arena->array_caches_atomic[i], arena, i + 1, 0);\n\ \ }\n\ \ return arena;\n\ \}\n\ @@ -3203,13 +3566,13 @@ \}\n\ \\n\ \heap_t A_STD\n\ - \gc_malloc_foreignptr(unsigned alignment, unsigned size, bool finalizer) {\n\ + \gc_malloc_foreignptr(gc_t gc, arena_t arena, unsigned alignment, unsigned size, bool finalizer) {\n\ \ // we don't allow higher alignments yet.\n\ \ assert (alignment <= sizeof(uintptr_t));\n\ \ // no finalizers yet\n\ \ assert (!finalizer);\n\ \ unsigned spacing = 1 + finalizer;\n\ - \ wptr_t *res = gc_array_alloc_atomic(saved_gc, saved_arena, spacing + TO_BLOCKS(size),\n\ + \ wptr_t *res = gc_array_alloc_atomic(gc, arena, spacing + TO_BLOCKS(size),\n\ \ finalizer ? SLAB_FLAG_FINALIZER : SLAB_FLAG_NONE);\n\ \ res[0] = (wptr_t)(res + spacing);\n\ \ if (finalizer)\n\ @@ -3218,8 +3581,8 @@ \}\n\ \\n\ \heap_t A_STD\n\ - \gc_new_foreignptr(HsPtr ptr) {\n\ - \ HsPtr *res = gc_array_alloc_atomic(saved_gc, saved_arena, 2, SLAB_FLAG_FINALIZER);\n\ + \gc_new_foreignptr(gc_t gc, arena_t arena, HsPtr ptr) {\n\ + \ HsPtr *res = gc_array_alloc_atomic(gc, arena, 2, SLAB_FLAG_FINALIZER);\n\ \ res[0] = ptr;\n\ \ res[1] = NULL;\n\ \ return TO_SPTR(P_WHNF, res);\n\ @@ -3264,7 +3627,12 @@ \}\n\ \\n\ \void hs_perform_gc(void) {\n\ - \ gc_perform_gc(saved_gc, saved_arena);\n\ + \ arena_t arena;\n\ + \ jhc_rts_lock();\n\ + \ SLIST_FOREACH(arena, &used_arenas, link) {\n\ + \ arena->force_gc_next_s_alloc = 1;\n\ + \ }\n\ + \ jhc_rts_unlock();\n\ \}\n\ \\n\ \#endif\n\ @@ -3300,8 +3668,13 @@ \#define _JHC_JGC_MEGABLOCK_SHIFT 20\n\ \#endif /* defined(_JHC_JGC_BLOCK_SHIFT) && defined(_JHC_JGC_MEGABLOCK_SHIFT) */\n\ \\n\ + \#if !defined(_JHC_JGC_GC_STACK_SHIFT)\n\ + \#define _JHC_JGC_GC_STACK_SHIFT 18\n\ + \#endif /* !defined(_JHC_JGC_BLOCK_SHIFT) */\n\ + \\n\ \#define BLOCK_SIZE (1UL << (_JHC_JGC_BLOCK_SHIFT))\n\ \#define MEGABLOCK_SIZE (1UL << (_JHC_JGC_MEGABLOCK_SHIFT))\n\ + \#define GC_STACK_SIZE (1UL << (_JHC_JGC_GC_STACK_SHIFT))\n\ \#define S_BLOCK(val) ((struct s_block *)((uintptr_t)(val) & ~(BLOCK_SIZE - 1)))\n\ \#define TO_BLOCKS(x) (((x) + sizeof(uintptr_t) - 1)/sizeof(uintptr_t))\n\ \\n\ @@ -3314,6 +3687,8 @@ \arena_t new_arena(void);\n\ \struct s_cache *find_cache(struct s_cache **rsc, arena_t arena,\n\ \ unsigned short size, unsigned short num_ptrs);\n\ + \void alloc_public_caches(arena_t arena, size_t size);\n\ + \struct s_caches_pub *public_caches(arena_t arena);\n\ \void gc_add_root(gc_t gc, arena_t arena, void * root);\n\ \void A_STD gc_perform_gc(gc_t gc, arena_t arena);\n\ \uint32_t get_heap_flags(void* sp);\n\ @@ -3323,8 +3698,8 @@ \heap_t gc_array_alloc(gc_t gc, arena_t arena, unsigned count) A_STD;\n\ \heap_t gc_array_alloc_atomic(gc_t gc, arena_t arena, unsigned count, unsigned slab_flags) A_STD;\n\ \/* foreignptr, saved_gc must be set properly. */\n\ - \heap_t gc_malloc_foreignptr(unsigned alignment, unsigned size, bool finalizer) A_STD;\n\ - \heap_t gc_new_foreignptr(HsPtr ptr) A_STD;\n\ + \heap_t gc_malloc_foreignptr(gc_t gc, arena_t arena, unsigned alignment, unsigned size, bool finalizer) A_STD;\n\ + \heap_t gc_new_foreignptr(gc_t gc, arena_t arena, HsPtr ptr) A_STD;\n\ \bool gc_add_foreignptr_finalizer(struct sptr* fp, HsFunPtr finalizer) A_STD;\n\ \\n\ \#define gc_frame0(gc,n,...) void *ptrs[n] = { __VA_ARGS__ }; \\\n\ @@ -3686,6 +4061,7 @@ \#include \"rts/rts_support.h\"\n\ \#include \"rts/profile.h\"\n\ \#include \"rts/gc.h\"\n\ + \#include \"rts/conc.h\"\n\ \\n\ \jmp_buf jhc_uncaught;\n\ \int jhc_argc;\n\ @@ -3733,16 +4109,18 @@ \ abort();\n\ \}\n\ \\n\ - \void jhc_hs_init(void);\n\ + \#if _JHC_GC == _JHC_GC_JGC\n\ + \void jhc_hs_init(gc_t gc,arena_t arena);\n\ + \#else\n\ + \void jhc_hs_init();\n\ + \#endif\n\ \\n\ - \static int hs_init_count;\n\ + \static int hs_init_count = 0;\n\ \void\n\ \hs_init(int *argc, char **argv[])\n\ \{\n\ - \\n\ \ if(!hs_init_count++) {\n\ - \ jhc_alloc_init();\n\ - \ jhc_hs_init();\n\ + \ jhc_conc_init();\n\ \ hs_set_argv(*argc,*argv);\n\ \#if JHC_isPosix\n\ \ struct utsname jhc_utsname;\n\ @@ -3763,7 +4141,6 @@ \ abort();\n\ \ }\n\ \ if(!--hs_init_count) {\n\ - \ jhc_alloc_fini();\n\ \ jhc_exit(0);\n\ \ }\n\ \}\n\ @@ -3820,13 +4197,18 @@ \#define _JHC_GC _JHC_GC_NONE\n\ \#endif\n\ \\n\ - \void jhc_alloc_init(void);\n\ - \void jhc_alloc_fini(void);\n\ - \\n\ \#include \"rts/gc_none.h\"\n\ \#include \"rts/gc_jgc.h\"\n\ \\n\ + \#if _JHC_GC == _JHC_GC_JGC\n\ + \void jhc_alloc_init(gc_t *gc_p,arena_t *arena_p);\n\ + \void jhc_alloc_fini(gc_t gc,arena_t arena);\n\ + \#else\n\ + \void jhc_alloc_init(void);\n\ + \void jhc_alloc_fini(void);\n\ \#endif\n\ + \\n\ + \#endif\n\ \"# -- | Generated from rts\/rts\/gc_none.c @@ -4381,16 +4763,20 @@ \\n\ \#define JHC_isPosix (!JHC_isWindows && !defined(__ARM_EABI__))\n\ \\n\ - \// the program will provide the following\n\ - \void _amain(void);\n\ - \void jhc_hs_init(void);\n\ - \extern const void * const nh_stuff[];\n\ - \\n\ \#include \"rts/profile.h\"\n\ \#include \"rts/rts_support.h\"\n\ \#include \"rts/gc.h\"\n\ \#include \"rts/jhc_rts.h\"\n\ \#include \"lib/lib_cbits.h\"\n\ + \\n\ + \// the program will provide the following\n\ + \void _amain(void);\n\ + \#if _JHC_GC == _JHC_GC_JGC\n\ + \void jhc_hs_init(gc_t gc,arena_t arena);\n\ + \#else\n\ + \void jhc_hs_init();\n\ + \#endif\n\ + \extern const void * const nh_stuff[];\n\ \"# -- | Generated from rts\/lib\/lib_cbits.h @@ -4407,35 +4793,28 @@ \extern HsInt jhc_data_unique;\n\ \HsBool jhc_wait_for_input(FILE *f,HsInt timeout);\n\ \\n\ - \#ifdef __WIN32__\n\ - \#define getchar_unlocked() getchar()\n\ - \#define putchar_unlocked(x) putchar(x)\n\ - \#define getc_unlocked(x) getc(x)\n\ - \#define putc_unlocked(x,y) putc(x,y)\n\ - \#endif\n\ - \\n\ \inline static int A_UNUSED\n\ \jhc_utf8_getchar(void)\n\ \{\n\ - \ return getchar_unlocked();\n\ + \ return getchar();\n\ \}\n\ \\n\ \inline static int A_UNUSED\n\ \jhc_utf8_getc(FILE *f)\n\ \{\n\ - \ return getc_unlocked(f);\n\ + \ return getc(f);\n\ \}\n\ \\n\ \inline static int A_UNUSED\n\ \jhc_utf8_putchar(int ch)\n\ \{\n\ - \ return putchar_unlocked(ch);\n\ + \ return putchar(ch);\n\ \}\n\ \\n\ \inline static int A_UNUSED\n\ \jhc_utf8_putc(int ch, FILE *f)\n\ \{\n\ - \ return putc_unlocked(ch,f);\n\ + \ return putc(ch,f);\n\ \}\n\ \\n\ \#endif\n\ @@ -4454,7 +4833,10 @@ \\n\ \#if _JHC_GC == _JHC_GC_JGC\n\ \\n\ + \struct s_caches_pub;\n\ + \\n\ \struct s_arena {\n\ + \ SLIST_ENTRY(s_arena) link;\n\ \ struct s_megablock *current_megablock;\n\ \ SLIST_HEAD(,s_block) free_blocks;\n\ \ unsigned block_used;\n\ @@ -4465,6 +4847,13 @@ \ unsigned number_gcs; // number of garbage collections\n\ \ unsigned number_allocs; // number of allocations since last garbage collection\n\ \ gc_t gc_stack_base;\n\ + \// 7 to share caches with the first 7 tuples\n\ + \#define GC_STATIC_ARRAY_NUM 7\n\ + \#define GC_MAX_BLOCK_ENTRIES 150\n\ + \ struct s_cache *array_caches[GC_STATIC_ARRAY_NUM];\n\ + \ struct s_cache *array_caches_atomic[GC_STATIC_ARRAY_NUM];\n\ + \ struct s_caches_pub *public_caches_p; // access from main_code.c\n\ + \ int force_gc_next_s_alloc;\n\ \};\n\ \\n\ \struct s_megablock {\n\ @@ -4509,6 +4898,109 @@ \};\n\ \#endif\n\ \#endif\n\ + \"# + +-- | Generated from rts\/rts\/conc.c +{-# NOINLINE conc_c #-} +conc_c :: ByteString +conc_c = unsafePerformIO $ unsafePackAddress "\ + \#include \"rts/conc.h\"\n\ + \\n\ + \static jhc_mutex_t jhc_rts_mutex;\n\ + \\n\ + \void\n\ + \jhc_conc_init()\n\ + \{\n\ + \ jhc_mutex_init(&jhc_rts_mutex);\n\ + \}\n\ + \\n\ + \void\n\ + \jhc_rts_lock()\n\ + \{\n\ + \ jhc_mutex_lock(&jhc_rts_mutex);\n\ + \}\n\ + \\n\ + \void\n\ + \jhc_rts_unlock()\n\ + \{\n\ + \ jhc_mutex_unlock(&jhc_rts_mutex);\n\ + \}\n\ + \\n\ + \#if _JHC_CONC == _JHC_CONC_NONE\n\ + \jhc_threadid_t\n\ + \forkOS_createThread(void *(*wrapper) (void *), void *entry, int *err)\n\ + \{\n\ + \ (*wrapper)(entry);\n\ + \ return 0; /* xxx */\n\ + \}\n\ + \\n\ + \#elif _JHC_CONC == _JHC_CONC_PTHREAD\n\ + \jhc_threadid_t\n\ + \forkOS_createThread(void *(*wrapper) (void *), void *entry, int *err)\n\ + \{\n\ + \ pthread_t tid;\n\ + \ *err = pthread_create(&tid, NULL, wrapper, entry);\n\ + \ if (*err) {\n\ + \ pthread_detach(tid);\n\ + \ }\n\ + \ return tid;\n\ + \}\n\ + \\n\ + \#elif _JHC_CONC == _JHC_CONC_CUSTOM\n\ + \/* You should impl me at your side. */\n\ + \#else\n\ + \#error \"You should choose _JHC_CONC.\"\n\ + \#endif /* _JHC_CONC == ??? */\n\ + \"# + +-- | Generated from rts\/rts\/conc.h +{-# NOINLINE conc_h #-} +conc_h :: ByteString +conc_h = unsafePerformIO $ unsafePackAddress "\ + \#ifndef CONC_H\n\ + \#define CONC_H\n\ + \\n\ + \#define _JHC_CONC_NONE 0\n\ + \#define _JHC_CONC_PTHREAD 1\n\ + \#define _JHC_CONC_CUSTOM 2\n\ + \\n\ + \#ifndef _JHC_CONC\n\ + \#define _JHC_CONC _JHC_CONC_NONE\n\ + \#endif\n\ + \\n\ + \#if _JHC_CONC == _JHC_CONC_NONE\n\ + \#define jhc_threadid_t int\n\ + \#define jhc_mutex_t int\n\ + \#define jhc_mutex_init(M)\x0009\&(*(M) = 0)\n\ + \#define jhc_mutex_lock(M)\x0009\&do { } while (/* CONSTCOND */ 0)\n\ + \#define jhc_mutex_unlock(M)\x0009\&do { } while (/* CONSTCOND */ 0)\n\ + \\n\ + \#elif _JHC_CONC == _JHC_CONC_PTHREAD\n\ + \#include \n\ + \#define jhc_threadid_t pthread_t\n\ + \#define jhc_mutex_t pthread_mutex_t\n\ + \#define jhc_mutex_init(M)\x0009\&(void) pthread_mutex_init((M), NULL)\n\ + \#define jhc_mutex_lock(M)\x0009\&pthread_mutex_lock((M))\n\ + \#define jhc_mutex_unlock(M)\x0009\&pthread_mutex_unlock((M))\n\ + \\n\ + \#elif _JHC_CONC == _JHC_CONC_CUSTOM\n\ + \/* You should impl \"jhc_threadid_t\" and \"jhc_mutex_t\". */\n\ + \void jhc_mutex_init(jhc_mutex_t *mutex)\n\ + \void jhc_mutex_lock(jhc_mutex_t *mutex)\n\ + \void jhc_mutex_unlock(jhc_mutex_t *mutex)\n\ + \\n\ + \#else\n\ + \#error \"You should choose _JHC_CONC.\"\n\ + \\n\ + \#endif /* _JHC_CONC == ??? */\n\ + \\n\ + \/* Common functions */\n\ + \jhc_threadid_t forkOS_createThread(void *(*wrapper) (void *), void *entry, int *err);\n\ + \void jhc_conc_init(void);\n\ + \void jhc_rts_lock(void);\n\ + \void jhc_rts_unlock(void);\n\ + \\n\ + \#endif /* CONC_H */\n\ \"# diff --git a/src/Version/Config.hs b/src/Version/Config.hs --- a/src/Version/Config.hs +++ b/src/Version/Config.hs @@ -1,7 +1,7 @@ module Version.Config where shortVersion = "0.8" -version = "0.8.0.5" +version = "0.8.0.6" package = "ajhc" libdir = "/usr/local/lib" datadir = "/usr/local/share" diff --git a/src/data/targets.ini b/src/data/targets.ini --- a/src/data/targets.ini +++ b/src/data/targets.ini @@ -26,7 +26,7 @@ ; cross compilation entries [win32] -cc=i686-w64-mingw32-gcc +cc=i386-mingw32-gcc executable_extension=.exe merge=i686