diff --git a/compiler/coreSyn/CoreArity.hs b/compiler/coreSyn/CoreArity.hs --- a/compiler/coreSyn/CoreArity.hs +++ b/compiler/coreSyn/CoreArity.hs @@ -1057,10 +1057,17 @@ where empty_subst = mkEmptyTCvSubst in_scope + go :: Arity -- Number of value args to expand to + -> TCvSubst -> Type -- We are really looking at subst(ty) + -> [EtaInfo] -- Accumulating parameter + -> (InScopeSet, [EtaInfo]) go n subst ty eis -- See Note [exprArity invariant] + + ----------- Done! No more expansion needed | n == 0 = (getTCvInScope subst, reverse eis) + ----------- Forall types (forall a. ty) | Just (tcv,ty') <- splitForAllTy_maybe ty , let (subst', tcv') = Type.substVarBndr subst tcv = let ((n_subst, n_tcv), n_n) @@ -1071,10 +1078,11 @@ -- lambda \co:ty. e co. In this case we generate a new variable -- of the coercion type, update the scope, and reduce n by 1. | isTyVar tcv = ((subst', tcv'), n) - | otherwise = (freshEtaId n subst' (varType tcv'), n-1) + | otherwise = (freshEtaId n subst' (varType tcv'), n-1) -- Avoid free vars of the original expression in go n_n n_subst ty' (EtaVar n_tcv : eis) + ----------- Function types (t1 -> t2) | Just (arg_ty, res_ty) <- splitFunTy_maybe ty , not (isTypeLevPoly arg_ty) -- See Note [Levity polymorphism invariants] in CoreSyn @@ -1084,14 +1092,19 @@ -- Avoid free vars of the original expression = go (n-1) subst' res_ty (EtaVar eta_id' : eis) + ----------- Newtypes + -- Given this: + -- newtype T = MkT ([T] -> Int) + -- Consider eta-expanding this + -- eta_expand 1 e T + -- We want to get + -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x) | Just (co, ty') <- topNormaliseNewType_maybe ty - = -- Given this: - -- newtype T = MkT ([T] -> Int) - -- Consider eta-expanding this - -- eta_expand 1 e T - -- We want to get - -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x) - go n subst ty' (pushCoercion co eis) + , let co' = Coercion.substCo subst co + -- Remember to apply the substitution to co (#16979) + -- (or we could have applied to ty, but then + -- we'd have had to zap it for the recursive call) + = go n subst ty' (pushCoercion co' eis) | otherwise -- We have an expression of arity > 0, -- but its type isn't a function, or a binder diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs --- a/compiler/coreSyn/CoreSyn.hs +++ b/compiler/coreSyn/CoreSyn.hs @@ -608,6 +608,8 @@ same number of arguments, counting both types and values; we call this the "join arity" (to distinguish from regular arity, which only counts values). + See Note [Join points are less general than the paper] + 2. For join arity n, the right-hand side must begin with at least n lambdas. No ticks, no casts, just lambdas! C.f. CoreUtils.joinRhsArity. @@ -656,6 +658,26 @@ Core Lint will check these invariants, anticipating that any binder whose OccInfo is marked AlwaysTailCalled will become a join point as soon as the simplifier (or simpleOptPgm) runs. + +Note [Join points are less general than the paper] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the paper "Compiling without continuations", this expression is +perfectly valid: + + join { j = \_ -> e } + in (case blah of ) + ( True -> j void# ) arg + ( False -> blah ) + +assuming 'j' has arity 1. Here the call to 'j' does not look like a +tail call, but actually everything is fine. See Section 3, "Managing \Delta" +in the paper. + +In GHC, however, we adopt a slightly more restrictive subset, in which +join point calls must be tail calls. I think we /could/ loosen it up, but +in fact the simplifier ensures that we always get tail calls, and it makes +the back end a bit easier I think. Generally, just less to think about; +nothing deeper than that. Note [The type of a join point] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/ghci/ByteCodeTypes.hs b/compiler/ghci/ByteCodeTypes.hs --- a/compiler/ghci/ByteCodeTypes.hs +++ b/compiler/ghci/ByteCodeTypes.hs @@ -35,6 +35,7 @@ import Data.ByteString (ByteString) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap +import Data.Maybe (catMaybes) import GHC.Exts.Heap import GHC.Stack.CCS @@ -110,14 +111,15 @@ -- | Information about a breakpoint that we know at code-generation time data CgBreakInfo = CgBreakInfo - { cgb_vars :: [(Id,Word16)] + { cgb_vars :: [Maybe (Id,Word16)] , cgb_resty :: Type } +-- See Note [Syncing breakpoint info] in compiler/main/InteractiveEval.hs -- Not a real NFData instance because we can't rnf Id or Type seqCgBreakInfo :: CgBreakInfo -> () seqCgBreakInfo CgBreakInfo{..} = - rnf (map snd cgb_vars) `seq` + rnf (map snd (catMaybes (cgb_vars))) `seq` seqType cgb_resty instance Outputable UnlinkedBCO where diff --git a/ghc-lib-parser.cabal b/ghc-lib-parser.cabal --- a/ghc-lib-parser.cabal +++ b/ghc-lib-parser.cabal @@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-parser -version: 8.8.0.20190723 +version: 8.8.1 license: BSD3 license-file: LICENSE category: Development @@ -44,11 +44,9 @@ ghc-lib/stage1/compiler/build/Config.hs ghc-lib/stage0/compiler/build/Parser.hs ghc-lib/stage0/compiler/build/Lexer.hs - includes/*.h + includes/ghcconfig.h + includes/MachDeps.h includes/CodeGen.Platform.hs - includes/rts/*.h - includes/rts/storage/*.h - includes/rts/prof/*.h compiler/nativeGen/*.h compiler/utils/*.h compiler/*.h @@ -61,6 +59,7 @@ default-language: Haskell2010 default-extensions: NoImplicitPrelude include-dirs: + includes ghc-lib/generated ghc-lib/stage0/compiler/build ghc-lib/stage1/compiler/build diff --git a/ghc-lib/generated/ghcversion.h b/ghc-lib/generated/ghcversion.h --- a/ghc-lib/generated/ghcversion.h +++ b/ghc-lib/generated/ghcversion.h @@ -5,8 +5,7 @@ # define __GLASGOW_HASKELL__ 808 #endif -#define __GLASGOW_HASKELL_PATCHLEVEL1__ 0 -#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20190721 +#define __GLASGOW_HASKELL_PATCHLEVEL1__ 1 #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\ ((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \ diff --git a/ghc-lib/stage0/compiler/build/Parser.hs b/ghc-lib/stage0/compiler/build/Parser.hs --- a/ghc-lib/stage0/compiler/build/Parser.hs +++ b/ghc-lib/stage0/compiler/build/Parser.hs @@ -12532,7 +12532,7 @@ {-# LINE 19 "" #-} -{-# LINE 1 "/var/folders/f_/bb4zyb7d2_z9bqm3hrqrjgp40000gn/T/ghc33323_0/ghc_2.h" #-} +{-# LINE 1 "/var/folders/f_/bb4zyb7d2_z9bqm3hrqrjgp40000gn/T/ghc99894_0/ghc_2.h" #-} diff --git a/ghc-lib/stage1/compiler/build/Config.hs b/ghc-lib/stage1/compiler/build/Config.hs --- a/ghc-lib/stage1/compiler/build/Config.hs +++ b/ghc-lib/stage1/compiler/build/Config.hs @@ -19,17 +19,17 @@ cProjectName :: String cProjectName = "The Glorious Glasgow Haskell Compilation System" cProjectGitCommitId :: String -cProjectGitCommitId = "3e139dba8b8fcc15c201803a0ae27255ada43c14" +cProjectGitCommitId = "9c787d4d24f2b515934c8503ee2bbd7cfac4da20" cProjectVersion :: String -cProjectVersion = "8.8.0.20190721" +cProjectVersion = "8.8.1" cProjectVersionInt :: String cProjectVersionInt = "808" cProjectPatchLevel :: String -cProjectPatchLevel = "020190721" +cProjectPatchLevel = "1" cProjectPatchLevel1 :: String -cProjectPatchLevel1 = "0" +cProjectPatchLevel1 = "1" cProjectPatchLevel2 :: String -cProjectPatchLevel2 = "20190721" +cProjectPatchLevel2 = "" cBooterVersion :: String cBooterVersion = "8.4.3" cStage :: String diff --git a/includes/Cmm.h b/includes/Cmm.h deleted file mode 100644 --- a/includes/Cmm.h +++ /dev/null @@ -1,941 +0,0 @@ -/* ----------------------------------------------------------------------------- - * - * (c) The University of Glasgow 2004-2013 - * - * This file is included at the top of all .cmm source files (and - * *only* .cmm files). It defines a collection of useful macros for - * making .cmm code a bit less error-prone to write, and a bit easier - * on the eye for the reader. - * - * For the syntax of .cmm files, see the parser in ghc/compiler/cmm/CmmParse.y. - * - * Accessing fields of structures defined in the RTS header files is - * done via automatically-generated macros in DerivedConstants.h. For - * example, where previously we used - * - * CurrentTSO->what_next = x - * - * in C-- we now use - * - * StgTSO_what_next(CurrentTSO) = x - * - * where the StgTSO_what_next() macro is automatically generated by - * mkDerivedConstants.c. If you need to access a field that doesn't - * already have a macro, edit that file (it's pretty self-explanatory). - * - * -------------------------------------------------------------------------- */ - -#pragma once - -/* - * In files that are included into both C and C-- (and perhaps - * Haskell) sources, we sometimes need to conditionally compile bits - * depending on the language. CMINUSMINUS==1 in .cmm sources: - */ -#define CMINUSMINUS 1 - -#include "ghcconfig.h" - -/* ----------------------------------------------------------------------------- - Types - - The following synonyms for C-- types are declared here: - - I8, I16, I32, I64 MachRep-style names for convenience - - W_ is shorthand for the word type (== StgWord) - F_ shorthand for float (F_ == StgFloat == C's float) - D_ shorthand for double (D_ == StgDouble == C's double) - - CInt has the same size as an int in C on this platform - CLong has the same size as a long in C on this platform - CBool has the same size as a bool in C on this platform - - --------------------------------------------------------------------------- */ - -#define I8 bits8 -#define I16 bits16 -#define I32 bits32 -#define I64 bits64 -#define P_ gcptr - -#if SIZEOF_VOID_P == 4 -#define W_ bits32 -/* Maybe it's better to include MachDeps.h */ -#define TAG_BITS 2 -#elif SIZEOF_VOID_P == 8 -#define W_ bits64 -/* Maybe it's better to include MachDeps.h */ -#define TAG_BITS 3 -#else -#error Unknown word size -#endif - -/* - * The RTS must sometimes UNTAG a pointer before dereferencing it. - * See the wiki page Commentary/Rts/HaskellExecution/PointerTagging - */ -#define TAG_MASK ((1 << TAG_BITS) - 1) -#define UNTAG(p) (p & ~TAG_MASK) -#define GETTAG(p) (p & TAG_MASK) - -#if SIZEOF_INT == 4 -#define CInt bits32 -#elif SIZEOF_INT == 8 -#define CInt bits64 -#else -#error Unknown int size -#endif - -#if SIZEOF_LONG == 4 -#define CLong bits32 -#elif SIZEOF_LONG == 8 -#define CLong bits64 -#else -#error Unknown long size -#endif - -#define CBool bits8 - -#define F_ float32 -#define D_ float64 -#define L_ bits64 -#define V16_ bits128 -#define V32_ bits256 -#define V64_ bits512 - -#define SIZEOF_StgDouble 8 -#define SIZEOF_StgWord64 8 - -/* ----------------------------------------------------------------------------- - Misc useful stuff - -------------------------------------------------------------------------- */ - -#define ccall foreign "C" - -#define NULL (0::W_) - -#define STRING(name,str) \ - section "rodata" { \ - name : bits8[] str; \ - } \ - -#if defined(TABLES_NEXT_TO_CODE) -#define RET_LBL(f) f##_info -#else -#define RET_LBL(f) f##_ret -#endif - -#if defined(TABLES_NEXT_TO_CODE) -#define ENTRY_LBL(f) f##_info -#else -#define ENTRY_LBL(f) f##_entry -#endif - -/* ----------------------------------------------------------------------------- - Byte/word macros - - Everything in C-- is in byte offsets (well, most things). We use - some macros to allow us to express offsets in words and to try to - avoid byte/word confusion. - -------------------------------------------------------------------------- */ - -#define SIZEOF_W SIZEOF_VOID_P -#define W_MASK (SIZEOF_W-1) - -#if SIZEOF_W == 4 -#define W_SHIFT 2 -#elif SIZEOF_W == 8 -#define W_SHIFT 3 -#endif - -/* Converting quantities of words to bytes */ -#define WDS(n) ((n)*SIZEOF_W) - -/* - * Converting quantities of bytes to words - * NB. these work on *unsigned* values only - */ -#define BYTES_TO_WDS(n) ((n) / SIZEOF_W) -#define ROUNDUP_BYTES_TO_WDS(n) (((n) + SIZEOF_W - 1) / SIZEOF_W) - -/* TO_W_(n) converts n to W_ type from a smaller type */ -#if SIZEOF_W == 4 -#define TO_I64(x) %sx64(x) -#define TO_W_(x) %sx32(x) -#define HALF_W_(x) %lobits16(x) -#elif SIZEOF_W == 8 -#define TO_I64(x) (x) -#define TO_W_(x) %sx64(x) -#define HALF_W_(x) %lobits32(x) -#endif - -#if SIZEOF_INT == 4 && SIZEOF_W == 8 -#define W_TO_INT(x) %lobits32(x) -#elif SIZEOF_INT == SIZEOF_W -#define W_TO_INT(x) (x) -#endif - -#if SIZEOF_LONG == 4 && SIZEOF_W == 8 -#define W_TO_LONG(x) %lobits32(x) -#elif SIZEOF_LONG == SIZEOF_W -#define W_TO_LONG(x) (x) -#endif - -/* ----------------------------------------------------------------------------- - Atomic memory operations. - -------------------------------------------------------------------------- */ - -#if SIZEOF_W == 4 -#define cmpxchgW cmpxchg32 -#elif SIZEOF_W == 8 -#define cmpxchgW cmpxchg64 -#endif - -/* ----------------------------------------------------------------------------- - Heap/stack access, and adjusting the heap/stack pointers. - -------------------------------------------------------------------------- */ - -#define Sp(n) W_[Sp + WDS(n)] -#define Hp(n) W_[Hp + WDS(n)] - -#define Sp_adj(n) Sp = Sp + WDS(n) /* pronounced "spadge" */ -#define Hp_adj(n) Hp = Hp + WDS(n) - -/* ----------------------------------------------------------------------------- - Assertions and Debuggery - -------------------------------------------------------------------------- */ - -#if defined(DEBUG) -#define ASSERT(predicate) \ - if (predicate) { \ - /*null*/; \ - } else { \ - foreign "C" _assertFail(__FILE__, __LINE__) never returns; \ - } -#else -#define ASSERT(p) /* nothing */ -#endif - -#if defined(DEBUG) -#define DEBUG_ONLY(s) s -#else -#define DEBUG_ONLY(s) /* nothing */ -#endif - -/* - * The IF_DEBUG macro is useful for debug messages that depend on one - * of the RTS debug options. For example: - * - * IF_DEBUG(RtsFlags_DebugFlags_apply, - * foreign "C" fprintf(stderr, stg_ap_0_ret_str)); - * - * Note the syntax is slightly different to the C version of this macro. - */ -#if defined(DEBUG) -#define IF_DEBUG(c,s) if (RtsFlags_DebugFlags_##c(RtsFlags) != 0::CBool) { s; } -#else -#define IF_DEBUG(c,s) /* nothing */ -#endif - -/* ----------------------------------------------------------------------------- - Entering - - It isn't safe to "enter" every closure. Functions in particular - have no entry code as such; their entry point contains the code to - apply the function. - - ToDo: range should end in N_CLOSURE_TYPES-1, not N_CLOSURE_TYPES, - but switch doesn't allow us to use exprs there yet. - - If R1 points to a tagged object it points either to - * A constructor. - * A function with arity <= TAG_MASK. - In both cases the right thing to do is to return. - Note: it is rather lucky that we can use the tag bits to do this - for both objects. Maybe it points to a brittle design? - - Indirections can contain tagged pointers, so their tag is checked. - -------------------------------------------------------------------------- */ - -#if defined(PROFILING) - -// When profiling, we cannot shortcut ENTER() by checking the tag, -// because LDV profiling relies on entering closures to mark them as -// "used". - -#define LOAD_INFO(ret,x) \ - info = %INFO_PTR(UNTAG(x)); - -#define UNTAG_IF_PROF(x) UNTAG(x) - -#else - -#define LOAD_INFO(ret,x) \ - if (GETTAG(x) != 0) { \ - ret(x); \ - } \ - info = %INFO_PTR(x); - -#define UNTAG_IF_PROF(x) (x) /* already untagged */ - -#endif - -// We need two versions of ENTER(): -// - ENTER(x) takes the closure as an argument and uses return(), -// for use in civilized code where the stack is handled by GHC -// -// - ENTER_NOSTACK() where the closure is in R1, and returns are -// explicit jumps, for use when we are doing the stack management -// ourselves. - -#if defined(PROFILING) -// See Note [Evaluating functions with profiling] in rts/Apply.cmm -#define ENTER(x) jump stg_ap_0_fast(x); -#else -#define ENTER(x) ENTER_(return,x) -#endif - -#define ENTER_R1() ENTER_(RET_R1,R1) - -#define RET_R1(x) jump %ENTRY_CODE(Sp(0)) [R1] - -#define ENTER_(ret,x) \ - again: \ - W_ info; \ - LOAD_INFO(ret,x) \ - /* See Note [Heap memory barriers] in SMP.h */ \ - prim_read_barrier; \ - switch [INVALID_OBJECT .. N_CLOSURE_TYPES] \ - (TO_W_( %INFO_TYPE(%STD_INFO(info)) )) { \ - case \ - IND, \ - IND_STATIC: \ - { \ - x = StgInd_indirectee(x); \ - goto again; \ - } \ - case \ - FUN, \ - FUN_1_0, \ - FUN_0_1, \ - FUN_2_0, \ - FUN_1_1, \ - FUN_0_2, \ - FUN_STATIC, \ - BCO, \ - PAP: \ - { \ - ret(x); \ - } \ - default: \ - { \ - x = UNTAG_IF_PROF(x); \ - jump %ENTRY_CODE(info) (x); \ - } \ - } - -// The FUN cases almost never happen: a pointer to a non-static FUN -// should always be tagged. This unfortunately isn't true for the -// interpreter right now, which leaves untagged FUNs on the stack. - -/* ----------------------------------------------------------------------------- - Constants. - -------------------------------------------------------------------------- */ - -#include "rts/Constants.h" -#include "DerivedConstants.h" -#include "rts/storage/ClosureTypes.h" -#include "rts/storage/FunTypes.h" -#include "rts/OSThreads.h" - -/* - * Need MachRegs, because some of the RTS code is conditionally - * compiled based on REG_R1, REG_R2, etc. - */ -#include "stg/RtsMachRegs.h" - -#include "rts/prof/LDV.h" - -#undef BLOCK_SIZE -#undef MBLOCK_SIZE -#include "rts/storage/Block.h" /* For Bdescr() */ - - -#define MyCapability() (BaseReg - OFFSET_Capability_r) - -/* ------------------------------------------------------------------------- - Info tables - ------------------------------------------------------------------------- */ - -#if defined(PROFILING) -#define PROF_HDR_FIELDS(w_,hdr1,hdr2) \ - w_ hdr1, \ - w_ hdr2, -#else -#define PROF_HDR_FIELDS(w_,hdr1,hdr2) /* nothing */ -#endif - -/* ------------------------------------------------------------------------- - Allocation and garbage collection - ------------------------------------------------------------------------- */ - -/* - * ALLOC_PRIM is for allocating memory on the heap for a primitive - * object. It is used all over PrimOps.cmm. - * - * We make the simplifying assumption that the "admin" part of a - * primitive closure is just the header when calculating sizes for - * ticky-ticky. It's not clear whether eg. the size field of an array - * should be counted as "admin", or the various fields of a BCO. - */ -#define ALLOC_PRIM(bytes) \ - HP_CHK_GEN_TICKY(bytes); \ - TICK_ALLOC_PRIM(SIZEOF_StgHeader,bytes-SIZEOF_StgHeader,0); \ - CCCS_ALLOC(bytes); - -#define HEAP_CHECK(bytes,failure) \ - TICK_BUMP(HEAP_CHK_ctr); \ - Hp = Hp + (bytes); \ - if (Hp > HpLim) { HpAlloc = (bytes); failure; } \ - TICK_ALLOC_HEAP_NOCTR(bytes); - -#define ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,failure) \ - HEAP_CHECK(bytes,failure) \ - TICK_ALLOC_PRIM(SIZEOF_StgHeader,bytes-SIZEOF_StgHeader,0); \ - CCCS_ALLOC(bytes); - -#define ALLOC_PRIM_(bytes,fun) \ - ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,GC_PRIM(fun)); - -#define ALLOC_PRIM_P(bytes,fun,arg) \ - ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,GC_PRIM_P(fun,arg)); - -#define ALLOC_PRIM_N(bytes,fun,arg) \ - ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,GC_PRIM_N(fun,arg)); - -/* CCS_ALLOC wants the size in words, because ccs->mem_alloc is in words */ -#define CCCS_ALLOC(__alloc) CCS_ALLOC(BYTES_TO_WDS(__alloc), CCCS) - -#define HP_CHK_GEN_TICKY(bytes) \ - HP_CHK_GEN(bytes); \ - TICK_ALLOC_HEAP_NOCTR(bytes); - -#define HP_CHK_P(bytes, fun, arg) \ - HEAP_CHECK(bytes, GC_PRIM_P(fun,arg)) - -// TODO I'm not seeing where ALLOC_P_TICKY is used; can it be removed? -// -NSF March 2013 -#define ALLOC_P_TICKY(bytes, fun, arg) \ - HP_CHK_P(bytes); \ - TICK_ALLOC_HEAP_NOCTR(bytes); - -#define CHECK_GC() \ - (bdescr_link(CurrentNursery) == NULL || \ - generation_n_new_large_words(W_[g0]) >= TO_W_(CLong[large_alloc_lim])) - -// allocate() allocates from the nursery, so we check to see -// whether the nursery is nearly empty in any function that uses -// allocate() - this includes many of the primops. -// -// HACK alert: the __L__ stuff is here to coax the common-block -// eliminator into commoning up the call stg_gc_noregs() with the same -// code that gets generated by a STK_CHK_GEN() in the same proc. We -// also need an if (0) { goto __L__; } so that the __L__ label isn't -// optimised away by the control-flow optimiser prior to common-block -// elimination (it will be optimised away later). -// -// This saves some code in gmp-wrappers.cmm where we have lots of -// MAYBE_GC() in the same proc as STK_CHK_GEN(). -// -#define MAYBE_GC(retry) \ - if (CHECK_GC()) { \ - HpAlloc = 0; \ - goto __L__; \ - __L__: \ - call stg_gc_noregs(); \ - goto retry; \ - } \ - if (0) { goto __L__; } - -#define GC_PRIM(fun) \ - jump stg_gc_prim(fun); - -// Version of GC_PRIM for use in low-level Cmm. We can call -// stg_gc_prim, because it takes one argument and therefore has a -// platform-independent calling convention (Note [Syntax of .cmm -// files] in CmmParse.y). -#define GC_PRIM_LL(fun) \ - R1 = fun; \ - jump stg_gc_prim [R1]; - -// We pass the fun as the second argument, because the arg is -// usually already in the first argument position (R1), so this -// avoids moving it to a different register / stack slot. -#define GC_PRIM_N(fun,arg) \ - jump stg_gc_prim_n(arg,fun); - -#define GC_PRIM_P(fun,arg) \ - jump stg_gc_prim_p(arg,fun); - -#define GC_PRIM_P_LL(fun,arg) \ - R1 = arg; \ - R2 = fun; \ - jump stg_gc_prim_p_ll [R1,R2]; - -#define GC_PRIM_PP(fun,arg1,arg2) \ - jump stg_gc_prim_pp(arg1,arg2,fun); - -#define MAYBE_GC_(fun) \ - if (CHECK_GC()) { \ - HpAlloc = 0; \ - GC_PRIM(fun) \ - } - -#define MAYBE_GC_N(fun,arg) \ - if (CHECK_GC()) { \ - HpAlloc = 0; \ - GC_PRIM_N(fun,arg) \ - } - -#define MAYBE_GC_P(fun,arg) \ - if (CHECK_GC()) { \ - HpAlloc = 0; \ - GC_PRIM_P(fun,arg) \ - } - -#define MAYBE_GC_PP(fun,arg1,arg2) \ - if (CHECK_GC()) { \ - HpAlloc = 0; \ - GC_PRIM_PP(fun,arg1,arg2) \ - } - -#define STK_CHK_LL(n, fun) \ - TICK_BUMP(STK_CHK_ctr); \ - if (Sp - (n) < SpLim) { \ - GC_PRIM_LL(fun) \ - } - -#define STK_CHK_P_LL(n, fun, arg) \ - TICK_BUMP(STK_CHK_ctr); \ - if (Sp - (n) < SpLim) { \ - GC_PRIM_P_LL(fun,arg) \ - } - -#define STK_CHK_PP(n, fun, arg1, arg2) \ - TICK_BUMP(STK_CHK_ctr); \ - if (Sp - (n) < SpLim) { \ - GC_PRIM_PP(fun,arg1,arg2) \ - } - -#define STK_CHK_ENTER(n, closure) \ - TICK_BUMP(STK_CHK_ctr); \ - if (Sp - (n) < SpLim) { \ - jump __stg_gc_enter_1(closure); \ - } - -// A funky heap check used by AutoApply.cmm - -#define HP_CHK_NP_ASSIGN_SP0(size,f) \ - HEAP_CHECK(size, Sp(0) = f; jump __stg_gc_enter_1 [R1];) - -/* ----------------------------------------------------------------------------- - Closure headers - -------------------------------------------------------------------------- */ - -/* - * This is really ugly, since we don't do the rest of StgHeader this - * way. The problem is that values from DerivedConstants.h cannot be - * dependent on the way (SMP, PROF etc.). For SIZEOF_StgHeader we get - * the value from GHC, but it seems like too much trouble to do that - * for StgThunkHeader. - */ -#define SIZEOF_StgThunkHeader SIZEOF_StgHeader+SIZEOF_StgSMPThunkHeader - -#define StgThunk_payload(__ptr__,__ix__) \ - W_[__ptr__+SIZEOF_StgThunkHeader+ WDS(__ix__)] - -/* ----------------------------------------------------------------------------- - Closures - -------------------------------------------------------------------------- */ - -/* The offset of the payload of an array */ -#define BYTE_ARR_CTS(arr) ((arr) + SIZEOF_StgArrBytes) - -/* The number of words allocated in an array payload */ -#define BYTE_ARR_WDS(arr) ROUNDUP_BYTES_TO_WDS(StgArrBytes_bytes(arr)) - -/* Getting/setting the info pointer of a closure */ -#define SET_INFO(p,info) StgHeader_info(p) = info -#define GET_INFO(p) StgHeader_info(p) - -/* Determine the size of an ordinary closure from its info table */ -#define sizeW_fromITBL(itbl) \ - SIZEOF_StgHeader + WDS(%INFO_PTRS(itbl)) + WDS(%INFO_NPTRS(itbl)) - -/* NB. duplicated from InfoTables.h! */ -#define BITMAP_SIZE(bitmap) ((bitmap) & BITMAP_SIZE_MASK) -#define BITMAP_BITS(bitmap) ((bitmap) >> BITMAP_BITS_SHIFT) - -/* Debugging macros */ -#define LOOKS_LIKE_INFO_PTR(p) \ - ((p) != NULL && \ - LOOKS_LIKE_INFO_PTR_NOT_NULL(p)) - -#define LOOKS_LIKE_INFO_PTR_NOT_NULL(p) \ - ( (TO_W_(%INFO_TYPE(%STD_INFO(p))) != INVALID_OBJECT) && \ - (TO_W_(%INFO_TYPE(%STD_INFO(p))) < N_CLOSURE_TYPES)) - -#define LOOKS_LIKE_CLOSURE_PTR(p) (LOOKS_LIKE_INFO_PTR(GET_INFO(UNTAG(p)))) - -/* - * The layout of the StgFunInfoExtra part of an info table changes - * depending on TABLES_NEXT_TO_CODE. So we define field access - * macros which use the appropriate version here: - */ -#if defined(TABLES_NEXT_TO_CODE) -/* - * when TABLES_NEXT_TO_CODE, slow_apply is stored as an offset - * instead of the normal pointer. - */ - -#define StgFunInfoExtra_slow_apply(fun_info) \ - (TO_W_(StgFunInfoExtraRev_slow_apply_offset(fun_info)) \ - + (fun_info) + SIZEOF_StgFunInfoExtraRev + SIZEOF_StgInfoTable) - -#define StgFunInfoExtra_fun_type(i) StgFunInfoExtraRev_fun_type(i) -#define StgFunInfoExtra_arity(i) StgFunInfoExtraRev_arity(i) -#define StgFunInfoExtra_bitmap(i) StgFunInfoExtraRev_bitmap(i) -#else -#define StgFunInfoExtra_slow_apply(i) StgFunInfoExtraFwd_slow_apply(i) -#define StgFunInfoExtra_fun_type(i) StgFunInfoExtraFwd_fun_type(i) -#define StgFunInfoExtra_arity(i) StgFunInfoExtraFwd_arity(i) -#define StgFunInfoExtra_bitmap(i) StgFunInfoExtraFwd_bitmap(i) -#endif - -#define mutArrCardMask ((1 << MUT_ARR_PTRS_CARD_BITS) - 1) -#define mutArrPtrCardDown(i) ((i) >> MUT_ARR_PTRS_CARD_BITS) -#define mutArrPtrCardUp(i) (((i) + mutArrCardMask) >> MUT_ARR_PTRS_CARD_BITS) -#define mutArrPtrsCardWords(n) ROUNDUP_BYTES_TO_WDS(mutArrPtrCardUp(n)) - -#if defined(PROFILING) || (!defined(THREADED_RTS) && defined(DEBUG)) -#define OVERWRITING_CLOSURE_SIZE(c, size) foreign "C" overwritingClosureSize(c "ptr", size) -#define OVERWRITING_CLOSURE(c) foreign "C" overwritingClosure(c "ptr") -#define OVERWRITING_CLOSURE_OFS(c,n) foreign "C" overwritingClosureOfs(c "ptr", n) -#else -#define OVERWRITING_CLOSURE_SIZE(c, size) /* nothing */ -#define OVERWRITING_CLOSURE(c) /* nothing */ -#define OVERWRITING_CLOSURE_OFS(c,n) /* nothing */ -#endif - -// Memory barriers. -// For discussion of how these are used to fence heap object -// accesses see Note [Heap memory barriers] in SMP.h. -#if defined(THREADED_RTS) -#define prim_read_barrier prim %read_barrier() -#else -#define prim_read_barrier /* nothing */ -#endif -#if defined(THREADED_RTS) -#define prim_write_barrier prim %write_barrier() -#else -#define prim_write_barrier /* nothing */ -#endif - -/* ----------------------------------------------------------------------------- - Ticky macros - -------------------------------------------------------------------------- */ - -#if defined(TICKY_TICKY) -#define TICK_BUMP_BY(ctr,n) CLong[ctr] = CLong[ctr] + n -#else -#define TICK_BUMP_BY(ctr,n) /* nothing */ -#endif - -#define TICK_BUMP(ctr) TICK_BUMP_BY(ctr,1) - -#define TICK_ENT_DYN_IND() TICK_BUMP(ENT_DYN_IND_ctr) -#define TICK_ENT_DYN_THK() TICK_BUMP(ENT_DYN_THK_ctr) -#define TICK_ENT_VIA_NODE() TICK_BUMP(ENT_VIA_NODE_ctr) -#define TICK_ENT_STATIC_IND() TICK_BUMP(ENT_STATIC_IND_ctr) -#define TICK_ENT_PERM_IND() TICK_BUMP(ENT_PERM_IND_ctr) -#define TICK_ENT_PAP() TICK_BUMP(ENT_PAP_ctr) -#define TICK_ENT_AP() TICK_BUMP(ENT_AP_ctr) -#define TICK_ENT_AP_STACK() TICK_BUMP(ENT_AP_STACK_ctr) -#define TICK_ENT_BH() TICK_BUMP(ENT_BH_ctr) -#define TICK_ENT_LNE() TICK_BUMP(ENT_LNE_ctr) -#define TICK_UNKNOWN_CALL() TICK_BUMP(UNKNOWN_CALL_ctr) -#define TICK_UPDF_PUSHED() TICK_BUMP(UPDF_PUSHED_ctr) -#define TICK_CATCHF_PUSHED() TICK_BUMP(CATCHF_PUSHED_ctr) -#define TICK_UPDF_OMITTED() TICK_BUMP(UPDF_OMITTED_ctr) -#define TICK_UPD_NEW_IND() TICK_BUMP(UPD_NEW_IND_ctr) -#define TICK_UPD_NEW_PERM_IND() TICK_BUMP(UPD_NEW_PERM_IND_ctr) -#define TICK_UPD_OLD_IND() TICK_BUMP(UPD_OLD_IND_ctr) -#define TICK_UPD_OLD_PERM_IND() TICK_BUMP(UPD_OLD_PERM_IND_ctr) - -#define TICK_SLOW_CALL_FUN_TOO_FEW() TICK_BUMP(SLOW_CALL_FUN_TOO_FEW_ctr) -#define TICK_SLOW_CALL_FUN_CORRECT() TICK_BUMP(SLOW_CALL_FUN_CORRECT_ctr) -#define TICK_SLOW_CALL_FUN_TOO_MANY() TICK_BUMP(SLOW_CALL_FUN_TOO_MANY_ctr) -#define TICK_SLOW_CALL_PAP_TOO_FEW() TICK_BUMP(SLOW_CALL_PAP_TOO_FEW_ctr) -#define TICK_SLOW_CALL_PAP_CORRECT() TICK_BUMP(SLOW_CALL_PAP_CORRECT_ctr) -#define TICK_SLOW_CALL_PAP_TOO_MANY() TICK_BUMP(SLOW_CALL_PAP_TOO_MANY_ctr) - -#define TICK_SLOW_CALL_fast_v16() TICK_BUMP(SLOW_CALL_fast_v16_ctr) -#define TICK_SLOW_CALL_fast_v() TICK_BUMP(SLOW_CALL_fast_v_ctr) -#define TICK_SLOW_CALL_fast_p() TICK_BUMP(SLOW_CALL_fast_p_ctr) -#define TICK_SLOW_CALL_fast_pv() TICK_BUMP(SLOW_CALL_fast_pv_ctr) -#define TICK_SLOW_CALL_fast_pp() TICK_BUMP(SLOW_CALL_fast_pp_ctr) -#define TICK_SLOW_CALL_fast_ppv() TICK_BUMP(SLOW_CALL_fast_ppv_ctr) -#define TICK_SLOW_CALL_fast_ppp() TICK_BUMP(SLOW_CALL_fast_ppp_ctr) -#define TICK_SLOW_CALL_fast_pppv() TICK_BUMP(SLOW_CALL_fast_pppv_ctr) -#define TICK_SLOW_CALL_fast_pppp() TICK_BUMP(SLOW_CALL_fast_pppp_ctr) -#define TICK_SLOW_CALL_fast_ppppp() TICK_BUMP(SLOW_CALL_fast_ppppp_ctr) -#define TICK_SLOW_CALL_fast_pppppp() TICK_BUMP(SLOW_CALL_fast_pppppp_ctr) -#define TICK_VERY_SLOW_CALL() TICK_BUMP(VERY_SLOW_CALL_ctr) - -/* NOTE: TICK_HISTO_BY and TICK_HISTO - currently have no effect. - The old code for it didn't typecheck and I - just commented it out to get ticky to work. - - krc 1/2007 */ - -#define TICK_HISTO_BY(histo,n,i) /* nothing */ - -#define TICK_HISTO(histo,n) TICK_HISTO_BY(histo,n,1) - -/* An unboxed tuple with n components. */ -#define TICK_RET_UNBOXED_TUP(n) \ - TICK_BUMP(RET_UNBOXED_TUP_ctr++); \ - TICK_HISTO(RET_UNBOXED_TUP,n) - -/* - * A slow call with n arguments. In the unevald case, this call has - * already been counted once, so don't count it again. - */ -#define TICK_SLOW_CALL(n) \ - TICK_BUMP(SLOW_CALL_ctr); \ - TICK_HISTO(SLOW_CALL,n) - -/* - * This slow call was found to be to an unevaluated function; undo the - * ticks we did in TICK_SLOW_CALL. - */ -#define TICK_SLOW_CALL_UNEVALD(n) \ - TICK_BUMP(SLOW_CALL_UNEVALD_ctr); \ - TICK_BUMP_BY(SLOW_CALL_ctr,-1); \ - TICK_HISTO_BY(SLOW_CALL,n,-1); - -/* Updating a closure with a new CON */ -#define TICK_UPD_CON_IN_NEW(n) \ - TICK_BUMP(UPD_CON_IN_NEW_ctr); \ - TICK_HISTO(UPD_CON_IN_NEW,n) - -#define TICK_ALLOC_HEAP_NOCTR(bytes) \ - TICK_BUMP(ALLOC_RTS_ctr); \ - TICK_BUMP_BY(ALLOC_RTS_tot,bytes) - -/* ----------------------------------------------------------------------------- - Saving and restoring STG registers - - STG registers must be saved around a C call, just in case the STG - register is mapped to a caller-saves machine register. Normally we - don't need to worry about this the code generator has already - loaded any live STG registers into variables for us, but in - hand-written low-level Cmm code where we don't know which registers - are live, we might have to save them all. - -------------------------------------------------------------------------- */ - -#define SAVE_STGREGS \ - W_ r1, r2, r3, r4, r5, r6, r7, r8; \ - F_ f1, f2, f3, f4, f5, f6; \ - D_ d1, d2, d3, d4, d5, d6; \ - L_ l1; \ - \ - r1 = R1; \ - r2 = R2; \ - r3 = R3; \ - r4 = R4; \ - r5 = R5; \ - r6 = R6; \ - r7 = R7; \ - r8 = R8; \ - \ - f1 = F1; \ - f2 = F2; \ - f3 = F3; \ - f4 = F4; \ - f5 = F5; \ - f6 = F6; \ - \ - d1 = D1; \ - d2 = D2; \ - d3 = D3; \ - d4 = D4; \ - d5 = D5; \ - d6 = D6; \ - \ - l1 = L1; - - -#define RESTORE_STGREGS \ - R1 = r1; \ - R2 = r2; \ - R3 = r3; \ - R4 = r4; \ - R5 = r5; \ - R6 = r6; \ - R7 = r7; \ - R8 = r8; \ - \ - F1 = f1; \ - F2 = f2; \ - F3 = f3; \ - F4 = f4; \ - F5 = f5; \ - F6 = f6; \ - \ - D1 = d1; \ - D2 = d2; \ - D3 = d3; \ - D4 = d4; \ - D5 = d5; \ - D6 = d6; \ - \ - L1 = l1; - -/* ----------------------------------------------------------------------------- - Misc junk - -------------------------------------------------------------------------- */ - -#define NO_TREC stg_NO_TREC_closure -#define END_TSO_QUEUE stg_END_TSO_QUEUE_closure -#define STM_AWOKEN stg_STM_AWOKEN_closure - -#define recordMutableCap(p, gen) \ - W_ __bd; \ - W_ mut_list; \ - mut_list = Capability_mut_lists(MyCapability()) + WDS(gen); \ - __bd = W_[mut_list]; \ - if (bdescr_free(__bd) >= bdescr_start(__bd) + BLOCK_SIZE) { \ - W_ __new_bd; \ - ("ptr" __new_bd) = foreign "C" allocBlock_lock(); \ - bdescr_link(__new_bd) = __bd; \ - __bd = __new_bd; \ - W_[mut_list] = __bd; \ - } \ - W_ free; \ - free = bdescr_free(__bd); \ - W_[free] = p; \ - bdescr_free(__bd) = free + WDS(1); - -#define recordMutable(p) \ - P_ __p; \ - W_ __bd; \ - W_ __gen; \ - __p = p; \ - __bd = Bdescr(__p); \ - __gen = TO_W_(bdescr_gen_no(__bd)); \ - if (__gen > 0) { recordMutableCap(__p, __gen); } - -/* ----------------------------------------------------------------------------- - Arrays - -------------------------------------------------------------------------- */ - -/* Complete function body for the clone family of (mutable) array ops. - Defined as a macro to avoid function call overhead or code - duplication. */ -#define cloneArray(info, src, offset, n) \ - W_ words, size; \ - gcptr dst, dst_p, src_p; \ - \ - again: MAYBE_GC(again); \ - \ - size = n + mutArrPtrsCardWords(n); \ - words = BYTES_TO_WDS(SIZEOF_StgMutArrPtrs) + size; \ - ("ptr" dst) = ccall allocate(MyCapability() "ptr", words); \ - TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(size), 0); \ - \ - SET_HDR(dst, info, CCCS); \ - StgMutArrPtrs_ptrs(dst) = n; \ - StgMutArrPtrs_size(dst) = size; \ - \ - dst_p = dst + SIZEOF_StgMutArrPtrs; \ - src_p = src + SIZEOF_StgMutArrPtrs + WDS(offset); \ - prim %memcpy(dst_p, src_p, n * SIZEOF_W, SIZEOF_W); \ - \ - return (dst); - -#define copyArray(src, src_off, dst, dst_off, n) \ - W_ dst_elems_p, dst_p, src_p, dst_cards_p, bytes; \ - \ - if ((n) != 0) { \ - SET_HDR(dst, stg_MUT_ARR_PTRS_DIRTY_info, CCCS); \ - \ - dst_elems_p = (dst) + SIZEOF_StgMutArrPtrs; \ - dst_p = dst_elems_p + WDS(dst_off); \ - src_p = (src) + SIZEOF_StgMutArrPtrs + WDS(src_off); \ - bytes = WDS(n); \ - \ - prim %memcpy(dst_p, src_p, bytes, SIZEOF_W); \ - \ - dst_cards_p = dst_elems_p + WDS(StgMutArrPtrs_ptrs(dst)); \ - setCards(dst_cards_p, dst_off, n); \ - } \ - \ - return (); - -#define copyMutableArray(src, src_off, dst, dst_off, n) \ - W_ dst_elems_p, dst_p, src_p, dst_cards_p, bytes; \ - \ - if ((n) != 0) { \ - SET_HDR(dst, stg_MUT_ARR_PTRS_DIRTY_info, CCCS); \ - \ - dst_elems_p = (dst) + SIZEOF_StgMutArrPtrs; \ - dst_p = dst_elems_p + WDS(dst_off); \ - src_p = (src) + SIZEOF_StgMutArrPtrs + WDS(src_off); \ - bytes = WDS(n); \ - \ - if ((src) == (dst)) { \ - prim %memmove(dst_p, src_p, bytes, SIZEOF_W); \ - } else { \ - prim %memcpy(dst_p, src_p, bytes, SIZEOF_W); \ - } \ - \ - dst_cards_p = dst_elems_p + WDS(StgMutArrPtrs_ptrs(dst)); \ - setCards(dst_cards_p, dst_off, n); \ - } \ - \ - return (); - -/* - * Set the cards in the cards table pointed to by dst_cards_p for an - * update to n elements, starting at element dst_off. - */ -#define setCards(dst_cards_p, dst_off, n) \ - W_ __start_card, __end_card, __cards; \ - __start_card = mutArrPtrCardDown(dst_off); \ - __end_card = mutArrPtrCardDown((dst_off) + (n) - 1); \ - __cards = __end_card - __start_card + 1; \ - prim %memset((dst_cards_p) + __start_card, 1, __cards, 1); - -/* Complete function body for the clone family of small (mutable) - array ops. Defined as a macro to avoid function call overhead or - code duplication. */ -#define cloneSmallArray(info, src, offset, n) \ - W_ words, size; \ - gcptr dst, dst_p, src_p; \ - \ - again: MAYBE_GC(again); \ - \ - words = BYTES_TO_WDS(SIZEOF_StgSmallMutArrPtrs) + n; \ - ("ptr" dst) = ccall allocate(MyCapability() "ptr", words); \ - TICK_ALLOC_PRIM(SIZEOF_StgSmallMutArrPtrs, WDS(n), 0); \ - \ - SET_HDR(dst, info, CCCS); \ - StgSmallMutArrPtrs_ptrs(dst) = n; \ - \ - dst_p = dst + SIZEOF_StgSmallMutArrPtrs; \ - src_p = src + SIZEOF_StgSmallMutArrPtrs + WDS(offset); \ - prim %memcpy(dst_p, src_p, n * SIZEOF_W, SIZEOF_W); \ - \ - return (dst); diff --git a/includes/HsFFI.h b/includes/HsFFI.h deleted file mode 100644 --- a/includes/HsFFI.h +++ /dev/null @@ -1,141 +0,0 @@ -/* ----------------------------------------------------------------------------- - * - * (c) The GHC Team, 2000 - * - * A mapping for Haskell types to C types, including the corresponding bounds. - * Intended to be used in conjuction with the FFI. - * - * WARNING: Keep this file and StgTypes.h in synch! - * - * ---------------------------------------------------------------------------*/ - -#pragma once - -#if defined(__cplusplus) -extern "C" { -#endif - -/* get types from GHC's runtime system */ -#include "ghcconfig.h" -#include "stg/Types.h" - -/* get limits for floating point types */ -#include - -typedef StgChar HsChar; -typedef StgInt HsInt; -typedef StgInt8 HsInt8; -typedef StgInt16 HsInt16; -typedef StgInt32 HsInt32; -typedef StgInt64 HsInt64; -typedef StgWord HsWord; -typedef StgWord8 HsWord8; -typedef StgWord16 HsWord16; -typedef StgWord32 HsWord32; -typedef StgWord64 HsWord64; -typedef StgFloat HsFloat; -typedef StgDouble HsDouble; -typedef StgInt HsBool; -typedef void* HsPtr; /* this should better match StgAddr */ -typedef void (*HsFunPtr)(void); /* this should better match StgAddr */ -typedef void* HsStablePtr; - -/* this should correspond to the type of StgChar in StgTypes.h */ -#define HS_CHAR_MIN 0 -#define HS_CHAR_MAX 0x10FFFF - -/* is it true or not? */ -#define HS_BOOL_FALSE 0 -#define HS_BOOL_TRUE 1 - -#define HS_BOOL_MIN HS_BOOL_FALSE -#define HS_BOOL_MAX HS_BOOL_TRUE - - -#define HS_INT_MIN STG_INT_MIN -#define HS_INT_MAX STG_INT_MAX -#define HS_WORD_MAX STG_WORD_MAX - -#define HS_INT8_MIN STG_INT8_MIN -#define HS_INT8_MAX STG_INT8_MAX -#define HS_INT16_MIN STG_INT16_MIN -#define HS_INT16_MAX STG_INT16_MAX -#define HS_INT32_MIN STG_INT32_MIN -#define HS_INT32_MAX STG_INT32_MAX -#define HS_INT64_MIN STG_INT64_MIN -#define HS_INT64_MAX STG_INT64_MAX -#define HS_WORD8_MAX STG_WORD8_MAX -#define HS_WORD16_MAX STG_WORD16_MAX -#define HS_WORD32_MAX STG_WORD32_MAX -#define HS_WORD64_MAX STG_WORD64_MAX - -#define HS_FLOAT_RADIX FLT_RADIX -#define HS_FLOAT_ROUNDS FLT_ROUNDS -#define HS_FLOAT_EPSILON FLT_EPSILON -#define HS_FLOAT_DIG FLT_DIG -#define HS_FLOAT_MANT_DIG FLT_MANT_DIG -#define HS_FLOAT_MIN FLT_MIN -#define HS_FLOAT_MIN_EXP FLT_MIN_EXP -#define HS_FLOAT_MIN_10_EXP FLT_MIN_10_EXP -#define HS_FLOAT_MAX FLT_MAX -#define HS_FLOAT_MAX_EXP FLT_MAX_EXP -#define HS_FLOAT_MAX_10_EXP FLT_MAX_10_EXP - -#define HS_DOUBLE_RADIX DBL_RADIX -#define HS_DOUBLE_ROUNDS DBL_ROUNDS -#define HS_DOUBLE_EPSILON DBL_EPSILON -#define HS_DOUBLE_DIG DBL_DIG -#define HS_DOUBLE_MANT_DIG DBL_MANT_DIG -#define HS_DOUBLE_MIN DBL_MIN -#define HS_DOUBLE_MIN_EXP DBL_MIN_EXP -#define HS_DOUBLE_MIN_10_EXP DBL_MIN_10_EXP -#define HS_DOUBLE_MAX DBL_MAX -#define HS_DOUBLE_MAX_EXP DBL_MAX_EXP -#define HS_DOUBLE_MAX_10_EXP DBL_MAX_10_EXP - -extern void hs_init (int *argc, char **argv[]); -extern void hs_exit (void); -extern void hs_exit_nowait(void); -extern void hs_set_argv (int argc, char *argv[]); -extern void hs_thread_done (void); - -extern void hs_perform_gc (void); - -// Lock the stable pointer table. The table must be unlocked -// again before calling any Haskell functions, even if those -// functions do not manipulate stable pointers. The Haskell -// garbage collector will not be able to run until this lock -// is released! It is also forbidden to call hs_free_fun_ptr -// or any stable pointer-related FFI functions other than -// hs_free_stable_ptr_unsafe while the table is locked. -extern void hs_lock_stable_ptr_table (void); - -// A deprecated synonym. -extern void hs_lock_stable_tables (void); - -// Unlock the stable pointer table. -extern void hs_unlock_stable_ptr_table (void); - -// A deprecated synonym. -extern void hs_unlock_stable_tables (void); - -// Free a stable pointer assuming that the stable pointer -// table is already locked. -extern void hs_free_stable_ptr_unsafe (HsStablePtr sp); - -extern void hs_free_stable_ptr (HsStablePtr sp); -extern void hs_free_fun_ptr (HsFunPtr fp); - -extern StgPtr hs_spt_lookup(StgWord64 key1, StgWord64 key2); -extern int hs_spt_keys(StgPtr keys[], int szKeys); -extern int hs_spt_key_count (void); - -extern void hs_try_putmvar (int capability, HsStablePtr sp); - -/* -------------------------------------------------------------------------- */ - - - -#if defined(__cplusplus) -} -#endif diff --git a/includes/Rts.h b/includes/Rts.h deleted file mode 100644 --- a/includes/Rts.h +++ /dev/null @@ -1,311 +0,0 @@ -/* ----------------------------------------------------------------------------- - * - * (c) The GHC Team, 1998-2009 - * - * RTS external APIs. This file declares everything that the GHC RTS - * exposes externally. - * - * To understand the structure of the RTS headers, see the wiki: - * http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes - * - * ---------------------------------------------------------------------------*/ - -#pragma once - -#if defined(__cplusplus) -extern "C" { -#endif - -/* We include windows.h very early, as on Win64 the CONTEXT type has - fields "R8", "R9" and "R10", which goes bad if we've already - #define'd those names for our own purposes (in stg/Regs.h) */ -#if defined(HAVE_WINDOWS_H) -#include -#endif - -#if !defined(IN_STG_CODE) -#define IN_STG_CODE 0 -#endif -#include "Stg.h" - -#include "HsFFI.h" -#include "RtsAPI.h" - -// Turn off inlining when debugging - it obfuscates things -#if defined(DEBUG) -# undef STATIC_INLINE -# define STATIC_INLINE static -#endif - -#include "rts/Types.h" -#include "rts/Time.h" - -#if __GNUC__ >= 3 -#define ATTRIBUTE_ALIGNED(n) __attribute__((aligned(n))) -#else -#define ATTRIBUTE_ALIGNED(n) /*nothing*/ -#endif - -// Symbols that are extern, but private to the RTS, are declared -// with visibility "hidden" to hide them outside the RTS shared -// library. -#if defined(HAS_VISIBILITY_HIDDEN) -#define RTS_PRIVATE GNUC3_ATTRIBUTE(visibility("hidden")) -#else -#define RTS_PRIVATE /* disabled: RTS_PRIVATE */ -#endif - -#if __GNUC__ >= 4 -#define RTS_UNLIKELY(p) __builtin_expect((p),0) -#else -#define RTS_UNLIKELY(p) p -#endif - -/* __builtin_unreachable is supported since GNU C 4.5 */ -#if __GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 5) -#define RTS_UNREACHABLE __builtin_unreachable() -#else -#define RTS_UNREACHABLE abort() -#endif - -/* Fix for mingw stat problem (done here so it's early enough) */ -#if defined(mingw32_HOST_OS) -#define __MSVCRT__ 1 -#endif - -/* Needed to get the macro version of errno on some OSs, and also to - get prototypes for the _r versions of C library functions. */ -#if !defined(_REENTRANT) -#define _REENTRANT 1 -#endif - -/* - * We often want to know the size of something in units of an - * StgWord... (rounded up, of course!) - */ -#define ROUNDUP_BYTES_TO_WDS(n) (((n) + sizeof(W_) - 1) / sizeof(W_)) - -#define sizeofW(t) ROUNDUP_BYTES_TO_WDS(sizeof(t)) - -/* ----------------------------------------------------------------------------- - Assertions and Debuggery - - CHECK(p) evaluates p and terminates with an error if p is false - ASSERT(p) like CHECK(p) if DEBUG is on, otherwise a no-op - -------------------------------------------------------------------------- */ - -void _assertFail(const char *filename, unsigned int linenum) - GNUC3_ATTRIBUTE(__noreturn__); - -#define CHECK(predicate) \ - if (predicate) \ - /*null*/; \ - else \ - _assertFail(__FILE__, __LINE__) - -#define CHECKM(predicate, msg, ...) \ - if (predicate) \ - /*null*/; \ - else \ - barf(msg, ##__VA_ARGS__) - -#if !defined(DEBUG) -#define ASSERT(predicate) /* nothing */ -#define ASSERTM(predicate,msg,...) /* nothing */ -#else -#define ASSERT(predicate) CHECK(predicate) -#define ASSERTM(predicate,msg,...) CHECKM(predicate,msg,##__VA_ARGS__) -#endif /* DEBUG */ - -/* - * Use this on the RHS of macros which expand to nothing - * to make sure that the macro can be used in a context which - * demands a non-empty statement. - */ - -#define doNothing() do { } while (0) - -#if defined(DEBUG) -#define USED_IF_DEBUG -#define USED_IF_NOT_DEBUG STG_UNUSED -#else -#define USED_IF_DEBUG STG_UNUSED -#define USED_IF_NOT_DEBUG -#endif - -#if defined(THREADED_RTS) -#define USED_IF_THREADS -#define USED_IF_NOT_THREADS STG_UNUSED -#else -#define USED_IF_THREADS STG_UNUSED -#define USED_IF_NOT_THREADS -#endif - -#define FMT_SizeT "zu" -#define FMT_HexSizeT "zx" - -/* ----------------------------------------------------------------------------- - Include everything STG-ish - -------------------------------------------------------------------------- */ - -/* System headers: stdlib.h is needed so that we can use NULL. It must - * come after MachRegs.h, because stdlib.h might define some inline - * functions which may only be defined after register variables have - * been declared. - */ -#include - -#include "rts/Config.h" - -/* Global constraints */ -#include "rts/Constants.h" - -/* Profiling information */ -#include "rts/prof/CCS.h" -#include "rts/prof/LDV.h" - -/* Parallel information */ -#include "rts/OSThreads.h" -#include "rts/SpinLock.h" - -#include "rts/Messages.h" -#include "rts/Threads.h" - -/* Storage format definitions */ -#include "rts/storage/FunTypes.h" -#include "rts/storage/InfoTables.h" -#include "rts/storage/Closures.h" -#include "rts/storage/Heap.h" -#include "rts/storage/ClosureTypes.h" -#include "rts/storage/TSO.h" -#include "stg/MiscClosures.h" /* InfoTables, closures etc. defined in the RTS */ -#include "rts/storage/Block.h" -#include "rts/storage/ClosureMacros.h" -#include "rts/storage/MBlock.h" -#include "rts/storage/GC.h" - -/* Other RTS external APIs */ -#include "rts/Parallel.h" -#include "rts/Signals.h" -#include "rts/BlockSignals.h" -#include "rts/Hpc.h" -#include "rts/Flags.h" -#include "rts/Adjustor.h" -#include "rts/FileLock.h" -#include "rts/GetTime.h" -#include "rts/Globals.h" -#include "rts/IOManager.h" -#include "rts/Linker.h" -#include "rts/Ticky.h" -#include "rts/Timer.h" -#include "rts/StablePtr.h" -#include "rts/StableName.h" -#include "rts/TTY.h" -#include "rts/Utils.h" -#include "rts/PrimFloat.h" -#include "rts/Main.h" -#include "rts/Profiling.h" -#include "rts/StaticPtrTable.h" -#include "rts/Libdw.h" -#include "rts/LibdwPool.h" - -/* Misc stuff without a home */ -DLL_IMPORT_RTS extern char **prog_argv; /* so we can get at these from Haskell */ -DLL_IMPORT_RTS extern int prog_argc; -DLL_IMPORT_RTS extern char *prog_name; - -void reportStackOverflow(StgTSO* tso); -void reportHeapOverflow(void); - -void stg_exit(int n) GNU_ATTRIBUTE(__noreturn__); - -#if !defined(mingw32_HOST_OS) -int stg_sig_install (int, int, void *); -#endif - -/* ----------------------------------------------------------------------------- - Ways - -------------------------------------------------------------------------- */ - -// Returns non-zero if the RTS is a profiling version -int rts_isProfiled(void); - -// Returns non-zero if the RTS is a dynamically-linked version -int rts_isDynamic(void); - -/* ----------------------------------------------------------------------------- - RTS Exit codes - -------------------------------------------------------------------------- */ - -/* 255 is allegedly used by dynamic linkers to report linking failure */ -#define EXIT_INTERNAL_ERROR 254 -#define EXIT_DEADLOCK 253 -#define EXIT_INTERRUPTED 252 -#define EXIT_HEAPOVERFLOW 251 -#define EXIT_KILLED 250 - -/* ----------------------------------------------------------------------------- - Miscellaneous garbage - -------------------------------------------------------------------------- */ - -#if defined(DEBUG) -#define TICK_VAR(arity) \ - extern StgInt SLOW_CALLS_##arity; \ - extern StgInt RIGHT_ARITY_##arity; \ - extern StgInt TAGGED_PTR_##arity; - -extern StgInt TOTAL_CALLS; - -TICK_VAR(1) -TICK_VAR(2) -#endif - -/* ----------------------------------------------------------------------------- - Assertions and Debuggery - -------------------------------------------------------------------------- */ - -#define IF_RTSFLAGS(c,s) if (RtsFlags.c) { s; } doNothing() - -#if defined(DEBUG) -#if IN_STG_CODE -#define IF_DEBUG(c,s) if (RtsFlags[0].DebugFlags.c) { s; } doNothing() -#else -#define IF_DEBUG(c,s) if (RtsFlags.DebugFlags.c) { s; } doNothing() -#endif -#else -#define IF_DEBUG(c,s) doNothing() -#endif - -#if defined(DEBUG) -#define DEBUG_ONLY(s) s -#else -#define DEBUG_ONLY(s) doNothing() -#endif - -#if defined(DEBUG) -#define DEBUG_IS_ON 1 -#else -#define DEBUG_IS_ON 0 -#endif - -/* ----------------------------------------------------------------------------- - Useful macros and inline functions - -------------------------------------------------------------------------- */ - -#if defined(__GNUC__) -#define SUPPORTS_TYPEOF -#endif - -#if defined(SUPPORTS_TYPEOF) -#define stg_min(a,b) ({typeof(a) _a = (a), _b = (b); _a <= _b ? _a : _b; }) -#define stg_max(a,b) ({typeof(a) _a = (a), _b = (b); _a <= _b ? _b : _a; }) -#else -#define stg_min(a,b) ((a) <= (b) ? (a) : (b)) -#define stg_max(a,b) ((a) <= (b) ? (b) : (a)) -#endif - -/* -------------------------------------------------------------------------- */ - -#if defined(__cplusplus) -} -#endif diff --git a/includes/RtsAPI.h b/includes/RtsAPI.h deleted file mode 100644 --- a/includes/RtsAPI.h +++ /dev/null @@ -1,487 +0,0 @@ -/* ---------------------------------------------------------------------------- - * - * (c) The GHC Team, 1998-2004 - * - * API for invoking Haskell functions via the RTS - * - * To understand the structure of the RTS headers, see the wiki: - * http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes - * - * --------------------------------------------------------------------------*/ - -#pragma once - -#if defined(__cplusplus) -extern "C" { -#endif - -#include "HsFFI.h" -#include "rts/Time.h" -#include "rts/EventLogWriter.h" - -/* - * Running the scheduler - */ -typedef enum { - NoStatus, /* not finished yet */ - Success, /* completed successfully */ - Killed, /* uncaught exception */ - Interrupted, /* stopped in response to a call to interruptStgRts */ - HeapExhausted /* out of memory */ -} SchedulerStatus; - -typedef struct StgClosure_ *HaskellObj; - -/* - * An abstract type representing the token returned by rts_lock() and - * used when allocating objects and threads in the RTS. - */ -typedef struct Capability_ Capability; - -/* - * The public view of a Capability: we can be sure it starts with - * these two components (but it may have more private fields). - */ -typedef struct CapabilityPublic_ { - StgFunTable f; - StgRegTable r; -} CapabilityPublic; - -/* ---------------------------------------------------------------------------- - RTS configuration settings, for passing to hs_init_ghc() - ------------------------------------------------------------------------- */ - -typedef enum { - RtsOptsNone, // +RTS causes an error - RtsOptsIgnore, // Ignore command line arguments - RtsOptsIgnoreAll, // Ignore command line and Environment arguments - RtsOptsSafeOnly, // safe RTS options allowed; others cause an error - RtsOptsAll // all RTS options allowed - } RtsOptsEnabledEnum; - -struct GCDetails_; - -// The RtsConfig struct is passed (by value) to hs_init_ghc(). The -// reason for using a struct is extensibility: we can add more -// fields to this later without breaking existing client code. -typedef struct { - - // Whether to interpret +RTS options on the command line - RtsOptsEnabledEnum rts_opts_enabled; - - // Whether to give RTS flag suggestions - HsBool rts_opts_suggestions; - - // additional RTS options - const char *rts_opts; - - // True if GHC was not passed -no-hs-main - HsBool rts_hs_main; - - // Whether to retain CAFs (default: false) - HsBool keep_cafs; - - // Writer a for eventlog. - const EventLogWriter *eventlog_writer; - - // Called before processing command-line flags, so that default - // settings for RtsFlags can be provided. - void (* defaultsHook) (void); - - // Called just before exiting - void (* onExitHook) (void); - - // Called on a stack overflow, before exiting - void (* stackOverflowHook) (W_ stack_size); - - // Called on heap overflow, before exiting - void (* outOfHeapHook) (W_ request_size, W_ heap_size); - - // Called when malloc() fails, before exiting - void (* mallocFailHook) (W_ request_size /* in bytes */, const char *msg); - - // Called for every GC - void (* gcDoneHook) (const struct GCDetails_ *stats); - - // Called when GC sync takes too long (+RTS --long-gc-sync=