Commit a6e68af1 authored by Herbert Valerio Riedel's avatar Herbert Valerio Riedel 🕺

Fold ghc-prim.git into ghc.git (re #8545)

At the time of merge, ghc-prim.git was at
[ad9bf96815cb5a9bb4acc51c99eff20be3e50da3/ghc-prim]
Signed-off-by: Herbert Valerio Riedel's avatarHerbert Valerio Riedel <hvr@gnu.org>
parents f964cd9c 1921238b
/dist-install/
/ghc.mk
/GNUmakefile
\ No newline at end of file
{-# LANGUAGE MagicHash, NoImplicitPrelude, BangPatterns #-}
-----------------------------------------------------------------------------
-- |
-- Module : GHC.CString
-- Copyright : (c) The University of Glasgow 2011
-- License : see libraries/ghc-prim/LICENSE
--
-- Maintainer : cvs-ghc@haskell.org
-- Stability : internal
-- Portability : non-portable (GHC Extensions)
--
-- GHC C strings definitions (previously in GHC.Base).
-- Use GHC.Exts from the base package instead of importing this
-- module directly.
--
-----------------------------------------------------------------------------
module GHC.CString (
unpackCString#, unpackAppendCString#, unpackFoldrCString#,
unpackCStringUtf8#, unpackNBytes#
) where
import GHC.Types
import GHC.Prim
-----------------------------------------------------------------------------
-- Unpacking C strings}
-----------------------------------------------------------------------------
-- This code is needed for virtually all programs, since it's used for
-- unpacking the strings of error messages.
-- Used to be in GHC.Base, but was moved to ghc-prim because the new generics
-- stuff uses Strings in the representation, so to give representations for
-- ghc-prim types we need unpackCString#
unpackCString# :: Addr# -> [Char]
{-# NOINLINE unpackCString# #-}
-- There's really no point in inlining this, ever, as the loop doesn't
-- specialise in an interesting But it's pretty small, so there's a danger
-- that it'll be inlined at every literal, which is a waste
unpackCString# addr
= unpack 0#
where
unpack nh
| isTrue# (ch `eqChar#` '\0'#) = []
| True = C# ch : unpack (nh +# 1#)
where
!ch = indexCharOffAddr# addr nh
unpackAppendCString# :: Addr# -> [Char] -> [Char]
{-# NOINLINE unpackAppendCString# #-}
-- See the NOINLINE note on unpackCString#
unpackAppendCString# addr rest
= unpack 0#
where
unpack nh
| isTrue# (ch `eqChar#` '\0'#) = rest
| True = C# ch : unpack (nh +# 1#)
where
!ch = indexCharOffAddr# addr nh
unpackFoldrCString# :: Addr# -> (Char -> a -> a) -> a -> a
-- Usually the unpack-list rule turns unpackFoldrCString# into unpackCString#
-- It also has a BuiltInRule in PrelRules.lhs:
-- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)
-- = unpackFoldrCString# "foobaz" c n
{-# NOINLINE unpackFoldrCString# #-}
-- At one stage I had NOINLINE [0] on the grounds that, unlike
-- unpackCString#, there *is* some point in inlining
-- unpackFoldrCString#, because we get better code for the
-- higher-order function call. BUT there may be a lot of
-- literal strings, and making a separate 'unpack' loop for
-- each is highly gratuitous. See nofib/real/anna/PrettyPrint.
unpackFoldrCString# addr f z
= unpack 0#
where
unpack nh
| isTrue# (ch `eqChar#` '\0'#) = z
| True = C# ch `f` unpack (nh +# 1#)
where
!ch = indexCharOffAddr# addr nh
unpackCStringUtf8# :: Addr# -> [Char]
unpackCStringUtf8# addr
= unpack 0#
where
unpack nh
| isTrue# (ch `eqChar#` '\0'# ) = []
| isTrue# (ch `leChar#` '\x7F'#) = C# ch : unpack (nh +# 1#)
| isTrue# (ch `leChar#` '\xDF'#) =
C# (chr# (((ord# ch -# 0xC0#) `uncheckedIShiftL#` 6#) +#
(ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#))) :
unpack (nh +# 2#)
| isTrue# (ch `leChar#` '\xEF'#) =
C# (chr# (((ord# ch -# 0xE0#) `uncheckedIShiftL#` 12#) +#
((ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#` 6#) +#
(ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#))) :
unpack (nh +# 3#)
| True =
C# (chr# (((ord# ch -# 0xF0#) `uncheckedIShiftL#` 18#) +#
((ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#` 12#) +#
((ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#) `uncheckedIShiftL#` 6#) +#
(ord# (indexCharOffAddr# addr (nh +# 3#)) -# 0x80#))) :
unpack (nh +# 4#)
where
!ch = indexCharOffAddr# addr nh
unpackNBytes# :: Addr# -> Int# -> [Char]
unpackNBytes# _addr 0# = []
unpackNBytes# addr len# = unpack [] (len# -# 1#)
where
unpack acc i#
| isTrue# (i# <# 0#) = acc
| True =
case indexCharOffAddr# addr i# of
ch -> unpack (C# ch : acc) (i# -# 1#)
This diff is collapsed.
{-# LANGUAGE MagicHash, NoImplicitPrelude, UnboxedTuples, UnliftedFFITypes, Trustworthy #-}
module GHC.Debug ( debugLn, debugErrLn ) where
import GHC.Prim
import GHC.Types
import GHC.Tuple ()
debugLn :: [Char] -> IO ()
debugLn xs = IO (\s0 ->
case mkMBA s0 xs of
(# s1, mba #) ->
case c_debugLn mba of
IO f -> f s1)
debugErrLn :: [Char] -> IO ()
debugErrLn xs = IO (\s0 ->
case mkMBA s0 xs of
(# s1, mba #) ->
case c_debugErrLn mba of
IO f -> f s1)
foreign import ccall unsafe "debugLn"
c_debugLn :: MutableByteArray# RealWorld -> IO ()
foreign import ccall unsafe "debugErrLn"
c_debugErrLn :: MutableByteArray# RealWorld -> IO ()
mkMBA :: State# RealWorld -> [Char] ->
(# State# RealWorld, MutableByteArray# RealWorld #)
mkMBA s0 xs = -- Start with 1 so that we have space to put in a \0 at
-- the end
case len 1# xs of
l ->
case newByteArray# l s0 of
(# s1, mba #) ->
case write mba 0# xs s1 of
s2 -> (# s2, mba #)
where len l [] = l
len l (_ : xs') = len (l +# 1#) xs'
write mba offset [] s = writeCharArray# mba offset '\0'# s
write mba offset (C# x : xs') s
= case writeCharArray# mba offset x s of
s' ->
write mba (offset +# 1#) xs' s'
{-# LANGUAGE CPP, MagicHash, NoImplicitPrelude, UnliftedFFITypes #-}
{-# OPTIONS_HADDOCK hide #-}
-----------------------------------------------------------------------------
-- |
-- Module : GHC.IntWord64
-- Copyright : (c) The University of Glasgow, 1997-2008
-- License : see libraries/ghc-prim/LICENSE
--
-- Maintainer : cvs-ghc@haskell.org
-- Stability : internal
-- Portability : non-portable (GHC Extensions)
--
-- Primitive operations on Int64# and Word64# on platforms where
-- WORD_SIZE_IN_BITS < 64.
--
-----------------------------------------------------------------------------
#include "MachDeps.h"
-- #hide
module GHC.IntWord64 (
#if WORD_SIZE_IN_BITS < 64
Int64#, Word64#, module GHC.IntWord64
#endif
) where
#if WORD_SIZE_IN_BITS < 64
import GHC.Prim
foreign import ccall unsafe "hs_eqWord64" eqWord64# :: Word64# -> Word64# -> Int#
foreign import ccall unsafe "hs_neWord64" neWord64# :: Word64# -> Word64# -> Int#
foreign import ccall unsafe "hs_ltWord64" ltWord64# :: Word64# -> Word64# -> Int#
foreign import ccall unsafe "hs_leWord64" leWord64# :: Word64# -> Word64# -> Int#
foreign import ccall unsafe "hs_gtWord64" gtWord64# :: Word64# -> Word64# -> Int#
foreign import ccall unsafe "hs_geWord64" geWord64# :: Word64# -> Word64# -> Int#
foreign import ccall unsafe "hs_eqInt64" eqInt64# :: Int64# -> Int64# -> Int#
foreign import ccall unsafe "hs_neInt64" neInt64# :: Int64# -> Int64# -> Int#
foreign import ccall unsafe "hs_ltInt64" ltInt64# :: Int64# -> Int64# -> Int#
foreign import ccall unsafe "hs_leInt64" leInt64# :: Int64# -> Int64# -> Int#
foreign import ccall unsafe "hs_gtInt64" gtInt64# :: Int64# -> Int64# -> Int#
foreign import ccall unsafe "hs_geInt64" geInt64# :: Int64# -> Int64# -> Int#
foreign import ccall unsafe "hs_quotInt64" quotInt64# :: Int64# -> Int64# -> Int64#
foreign import ccall unsafe "hs_remInt64" remInt64# :: Int64# -> Int64# -> Int64#
foreign import ccall unsafe "hs_plusInt64" plusInt64# :: Int64# -> Int64# -> Int64#
foreign import ccall unsafe "hs_minusInt64" minusInt64# :: Int64# -> Int64# -> Int64#
foreign import ccall unsafe "hs_timesInt64" timesInt64# :: Int64# -> Int64# -> Int64#
foreign import ccall unsafe "hs_negateInt64" negateInt64# :: Int64# -> Int64#
foreign import ccall unsafe "hs_quotWord64" quotWord64# :: Word64# -> Word64# -> Word64#
foreign import ccall unsafe "hs_remWord64" remWord64# :: Word64# -> Word64# -> Word64#
foreign import ccall unsafe "hs_and64" and64# :: Word64# -> Word64# -> Word64#
foreign import ccall unsafe "hs_or64" or64# :: Word64# -> Word64# -> Word64#
foreign import ccall unsafe "hs_xor64" xor64# :: Word64# -> Word64# -> Word64#
foreign import ccall unsafe "hs_not64" not64# :: Word64# -> Word64#
foreign import ccall unsafe "hs_uncheckedShiftL64" uncheckedShiftL64# :: Word64# -> Int# -> Word64#
foreign import ccall unsafe "hs_uncheckedShiftRL64" uncheckedShiftRL64# :: Word64# -> Int# -> Word64#
foreign import ccall unsafe "hs_uncheckedIShiftL64" uncheckedIShiftL64# :: Int64# -> Int# -> Int64#
foreign import ccall unsafe "hs_uncheckedIShiftRA64" uncheckedIShiftRA64# :: Int64# -> Int# -> Int64#
foreign import ccall unsafe "hs_uncheckedIShiftRL64" uncheckedIShiftRL64# :: Int64# -> Int# -> Int64#
foreign import ccall unsafe "hs_int64ToWord64" int64ToWord64# :: Int64# -> Word64#
foreign import ccall unsafe "hs_word64ToInt64" word64ToInt64# :: Word64# -> Int64#
foreign import ccall unsafe "hs_intToInt64" intToInt64# :: Int# -> Int64#
foreign import ccall unsafe "hs_int64ToInt" int64ToInt# :: Int64# -> Int#
foreign import ccall unsafe "hs_wordToWord64" wordToWord64# :: Word# -> Word64#
foreign import ccall unsafe "hs_word64ToWord" word64ToWord# :: Word64# -> Word#
#endif
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}
-----------------------------------------------------------------------------
-- |
-- Module : GHC.Magic
-- Copyright : (c) The University of Glasgow 2009
-- License : see libraries/ghc-prim/LICENSE
--
-- Maintainer : cvs-ghc@haskell.org
-- Stability : internal
-- Portability : non-portable (GHC Extensions)
--
-- GHC magic.
--
-- Use GHC.Exts from the base package instead of importing this
-- module directly.
--
-----------------------------------------------------------------------------
module GHC.Magic ( inline, lazy ) where
-- | The call '(inline f)' arranges that 'f' is inlined, regardless of
-- its size. More precisely, the call '(inline f)' rewrites to the
-- right-hand side of 'f'\'s definition. This allows the programmer to
-- control inlining from a particular call site rather than the
-- definition site of the function (c.f. 'INLINE' pragmas).
--
-- This inlining occurs regardless of the argument to the call or the
-- size of 'f'\'s definition; it is unconditional. The main caveat is
-- that 'f'\'s definition must be visible to the compiler; it is
-- therefore recommended to mark the function with an 'INLINABLE'
-- pragma at its definition so that GHC guarantees to record its
-- unfolding regardless of size.
--
-- If no inlining takes place, the 'inline' function expands to the
-- identity function in Phase zero, so its use imposes no overhead.
{-# NOINLINE[0] inline #-}
inline :: a -> a
inline x = x
-- | The 'lazy' function restrains strictness analysis a little. The
-- call '(lazy e)' means the same as 'e', but 'lazy' has a magical
-- property so far as strictness analysis is concerned: it is lazy in
-- its first argument, even though its semantics is strict. After
-- strictness analysis has run, calls to 'lazy' are inlined to be the
-- identity function.
--
-- This behaviour is occasionally useful when controlling evaluation
-- order. Notably, 'lazy' is used in the library definition of
-- 'Control.Parallel.par':
--
-- > par :: a -> b -> b
-- > par x y = case (par# x) of _ -> lazy y
--
-- If 'lazy' were not lazy, 'par' would look strict in 'y' which
-- would defeat the whole purpose of 'par'.
--
-- Like 'seq', the argument of 'lazy' can have an unboxed type.
lazy :: a -> a
lazy x = x
-- Implementation note: its strictness and unfolding are over-ridden
-- by the definition in MkId.lhs; in both cases to nothing at all.
-- That way, 'lazy' does not get inlined, and the strictness analyser
-- sees it as lazy. Then the worker/wrapper phase inlines it.
-- Result: happiness
This diff is collapsed.
{-# LANGUAGE MagicHash, NoImplicitPrelude, TypeFamilies, UnboxedTuples #-}
-----------------------------------------------------------------------------
-- |
-- Module : GHC.Types
-- Copyright : (c) The University of Glasgow 2009
-- License : see libraries/ghc-prim/LICENSE
--
-- Maintainer : cvs-ghc@haskell.org
-- Stability : internal
-- Portability : non-portable (GHC Extensions)
--
-- GHC type definitions.
-- Use GHC.Exts from the base package instead of importing this
-- module directly.
--
-----------------------------------------------------------------------------
module GHC.Types (
Bool(..), Char(..), Int(..), Word(..),
Float(..), Double(..),
Ordering(..), IO(..),
isTrue#,
SPEC(..),
Coercible,
) where
import GHC.Prim
infixr 5 :
data [] a = [] | a : [a]
data {-# CTYPE "HsBool" #-} Bool = False | True
{- | The character type 'Char' is an enumeration whose values represent
Unicode (or equivalently ISO\/IEC 10646) characters (see
<http://www.unicode.org/> for details). This set extends the ISO 8859-1
(Latin-1) character set (the first 256 characters), which is itself an extension
of the ASCII character set (the first 128 characters). A character literal in
Haskell has type 'Char'.
To convert a 'Char' to or from the corresponding 'Int' value defined
by Unicode, use 'Prelude.toEnum' and 'Prelude.fromEnum' from the
'Prelude.Enum' class respectively (or equivalently 'ord' and 'chr').
-}
data {-# CTYPE "HsChar" #-} Char = C# Char#
-- | A fixed-precision integer type with at least the range @[-2^29 .. 2^29-1]@.
-- The exact range for a given implementation can be determined by using
-- 'Prelude.minBound' and 'Prelude.maxBound' from the 'Prelude.Bounded' class.
data {-# CTYPE "HsInt" #-} Int = I# Int#
-- |A 'Word' is an unsigned integral type, with the same size as 'Int'.
data {-# CTYPE "HsWord" #-} Word = W# Word#
-- | Single-precision floating point numbers.
-- It is desirable that this type be at least equal in range and precision
-- to the IEEE single-precision type.
data {-# CTYPE "HsFloat" #-} Float = F# Float#
-- | Double-precision floating point numbers.
-- It is desirable that this type be at least equal in range and precision
-- to the IEEE double-precision type.
data {-# CTYPE "HsDouble" #-} Double = D# Double#
data Ordering = LT | EQ | GT
{- |
A value of type @'IO' a@ is a computation which, when performed,
does some I\/O before returning a value of type @a@.
There is really only one way to \"perform\" an I\/O action: bind it to
@Main.main@ in your program. When your program is run, the I\/O will
be performed. It isn't possible to perform I\/O from an arbitrary
function, unless that function is itself in the 'IO' monad and called
at some point, directly or indirectly, from @Main.main@.
'IO' is a monad, so 'IO' actions can be combined using either the do-notation
or the '>>' and '>>=' operations from the 'Monad' class.
-}
newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #))
{-
Note [Kind-changing of (~) and Coercible]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(~) and Coercible are tricky to define. To the user, they must appear as
constraints, but we cannot define them as such in Haskell. But we also cannot
just define them only in GHC.Prim (like (->)), because we need a real module
for them, e.g. to compile the constructor's info table.
Furthermore the type of MkCoercible cannot be written in Haskell (no syntax for
~#R).
So we define them as regular data types in GHC.Types, and do magic in GHC to
change the kind and type, in tysWiredIn.
-}
-- | A data constructor used to box up all unlifted equalities
--
-- The type constructor is special in that GHC pretends that it
-- has kind (? -> ? -> Fact) rather than (* -> * -> *)
data (~) a b = Eq# ((~#) a b)
-- | This two-parameter class has instances for types @a@ and @b@ if
-- the compiler can infer that they have the same representation. This class
-- does not have regular instances; instead they are created on-the-fly during
-- type-checking. Trying to manually declare an instance of @Coercible@
-- is an error.
--
-- Nevertheless one can pretend that the following three kinds of instances
-- exist. First, as a trivial base-case:
--
-- @instance a a@
--
-- Furthermore, for every type constructor there is
-- an instance that allows to coerce under the type constructor. For
-- example, let @D@ be a prototypical type constructor (@data@ or
-- @newtype@) with three type arguments, which have roles @nominal@,
-- @representational@ resp. @phantom@. Then there is an instance of
-- the form
--
-- @instance Coercible b b\' => Coercible (D a b c) (D a b\' c\')@
--
-- Note that the @nominal@ type arguments are equal, the
-- @representational@ type arguments can differ, but need to have a
-- @Coercible@ instance themself, and the @phantom@ type arguments can be
-- changed arbitrarily.
--
-- The third kind of instance exists for every @newtype NT = MkNT T@ and
-- comes in two variants, namely
--
-- @instance Coercible a T => Coercible a NT@
--
-- @instance Coercible T b => Coercible NT b@
--
-- This instance is only usable if the constructor @MkNT@ is in scope.
--
-- If, as a library author of a type constructor like @Set a@, you
-- want to prevent a user of your module to write
-- @coerce :: Set T -> Set NT@,
-- you need to set the role of @Set@\'s type parameter to @nominal@,
-- by writing
--
-- @type role Set nominal@
--
-- For more details about this feature, please refer to
-- <http://www.cis.upenn.edu/~eir/papers/2014/coercible/coercible.pdf Safe Coercions>
-- by Joachim Breitner, Richard A. Eisenberg, Simon Peyton Jones and Stephanie Weirich.
--
-- /Since: 4.7.0.0/
data Coercible a b = MkCoercible ((~#) a b)
-- Also see Note [Kind-changing of (~) and Coercible]
-- | Alias for tagToEnum#. Returns True of its parameter is 1# and False
-- if it is 0#.
{-# INLINE isTrue# #-}
isTrue# :: Int# -> Bool -- See Note [Optimizing isTrue#]
isTrue# x = tagToEnum# x
-- Note [Optimizing isTrue#]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- Current definition of isTrue# is a temporary workaround. We would like to
-- have functions isTrue# and isFalse# defined like this:
--
-- isTrue# :: Int# -> Bool
-- isTrue# 1# = True
-- isTrue# _ = False
--
-- isFalse# :: Int# -> Bool
-- isFalse# 0# = True
-- isFalse# _ = False
--
-- These functions would allow us to safely check if a tag can represent True
-- or False. Using isTrue# and isFalse# as defined above will not introduce
-- additional case into the code. When we scrutinize return value of isTrue#
-- or isFalse#, either explicitly in a case expression or implicitly in a guard,
-- the result will always be a single case expression (given that optimizations
-- are turned on). This results from case-of-case transformation. Consider this
-- code (this is both valid Haskell and Core):
--
-- case isTrue# (a ># b) of
-- True -> e1
-- False -> e2
--
-- Inlining isTrue# gives:
--
-- case (case (a ># b) of { 1# -> True; _ -> False } ) of
-- True -> e1
-- False -> e2
--
-- Case-of-case transforms that to:
--
-- case (a ># b) of
-- 1# -> case True of
-- True -> e1
-- False -> e2
-- _ -> case False of
-- True -> e1
-- False -> e2
--
-- Which is then simplified by case-of-known-constructor:
--
-- case (a ># b) of
-- 1# -> e1
-- _ -> e2
--
-- While we get good Core here, the code generator will generate very bad Cmm
-- if e1 or e2 do allocation. It will push heap checks into case alternatives
-- which results in about 2.5% increase in code size. Until this is improved we
-- just make isTrue# an alias to tagToEnum#. This is a temporary solution (if
-- you're reading this in 2023 then things went wrong). See #8326.
--
-- | SPEC is used by GHC in the @SpecConstr@ pass in order to inform
-- the compiler when to be particularly aggressive. In particular, it
-- tells GHC to specialize regardless of size or the number of
-- specializations. However, not all loops fall into this category.
--
-- Libraries can specify this by using 'SPEC' data type to inform which
-- loops should be aggressively specialized.
data SPEC = SPEC | SPEC2
This library (libraries/ghc-prim) is derived from code from several
sources:
* Code from the GHC project which is largely (c) The University of
Glasgow, and distributable under a BSD-style license (see below),
* Code from the Haskell 98 Report which is (c) Simon Peyton Jones
and freely redistributable (but see the full license for
restrictions).
The full text of these licenses is reproduced below. All of the
licenses are BSD-style or compatible.
-----------------------------------------------------------------------------
The Glasgow Haskell Compiler License
Copyright 2004, The University Court of the University of Glasgow.
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
- Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
- Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
- Neither name of the University nor the names of its contributors may be
used to endorse or promote products derived from this software without
specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
DAMAGE.
-----------------------------------------------------------------------------
Code derived from the document "Report on the Programming Language
Haskell 98", is distributed under the following license:
Copyright (c) 2002 Simon Peyton Jones
The authors intend this Report to belong to the entire Haskell
community, and so we grant permission to copy and distribute it for
any purpose, provided that it is reproduced in its entirety,
including this Notice. Modified versions of this Report may also be
copied and distributed for any purpose, provided that the modified
version is clearly presented as such, and that it does not claim to
be a definition of the Haskell 98 Language.
-- We need to do some ugly hacks here because of GHC magic
module Main (main) where
import Control.Monad
import Data.List
import Data.Maybe
import Distribution.PackageDescription
import Distribution.Simple
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Program
import Distribution.Simple.Utils
import Distribution.Text
import System.Cmd
import System.FilePath
import System.Exit
import System.Directory
main :: IO ()
main = do let hooks = simpleUserHooks {
regHook = addPrimModule
$ regHook simpleUserHooks,
buildHook = build_primitive_sources
$ buildHook simpleUserHooks,
haddockHook = addPrimModuleForHaddock
$ build_primitive_sources
$ haddockHook simpleUserHooks }
defaultMainWithHooks hooks
type Hook a = PackageDescription -> LocalBuildInfo -> UserHooks -> a -> IO ()
addPrimModule :: Hook a -> Hook a
addPrimModule f pd lbi uhs x =
do let -- I'm not sure which one of these we actually need to change.
-- It seems bad that there are two.
pd' = addPrimModuleToPD pd
lpd = addPrimModuleToPD (localPkgDescr lbi)
lbi' = lbi { localPkgDescr = lpd }
f pd' lbi' uhs x
addPrimModuleForHaddock :: Hook a -> Hook a
addPrimModuleForHaddock f pd lbi uhs x =
do let pc = withPrograms lbi
pc' = userSpecifyArgs "haddock" ["GHC/Prim.hs"] pc
lbi' = lbi { withPrograms = pc' }
f pd lbi' uhs x
addPrimModuleToPD :: PackageDescription -> PackageDescription
addPrimModuleToPD pd =
case library pd of
Just lib ->
let ems = fromJust (simpleParse "GHC.Prim") : exposedModules lib
lib' = lib { exposedModules = ems }
in pd { library = Just lib' }
Nothing ->
error "Expected a library, but none found"
build_primitive_sources :: Hook a -> Hook a
build_primitive_sources f pd lbi uhs x
= do when (compilerFlavor (compiler lbi) == GHC) $ do
let genprimopcode = joinPath ["..", "..", "utils",
"genprimopcode", "genprimopcode"]
primops = joinPath ["..", "..", "compiler", "prelude",
"primops.txt"]
primhs = joinPath ["GHC", "Prim.hs"]
primopwrappers = joinPath ["GHC", "PrimopWrappers.hs"]
primhs_tmp = addExtension primhs "tmp"
primopwrappers_tmp = addExtension primopwrappers "tmp"
maybeExit $ system (genprimopcode ++ " --make-haskell-source < "
++ primops ++ " > " ++ primhs_tmp)
maybeUpdateFile primhs_tmp primhs
maybeExit $ system (genprimopcode ++ " --make-haskell-wrappers < "
++ primops ++ " > " ++ primopwrappers_tmp)
maybeUpdateFile primopwrappers_tmp primopwrappers
f pd lbi uhs x
-- Replace a file only if the new version is different from the old.
-- This prevents make from doing unnecessary work after we run 'setup makefile'
maybeUpdateFile :: FilePath -> FilePath -> IO ()
maybeUpdateFile source target = do
r <- rawSystem "cmp" ["-s" {-quiet-}, source, target]
case r of
ExitSuccess -> removeFile source
ExitFailure _ -> do exists <- doesFileExist target
when exists $ removeFile target
renameFile source target
#include "Rts.h"
extern StgWord16 hs_bswap16(StgWord16 x);
StgWord16
hs_bswap16(StgWord16 x)
{
return ((x >> 8) | (x << 8));
}