From 1dfaee318171836b32f6b33a14231c69adfdef2f Mon Sep 17 00:00:00 2001 From: apt Date: Fri, 17 Aug 2001 17:18:54 +0000 Subject: [PATCH] [project @ 2001-08-17 17:18:51 by apt] How I spent my summer vacation. Primops ------- The format of the primops.txt.pp file has been enhanced to allow (latex-style) primop descriptions to be included. There is a new flag to genprimopcode that generates documentation including these descriptions. A first cut at descriptions of the more interesting primops has been made, and the file has been reordered a bit. 31-bit words ------------ The front end now can cope with the possibility of 31-bit (or even 30-bit) Int# and Word# types. The only current use of this is to generate external .core files that can be translated into OCAML source files (OCAML uses a one-bit tag to distinguish integers from pointers). The only way to get this right now is by hand-defining the preprocessor symbol WORD_SIZE_IN_BITS, which is normally set automatically from the familiar WORD_SIZE_IN_BYTES. Just in case 31-bit words are used, we now have Int32# and Word32# primitive types and an associated family of operators, paralleling the existing 64-bit stuff. Of course, none of the operators actually need to be implemented in the absence of a 31-bit backend. There has also been some minor re-jigging of the 32 vs. 64 bit stuff. See the description at the top of primops.txt.pp file for more details. Note that, for the first time, the *type* of a primop can now depend on the target word size. Also, the family of primops intToInt8#, intToInt16#, etc. have been renamed narrow8Int#, narrow16Int#, etc., to emphasize that they work on Int#'s and don't actually convert between types. Addresses --------- As another part of coping with the possibility of 31-bit ints, the addr2Int# and int2Addr# primops are now thoroughly deprecated (and not even defined in the 31-bit case) and all uses of them have been removed except from the (deprecated) module hslibs/lang/Addr Addr# should now be treated as a proper abstract type, and has these suitable operators: nullAddr# : Int# -> Addr# (ignores its argument; nullary primops cause problems at various places) plusAddr# : Addr# -> Int# -> Addr# minusAddr : Addr# -> Addr# -> Int# remAddr# : Addr# -> Int# -> Int# Obviously, these don't allow completely arbitrary offsets if 31-bit ints are in use, but they should do for all practical purposes. It is also still possible to generate an address constant, and there is a built-in rule that makes use of this to remove the nullAddr# calls. Misc ---- There is a new compile flag -fno-code that causes GHC to quit after generating .hi files and .core files (if requested) but before generating STG. Z-encoded names for tuples have been rationalized; e.g., Z3H now means an unboxed 3-tuple, rather than an unboxed tuple with 3 commas (i.e., a 4-tuple)! Removed misc. litlits in hslibs/lang Misc. small changes to external core format. The external core description has also been substantially updated, and incorporates the automatically-generated primop documentation; its in the repository at /papers/ext-core/core.tex. A little make-system addition to allow passing CPP options to compiler and library builds. --- ghc/compiler/Makefile | 5 +- ghc/compiler/absCSyn/PprAbsC.lhs | 2 + ghc/compiler/basicTypes/Literal.lhs | 34 +- ghc/compiler/basicTypes/OccName.lhs | 34 +- ghc/compiler/codeGen/CgRetConv.lhs | 4 +- ghc/compiler/coreSyn/ExternalCore.lhs | 2 +- ghc/compiler/coreSyn/MkExternalCore.lhs | 18 +- ghc/compiler/coreSyn/PprExternalCore.lhs | 2 +- ghc/compiler/main/CmdLineOpts.lhs | 1 + ghc/compiler/main/DriverFlags.hs | 3 +- ghc/compiler/main/DriverPipeline.hs | 17 +- ghc/compiler/main/HscMain.lhs | 31 +- ghc/compiler/nativeGen/MachCode.lhs | 14 +- ghc/compiler/nativeGen/StixPrim.lhs | 33 +- ghc/compiler/prelude/PrelNames.lhs | 100 +- ghc/compiler/prelude/PrelRules.lhs | 25 +- ghc/compiler/prelude/PrimOp.lhs | 2 + ghc/compiler/prelude/TysPrim.lhs | 13 + ghc/compiler/prelude/primops.txt | 2618 ++++++++++++++++++++++++++++++ ghc/compiler/prelude/primops.txt.pp | 1111 ++++++++----- ghc/compiler/typecheck/TcForeign.lhs | 10 +- ghc/includes/MachDeps.h | 20 +- ghc/includes/PrimOps.h | 45 +- ghc/lib/std/Makefile | 3 +- ghc/lib/std/PrelBase.lhs | 17 +- ghc/lib/std/PrelBits.lhs | 15 +- ghc/lib/std/PrelEnum.lhs | 5 +- ghc/lib/std/PrelGHC.hi-boot | 1506 +++++++++++++++++ ghc/lib/std/PrelGHC.hi-boot.pp | 70 +- ghc/lib/std/PrelInt.lhs | 303 +++- ghc/lib/std/PrelPtr.lhs | 16 +- ghc/lib/std/PrelStorable.lhs | 46 +- ghc/lib/std/PrelWord.lhs | 272 +++- ghc/tests/mk/boilerplate.mk | 2 +- ghc/utils/genprimopcode/Main.hs | 272 +++- 35 files changed, 5756 insertions(+), 915 deletions(-) create mode 100644 ghc/compiler/prelude/primops.txt create mode 100644 ghc/lib/std/PrelGHC.hi-boot diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index 3f7fae9..d88a4a9 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Makefile,v 1.189 2001/08/16 22:54:24 sof Exp $ +# $Id: Makefile,v 1.190 2001/08/17 17:18:51 apt Exp $ TOP = .. include $(TOP)/mk/boilerplate.mk @@ -324,7 +324,8 @@ PRIMOP_BITS=primop-data-decl.hs-incl \ primop-usage.hs-incl \ primop-primop-info.hs-incl -SRC_CPP_OPTS += -I$(GHC_INCLUDE_DIR) +SRC_CPP_OPTS += -I$(GHC_INCLUDE_DIR) -traditional +SRC_CPP_OPTS += ${GhcCppOpts} ifneq "$(BootingFromHc)" "YES" prelude/PrimOp.lhs prelude/PrimOp.o: $(PRIMOP_BITS) diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index 6f3282a..2ce020e 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -1305,6 +1305,8 @@ pprUnionTag CharRep = char 'c' pprUnionTag Int8Rep = ptext SLIT("i8") pprUnionTag IntRep = char 'i' pprUnionTag WordRep = char 'w' +pprUnionTag Int32Rep = char 'i' +pprUnionTag Word32Rep = char 'w' pprUnionTag AddrRep = char 'a' pprUnionTag FloatRep = char 'f' pprUnionTag DoubleRep = panic "pprUnionTag:Double?" diff --git a/ghc/compiler/basicTypes/Literal.lhs b/ghc/compiler/basicTypes/Literal.lhs index f9de3e3..03101e3 100644 --- a/ghc/compiler/basicTypes/Literal.lhs +++ b/ghc/compiler/basicTypes/Literal.lhs @@ -15,11 +15,11 @@ module Literal , inIntRange, inWordRange, tARGET_MAX_INT, inCharRange , word2IntLit, int2WordLit - , intToInt8Lit, intToInt16Lit, intToInt32Lit - , wordToWord8Lit, wordToWord16Lit, wordToWord32Lit + , narrow8IntLit, narrow16IntLit, narrow32IntLit + , narrow8WordLit, narrow16WordLit, narrow32WordLit , char2IntLit, int2CharLit , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit - , addr2IntLit, int2AddrLit, float2DoubleLit, double2FloatLit + , nullAddrLit, float2DoubleLit, double2FloatLit ) where #include "HsVersions.h" @@ -100,9 +100,9 @@ data Literal | MachAddr Integer -- Whatever this machine thinks is a "pointer" - | MachInt Integer -- Int# At least 32 bits + | MachInt Integer -- Int# At least WORD_SIZE_IN_BITS bits | MachInt64 Integer -- Int64# At least 64 bits - | MachWord Integer -- Word# At least 32 bits + | MachWord Integer -- Word# At least WORD_SIZE_IN_BITS bits | MachWord64 Integer -- Word64# At least 64 bits | MachFloat Rational @@ -163,11 +163,11 @@ inCharRange c = c >= 0 && c <= tARGET_MAX_CHAR ~~~~~~~~~ \begin{code} word2IntLit, int2WordLit, - intToInt8Lit, intToInt16Lit, intToInt32Lit, - wordToWord8Lit, wordToWord16Lit, wordToWord32Lit, + narrow8IntLit, narrow16IntLit, narrow32IntLit, + narrow8WordLit, narrow16WordLit, narrow32WordLit, char2IntLit, int2CharLit, float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit, - addr2IntLit, int2AddrLit, float2DoubleLit, double2FloatLit + float2DoubleLit, double2FloatLit :: Literal -> Literal word2IntLit (MachWord w) @@ -178,12 +178,12 @@ int2WordLit (MachInt i) | i < 0 = MachWord (1 + tARGET_MAX_WORD + i) -- (-1) ---> tARGET_MAX_WORD | otherwise = MachWord i -intToInt8Lit (MachInt i) = MachInt (toInteger (fromInteger i :: Int8)) -intToInt16Lit (MachInt i) = MachInt (toInteger (fromInteger i :: Int16)) -intToInt32Lit (MachInt i) = MachInt (toInteger (fromInteger i :: Int32)) -wordToWord8Lit (MachWord w) = MachWord (toInteger (fromInteger w :: Word8)) -wordToWord16Lit (MachWord w) = MachWord (toInteger (fromInteger w :: Word16)) -wordToWord32Lit (MachWord w) = MachWord (toInteger (fromInteger w :: Word32)) +narrow8IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int8)) +narrow16IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int16)) +narrow32IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int32)) +narrow8WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word8)) +narrow16WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word16)) +narrow32WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word32)) char2IntLit (MachChar c) = MachInt (toInteger c) int2CharLit (MachInt i) = MachChar (fromInteger i) @@ -194,11 +194,11 @@ int2FloatLit (MachInt i) = MachFloat (fromInteger i) double2IntLit (MachDouble f) = MachInt (truncate f) int2DoubleLit (MachInt i) = MachDouble (fromInteger i) -addr2IntLit (MachAddr a) = MachInt a -int2AddrLit (MachInt i) = MachAddr i - float2DoubleLit (MachFloat f) = MachDouble f double2FloatLit (MachDouble d) = MachFloat d + +nullAddrLit :: Literal +nullAddrLit = MachAddr 0 \end{code} Predicates diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs index f7e7c17..c10e1c4 100644 --- a/ghc/compiler/basicTypes/OccName.lhs +++ b/ghc/compiler/basicTypes/OccName.lhs @@ -258,18 +258,19 @@ Here's our convention for splitting up the interface file name space: $dm... default methods $p... superclass selectors $w... workers - $T... compiler-generated tycons for dictionaries - $D... ...ditto data cons + :T... compiler-generated tycons for dictionaries + :D... ...ditto data cons $sf.. specialised version of f in encoded form these appear as Zdfxxx etc :... keywords (export:, letrec: etc.) +--- I THINK THIS IS WRONG! This knowledge is encoded in the following functions. -@mk_deriv@ generates an @OccName@ from the one-char prefix and a string. +@mk_deriv@ generates an @OccName@ from the prefix and a string. NB: The string must already be encoded! \begin{code} @@ -426,13 +427,12 @@ The basic encoding scheme is this. foo## foozhzh foo##1 foozhzh1 fooZ fooZZ - :+ Zczp - () Z0T - (,,,,) Z4T 5-tuple - (#,,,,#) Z4H unboxed 5-tuple - (NB: the number is one different to the number of - elements. No real reason except that () is a zero-tuple, - while (,) is a 2-tuple.) + :+ ZCzp + () Z0T 0-tuple + (,,,,) Z5T 5-tuple + (# #) Z1H unboxed 1-tuple (note the space) + (#,,,,#) Z5H unboxed 5-tuple + (NB: There is no Z1T nor Z0H.) \begin{code} -- alreadyEncoded is used in ASSERTs to check for encoded @@ -459,11 +459,13 @@ encode cs = case maybe_tuple cs of go [] = [] go (c:cs) = encode_ch c ++ go cs +maybe_tuple "(# #)" = Just("Z1H") maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of - (n, '#' : ')' : cs) -> Just ('Z' : shows n "H") + (n, '#' : ')' : cs) -> Just ('Z' : shows (n+1) "H") other -> Nothing +maybe_tuple "()" = Just("Z0T") maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of - (n, ')' : cs) -> Just ('Z' : shows n "T") + (n, ')' : cs) -> Just ('Z' : shows (n+1) "T") other -> Nothing maybe_tuple other = Nothing @@ -565,8 +567,10 @@ decode_escape (c : rest) | isDigit c = go (digitToInt c) rest where go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest - go n ('T' : rest) = '(' : replicate n ',' ++ ')' : decode rest - go n ('H' : rest) = '(' : '#' : replicate n ',' ++ '#' : ')' : decode rest + go 0 ('T' : rest) = "()" ++ (decode rest) + go n ('T' : rest) = '(' : replicate (n-1) ',' ++ ')' : decode rest + go 1 ('H' : rest) = "(# #)" ++ (decode rest) + go n ('H' : rest) = '(' : '#' : replicate (n-1) ',' ++ '#' : ')' : decode rest go n ('U' : rest) = chr n : decode rest go n other = pprPanic "decode_escape" (ppr n <+> text (c:rest)) @@ -576,7 +580,7 @@ decode_escape (c : rest) = pprTrace "decode_escape" (char c) (decode rest) %************************************************************************ %* * -n\subsection{Lexical categories} +\subsection{Lexical categories} %* * %************************************************************************ diff --git a/ghc/compiler/codeGen/CgRetConv.lhs b/ghc/compiler/codeGen/CgRetConv.lhs index 0b72ebe..6108567 100644 --- a/ghc/compiler/codeGen/CgRetConv.lhs +++ b/ghc/compiler/codeGen/CgRetConv.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP Project, Glasgow University, 1992-1998 % -% $Id: CgRetConv.lhs,v 1.29 2000/11/14 17:41:04 sewardj Exp $ +% $Id: CgRetConv.lhs,v 1.30 2001/08/17 17:18:52 apt Exp $ % \section[CgRetConv]{Return conventions for the code generator} @@ -77,6 +77,8 @@ dataReturnConvPrim :: PrimRep -> MagicId dataReturnConvPrim IntRep = VanillaReg IntRep (_ILIT 1) dataReturnConvPrim WordRep = VanillaReg WordRep (_ILIT 1) +dataReturnConvPrim Int32Rep = VanillaReg Int32Rep (_ILIT 1) +dataReturnConvPrim Word32Rep = VanillaReg Word32Rep (_ILIT 1) dataReturnConvPrim Int64Rep = LongReg Int64Rep (_ILIT 1) dataReturnConvPrim Word64Rep = LongReg Word64Rep (_ILIT 1) dataReturnConvPrim AddrRep = VanillaReg AddrRep (_ILIT 1) diff --git a/ghc/compiler/coreSyn/ExternalCore.lhs b/ghc/compiler/coreSyn/ExternalCore.lhs index cadb639..9ed748f 100644 --- a/ghc/compiler/coreSyn/ExternalCore.lhs +++ b/ghc/compiler/coreSyn/ExternalCore.lhs @@ -34,7 +34,7 @@ data Exp | Case Exp Vbind [Alt] {- non-empty list -} | Coerce Ty Exp | Note String Exp - | Ccall String Ty + | External String Ty data Bind = Vb Vbind diff --git a/ghc/compiler/coreSyn/MkExternalCore.lhs b/ghc/compiler/coreSyn/MkExternalCore.lhs index 9b0a507..cb89c9a 100644 --- a/ghc/compiler/coreSyn/MkExternalCore.lhs +++ b/ghc/compiler/coreSyn/MkExternalCore.lhs @@ -128,8 +128,10 @@ make_exp :: CoreExpr -> C.Exp make_exp (Var v) = case globalIdDetails v of DataConId _ -> C.Dcon (make_con_qid (Var.varName v)) - FCallId (CCall (CCallSpec (StaticTarget nm) _ _)) -> C.Ccall (_UNPK_ nm) (make_ty (varType v)) + FCallId (CCall (CCallSpec (StaticTarget nm) _ _)) -> C.External (_UNPK_ nm) (make_ty (varType v)) + FCallId _ -> error "MkExternalCore died: can't handle non-static-C foreign call" _ -> C.Var (make_var_qid (Var.varName v)) +make_exp (Lit (l@(MachLabel s))) = C.External (_UNPK_ s) (make_ty (literalType l)) make_exp (Lit l) = C.Lit (make_lit l) make_exp (App e (Type t)) = C.Appt (make_exp e) (make_ty t) make_exp (App e1 e2) = C.App (make_exp e1) (make_exp e2) @@ -163,7 +165,6 @@ make_lit l = MachWord64 i -> C.Lint i t MachFloat r -> C.Lrational r t MachDouble r -> C.Lrational r t - MachLabel s -> C.Lstring (_UNPK_ s) t _ -> error "MkExternalCore died: make_lit" where t = make_ty (literalType l) @@ -188,18 +189,17 @@ make_kind _ = error "MkExternalCore died: make_kind" {- Id generation. -} -{- Use encoded strings, except restore '#'s. +{- Use encoded strings. Also, adjust casing to work around some badly-chosen internal names. -} make_id :: Bool -> Name -> C.Id make_id is_var nm = case n of - c:cs -> if isUpper c && is_var then (toLower c):(decode cs) - else if isLower c && (not is_var) then (toUpper c):(decode cs) - else decode n + 'Z':cs | is_var -> 'z':cs + 'z':cs | not is_var -> 'Z':cs + c:cs | isUpper c && is_var -> 'z':'d':n + c:cs | isLower c && (not is_var) -> 'Z':'d':n + _ -> n where n = (occNameString . nameOccName) nm - decode ('z':'h':cs) = '#':(decode cs) - decode (c:cs) = c:(decode cs) - decode [] = [] make_var_id :: Name -> C.Id make_var_id = make_id True diff --git a/ghc/compiler/coreSyn/PprExternalCore.lhs b/ghc/compiler/coreSyn/PprExternalCore.lhs index c7e51e3..16acc68 100644 --- a/ghc/compiler/coreSyn/PprExternalCore.lhs +++ b/ghc/compiler/coreSyn/PprExternalCore.lhs @@ -135,7 +135,7 @@ pexp (Case e vb alts) = sep [text "%case" <+> paexp e, $$ (indent (braces (vcat (punctuate (char ';') (map palt alts))))) pexp (Coerce t e) = (text "%coerce" <+> paty t) $$ pexp e pexp (Note s e) = (text "%note" <+> pstring s) $$ pexp e -pexp (Ccall n t) = (text "%ccall" <+> pstring n) $$ paty t +pexp (External n t) = (text "%external" <+> pstring n) $$ paty t pexp e = pfexp e diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index b839783..33d9320 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -331,6 +331,7 @@ data HscLang | HscJava | HscILX | HscInterpreted + | HscNothing deriving (Eq, Show) defaultDynFlags = DynFlags { diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs index 76c6082..e9b2a80 100644 --- a/ghc/compiler/main/DriverFlags.hs +++ b/ghc/compiler/main/DriverFlags.hs @@ -1,7 +1,7 @@ {-# OPTIONS -#include "hschooks.h" #-} ----------------------------------------------------------------------------- --- $Id: DriverFlags.hs,v 1.65 2001/08/15 09:32:40 rrt Exp $ +-- $Id: DriverFlags.hs,v 1.66 2001/08/17 17:18:52 apt Exp $ -- -- Driver flags -- @@ -387,6 +387,7 @@ dynamic_flags = [ , ( "fvia-c", NoArg (setLang HscC) ) , ( "fvia-C", NoArg (setLang HscC) ) , ( "filx", NoArg (setLang HscILX) ) + , ( "fno-code", NoArg (setLang HscNothing) ) -- "active negatives" , ( "fno-implicit-prelude", NoArg (setDynFlag Opt_NoImplicitPrelude) ) diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index 2c06c1b..2142f91 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -177,6 +177,7 @@ genPipeline todo stop_flag persistent_output lang (filename,suffix) HscILX | split -> not_valid | otherwise -> [ Unlit, Cpp, Hsc, Ilx2Il, Ilasm ] #endif + HscNothing -> [ Unlit, Cpp, Hsc ] | cish = [ Cc, As ] @@ -535,13 +536,14 @@ run_phase Hsc basename suff input_fn output_fn HscRecomp pcs details iface stub_h_exists stub_c_exists _maybe_interpreted_code -> do - -- deal with stubs - maybe_stub_o <- compileStub dyn_flags' stub_c_exists - case maybe_stub_o of - Nothing -> return () - Just stub_o -> add v_Ld_inputs stub_o - - return (Just output_fn) + -- deal with stubs + maybe_stub_o <- compileStub dyn_flags' stub_c_exists + case maybe_stub_o of + Nothing -> return () + Just stub_o -> add v_Ld_inputs stub_o + case hscLang dyn_flags of + HscNothing -> return Nothing + _ -> return (Just output_fn) } ----------------------------------------------------------------------------- @@ -1034,6 +1036,7 @@ compile ghci_mode summary source_unchanged have_object HscILX -> return (phaseInputExt Ilx2Il) #endif HscInterpreted -> return (error "no output file") + HscNothing -> return (error "no output file") let dyn_flags' = dyn_flags { hscOutName = output_fn, hscStubCOutName = basename ++ "_stub.c", diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 8e8aa38..290f177 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -202,6 +202,7 @@ hscRecomp ghci_mode dflags have_object = do { -- what target are we shooting for? ; let toInterp = dopt_HscLang dflags == HscInterpreted + ; let toNothing = dopt_HscLang dflags == HscNothing ; when (verbosity dflags >= 1) $ hPutStrLn stderr ("Compiling " ++ @@ -359,19 +360,23 @@ hscRecomp ghci_mode dflags have_object mkFinalIface ghci_mode dflags location maybe_checked_iface new_iface tidy_details - ------------------ Code generation ------------------ - abstractC <- _scc_ "CodeGen" - codeGen dflags this_mod imported_modules - cost_centre_info fe_binders - local_tycons stg_binds - - ------------------ Code output ----------------------- - (stub_h_exists, stub_c_exists) - <- codeOutput dflags this_mod local_tycons - binds stg_binds - c_code h_code abstractC - - return (stub_h_exists, stub_c_exists, Nothing, final_iface) + if toNothing + then do + return (False, False, Nothing, final_iface) + else do + ------------------ Code generation ------------------ + abstractC <- _scc_ "CodeGen" + codeGen dflags this_mod imported_modules + cost_centre_info fe_binders + local_tycons stg_binds + + ------------------ Code output ----------------------- + (stub_h_exists, stub_c_exists) + <- codeOutput dflags this_mod local_tycons + binds stg_binds + c_code h_code abstractC + + return (stub_h_exists, stub_c_exists, Nothing, final_iface) ; let final_details = tidy_details {md_binds = []} diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index 01b9c6e..9117e78 100644 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -457,7 +457,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps AddrNeOp -> int_NE_code x y AddrLtOp -> trivialCode (CMP ULT) x y AddrLeOp -> trivialCode (CMP ULE) x y - + FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y @@ -494,6 +494,10 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps DoubleMulOp -> trivialFCode DoubleRep (FMUL TF) x y DoubleDivOp -> trivialFCode DoubleRep (FDIV TF) x y + AddrAddOp -> trivialCode (ADD Q False) x y + AddrSubOp -> trivialCode (SUB Q False) x y + AddrRemOp -> trivialCode (REM Q True) x y + AndOp -> trivialCode AND x y OrOp -> trivialCode OR x y XorOp -> trivialCode XOR x y @@ -765,6 +769,10 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps DoubleMulOp -> trivialFCode DoubleRep GMUL x y DoubleDivOp -> trivialFCode DoubleRep GDIV x y + AddrAddOp -> add_code L x y + AddrSubOp -> sub_code L x y + AddrRemOp -> trivialCode (IREM L) Nothing x y + AndOp -> let op = AND L in trivialCode op (Just op) x y OrOp -> let op = OR L in trivialCode op (Just op) x y XorOp -> let op = XOR L in trivialCode op (Just op) x y @@ -1132,6 +1140,10 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps DoubleMulOp -> trivialFCode DoubleRep FMUL x y DoubleDivOp -> trivialFCode DoubleRep FDIV x y + AddrAddOp -> trivialCode (ADD False False) x y + AddrSubOp -> trivialCode (SUB False False) x y + AddrRemOp -> imul_div SLIT(".rem") x y + AndOp -> trivialCode (AND False) x y OrOp -> trivialCode (OR False) x y XorOp -> trivialCode (XOR False) x y diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index 38dfa3a..45461ca 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -7,6 +7,7 @@ module StixPrim ( primCode, amodeToStix, amodeToStix', foreignCallCode ) where #include "HsVersions.h" +#include "MachDeps.h" import MachMisc import Stix @@ -140,33 +141,41 @@ primCode [res] Integer2IntOp arg@[sa,da] primCode [res] Integer2WordOp arg@[sa,da] = gmpInteger2Word res (sa,da) -primCode [res] Int2AddrOp [arg] - = simpleCoercion AddrRep res arg - -primCode [res] Addr2IntOp [arg] - = simpleCoercion IntRep res arg - primCode [res] Int2WordOp [arg] = simpleCoercion IntRep{-WordRep?-} res arg primCode [res] Word2IntOp [arg] = simpleCoercion IntRep res arg +primCode [res] AddrNullOp [arg] + = let + assign = StAssign AddrRep (amodeToStix res) (StInt 0) + in + returnUs (\xs -> assign : xs) + primCode [res] AddrToHValueOp [arg] = simpleCoercion PtrRep res arg -primCode [res] IntToInt8Op [arg] +#if (WORD_SIZE_IN_BITS == 32 || WORD_SIZE_IN_BITS == 64) +primCode [res] Int2AddrOp [arg] + = simpleCoercion AddrRep res arg + +primCode [res] Addr2IntOp [arg] + = simpleCoercion IntRep res arg +#endif + +primCode [res] Narrow8IntOp [arg] = narrowingCoercion IntRep Int8Rep res arg -primCode [res] IntToInt16Op [arg] +primCode [res] Narrow16IntOp [arg] = narrowingCoercion IntRep Int16Rep res arg -primCode [res] IntToInt32Op [arg] +primCode [res] Narrow32IntOp [arg] = narrowingCoercion IntRep Int32Rep res arg -primCode [res] WordToWord8Op [arg] +primCode [res] Narrow8WordOp [arg] = narrowingCoercion WordRep Word8Rep res arg -primCode [res] WordToWord16Op [arg] +primCode [res] Narrow16WordOp [arg] = narrowingCoercion WordRep Word16Rep res arg -primCode [res] WordToWord32Op [arg] +primCode [res] Narrow32WordOp [arg] = narrowingCoercion WordRep Word32Rep res arg \end{code} diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index 0f45777..d774e74 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -318,8 +318,10 @@ typeConName = kindQual SLIT("Type") typeConKey funTyConName = tcQual pREL_GHC_Name SLIT("(->)") funTyConKey charPrimTyConName = tcQual pREL_GHC_Name SLIT("Char#") charPrimTyConKey intPrimTyConName = tcQual pREL_GHC_Name SLIT("Int#") intPrimTyConKey +int32PrimTyConName = tcQual pREL_GHC_Name SLIT("Int32#") int32PrimTyConKey int64PrimTyConName = tcQual pREL_GHC_Name SLIT("Int64#") int64PrimTyConKey wordPrimTyConName = tcQual pREL_GHC_Name SLIT("Word#") wordPrimTyConKey +word32PrimTyConName = tcQual pREL_GHC_Name SLIT("Word32#") word32PrimTyConKey word64PrimTyConName = tcQual pREL_GHC_Name SLIT("Word64#") word64PrimTyConKey addrPrimTyConName = tcQual pREL_GHC_Name SLIT("Addr#") addrPrimTyConKey floatPrimTyConName = tcQual pREL_GHC_Name SLIT("Float#") floatPrimTyConKey @@ -696,58 +698,60 @@ intPrimTyConKey = mkPreludeTyConUnique 14 intTyConKey = mkPreludeTyConUnique 15 int8TyConKey = mkPreludeTyConUnique 16 int16TyConKey = mkPreludeTyConUnique 17 -int32TyConKey = mkPreludeTyConUnique 18 -int64PrimTyConKey = mkPreludeTyConUnique 19 -int64TyConKey = mkPreludeTyConUnique 20 -integerTyConKey = mkPreludeTyConUnique 21 -listTyConKey = mkPreludeTyConUnique 22 -foreignObjPrimTyConKey = mkPreludeTyConUnique 23 -foreignObjTyConKey = mkPreludeTyConUnique 24 -foreignPtrTyConKey = mkPreludeTyConUnique 25 -weakPrimTyConKey = mkPreludeTyConUnique 26 -mutableArrayPrimTyConKey = mkPreludeTyConUnique 27 -mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 28 -orderingTyConKey = mkPreludeTyConUnique 29 -mVarPrimTyConKey = mkPreludeTyConUnique 30 -ratioTyConKey = mkPreludeTyConUnique 31 -rationalTyConKey = mkPreludeTyConUnique 32 -realWorldTyConKey = mkPreludeTyConUnique 33 -stablePtrPrimTyConKey = mkPreludeTyConUnique 34 -stablePtrTyConKey = mkPreludeTyConUnique 35 -statePrimTyConKey = mkPreludeTyConUnique 36 -stableNamePrimTyConKey = mkPreludeTyConUnique 50 -stableNameTyConKey = mkPreludeTyConUnique 51 -mutableByteArrayTyConKey = mkPreludeTyConUnique 52 -mutVarPrimTyConKey = mkPreludeTyConUnique 53 -ioTyConKey = mkPreludeTyConUnique 55 -byteArrayTyConKey = mkPreludeTyConUnique 56 -wordPrimTyConKey = mkPreludeTyConUnique 57 -wordTyConKey = mkPreludeTyConUnique 58 -word8TyConKey = mkPreludeTyConUnique 59 -word16TyConKey = mkPreludeTyConUnique 60 -word32TyConKey = mkPreludeTyConUnique 61 -word64PrimTyConKey = mkPreludeTyConUnique 62 -word64TyConKey = mkPreludeTyConUnique 63 -liftedConKey = mkPreludeTyConUnique 64 -unliftedConKey = mkPreludeTyConUnique 65 -anyBoxConKey = mkPreludeTyConUnique 66 -kindConKey = mkPreludeTyConUnique 67 -boxityConKey = mkPreludeTyConUnique 68 -typeConKey = mkPreludeTyConUnique 69 -threadIdPrimTyConKey = mkPreludeTyConUnique 70 -bcoPrimTyConKey = mkPreludeTyConUnique 71 -ptrTyConKey = mkPreludeTyConUnique 72 -funPtrTyConKey = mkPreludeTyConUnique 73 +int32PrimTyConKey = mkPreludeTyConUnique 18 +int32TyConKey = mkPreludeTyConUnique 19 +int64PrimTyConKey = mkPreludeTyConUnique 20 +int64TyConKey = mkPreludeTyConUnique 21 +integerTyConKey = mkPreludeTyConUnique 22 +listTyConKey = mkPreludeTyConUnique 23 +foreignObjPrimTyConKey = mkPreludeTyConUnique 24 +foreignObjTyConKey = mkPreludeTyConUnique 25 +foreignPtrTyConKey = mkPreludeTyConUnique 26 +weakPrimTyConKey = mkPreludeTyConUnique 27 +mutableArrayPrimTyConKey = mkPreludeTyConUnique 28 +mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 29 +orderingTyConKey = mkPreludeTyConUnique 30 +mVarPrimTyConKey = mkPreludeTyConUnique 31 +ratioTyConKey = mkPreludeTyConUnique 32 +rationalTyConKey = mkPreludeTyConUnique 33 +realWorldTyConKey = mkPreludeTyConUnique 34 +stablePtrPrimTyConKey = mkPreludeTyConUnique 35 +stablePtrTyConKey = mkPreludeTyConUnique 36 +statePrimTyConKey = mkPreludeTyConUnique 50 +stableNamePrimTyConKey = mkPreludeTyConUnique 51 +stableNameTyConKey = mkPreludeTyConUnique 52 +mutableByteArrayTyConKey = mkPreludeTyConUnique 53 +mutVarPrimTyConKey = mkPreludeTyConUnique 55 +ioTyConKey = mkPreludeTyConUnique 56 +byteArrayTyConKey = mkPreludeTyConUnique 57 +wordPrimTyConKey = mkPreludeTyConUnique 58 +wordTyConKey = mkPreludeTyConUnique 59 +word8TyConKey = mkPreludeTyConUnique 60 +word16TyConKey = mkPreludeTyConUnique 61 +word32PrimTyConKey = mkPreludeTyConUnique 62 +word32TyConKey = mkPreludeTyConUnique 63 +word64PrimTyConKey = mkPreludeTyConUnique 64 +word64TyConKey = mkPreludeTyConUnique 65 +liftedConKey = mkPreludeTyConUnique 66 +unliftedConKey = mkPreludeTyConUnique 67 +anyBoxConKey = mkPreludeTyConUnique 68 +kindConKey = mkPreludeTyConUnique 69 +boxityConKey = mkPreludeTyConUnique 70 +typeConKey = mkPreludeTyConUnique 71 +threadIdPrimTyConKey = mkPreludeTyConUnique 72 +bcoPrimTyConKey = mkPreludeTyConUnique 73 +ptrTyConKey = mkPreludeTyConUnique 74 +funPtrTyConKey = mkPreludeTyConUnique 75 -- Usage type constructors -usageConKey = mkPreludeTyConUnique 74 -usOnceTyConKey = mkPreludeTyConUnique 75 -usManyTyConKey = mkPreludeTyConUnique 76 +usageConKey = mkPreludeTyConUnique 76 +usOnceTyConKey = mkPreludeTyConUnique 77 +usManyTyConKey = mkPreludeTyConUnique 78 -- Generic Type Constructors -crossTyConKey = mkPreludeTyConUnique 77 -plusTyConKey = mkPreludeTyConUnique 78 -genUnitTyConKey = mkPreludeTyConUnique 79 +crossTyConKey = mkPreludeTyConUnique 79 +plusTyConKey = mkPreludeTyConUnique 80 +genUnitTyConKey = mkPreludeTyConUnique 81 \end{code} %************************************************************************ diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs index 7b944ed..fd73bc8 100644 --- a/ghc/compiler/prelude/PrelRules.lhs +++ b/ghc/compiler/prelude/PrelRules.lhs @@ -24,11 +24,11 @@ import Id ( mkWildId ) import Literal ( Literal(..), isLitLitLit, mkMachInt, mkMachWord , literalType , word2IntLit, int2WordLit - , intToInt8Lit, intToInt16Lit, intToInt32Lit - , wordToWord8Lit, wordToWord16Lit, wordToWord32Lit + , narrow8IntLit, narrow16IntLit, narrow32IntLit + , narrow8WordLit, narrow16WordLit, narrow32WordLit , char2IntLit, int2CharLit , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit - , addr2IntLit, int2AddrLit, float2DoubleLit, double2FloatLit + , nullAddrLit, float2DoubleLit, double2FloatLit ) import PrimOp ( PrimOp(..), primOpOcc ) import TysWiredIn ( trueDataConId, falseDataConId ) @@ -60,6 +60,7 @@ primOpRule op = fmap BuiltinRule (primop_rule op) -- ToDo: something for integer-shift ops? -- NotOp + primop_rule AddrNullOp = Just nullAddrRule primop_rule SeqOp = Just seqRule primop_rule TagToEnumOp = Just tagToEnumRule primop_rule DataToTagOp = Just dataToTagRule @@ -89,20 +90,18 @@ primOpRule op = fmap BuiltinRule (primop_rule op) -- coercions primop_rule Word2IntOp = Just (oneLit (litCoerce word2IntLit op_name)) primop_rule Int2WordOp = Just (oneLit (litCoerce int2WordLit op_name)) - primop_rule IntToInt8Op = Just (oneLit (litCoerce intToInt8Lit op_name)) - primop_rule IntToInt16Op = Just (oneLit (litCoerce intToInt16Lit op_name)) - primop_rule IntToInt32Op = Just (oneLit (litCoerce intToInt32Lit op_name)) - primop_rule WordToWord8Op = Just (oneLit (litCoerce wordToWord8Lit op_name)) - primop_rule WordToWord16Op = Just (oneLit (litCoerce wordToWord16Lit op_name)) - primop_rule WordToWord32Op = Just (oneLit (litCoerce wordToWord32Lit op_name)) + primop_rule Narrow8IntOp = Just (oneLit (litCoerce narrow8IntLit op_name)) + primop_rule Narrow16IntOp = Just (oneLit (litCoerce narrow16IntLit op_name)) + primop_rule Narrow32IntOp = Just (oneLit (litCoerce narrow32IntLit op_name)) + primop_rule Narrow8WordOp = Just (oneLit (litCoerce narrow8WordLit op_name)) + primop_rule Narrow16WordOp = Just (oneLit (litCoerce narrow16WordLit op_name)) + primop_rule Narrow32WordOp = Just (oneLit (litCoerce narrow32WordLit op_name)) primop_rule OrdOp = Just (oneLit (litCoerce char2IntLit op_name)) primop_rule ChrOp = Just (oneLit (litCoerce int2CharLit op_name)) primop_rule Float2IntOp = Just (oneLit (litCoerce float2IntLit op_name)) primop_rule Int2FloatOp = Just (oneLit (litCoerce int2FloatLit op_name)) primop_rule Double2IntOp = Just (oneLit (litCoerce double2IntLit op_name)) primop_rule Int2DoubleOp = Just (oneLit (litCoerce int2DoubleLit op_name)) - primop_rule Addr2IntOp = Just (oneLit (litCoerce addr2IntLit op_name)) - primop_rule Int2AddrOp = Just (oneLit (litCoerce int2AddrLit op_name)) -- SUP: Not sure what the standard says about precision in the following 2 cases primop_rule Float2DoubleOp = Just (oneLit (litCoerce float2DoubleLit op_name)) primop_rule Double2FloatOp = Just (oneLit (litCoerce double2FloatLit op_name)) @@ -351,6 +350,10 @@ mkFloatVal f = Lit (convFloating (MachFloat f)) mkDoubleVal d = Lit (convFloating (MachDouble d)) \end{code} +\begin{code} +nullAddrRule _ = Just(SLIT("nullAddr"), Lit(nullAddrLit)) +\end{code} + %************************************************************************ %* * diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 4075028..04efcb3 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -325,7 +325,9 @@ primOpInfo op = pprPanic "primOpInfo:" (ppr op) Some PrimOps need to be called out-of-line because they either need to perform a heap check or they block. + \begin{code} +primOpOutOfLine :: PrimOp -> Bool #include "primop-out-of-line.hs-incl" \end{code} diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs index f36f212..d672241 100644 --- a/ghc/compiler/prelude/TysPrim.lhs +++ b/ghc/compiler/prelude/TysPrim.lhs @@ -38,6 +38,9 @@ module TysPrim( foreignObjPrimTyCon, foreignObjPrimTy, threadIdPrimTyCon, threadIdPrimTy, + int32PrimTyCon, int32PrimTy, + word32PrimTyCon, word32PrimTy, + int64PrimTyCon, int64PrimTy, word64PrimTyCon, word64PrimTy, @@ -74,6 +77,7 @@ primTyCons , doublePrimTyCon , floatPrimTyCon , intPrimTyCon + , int32PrimTyCon , int64PrimTyCon , foreignObjPrimTyCon , bcoPrimTyCon @@ -88,6 +92,7 @@ primTyCons , statePrimTyCon , threadIdPrimTyCon , wordPrimTyCon + , word32PrimTyCon , word64PrimTyCon ] \end{code} @@ -163,12 +168,18 @@ charPrimTyCon = pcPrimTyCon0 charPrimTyConName CharRep intPrimTy = mkTyConTy intPrimTyCon intPrimTyCon = pcPrimTyCon0 intPrimTyConName IntRep +int32PrimTy = mkTyConTy int32PrimTyCon +int32PrimTyCon = pcPrimTyCon0 int32PrimTyConName Int32Rep + int64PrimTy = mkTyConTy int64PrimTyCon int64PrimTyCon = pcPrimTyCon0 int64PrimTyConName Int64Rep wordPrimTy = mkTyConTy wordPrimTyCon wordPrimTyCon = pcPrimTyCon0 wordPrimTyConName WordRep +word32PrimTy = mkTyConTy word32PrimTyCon +word32PrimTyCon = pcPrimTyCon0 word32PrimTyConName Word32Rep + word64PrimTy = mkTyConTy word64PrimTyCon word64PrimTyCon = pcPrimTyCon0 word64PrimTyConName Word64Rep @@ -362,7 +373,9 @@ primRepTyCon CharRep = charPrimTyCon primRepTyCon Int8Rep = charPrimTyCon primRepTyCon IntRep = intPrimTyCon primRepTyCon WordRep = wordPrimTyCon +primRepTyCon Int32Rep = int32PrimTyCon primRepTyCon Int64Rep = int64PrimTyCon +primRepTyCon Word32Rep = word32PrimTyCon primRepTyCon Word64Rep = word64PrimTyCon primRepTyCon AddrRep = addrPrimTyCon primRepTyCon FloatRep = floatPrimTyCon diff --git a/ghc/compiler/prelude/primops.txt b/ghc/compiler/prelude/primops.txt new file mode 100644 index 0000000..e1d6bda --- /dev/null +++ b/ghc/compiler/prelude/primops.txt @@ -0,0 +1,2618 @@ +----------------------------------------------------------------------- +-- $Id: primops.txt,v 1.25 2001/08/17 17:18:53 apt Exp $ +-- +-- Primitive Operations +-- +----------------------------------------------------------------------- + +-- This file is processed by the utility program genprimopcode to produce +-- a number of include files within the compiler and optionally to produce +-- human-readable documentation. +-- +-- It should first be preprocessed. +-- +-- To add a new primop, you currently need to update the following files: +-- +-- - this file (ghc/compiler/prelude/primops.txt), which includes +-- the type of the primop, and various other properties (its +-- strictness attributes, whether it is defined as a macro +-- or as out-of-line code, etc.) +-- +-- - ghc/lib/std/PrelGHC.hi-boot, to declare the primop +-- +-- - if the primop is inline (i.e. a macro), then: +-- ghc/includes/PrimOps.h +-- ghc/compiler/nativeGen/StixPrim.lhs +-- ghc/compiler/nativeGen/MachCode.lhs (if implementation is machine-dependent) +-- +-- - or, for an out-of-line primop: +-- ghc/includes/PrimOps.h (just add the declaration) +-- ghc/rts/PrimOps.hc (define it here) +-- +-- - the User's Guide +-- + +-- This file is divided into named sections, each containing or more primop entries. +-- Section headers have the format: +-- +-- section "section-name" {description} +-- +-- This information is used solely when producing documentation; it is otherwise ignored. +-- The description is optional. +-- +-- The format of each primop entry is as follows: +-- +-- primop internal-name "name-in-program-text" type category {description} attributes + +-- The description is optional. + +-- The default attribute values which apply if you don't specify +-- other ones. Attribute values can be True, False, or arbitrary +-- text between curly brackets. This is a kludge to enable +-- processors of this file to easily get hold of simple info +-- (eg, out_of_line), whilst avoiding parsing complex expressions +-- needed for strictness and usage info. + +defaults + has_side_effects = False + out_of_line = False + commutable = False + needs_wrapper = False + can_fail = False + strictness = { \ arity -> StrictnessInfo (replicate arity wwPrim) False } + usage = { nomangle other } + +-- Currently, documentation is produced using latex, so contents of description fields +-- should be legal latex. Descriptions can contain matched pairs of embedded curly brackets. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +section "The word size story." + {Haskell98 specifies that signed integers (type {\tt Int}) must contain at least 30 + bits. GHC always implements {\tt Int} using the primitive type {\tt Int\#}, whose + size equals the {\tt MachDeps.h} constant {\tt WORD\_SIZE\_IN\_BITS}. This + is normally set based on the {\tt config.h} parameter {\tt 4}, + i.e., 32 bits on 32-bit machines, 64 bits on 64-bit machines. However, it can + also be explicitly set to a smaller number, e.g., 31 bits, to allow the possibility + of using tag bits. Currently GHC itself has only 32-bit and 64-bit variants, + but 30 or 31-bit code can be exported as an external core file for use in + other back ends. + + GHC also implements a primitive unsigned integer type {\tt Word\#} which always + has the same number of bits as {\tt Int\#}. + + In addition, GHC supports families of explicit-sized integers and words at + 8, 16, 32, and 64 bits, with the usual arithmetic operations, comparisons, + and a range of conversions. The 8-bit and 16-bit sizes are always represented as + {\tt Int\#} and {\tt Word\#}, and the operations implemented in terms of the + the primops on these types, with suitable range restrictions on the results + (using the {\tt Narrow$n$Int\#} and {\tt Narrow$n$Word\#} families of primops. + The 32-bit sizes are represented using {\tt Int\#} and {\tt Word\#} when + {\tt WORD\_SIZE\_IN\_BITS} $\geq$ 32; + otherwise, these are represented using distinct primitive types {\tt Int32\#} + and {\tt Word32\#}. These (when needed) have a complete set of corresponding + operations; however, nearly all of these are implemented as external C functions + rather than as primops. Exactly the same story applies to the 64-bit sizes. + All of these details are hidden under the {\tt PrelInt} and {\tt PrelWord} modules, + which use {\tt \#if}-defs to invoke the appropriate types and operators. + + Word size also matters for the families of primops + for indexing/reading/writing fixed-size quantities at offsets from + an array base, address, or foreign pointer. Here, a slightly different approach is taken. + The names of these primops are fixed, but their + {\it types} vary according to the value of {\tt WORD\_SIZE\_IN\_BITS}. For example, if + word size is at least 32 bits then an operator like \texttt{indexInt32Array\#} + has type {\tt ByteArr\# -> Int\# -> Int\#}; otherwise it has type + {\tt ByteArr\# -> Int\# -> Int32\#}. This approach confines the necessary {\tt \#if}-defs to this file; + no conditional compilation is needed in the files that expose these primops, namely \texttt{lib/std/PrelStorable.lhs}, + \texttt{hslibs/lang/ArrayBase.hs}, and (in deprecated fashion) in \texttt{hslibs/lang/ForeignObj.lhs} + and \texttt{hslibs/lang/Addr.lhs}. + + Finally, there are strongly deprecated primops for coercing between {\tt Addr\#}, the primitive + type of machine addresses, and {\tt Int\#}. These are pretty bogus anyway, but will work on + existing 32-bit and 64-bit GHC targets; they are completely bogus when tag bits are used in + {\tt Int\#}, so are not available in this case. +} + +-- Define synonyms for indexing ops. + + + + + + + + + + + + + + + + + +------------------------------------------------------------------------ +section "Char#" + {Operations on 31-bit characters.} +------------------------------------------------------------------------ + + +primop CharGtOp "gtChar#" Compare Char# -> Char# -> Bool +primop CharGeOp "geChar#" Compare Char# -> Char# -> Bool + +primop CharEqOp "eqChar#" Compare + Char# -> Char# -> Bool + with commutable = True + +primop CharNeOp "neChar#" Compare + Char# -> Char# -> Bool + with commutable = True + +primop CharLtOp "ltChar#" Compare Char# -> Char# -> Bool +primop CharLeOp "leChar#" Compare Char# -> Char# -> Bool + +primop OrdOp "ord#" GenPrimOp Char# -> Int# + +------------------------------------------------------------------------ +section "Int#" + {Operations on native-size integers (30+ bits).} +------------------------------------------------------------------------ + +primop IntAddOp "+#" Dyadic + Int# -> Int# -> Int# + with commutable = True + +primop IntSubOp "-#" Dyadic Int# -> Int# -> Int# + +primop IntMulOp "*#" + Dyadic Int# -> Int# -> Int# + with commutable = True + +primop IntQuotOp "quotInt#" Dyadic + Int# -> Int# -> Int# + {Rounds towards zero.} + with can_fail = True + +primop IntRemOp "remInt#" Dyadic + Int# -> Int# -> Int# + {Satisfies \texttt{(quotInt\# x y) *\# y +\# (remInt\# x y) == x}.} + with can_fail = True + +primop IntGcdOp "gcdInt#" Dyadic Int# -> Int# -> Int# +primop IntNegOp "negateInt#" Monadic Int# -> Int# +primop IntAddCOp "addIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) + {Add with carry. First member of result is (wrapped) sum; second member is 0 iff no overflow occured.} +primop IntSubCOp "subIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) + {Subtract with carry. First member of result is (wrapped) difference; second member is 0 iff no overflow occured.} +primop IntMulCOp "mulIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) + {Multiply with carry. First member of result is (wrapped) product; second member is 0 iff no overflow occured.} +primop IntGtOp ">#" Compare Int# -> Int# -> Bool +primop IntGeOp ">=#" Compare Int# -> Int# -> Bool + +primop IntEqOp "==#" Compare + Int# -> Int# -> Bool + with commutable = True + +primop IntNeOp "/=#" Compare + Int# -> Int# -> Bool + with commutable = True + +primop IntLtOp "<#" Compare Int# -> Int# -> Bool +primop IntLeOp "<=#" Compare Int# -> Int# -> Bool + +primop ChrOp "chr#" GenPrimOp Int# -> Char# + +primop Int2WordOp "int2Word#" GenPrimOp Int# -> Word# +primop Int2FloatOp "int2Float#" GenPrimOp Int# -> Float# +primop Int2DoubleOp "int2Double#" GenPrimOp Int# -> Double# + +primop Int2IntegerOp "int2Integer#" + GenPrimOp Int# -> (# Int#, ByteArr# #) + with out_of_line = True + +primop ISllOp "iShiftL#" GenPrimOp Int# -> Int# -> Int# + {Shift left. Return 0 if shifted by more than size of an Int\#.} +primop ISraOp "iShiftRA#" GenPrimOp Int# -> Int# -> Int# + {Shift right arithemetic. Return 0 if shifted by more than size of an Int\#.} +primop ISrlOp "iShiftRL#" GenPrimOp Int# -> Int# -> Int# + {Shift right logical. Return 0 if shifted by more than size of an Int\#.} + +------------------------------------------------------------------------ +section "Word#" + {Operations on native-sized unsigned words (30+ bits).} +------------------------------------------------------------------------ + +primop WordAddOp "plusWord#" Dyadic Word# -> Word# -> Word# + with commutable = True + +primop WordSubOp "minusWord#" Dyadic Word# -> Word# -> Word# + +primop WordMulOp "timesWord#" Dyadic Word# -> Word# -> Word# + with commutable = True + +primop WordQuotOp "quotWord#" Dyadic Word# -> Word# -> Word# + with can_fail = True + +primop WordRemOp "remWord#" Dyadic Word# -> Word# -> Word# + with can_fail = True + +primop AndOp "and#" Dyadic Word# -> Word# -> Word# + with commutable = True + +primop OrOp "or#" Dyadic Word# -> Word# -> Word# + with commutable = True + +primop XorOp "xor#" Dyadic Word# -> Word# -> Word# + with commutable = True + +primop NotOp "not#" Monadic Word# -> Word# + +primop SllOp "shiftL#" GenPrimOp Word# -> Int# -> Word# + {Shift left logical. Return 0 if shifted by more than number of bits in a Word\#.} +primop SrlOp "shiftRL#" GenPrimOp Word# -> Int# -> Word# + {Shift right logical. Return 0 if shifted by more than number of bits in a Word\#.} + +primop Word2IntOp "word2Int#" GenPrimOp Word# -> Int# + +primop Word2IntegerOp "word2Integer#" GenPrimOp + Word# -> (# Int#, ByteArr# #) + with out_of_line = True + +primop WordGtOp "gtWord#" Compare Word# -> Word# -> Bool +primop WordGeOp "geWord#" Compare Word# -> Word# -> Bool +primop WordEqOp "eqWord#" Compare Word# -> Word# -> Bool +primop WordNeOp "neWord#" Compare Word# -> Word# -> Bool +primop WordLtOp "ltWord#" Compare Word# -> Word# -> Bool +primop WordLeOp "leWord#" Compare Word# -> Word# -> Bool + +------------------------------------------------------------------------ +section "Narrowings" + {Explicit narrowing of native-sized ints or words.} +------------------------------------------------------------------------ + +primop Narrow8IntOp "narrow8Int#" Monadic Int# -> Int# +primop Narrow16IntOp "narrow16Int#" Monadic Int# -> Int# +primop Narrow32IntOp "narrow32Int#" Monadic Int# -> Int# +primop Narrow8WordOp "narrow8Word#" Monadic Word# -> Word# +primop Narrow16WordOp "narrow16Word#" Monadic Word# -> Word# +primop Narrow32WordOp "narrow32Word#" Monadic Word# -> Word# + + + + + + +------------------------------------------------------------------------ +section "Int64#" + {Operations on 64-bit unsigned words. This type is only used + if plain Int\# has less than 64 bits. In any case, the operations + are not primops; they are implemented (if needed) as ccalls instead.} +------------------------------------------------------------------------ + +primop Int64ToIntegerOp "int64ToInteger#" GenPrimOp + Int64# -> (# Int#, ByteArr# #) + with out_of_line = True + +------------------------------------------------------------------------ +section "Word64#" + {Operations on 64-bit unsigned words. This type is only used + if plain Word\# has less than 64 bits. In any case, the operations + are not primops; they are implemented (if needed) as ccalls instead.} +------------------------------------------------------------------------ + +primop Word64ToIntegerOp "word64ToInteger#" GenPrimOp + Word64# -> (# Int#, ByteArr# #) + with out_of_line = True + + + +------------------------------------------------------------------------ +section "Integer#" + {Operations on arbitrary-precision integers. These operations are +implemented via the GMP package. An integer is represented as a pair +consisting of an Int\# representing the number of 'limbs' in use and +the sign, and a ByteArr\# containing the 'limbs' themselves. Such pairs +are returned as unboxed pairs, but must be passed as separate components.} +------------------------------------------------------------------------ + +primop IntegerAddOp "plusInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + with commutable = True + out_of_line = True + +primop IntegerSubOp "minusInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + with out_of_line = True + +primop IntegerMulOp "timesInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + with commutable = True + out_of_line = True + +primop IntegerGcdOp "gcdInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + {Greatest common divisor.} + with commutable = True + out_of_line = True + +primop IntegerIntGcdOp "gcdIntegerInt#" GenPrimOp + Int# -> ByteArr# -> Int# -> Int# + {Greatest common divisor, where second argument is an ordinary Int\#.} + -- with commutable = True (surely not? APT 8/01) + +primop IntegerDivExactOp "divExactInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + {Divisor is guaranteed to be a factor of dividend.} + with out_of_line = True + +primop IntegerQuotOp "quotInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + {Rounds towards zero.} + with out_of_line = True + +primop IntegerRemOp "remInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + {Satisfies \texttt{plusInteger\# (timesInteger\# (quotInteger\# x y) y) (remInteger\# x y) == x}.} + with out_of_line = True + +primop IntegerCmpOp "cmpInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> Int# + {Returns -1,0,1 according as first argument is less than, equal to, or greater than second argument.} + with needs_wrapper = True + +primop IntegerCmpIntOp "cmpIntegerInt#" GenPrimOp + Int# -> ByteArr# -> Int# -> Int# + {Returns -1,0,1 according as first argument is less than, equal to, or greater than second argument, which + is an ordinary Int\#.} + with needs_wrapper = True + +primop IntegerQuotRemOp "quotRemInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr#, Int#, ByteArr# #) + {Compute quot and rem simulaneously.} + with can_fail = True + out_of_line = True + +primop IntegerDivModOp "divModInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr#, Int#, ByteArr# #) + {Compute div and mod simultaneously, where div rounds towards negative infinity + and\texttt{(q,r) = divModInteger\#(x,y)} implies \texttt{plusInteger\# (timesInteger\# q y) r = x}.} + with can_fail = True + out_of_line = True + +primop Integer2IntOp "integer2Int#" GenPrimOp + Int# -> ByteArr# -> Int# + with needs_wrapper = True + +primop Integer2WordOp "integer2Word#" GenPrimOp + Int# -> ByteArr# -> Word# + with needs_wrapper = True + + + + + + + + + + +primop IntegerToInt64Op "integerToInt64#" GenPrimOp + Int# -> ByteArr# -> Int64# + +primop IntegerToWord64Op "integerToWord64#" GenPrimOp + Int# -> ByteArr# -> Word64# + + +primop IntegerAndOp "andInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + with out_of_line = True + +primop IntegerOrOp "orInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + with out_of_line = True + +primop IntegerXorOp "xorInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + with out_of_line = True + +primop IntegerComplementOp "complementInteger#" GenPrimOp + Int# -> ByteArr# -> (# Int#, ByteArr# #) + with out_of_line = True + + +------------------------------------------------------------------------ +section "Double#" + {Operations on double-precision (64 bit) floating-point numbers.} +------------------------------------------------------------------------ + +primop DoubleGtOp ">##" Compare Double# -> Double# -> Bool +primop DoubleGeOp ">=##" Compare Double# -> Double# -> Bool + +primop DoubleEqOp "==##" Compare + Double# -> Double# -> Bool + with commutable = True + +primop DoubleNeOp "/=##" Compare + Double# -> Double# -> Bool + with commutable = True + +primop DoubleLtOp "<##" Compare Double# -> Double# -> Bool +primop DoubleLeOp "<=##" Compare Double# -> Double# -> Bool + +primop DoubleAddOp "+##" Dyadic + Double# -> Double# -> Double# + with commutable = True + +primop DoubleSubOp "-##" Dyadic Double# -> Double# -> Double# + +primop DoubleMulOp "*##" Dyadic + Double# -> Double# -> Double# + with commutable = True + +primop DoubleDivOp "/##" Dyadic + Double# -> Double# -> Double# + with can_fail = True + +primop DoubleNegOp "negateDouble#" Monadic Double# -> Double# + +primop Double2IntOp "double2Int#" GenPrimOp Double# -> Int# +primop Double2FloatOp "double2Float#" GenPrimOp Double# -> Float# + +primop DoubleExpOp "expDouble#" Monadic + Double# -> Double# + with needs_wrapper = True + +primop DoubleLogOp "logDouble#" Monadic + Double# -> Double# + with + needs_wrapper = True + can_fail = True + +primop DoubleSqrtOp "sqrtDouble#" Monadic + Double# -> Double# + with needs_wrapper = True + +primop DoubleSinOp "sinDouble#" Monadic + Double# -> Double# + with needs_wrapper = True + +primop DoubleCosOp "cosDouble#" Monadic + Double# -> Double# + with needs_wrapper = True + +primop DoubleTanOp "tanDouble#" Monadic + Double# -> Double# + with needs_wrapper = True + +primop DoubleAsinOp "asinDouble#" Monadic + Double# -> Double# + with + needs_wrapper = True + can_fail = True + +primop DoubleAcosOp "acosDouble#" Monadic + Double# -> Double# + with + needs_wrapper = True + can_fail = True + +primop DoubleAtanOp "atanDouble#" Monadic + Double# -> Double# + with + needs_wrapper = True + +primop DoubleSinhOp "sinhDouble#" Monadic + Double# -> Double# + with needs_wrapper = True + +primop DoubleCoshOp "coshDouble#" Monadic + Double# -> Double# + with needs_wrapper = True + +primop DoubleTanhOp "tanhDouble#" Monadic + Double# -> Double# + with needs_wrapper = True + +primop DoublePowerOp "**##" Dyadic + Double# -> Double# -> Double# + {Exponentiation.} + with needs_wrapper = True + +primop DoubleDecodeOp "decodeDouble#" GenPrimOp + Double# -> (# Int#, Int#, ByteArr# #) + {Convert to arbitrary-precision integer. + First Int\# in result is the exponent; second Int\# and ByteArr\# represent an Integer\# + holding the mantissa.} + with out_of_line = True + +------------------------------------------------------------------------ +section "Float#" + {Operations on single-precision (32-bit) floating-point numbers.} +------------------------------------------------------------------------ + +primop FloatGtOp "gtFloat#" Compare Float# -> Float# -> Bool +primop FloatGeOp "geFloat#" Compare Float# -> Float# -> Bool + +primop FloatEqOp "eqFloat#" Compare + Float# -> Float# -> Bool + with commutable = True + +primop FloatNeOp "neFloat#" Compare + Float# -> Float# -> Bool + with commutable = True + +primop FloatLtOp "ltFloat#" Compare Float# -> Float# -> Bool +primop FloatLeOp "leFloat#" Compare Float# -> Float# -> Bool + +primop FloatAddOp "plusFloat#" Dyadic + Float# -> Float# -> Float# + with commutable = True + +primop FloatSubOp "minusFloat#" Dyadic Float# -> Float# -> Float# + +primop FloatMulOp "timesFloat#" Dyadic + Float# -> Float# -> Float# + with commutable = True + +primop FloatDivOp "divideFloat#" Dyadic + Float# -> Float# -> Float# + with can_fail = True + +primop FloatNegOp "negateFloat#" Monadic Float# -> Float# + +primop Float2IntOp "float2Int#" GenPrimOp Float# -> Int# + +primop FloatExpOp "expFloat#" Monadic + Float# -> Float# + with needs_wrapper = True + +primop FloatLogOp "logFloat#" Monadic + Float# -> Float# + with needs_wrapper = True + can_fail = True + +primop FloatSqrtOp "sqrtFloat#" Monadic + Float# -> Float# + with needs_wrapper = True + +primop FloatSinOp "sinFloat#" Monadic + Float# -> Float# + with needs_wrapper = True + +primop FloatCosOp "cosFloat#" Monadic + Float# -> Float# + with needs_wrapper = True + +primop FloatTanOp "tanFloat#" Monadic + Float# -> Float# + with needs_wrapper = True + +primop FloatAsinOp "asinFloat#" Monadic + Float# -> Float# + with needs_wrapper = True + can_fail = True + +primop FloatAcosOp "acosFloat#" Monadic + Float# -> Float# + with needs_wrapper = True + can_fail = True + +primop FloatAtanOp "atanFloat#" Monadic + Float# -> Float# + with needs_wrapper = True + +primop FloatSinhOp "sinhFloat#" Monadic + Float# -> Float# + with needs_wrapper = True + +primop FloatCoshOp "coshFloat#" Monadic + Float# -> Float# + with needs_wrapper = True + +primop FloatTanhOp "tanhFloat#" Monadic + Float# -> Float# + with needs_wrapper = True + +primop FloatPowerOp "powerFloat#" Dyadic + Float# -> Float# -> Float# + with needs_wrapper = True + +primop Float2DoubleOp "float2Double#" GenPrimOp Float# -> Double# + +primop FloatDecodeOp "decodeFloat#" GenPrimOp + Float# -> (# Int#, Int#, ByteArr# #) + {Convert to arbitrary-precision integer. + First Int\# in result is the exponent; second Int\# and ByteArr\# represent an Integer\# + holding the mantissa.} + with out_of_line = True + +------------------------------------------------------------------------ +section "Arrays" + {Operations on Array\#.} +------------------------------------------------------------------------ + +primop NewArrayOp "newArray#" GenPrimOp + Int# -> a -> State# s -> (# State# s, MutArr# s a #) + {Create a new mutable array of specified size (in bytes), + in the specified state thread, + with each element containing the specified initial value.} + with + strictness = { \ arity -> StrictnessInfo [wwPrim, wwLazy, wwPrim] False } + usage = { mangle NewArrayOp [mkP, mkM, mkP] mkM } + out_of_line = True + +primop SameMutableArrayOp "sameMutableArray#" GenPrimOp + MutArr# s a -> MutArr# s a -> Bool + with + usage = { mangle SameMutableArrayOp [mkP, mkP] mkM } + +primop ReadArrayOp "readArray#" GenPrimOp + MutArr# s a -> Int# -> State# s -> (# State# s, a #) + {Read from specified index of mutable array. Result is not yet evaluated.} + with + usage = { mangle ReadArrayOp [mkM, mkP, mkP] mkM } + +primop WriteArrayOp "writeArray#" GenPrimOp + MutArr# s a -> Int# -> a -> State# s -> State# s + {Write to specified index of mutable array.} + with + usage = { mangle WriteArrayOp [mkM, mkP, mkM, mkP] mkR } + strictness = { \ arity -> StrictnessInfo [wwPrim, wwPrim, wwLazy, wwPrim] False } + has_side_effects = True + +primop IndexArrayOp "indexArray#" GenPrimOp + Array# a -> Int# -> (# a #) + {Read from specified index of immutable array. Result is packaged into + an unboxed singleton; the result itself is not yet evaluated.} + with + usage = { mangle IndexArrayOp [mkM, mkP] mkM } + +primop UnsafeFreezeArrayOp "unsafeFreezeArray#" GenPrimOp + MutArr# s a -> State# s -> (# State# s, Array# a #) + {Make a mutable array immutable, without copying.} + with + usage = { mangle UnsafeFreezeArrayOp [mkM, mkP] mkM } + has_side_effects = True + +primop UnsafeThawArrayOp "unsafeThawArray#" GenPrimOp + Array# a -> State# s -> (# State# s, MutArr# s a #) + {Make an immutable array mutable, without copying.} + with + usage = { mangle UnsafeThawArrayOp [mkM, mkP] mkM } + out_of_line = True + +------------------------------------------------------------------------ +section "Byte Arrays" + {Operations on ByteArray\#. A ByteArray\# is a just a region of + raw memory in the garbage-collected heap, which is not scanned + for pointers. It carries its own size (in bytes). There are + three sets of operations for accessing byte array contents: + index for reading from immutable byte arrays, and read/write + for mutable byte arrays. Each set contains operations for + a range of useful primitive data types. Each operation takes + an offset measured in terms of the size fo the primitive type + being read or written.} + +------------------------------------------------------------------------ + +primop NewByteArrayOp_Char "newByteArray#" GenPrimOp + Int# -> State# s -> (# State# s, MutByteArr# s #) + {Create a new mutable byte array of specified size (in bytes), in + the specified state thread.} + with out_of_line = True + +primop NewPinnedByteArrayOp_Char "newPinnedByteArray#" GenPrimOp + Int# -> State# s -> (# State# s, MutByteArr# s #) + {Create a mutable byte array that the GC guarantees not to move.} + with out_of_line = True + +primop ByteArrayContents_Char "byteArrayContents#" GenPrimOp + ByteArr# -> Addr# + {Intended for use with pinned arrays; otherwise very unsafe!} + +primop SameMutableByteArrayOp "sameMutableByteArray#" GenPrimOp + MutByteArr# s -> MutByteArr# s -> Bool + +primop UnsafeFreezeByteArrayOp "unsafeFreezeByteArray#" GenPrimOp + MutByteArr# s -> State# s -> (# State# s, ByteArr# #) + {Make a mutable byte array immutable, without copying.} + with + has_side_effects = True + +primop SizeofByteArrayOp "sizeofByteArray#" GenPrimOp + ByteArr# -> Int# + +primop SizeofMutableByteArrayOp "sizeofMutableByteArray#" GenPrimOp + MutByteArr# s -> Int# + + +primop IndexByteArrayOp_Char "indexCharArray#" GenPrimOp + ByteArr# -> Int# -> Char# + {Read 8-bit character; offset in bytes.} + +primop IndexByteArrayOp_WideChar "indexWideCharArray#" GenPrimOp + ByteArr# -> Int# -> Char# + {Read 31-bit character; offset in 4-byte words.} + +primop IndexByteArrayOp_Int "indexIntArray#" GenPrimOp + ByteArr# -> Int# -> Int# + +primop IndexByteArrayOp_Word "indexWordArray#" GenPrimOp + ByteArr# -> Int# -> Word# + +primop IndexByteArrayOp_Addr "indexAddrArray#" GenPrimOp + ByteArr# -> Int# -> Addr# + +primop IndexByteArrayOp_Float "indexFloatArray#" GenPrimOp + ByteArr# -> Int# -> Float# + +primop IndexByteArrayOp_Double "indexDoubleArray#" GenPrimOp + ByteArr# -> Int# -> Double# + +primop IndexByteArrayOp_StablePtr "indexStablePtrArray#" GenPrimOp + ByteArr# -> Int# -> StablePtr# a + +primop IndexByteArrayOp_Int8 "indexInt8Array#" GenPrimOp + ByteArr# -> Int# -> Int# + +primop IndexByteArrayOp_Int16 "indexInt16Array#" GenPrimOp + ByteArr# -> Int# -> Int# + +primop IndexByteArrayOp_Int32 "indexInt32Array#" GenPrimOp + ByteArr# -> Int# -> Int# + +primop IndexByteArrayOp_Int64 "indexInt64Array#" GenPrimOp + ByteArr# -> Int# -> Int64# + +primop IndexByteArrayOp_Word8 "indexWord8Array#" GenPrimOp + ByteArr# -> Int# -> Word# + +primop IndexByteArrayOp_Word16 "indexWord16Array#" GenPrimOp + ByteArr# -> Int# -> Word# + +primop IndexByteArrayOp_Word32 "indexWord32Array#" GenPrimOp + ByteArr# -> Int# -> Word# + +primop IndexByteArrayOp_Word64 "indexWord64Array#" GenPrimOp + ByteArr# -> Int# -> Word64# + +primop ReadByteArrayOp_Char "readCharArray#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Char# #) + {Read 8-bit character; offset in bytes.} + +primop ReadByteArrayOp_WideChar "readWideCharArray#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Char# #) + {Read 31-bit character; offset in 4-byte words.} + +primop ReadByteArrayOp_Int "readIntArray#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Int# #) + +primop ReadByteArrayOp_Word "readWordArray#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Word# #) + +primop ReadByteArrayOp_Addr "readAddrArray#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Addr# #) + +primop ReadByteArrayOp_Float "readFloatArray#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Float# #) + +primop ReadByteArrayOp_Double "readDoubleArray#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Double# #) + +primop ReadByteArrayOp_StablePtr "readStablePtrArray#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, StablePtr# a #) + +primop ReadByteArrayOp_Int8 "readInt8Array#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Int# #) + +primop ReadByteArrayOp_Int16 "readInt16Array#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Int# #) + +primop ReadByteArrayOp_Int32 "readInt32Array#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Int# #) + +primop ReadByteArrayOp_Int64 "readInt64Array#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Int64# #) + +primop ReadByteArrayOp_Word8 "readWord8Array#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Word# #) + +primop ReadByteArrayOp_Word16 "readWord16Array#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Word# #) + +primop ReadByteArrayOp_Word32 "readWord32Array#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Word# #) + +primop ReadByteArrayOp_Word64 "readWord64Array#" GenPrimOp + MutByteArr# s -> Int# -> State# s -> (# State# s, Word64# #) + +primop WriteByteArrayOp_Char "writeCharArray#" GenPrimOp + MutByteArr# s -> Int# -> Char# -> State# s -> State# s + {Write 8-bit character; offset in bytes.} + with has_side_effects = True + +primop WriteByteArrayOp_WideChar "writeWideCharArray#" GenPrimOp + MutByteArr# s -> Int# -> Char# -> State# s -> State# s + {Write 31-bit character; offset in 4-byte words.} + with has_side_effects = True + +primop WriteByteArrayOp_Int "writeIntArray#" GenPrimOp + MutByteArr# s -> Int# -> Int# -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_Word "writeWordArray#" GenPrimOp + MutByteArr# s -> Int# -> Word# -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_Addr "writeAddrArray#" GenPrimOp + MutByteArr# s -> Int# -> Addr# -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_Float "writeFloatArray#" GenPrimOp + MutByteArr# s -> Int# -> Float# -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_Double "writeDoubleArray#" GenPrimOp + MutByteArr# s -> Int# -> Double# -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_StablePtr "writeStablePtrArray#" GenPrimOp + MutByteArr# s -> Int# -> StablePtr# a -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_Int8 "writeInt8Array#" GenPrimOp + MutByteArr# s -> Int# -> Int# -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_Int16 "writeInt16Array#" GenPrimOp + MutByteArr# s -> Int# -> Int# -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_Int32 "writeInt32Array#" GenPrimOp + MutByteArr# s -> Int# -> Int# -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_Int64 "writeInt64Array#" GenPrimOp + MutByteArr# s -> Int# -> Int64# -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_Word8 "writeWord8Array#" GenPrimOp + MutByteArr# s -> Int# -> Word# -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_Word16 "writeWord16Array#" GenPrimOp + MutByteArr# s -> Int# -> Word# -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_Word32 "writeWord32Array#" GenPrimOp + MutByteArr# s -> Int# -> Word# -> State# s -> State# s + with has_side_effects = True + +primop WriteByteArrayOp_Word64 "writeWord64Array#" GenPrimOp + MutByteArr# s -> Int# -> Word64# -> State# s -> State# s + with has_side_effects = True + +------------------------------------------------------------------------ +section "Addr#" + {Addr\# is an arbitrary machine address assumed to point outside + the garbage-collected heap.} +------------------------------------------------------------------------ + +primop AddrNullOp "nullAddr#" GenPrimOp Int# -> Addr# + {Returns null address. Argument is ignored (nullary primops + don't quite work!)} +primop AddrAddOp "plusAddr#" GenPrimOp Addr# -> Int# -> Addr# +primop AddrSubOp "minusAddr#" GenPrimOp Addr# -> Addr# -> Int# + {Result is meaningless if two Addr\#s are so far apart that their + difference doesn't fit in an Int\#.} +primop AddrRemOp "remAddr#" GenPrimOp Addr# -> Int# -> Int# + {Return the remainder when the Addr\# arg, treated like an Int\#, + is divided by the Int\# arg.} + +primop Addr2IntOp "addr2Int#" GenPrimOp Addr# -> Int# + {Coerce directly from address to int. Strongly deprecated.} +primop Int2AddrOp "int2Addr#" GenPrimOp Int# -> Addr# + {Coerce directly from int to address. Strongly deprecated.} + + +primop AddrGtOp "gtAddr#" Compare Addr# -> Addr# -> Bool +primop AddrGeOp "geAddr#" Compare Addr# -> Addr# -> Bool +primop AddrEqOp "eqAddr#" Compare Addr# -> Addr# -> Bool +primop AddrNeOp "neAddr#" Compare Addr# -> Addr# -> Bool +primop AddrLtOp "ltAddr#" Compare Addr# -> Addr# -> Bool +primop AddrLeOp "leAddr#" Compare Addr# -> Addr# -> Bool + +primop IndexOffAddrOp_Char "indexCharOffAddr#" GenPrimOp + Addr# -> Int# -> Char# + {Reads 8-bit character; offset in bytes.} + +primop IndexOffAddrOp_WideChar "indexWideCharOffAddr#" GenPrimOp + Addr# -> Int# -> Char# + {Reads 31-bit character; offset in 4-byte words.} + +primop IndexOffAddrOp_Int "indexIntOffAddr#" GenPrimOp + Addr# -> Int# -> Int# + +primop IndexOffAddrOp_Word "indexWordOffAddr#" GenPrimOp + Addr# -> Int# -> Word# + +primop IndexOffAddrOp_Addr "indexAddrOffAddr#" GenPrimOp + Addr# -> Int# -> Addr# + +primop IndexOffAddrOp_Float "indexFloatOffAddr#" GenPrimOp + Addr# -> Int# -> Float# + +primop IndexOffAddrOp_Double "indexDoubleOffAddr#" GenPrimOp + Addr# -> Int# -> Double# + +primop IndexOffAddrOp_StablePtr "indexStablePtrOffAddr#" GenPrimOp + Addr# -> Int# -> StablePtr# a + +primop IndexOffAddrOp_Int8 "indexInt8OffAddr#" GenPrimOp + Addr# -> Int# -> Int# + +primop IndexOffAddrOp_Int16 "indexInt16OffAddr#" GenPrimOp + Addr# -> Int# -> Int# + +primop IndexOffAddrOp_Int32 "indexInt32OffAddr#" GenPrimOp + Addr# -> Int# -> Int# + +primop IndexOffAddrOp_Int64 "indexInt64OffAddr#" GenPrimOp + Addr# -> Int# -> Int64# + +primop IndexOffAddrOp_Word8 "indexWord8OffAddr#" GenPrimOp + Addr# -> Int# -> Word# + +primop IndexOffAddrOp_Word16 "indexWord16OffAddr#" GenPrimOp + Addr# -> Int# -> Word# + +primop IndexOffAddrOp_Word32 "indexWord32OffAddr#" GenPrimOp + Addr# -> Int# -> Word# + +primop IndexOffAddrOp_Word64 "indexWord64OffAddr#" GenPrimOp + Addr# -> Int# -> Word64# + +primop ReadOffAddrOp_Char "readCharOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Char# #) + {Reads 8-bit character; offset in bytes.} + +primop ReadOffAddrOp_WideChar "readWideCharOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Char# #) + {Reads 31-bit character; offset in 4-byte words.} + +primop ReadOffAddrOp_Int "readIntOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Int# #) + +primop ReadOffAddrOp_Word "readWordOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Word# #) + +primop ReadOffAddrOp_Addr "readAddrOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Addr# #) + +primop ReadOffAddrOp_Float "readFloatOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Float# #) + +primop ReadOffAddrOp_Double "readDoubleOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Double# #) + +primop ReadOffAddrOp_StablePtr "readStablePtrOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, StablePtr# a #) + +primop ReadOffAddrOp_Int8 "readInt8OffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Int# #) + +primop ReadOffAddrOp_Int16 "readInt16OffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Int# #) + +primop ReadOffAddrOp_Int32 "readInt32OffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Int# #) + +primop ReadOffAddrOp_Int64 "readInt64OffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Int64# #) + +primop ReadOffAddrOp_Word8 "readWord8OffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Word# #) + +primop ReadOffAddrOp_Word16 "readWord16OffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Word# #) + +primop ReadOffAddrOp_Word32 "readWord32OffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Word# #) + +primop ReadOffAddrOp_Word64 "readWord64OffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, Word64# #) + + +primop WriteOffAddrOp_Char "writeCharOffAddr#" GenPrimOp + Addr# -> Int# -> Char# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_WideChar "writeWideCharOffAddr#" GenPrimOp + Addr# -> Int# -> Char# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Int "writeIntOffAddr#" GenPrimOp + Addr# -> Int# -> Int# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Word "writeWordOffAddr#" GenPrimOp + Addr# -> Int# -> Word# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Addr "writeAddrOffAddr#" GenPrimOp + Addr# -> Int# -> Addr# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_ForeignObj "writeForeignObjOffAddr#" GenPrimOp + Addr# -> Int# -> ForeignObj# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Float "writeFloatOffAddr#" GenPrimOp + Addr# -> Int# -> Float# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Double "writeDoubleOffAddr#" GenPrimOp + Addr# -> Int# -> Double# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_StablePtr "writeStablePtrOffAddr#" GenPrimOp + Addr# -> Int# -> StablePtr# a -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Int8 "writeInt8OffAddr#" GenPrimOp + Addr# -> Int# -> Int# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Int16 "writeInt16OffAddr#" GenPrimOp + Addr# -> Int# -> Int# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Int32 "writeInt32OffAddr#" GenPrimOp + Addr# -> Int# -> Int# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Int64 "writeInt64OffAddr#" GenPrimOp + Addr# -> Int# -> Int64# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Word8 "writeWord8OffAddr#" GenPrimOp + Addr# -> Int# -> Word# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Word16 "writeWord16OffAddr#" GenPrimOp + Addr# -> Int# -> Word# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Word32 "writeWord32OffAddr#" GenPrimOp + Addr# -> Int# -> Word# -> State# s -> State# s + with has_side_effects = True + +primop WriteOffAddrOp_Word64 "writeWord64OffAddr#" GenPrimOp + Addr# -> Int# -> Word64# -> State# s -> State# s + with has_side_effects = True + +------------------------------------------------------------------------ +section "ForeignObj#" + {Operations on ForeignObj\#. The indexing operations are + all deprecated.} +------------------------------------------------------------------------ + +primop MkForeignObjOp "mkForeignObj#" GenPrimOp + Addr# -> State# RealWorld -> (# State# RealWorld, ForeignObj# #) + with + has_side_effects = True + out_of_line = True + +primop WriteForeignObjOp "writeForeignObj#" GenPrimOp + ForeignObj# -> Addr# -> State# s -> State# s + with + has_side_effects = True + +primop ForeignObjToAddrOp "foreignObjToAddr#" GenPrimOp + ForeignObj# -> Addr# + +primop TouchOp "touch#" GenPrimOp + o -> State# RealWorld -> State# RealWorld + with + has_side_effects = True + strictness = { \ arity -> StrictnessInfo [wwLazy, wwPrim] False } + +primop EqForeignObj "eqForeignObj#" GenPrimOp + ForeignObj# -> ForeignObj# -> Bool + with commutable = True + +primop IndexOffForeignObjOp_Char "indexCharOffForeignObj#" GenPrimOp + ForeignObj# -> Int# -> Char# + {Read 8-bit character; offset in bytes.} + +primop IndexOffForeignObjOp_WideChar "indexWideCharOffForeignObj#" GenPrimOp + ForeignObj# -> Int# -> Char# + {Read 31-bit character; offset in 4-byte words.} + +primop IndexOffForeignObjOp_Int "indexIntOffForeignObj#" GenPrimOp + ForeignObj# -> Int# -> Int# + +primop IndexOffForeignObjOp_Word "indexWordOffForeignObj#" GenPrimOp + ForeignObj# -> Int# -> Word# + +primop IndexOffForeignObjOp_Addr "indexAddrOffForeignObj#" GenPrimOp + ForeignObj# -> Int# -> Addr# + +primop IndexOffForeignObjOp_Float "indexFloatOffForeignObj#" GenPrimOp + ForeignObj# -> Int# -> Float# + +primop IndexOffForeignObjOp_Double "indexDoubleOffForeignObj#" GenPrimOp + ForeignObj# -> Int# -> Double# + +primop IndexOffForeignObjOp_StablePtr "indexStablePtrOffForeignObj#" GenPrimOp + ForeignObj# -> Int# -> StablePtr# a + +primop IndexOffForeignObjOp_Int8 "indexInt8OffForeignObj#" GenPrimOp + ForeignObj# -> Int# -> Int# + +primop IndexOffForeignObjOp_Int16 "indexInt16OffForeignObj#" GenPrimOp + ForeignObj# -> Int# -> Int# + +primop IndexOffForeignObjOp_Int32 "indexInt32OffForeignObj#" GenPrimOp + ForeignObj# -> Int# -> Int# + +primop IndexOffForeignObjOp_Int64 "indexInt64OffForeignObj#" GenPrimOp + ForeignObj# -> Int# -> Int64# + +primop IndexOffForeignObjOp_Word8 "indexWord8OffForeignObj#" GenPrimOp + ForeignObj# -> Int# -> Word# + +primop IndexOffForeignObjOp_Word16 "indexWord16OffForeignObj#" GenPrimOp + ForeignObj# -> Int# -> Word# + +primop IndexOffForeignObjOp_Word32 "indexWord32OffForeignObj#" GenPrimOp + ForeignObj# -> Int# -> Word# + +primop IndexOffForeignObjOp_Word64 "indexWord64OffForeignObj#" GenPrimOp + ForeignObj# -> Int# -> Word64# + + + +------------------------------------------------------------------------ +section "Mutable variables" + {Operations on MutVar\#s, which behave like single-element mutable arrays.} +------------------------------------------------------------------------ + +primop NewMutVarOp "newMutVar#" GenPrimOp + a -> State# s -> (# State# s, MutVar# s a #) + {Create MutVar\# with specified initial value in specified state thread.} + with + usage = { mangle NewMutVarOp [mkM, mkP] mkM } + strictness = { \ arity -> StrictnessInfo [wwLazy, wwPrim] False } + out_of_line = True + +primop ReadMutVarOp "readMutVar#" GenPrimOp + MutVar# s a -> State# s -> (# State# s, a #) + {Read contents of MutVar\#. Result is not yet evaluated.} + with + usage = { mangle ReadMutVarOp [mkM, mkP] mkM } + +primop WriteMutVarOp "writeMutVar#" GenPrimOp + MutVar# s a -> a -> State# s -> State# s + {Write contents of MutVar\#.} + with + strictness = { \ arity -> StrictnessInfo [wwPrim, wwLazy, wwPrim] False } + usage = { mangle WriteMutVarOp [mkM, mkM, mkP] mkR } + has_side_effects = True + +primop SameMutVarOp "sameMutVar#" GenPrimOp + MutVar# s a -> MutVar# s a -> Bool + with + usage = { mangle SameMutVarOp [mkP, mkP] mkM } + +------------------------------------------------------------------------ +section "Exceptions" +------------------------------------------------------------------------ + +primop CatchOp "catch#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a #) ) + -> (b -> State# RealWorld -> (# State# RealWorld, a #) ) + -> State# RealWorld + -> (# State# RealWorld, a #) + with + strictness = { \ arity -> StrictnessInfo [wwLazy, wwLazy, wwPrim] False } + -- Catch is actually strict in its first argument + -- but we don't want to tell the strictness + -- analyser about that! + usage = { mangle CatchOp [mkM, mkM . (inFun CatchOp mkM mkM), mkP] mkM } + -- [mkO, mkO . (inFun mkM mkO)] mkO + -- might use caught action multiply + out_of_line = True + +primop RaiseOp "raise#" GenPrimOp + a -> b + with + strictness = { \ arity -> StrictnessInfo [wwLazy] True } + -- NB: True => result is bottom + usage = { mangle RaiseOp [mkM] mkM } + out_of_line = True + +primop BlockAsyncExceptionsOp "blockAsyncExceptions#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a #)) + -> (State# RealWorld -> (# State# RealWorld, a #)) + with + strictness = { \ arity -> StrictnessInfo [wwLazy] False } + out_of_line = True + +primop UnblockAsyncExceptionsOp "unblockAsyncExceptions#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a #)) + -> (State# RealWorld -> (# State# RealWorld, a #)) + with + strictness = { \ arity -> StrictnessInfo [wwLazy] False } + out_of_line = True + +------------------------------------------------------------------------ +section "Synchronized Mutable Variables" + {Operations on MVar\#s, which are shared mutable variables + ({\it not} the same as MutVar\#s!). (Note: in a non-concurrent implementation, + (MVar\# a) can be represented by (MutVar\# (Maybe a)).)} +------------------------------------------------------------------------ + + +primop NewMVarOp "newMVar#" GenPrimOp + State# s -> (# State# s, MVar# s a #) + {Create new mvar; initially empty.} + with + usage = { mangle NewMVarOp [mkP] mkR } + out_of_line = True + +primop TakeMVarOp "takeMVar#" GenPrimOp + MVar# s a -> State# s -> (# State# s, a #) + {If mvar is empty, block until it becomes full. + Then remove and return its contents, and set it empty.} + with + usage = { mangle TakeMVarOp [mkM, mkP] mkM } + has_side_effects = True + out_of_line = True + +primop TryTakeMVarOp "tryTakeMVar#" GenPrimOp + MVar# s a -> State# s -> (# State# s, Int#, a #) + {If mvar is empty, immediately return with integer 0 and value undefined. + Otherwise, return with integer 1 and contents of mvar, and set mvar empty.} + with + usage = { mangle TryTakeMVarOp [mkM, mkP] mkM } + has_side_effects = True + out_of_line = True + +primop PutMVarOp "putMVar#" GenPrimOp + MVar# s a -> a -> State# s -> State# s + {If mvar is full, block until it becomes empty. + Then store value arg as its new contents.} + with + strictness = { \ arity -> StrictnessInfo [wwPrim, wwLazy, wwPrim] False } + usage = { mangle PutMVarOp [mkM, mkM, mkP] mkR } + has_side_effects = True + out_of_line = True + +primop TryPutMVarOp "tryPutMVar#" GenPrimOp + MVar# s a -> a -> State# s -> (# State# s, Int# #) + {If mvar is full, immediately return with integer 0. + Otherwise, store value arg as mvar's new contents, and return with integer 1.} + with + strictness = { \ arity -> StrictnessInfo [wwPrim, wwLazy, wwPrim] False } + usage = { mangle TryPutMVarOp [mkM, mkM, mkP] mkR } + has_side_effects = True + out_of_line = True + +primop SameMVarOp "sameMVar#" GenPrimOp + MVar# s a -> MVar# s a -> Bool + with + usage = { mangle SameMVarOp [mkP, mkP] mkM } + +primop IsEmptyMVarOp "isEmptyMVar#" GenPrimOp + MVar# s a -> State# s -> (# State# s, Int# #) + {Return 1 if mvar is empty; 0 otherwise.} + with + usage = { mangle IsEmptyMVarOp [mkP, mkP] mkM } + + +------------------------------------------------------------------------ +section "Delay/wait operations" +------------------------------------------------------------------------ + +primop DelayOp "delay#" GenPrimOp + Int# -> State# s -> State# s + {Sleep specified number of microseconds.} + with + needs_wrapper = True + has_side_effects = True + out_of_line = True + +primop WaitReadOp "waitRead#" GenPrimOp + Int# -> State# s -> State# s + {Block until input is available on specified file descriptor.} + with + needs_wrapper = True + has_side_effects = True + out_of_line = True + +primop WaitWriteOp "waitWrite#" GenPrimOp + Int# -> State# s -> State# s + {Block until output is possible on specified file descriptor.} + with + needs_wrapper = True + has_side_effects = True + out_of_line = True + +------------------------------------------------------------------------ +section "Concurrency primitives" + {(In a non-concurrent implementation, ThreadId\# can be as singleton + type, whose (unique) value is returned by myThreadId\#. The + other operations can be omitted.)} +------------------------------------------------------------------------ + +primop ForkOp "fork#" GenPrimOp + a -> State# RealWorld -> (# State# RealWorld, ThreadId# #) + with + usage = { mangle ForkOp [mkO, mkP] mkR } + strictness = { \ arity -> StrictnessInfo [wwLazy, wwPrim] False } + has_side_effects = True + out_of_line = True + +primop KillThreadOp "killThread#" GenPrimOp + ThreadId# -> a -> State# RealWorld -> State# RealWorld + with + usage = { mangle KillThreadOp [mkP, mkM, mkP] mkR } + has_side_effects = True + out_of_line = True + +primop YieldOp "yield#" GenPrimOp + State# RealWorld -> State# RealWorld + with + has_side_effects = True + out_of_line = True + +primop MyThreadIdOp "myThreadId#" GenPrimOp + State# RealWorld -> (# State# RealWorld, ThreadId# #) + +------------------------------------------------------------------------ +section "Weak pointers" +------------------------------------------------------------------------ + +-- note that tyvar "o" denotes openAlphaTyVar + +primop MkWeakOp "mkWeak#" GenPrimOp + o -> b -> c -> State# RealWorld -> (# State# RealWorld, Weak# b #) + with + strictness = { \ arity -> StrictnessInfo [wwLazy, wwLazy, wwLazy, wwPrim] False } + usage = { mangle MkWeakOp [mkZ, mkM, mkM, mkP] mkM } + has_side_effects = True + out_of_line = True + +primop DeRefWeakOp "deRefWeak#" GenPrimOp + Weak# a -> State# RealWorld -> (# State# RealWorld, Int#, a #) + with + usage = { mangle DeRefWeakOp [mkM, mkP] mkM } + has_side_effects = True + +primop FinalizeWeakOp "finalizeWeak#" GenPrimOp + Weak# a -> State# RealWorld -> (# State# RealWorld, Int#, + (State# RealWorld -> (# State# RealWorld, Unit #)) #) + with + usage = { mangle FinalizeWeakOp [mkM, mkP] + (mkR . (inUB FinalizeWeakOp + [id,id,inFun FinalizeWeakOp mkR mkM])) } + has_side_effects = True + out_of_line = True + +------------------------------------------------------------------------ +section "Stable pointers and names" +------------------------------------------------------------------------ + +primop MakeStablePtrOp "makeStablePtr#" GenPrimOp + a -> State# RealWorld -> (# State# RealWorld, StablePtr# a #) + with + strictness = { \ arity -> StrictnessInfo [wwLazy, wwPrim] False } + usage = { mangle MakeStablePtrOp [mkM, mkP] mkM } + has_side_effects = True + +primop DeRefStablePtrOp "deRefStablePtr#" GenPrimOp + StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #) + with + usage = { mangle DeRefStablePtrOp [mkM, mkP] mkM } + needs_wrapper = True + has_side_effects = True + +primop EqStablePtrOp "eqStablePtr#" GenPrimOp + StablePtr# a -> StablePtr# a -> Int# + with + usage = { mangle EqStablePtrOp [mkP, mkP] mkR } + has_side_effects = True + +primop MakeStableNameOp "makeStableName#" GenPrimOp + a -> State# RealWorld -> (# State# RealWorld, StableName# a #) + with + usage = { mangle MakeStableNameOp [mkZ, mkP] mkR } + strictness = { \ arity -> StrictnessInfo [wwLazy, wwPrim] False } + needs_wrapper = True + has_side_effects = True + out_of_line = True + +primop EqStableNameOp "eqStableName#" GenPrimOp + StableName# a -> StableName# a -> Int# + with + usage = { mangle EqStableNameOp [mkP, mkP] mkR } + +primop StableNameToIntOp "stableNameToInt#" GenPrimOp + StableName# a -> Int# + with + usage = { mangle StableNameToIntOp [mkP] mkR } + +------------------------------------------------------------------------ +section "Unsafe pointer equality" +-- (#1 Bad Guy: Alistair Reid :) +------------------------------------------------------------------------ + +primop ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp + a -> a -> Int# + with + usage = { mangle ReallyUnsafePtrEqualityOp [mkZ, mkZ] mkR } + +------------------------------------------------------------------------ +section "Parallelism" +------------------------------------------------------------------------ + +primop SeqOp "seq#" GenPrimOp + a -> Int# + with + usage = { mangle SeqOp [mkO] mkR } + strictness = { \ arity -> StrictnessInfo [wwStrict] False } + -- Seq is strict in its argument; see notes in ConFold.lhs + has_side_effects = True + +primop ParOp "par#" GenPrimOp + a -> Int# + with + usage = { mangle ParOp [mkO] mkR } + strictness = { \ arity -> StrictnessInfo [wwLazy] False } + -- Note that Par is lazy to avoid that the sparked thing + -- gets evaluted strictly, which it should *not* be + has_side_effects = True + +-- HWL: The first 4 Int# in all par... annotations denote: +-- name, granularity info, size of result, degree of parallelism +-- Same structure as _seq_ i.e. returns Int# +-- KSW: v, the second arg in parAt# and parAtForNow#, is used only to determine +-- `the processor containing the expression v'; it is not evaluated + +primop ParGlobalOp "parGlobal#" GenPrimOp + a -> Int# -> Int# -> Int# -> Int# -> b -> Int# + with + usage = { mangle ParGlobalOp [mkO, mkP, mkP, mkP, mkP, mkM] mkM } + has_side_effects = True + +primop ParLocalOp "parLocal#" GenPrimOp + a -> Int# -> Int# -> Int# -> Int# -> b -> Int# + with + usage = { mangle ParLocalOp [mkO, mkP, mkP, mkP, mkP, mkM] mkM } + has_side_effects = True + +primop ParAtOp "parAt#" GenPrimOp + b -> a -> Int# -> Int# -> Int# -> Int# -> c -> Int# + with + usage = { mangle ParAtOp [mkO, mkZ, mkP, mkP, mkP, mkP, mkM] mkM } + has_side_effects = True + +primop ParAtAbsOp "parAtAbs#" GenPrimOp + a -> Int# -> Int# -> Int# -> Int# -> Int# -> b -> Int# + with + usage = { mangle ParAtAbsOp [mkO, mkP, mkP, mkP, mkP, mkM] mkM } + has_side_effects = True + +primop ParAtRelOp "parAtRel#" GenPrimOp + a -> Int# -> Int# -> Int# -> Int# -> Int# -> b -> Int# + with + usage = { mangle ParAtRelOp [mkO, mkP, mkP, mkP, mkP, mkM] mkM } + has_side_effects = True + +primop ParAtForNowOp "parAtForNow#" GenPrimOp + b -> a -> Int# -> Int# -> Int# -> Int# -> c -> Int# + with + usage = { mangle ParAtForNowOp [mkO, mkZ, mkP, mkP, mkP, mkP, mkM] mkM } + has_side_effects = True + +-- copyable# and noFollow# are yet to be implemented (for GpH) +-- +--primop CopyableOp "copyable#" GenPrimOp +-- a -> Int# +-- with +-- usage = { mangle CopyableOp [mkZ] mkR } +-- has_side_effects = True +-- +--primop NoFollowOp "noFollow#" GenPrimOp +-- a -> Int# +-- with +-- usage = { mangle NoFollowOp [mkZ] mkR } +-- has_side_effects = True + + +------------------------------------------------------------------------ +section "Tag to enum stuff" + {Convert back and forth between values of enumerated types + and small integers.} +------------------------------------------------------------------------ + +primop DataToTagOp "dataToTag#" GenPrimOp + a -> Int# + with + strictness = { \ arity -> StrictnessInfo [wwLazy] False } + +primop TagToEnumOp "tagToEnum#" GenPrimOp + Int# -> a + +------------------------------------------------------------------------ +section "Bytecode operations" + {Support for the bytecode interpreter and linker.} +------------------------------------------------------------------------ + + +primop AddrToHValueOp "addrToHValue#" GenPrimOp + Addr# -> (# a #) + {Convert an Addr\# to a followable type.} + +primop MkApUpd0_Op "mkApUpd0#" GenPrimOp + a -> (# a #) + with + out_of_line = True + +primop NewBCOOp "newBCO#" GenPrimOp + ByteArr# -> ByteArr# -> Array# a -> ByteArr# -> State# s -> (# State# s, BCO# #) + with + has_side_effects = True + out_of_line = True + +------------------------------------------------------------------------ +--- --- +------------------------------------------------------------------------ + +thats_all_folks + + + diff --git a/ghc/compiler/prelude/primops.txt.pp b/ghc/compiler/prelude/primops.txt.pp index 73aad47..50c7d21 100644 --- a/ghc/compiler/prelude/primops.txt.pp +++ b/ghc/compiler/prelude/primops.txt.pp @@ -1,34 +1,52 @@ ----------------------------------------------------------------------- --- $Id: primops.txt.pp,v 1.3 2001/08/17 00:14:49 sof Exp $ +-- $Id: primops.txt.pp,v 1.4 2001/08/17 17:18:53 apt Exp $ -- -- Primitive Operations -- ----------------------------------------------------------------------- +-- This file is processed by the utility program genprimopcode to produce +-- a number of include files within the compiler and optionally to produce +-- human-readable documentation. +-- +-- It should first be preprocessed. +-- -- To add a new primop, you currently need to update the following files: -- --- - this file (ghc/compiler/prelude/primops.txt.pp), which includes +-- - this file (ghc/compiler/prelude/primops.txt), which includes -- the type of the primop, and various other properties (its -- strictness attributes, whether it is defined as a macro -- or as out-of-line code, etc.) -- --- - ghc/lib/std/PrelGHC.hi-boot.pp, to declare the primop +-- - ghc/lib/std/PrelGHC.hi-boot, to declare the primop -- -- - if the primop is inline (i.e. a macro), then: -- ghc/includes/PrimOps.h --- ghc/compiler/nativeGen/StixPrim.lhs --- +-- ghc/compiler/nativeGen/StixPrim.lhs +-- ghc/compiler/nativeGen/MachCode.lhs (if implementation is machine-dependent) +-- -- - or, for an out-of-line primop: -- ghc/includes/PrimOps.h (just add the declaration) -- ghc/rts/PrimOps.hc (define it here) -- --- - the Users Guide +-- - the User's Guide +-- + +-- This file is divided into named sections, each containing or more primop entries. +-- Section headers have the format: +-- +-- section "section-name" {description} +-- +-- This information is used solely when producing documentation; it is otherwise ignored. +-- The description is optional. +-- +-- The format of each primop entry is as follows: -- +-- primop internal-name "name-in-program-text" type category {description} attributes -#include "config.h" -#include "Derived.h" +-- The description is optional. --- The default attribute values which apply if you dont specify +-- The default attribute values which apply if you don't specify -- other ones. Attribute values can be True, False, or arbitrary -- text between curly brackets. This is a kludge to enable -- processors of this file to easily get hold of simple info @@ -44,63 +62,393 @@ defaults strictness = { \ arity -> StrictnessInfo (replicate arity wwPrim) False } usage = { nomangle other } +-- Currently, documentation is produced using latex, so contents of description fields +-- should be legal latex. Descriptions can contain matched pairs of embedded curly brackets. + +#include "MachDeps.h" + +section "The word size story." + {Haskell98 specifies that signed integers (type {\tt Int}) must contain at least 30 + bits. GHC always implements {\tt Int} using the primitive type {\tt Int\#}, whose + size equals the {\tt MachDeps.h} constant {\tt WORD\_SIZE\_IN\_BITS}. This + is normally set based on the {\tt config.h} parameter {\tt SIZEOF_LONG}, + i.e., 32 bits on 32-bit machines, 64 bits on 64-bit machines. However, it can + also be explicitly set to a smaller number, e.g., 31 bits, to allow the possibility + of using tag bits. Currently GHC itself has only 32-bit and 64-bit variants, + but 30 or 31-bit code can be exported as an external core file for use in + other back ends. + + GHC also implements a primitive unsigned integer type {\tt Word\#} which always + has the same number of bits as {\tt Int\#}. + + In addition, GHC supports families of explicit-sized integers and words at + 8, 16, 32, and 64 bits, with the usual arithmetic operations, comparisons, + and a range of conversions. The 8-bit and 16-bit sizes are always represented as + {\tt Int\#} and {\tt Word\#}, and the operations implemented in terms of the + the primops on these types, with suitable range restrictions on the results + (using the {\tt Narrow$n$Int\#} and {\tt Narrow$n$Word\#} families of primops. + The 32-bit sizes are represented using {\tt Int\#} and {\tt Word\#} when + {\tt WORD\_SIZE\_IN\_BITS} $\geq$ 32; + otherwise, these are represented using distinct primitive types {\tt Int32\#} + and {\tt Word32\#}. These (when needed) have a complete set of corresponding + operations; however, nearly all of these are implemented as external C functions + rather than as primops. Exactly the same story applies to the 64-bit sizes. + All of these details are hidden under the {\tt PrelInt} and {\tt PrelWord} modules, + which use {\tt \#if}-defs to invoke the appropriate types and operators. + + Word size also matters for the families of primops + for indexing/reading/writing fixed-size quantities at offsets from + an array base, address, or foreign pointer. Here, a slightly different approach is taken. + The names of these primops are fixed, but their + {\it types} vary according to the value of {\tt WORD\_SIZE\_IN\_BITS}. For example, if + word size is at least 32 bits then an operator like \texttt{indexInt32Array\#} + has type {\tt ByteArr\# -> Int\# -> Int\#}; otherwise it has type + {\tt ByteArr\# -> Int\# -> Int32\#}. This approach confines the necessary {\tt \#if}-defs to this file; + no conditional compilation is needed in the files that expose these primops, namely \texttt{lib/std/PrelStorable.lhs}, + \texttt{hslibs/lang/ArrayBase.hs}, and (in deprecated fashion) in \texttt{hslibs/lang/ForeignObj.lhs} + and \texttt{hslibs/lang/Addr.lhs}. + + Finally, there are strongly deprecated primops for coercing between {\tt Addr\#}, the primitive + type of machine addresses, and {\tt Int\#}. These are pretty bogus anyway, but will work on + existing 32-bit and 64-bit GHC targets; they are completely bogus when tag bits are used in + {\tt Int\#}, so are not available in this case. +} + +-- Define synonyms for indexing ops. + +#if WORD_SIZE_IN_BITS < 32 +#define INT32 Int32# +#define WORD32 Word32# +#else +#define INT32 Int# +#define WORD32 Word# +#endif + +#if WORD_SIZE_IN_BITS < 64 +#define INT64 Int64# +#define WORD64 Word64# +#else +#define INT64 Int# +#define WORD64 Word# +#endif ------------------------------------------------------------------------ ---- Support for the bytecode interpreter and linker --- +section "Char#" + {Operations on 31-bit characters.} ------------------------------------------------------------------------ --- Convert an Addr# to a followable type -primop AddrToHValueOp "addrToHValue#" GenPrimOp - Addr# -> (# a #) -primop MkApUpd0_Op "mkApUpd0#" GenPrimOp - a -> (# a #) - with - out_of_line = True +primop CharGtOp "gtChar#" Compare Char# -> Char# -> Bool +primop CharGeOp "geChar#" Compare Char# -> Char# -> Bool -primop NewBCOOp "newBCO#" GenPrimOp - ByteArr# -> ByteArr# -> Array# a -> ByteArr# -> State# s -> (# State# s, BCO# #) - with - has_side_effects = True - out_of_line = True +primop CharEqOp "eqChar#" Compare + Char# -> Char# -> Bool + with commutable = True +primop CharNeOp "neChar#" Compare + Char# -> Char# -> Bool + with commutable = True + +primop CharLtOp "ltChar#" Compare Char# -> Char# -> Bool +primop CharLeOp "leChar#" Compare Char# -> Char# -> Bool + +primop OrdOp "ord#" GenPrimOp Char# -> Int# ------------------------------------------------------------------------ ---- Addr# --- +section "Int#" + {Operations on native-size integers (30+ bits).} ------------------------------------------------------------------------ -primop AddrGtOp "gtAddr#" Compare Addr# -> Addr# -> Bool -primop AddrGeOp "geAddr#" Compare Addr# -> Addr# -> Bool -primop AddrEqOp "eqAddr#" Compare Addr# -> Addr# -> Bool -primop AddrNeOp "neAddr#" Compare Addr# -> Addr# -> Bool -primop AddrLtOp "ltAddr#" Compare Addr# -> Addr# -> Bool -primop AddrLeOp "leAddr#" Compare Addr# -> Addr# -> Bool +primop IntAddOp "+#" Dyadic + Int# -> Int# -> Int# + with commutable = True -primop Addr2IntOp "addr2Int#" GenPrimOp Addr# -> Int# +primop IntSubOp "-#" Dyadic Int# -> Int# -> Int# +primop IntMulOp "*#" + Dyadic Int# -> Int# -> Int# + with commutable = True + +primop IntQuotOp "quotInt#" Dyadic + Int# -> Int# -> Int# + {Rounds towards zero.} + with can_fail = True + +primop IntRemOp "remInt#" Dyadic + Int# -> Int# -> Int# + {Satisfies \texttt{(quotInt\# x y) *\# y +\# (remInt\# x y) == x}.} + with can_fail = True + +primop IntGcdOp "gcdInt#" Dyadic Int# -> Int# -> Int# +primop IntNegOp "negateInt#" Monadic Int# -> Int# +primop IntAddCOp "addIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) + {Add with carry. First member of result is (wrapped) sum; second member is 0 iff no overflow occured.} +primop IntSubCOp "subIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) + {Subtract with carry. First member of result is (wrapped) difference; second member is 0 iff no overflow occured.} +primop IntMulCOp "mulIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) + {Multiply with carry. First member of result is (wrapped) product; second member is 0 iff no overflow occured.} +primop IntGtOp ">#" Compare Int# -> Int# -> Bool +primop IntGeOp ">=#" Compare Int# -> Int# -> Bool + +primop IntEqOp "==#" Compare + Int# -> Int# -> Bool + with commutable = True + +primop IntNeOp "/=#" Compare + Int# -> Int# -> Bool + with commutable = True + +primop IntLtOp "<#" Compare Int# -> Int# -> Bool +primop IntLeOp "<=#" Compare Int# -> Int# -> Bool + +primop ChrOp "chr#" GenPrimOp Int# -> Char# + +primop Int2WordOp "int2Word#" GenPrimOp Int# -> Word# +primop Int2FloatOp "int2Float#" GenPrimOp Int# -> Float# +primop Int2DoubleOp "int2Double#" GenPrimOp Int# -> Double# + +primop Int2IntegerOp "int2Integer#" + GenPrimOp Int# -> (# Int#, ByteArr# #) + with out_of_line = True + +primop ISllOp "iShiftL#" GenPrimOp Int# -> Int# -> Int# + {Shift left. Return 0 if shifted by more than size of an Int\#.} +primop ISraOp "iShiftRA#" GenPrimOp Int# -> Int# -> Int# + {Shift right arithemetic. Return 0 if shifted by more than size of an Int\#.} +primop ISrlOp "iShiftRL#" GenPrimOp Int# -> Int# -> Int# + {Shift right logical. Return 0 if shifted by more than size of an Int\#.} ------------------------------------------------------------------------ ---- Char# --- +section "Word#" + {Operations on native-sized unsigned words (30+ bits).} ------------------------------------------------------------------------ -primop CharGtOp "gtChar#" Compare Char# -> Char# -> Bool -primop CharGeOp "geChar#" Compare Char# -> Char# -> Bool +primop WordAddOp "plusWord#" Dyadic Word# -> Word# -> Word# + with commutable = True -primop CharEqOp "eqChar#" Compare - Char# -> Char# -> Bool +primop WordSubOp "minusWord#" Dyadic Word# -> Word# -> Word# + +primop WordMulOp "timesWord#" Dyadic Word# -> Word# -> Word# with commutable = True -primop CharNeOp "neChar#" Compare - Char# -> Char# -> Bool +primop WordQuotOp "quotWord#" Dyadic Word# -> Word# -> Word# + with can_fail = True + +primop WordRemOp "remWord#" Dyadic Word# -> Word# -> Word# + with can_fail = True + +primop AndOp "and#" Dyadic Word# -> Word# -> Word# with commutable = True -primop CharLtOp "ltChar#" Compare Char# -> Char# -> Bool -primop CharLeOp "leChar#" Compare Char# -> Char# -> Bool +primop OrOp "or#" Dyadic Word# -> Word# -> Word# + with commutable = True + +primop XorOp "xor#" Dyadic Word# -> Word# -> Word# + with commutable = True + +primop NotOp "not#" Monadic Word# -> Word# + +primop SllOp "shiftL#" GenPrimOp Word# -> Int# -> Word# + {Shift left logical. Return 0 if shifted by more than number of bits in a Word\#.} +primop SrlOp "shiftRL#" GenPrimOp Word# -> Int# -> Word# + {Shift right logical. Return 0 if shifted by more than number of bits in a Word\#.} + +primop Word2IntOp "word2Int#" GenPrimOp Word# -> Int# + +primop Word2IntegerOp "word2Integer#" GenPrimOp + Word# -> (# Int#, ByteArr# #) + with out_of_line = True + +primop WordGtOp "gtWord#" Compare Word# -> Word# -> Bool +primop WordGeOp "geWord#" Compare Word# -> Word# -> Bool +primop WordEqOp "eqWord#" Compare Word# -> Word# -> Bool +primop WordNeOp "neWord#" Compare Word# -> Word# -> Bool +primop WordLtOp "ltWord#" Compare Word# -> Word# -> Bool +primop WordLeOp "leWord#" Compare Word# -> Word# -> Bool + +------------------------------------------------------------------------ +section "Narrowings" + {Explicit narrowing of native-sized ints or words.} +------------------------------------------------------------------------ + +primop Narrow8IntOp "narrow8Int#" Monadic Int# -> Int# +primop Narrow16IntOp "narrow16Int#" Monadic Int# -> Int# +primop Narrow32IntOp "narrow32Int#" Monadic Int# -> Int# +primop Narrow8WordOp "narrow8Word#" Monadic Word# -> Word# +primop Narrow16WordOp "narrow16Word#" Monadic Word# -> Word# +primop Narrow32WordOp "narrow32Word#" Monadic Word# -> Word# + + +#if WORD_SIZE_IN_BITS < 32 +------------------------------------------------------------------------ +section "Int32#" + {Operations on 32-bit integers (Int32\#). This type is only used + if plain Int\# has less than 32 bits. In any case, the operations + are not primops; they are implemented (if needed) as ccalls instead.} +------------------------------------------------------------------------ + +primop Int32ToIntegerOp "int32ToInteger#" GenPrimOp + Int32# -> (# Int#, ByteArr# #) + with out_of_line = True + + +------------------------------------------------------------------------ +section "Word32#" + {Operations on 32-bit unsigned words. This type is only used + if plain Word\# has less than 32 bits. In any case, the operations + are not primops; they are implemented (if needed) as ccalls instead.} +------------------------------------------------------------------------ + +primop Word32ToIntegerOp "word32ToInteger#" GenPrimOp + Word32# -> (# Int#, ByteArr# #) + with out_of_line = True + + +#endif + + +#if WORD_SIZE_IN_BITS < 64 +------------------------------------------------------------------------ +section "Int64#" + {Operations on 64-bit unsigned words. This type is only used + if plain Int\# has less than 64 bits. In any case, the operations + are not primops; they are implemented (if needed) as ccalls instead.} +------------------------------------------------------------------------ + +primop Int64ToIntegerOp "int64ToInteger#" GenPrimOp + Int64# -> (# Int#, ByteArr# #) + with out_of_line = True + +------------------------------------------------------------------------ +section "Word64#" + {Operations on 64-bit unsigned words. This type is only used + if plain Word\# has less than 64 bits. In any case, the operations + are not primops; they are implemented (if needed) as ccalls instead.} +------------------------------------------------------------------------ + +primop Word64ToIntegerOp "word64ToInteger#" GenPrimOp + Word64# -> (# Int#, ByteArr# #) + with out_of_line = True + +#endif + +------------------------------------------------------------------------ +section "Integer#" + {Operations on arbitrary-precision integers. These operations are +implemented via the GMP package. An integer is represented as a pair +consisting of an Int\# representing the number of 'limbs' in use and +the sign, and a ByteArr\# containing the 'limbs' themselves. Such pairs +are returned as unboxed pairs, but must be passed as separate components.} +------------------------------------------------------------------------ + +primop IntegerAddOp "plusInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + with commutable = True + out_of_line = True + +primop IntegerSubOp "minusInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + with out_of_line = True + +primop IntegerMulOp "timesInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + with commutable = True + out_of_line = True + +primop IntegerGcdOp "gcdInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + {Greatest common divisor.} + with commutable = True + out_of_line = True + +primop IntegerIntGcdOp "gcdIntegerInt#" GenPrimOp + Int# -> ByteArr# -> Int# -> Int# + {Greatest common divisor, where second argument is an ordinary Int\#.} + -- with commutable = True (surely not? APT 8/01) + +primop IntegerDivExactOp "divExactInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + {Divisor is guaranteed to be a factor of dividend.} + with out_of_line = True + +primop IntegerQuotOp "quotInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + {Rounds towards zero.} + with out_of_line = True + +primop IntegerRemOp "remInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + {Satisfies \texttt{plusInteger\# (timesInteger\# (quotInteger\# x y) y) (remInteger\# x y) == x}.} + with out_of_line = True + +primop IntegerCmpOp "cmpInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> Int# + {Returns -1,0,1 according as first argument is less than, equal to, or greater than second argument.} + with needs_wrapper = True + +primop IntegerCmpIntOp "cmpIntegerInt#" GenPrimOp + Int# -> ByteArr# -> Int# -> Int# + {Returns -1,0,1 according as first argument is less than, equal to, or greater than second argument, which + is an ordinary Int\#.} + with needs_wrapper = True + +primop IntegerQuotRemOp "quotRemInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr#, Int#, ByteArr# #) + {Compute quot and rem simulaneously.} + with can_fail = True + out_of_line = True + +primop IntegerDivModOp "divModInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr#, Int#, ByteArr# #) + {Compute div and mod simultaneously, where div rounds towards negative infinity + and\texttt{(q,r) = divModInteger\#(x,y)} implies \texttt{plusInteger\# (timesInteger\# q y) r = x}.} + with can_fail = True + out_of_line = True + +primop Integer2IntOp "integer2Int#" GenPrimOp + Int# -> ByteArr# -> Int# + with needs_wrapper = True + +primop Integer2WordOp "integer2Word#" GenPrimOp + Int# -> ByteArr# -> Word# + with needs_wrapper = True + +#if WORD_SIZE_IN_BITS < 32 +primop IntegerToInt32Op "integerToInt32#" GenPrimOp + Int# -> ByteArr# -> Int32# + +primop IntegerToWord32Op "integerToWord32#" GenPrimOp + Int# -> ByteArr# -> Word32# +#endif + +#if WORD_SIZE_IN_BITS < 64 +primop IntegerToInt64Op "integerToInt64#" GenPrimOp + Int# -> ByteArr# -> Int64# + +primop IntegerToWord64Op "integerToWord64#" GenPrimOp + Int# -> ByteArr# -> Word64# +#endif + +primop IntegerAndOp "andInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + with out_of_line = True + +primop IntegerOrOp "orInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + with out_of_line = True + +primop IntegerXorOp "xorInteger#" GenPrimOp + Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) + with out_of_line = True + +primop IntegerComplementOp "complementInteger#" GenPrimOp + Int# -> ByteArr# -> (# Int#, ByteArr# #) + with out_of_line = True -primop OrdOp "ord#" GenPrimOp Char# -> Int# ------------------------------------------------------------------------ ---- Double# --- +section "Double#" + {Operations on double-precision (64 bit) floating-point numbers.} ------------------------------------------------------------------------ primop DoubleGtOp ">##" Compare Double# -> Double# -> Bool @@ -193,14 +541,19 @@ primop DoubleTanhOp "tanhDouble#" Monadic primop DoublePowerOp "**##" Dyadic Double# -> Double# -> Double# + {Exponentiation.} with needs_wrapper = True primop DoubleDecodeOp "decodeDouble#" GenPrimOp Double# -> (# Int#, Int#, ByteArr# #) + {Convert to arbitrary-precision integer. + First Int\# in result is the exponent; second Int\# and ByteArr\# represent an Integer\# + holding the mantissa.} with out_of_line = True ------------------------------------------------------------------------ ---- Float# --- +section "Float#" + {Operations on single-precision (32-bit) floating-point numbers.} ------------------------------------------------------------------------ primop FloatGtOp "gtFloat#" Compare Float# -> Float# -> Bool @@ -294,258 +647,118 @@ primop Float2DoubleOp "float2Double#" GenPrimOp Float# -> Double# primop FloatDecodeOp "decodeFloat#" GenPrimOp Float# -> (# Int#, Int#, ByteArr# #) + {Convert to arbitrary-precision integer. + First Int\# in result is the exponent; second Int\# and ByteArr\# represent an Integer\# + holding the mantissa.} with out_of_line = True ------------------------------------------------------------------------ ---- Int# --- ------------------------------------------------------------------------- - -primop IntAddOp "+#" Dyadic - Int# -> Int# -> Int# - with commutable = True - -primop IntSubOp "-#" Dyadic Int# -> Int# -> Int# - -primop IntMulOp "*#" - Dyadic Int# -> Int# -> Int# - with commutable = True - -primop IntQuotOp "quotInt#" Dyadic - Int# -> Int# -> Int# - with can_fail = True - -primop IntRemOp "remInt#" Dyadic - Int# -> Int# -> Int# - with can_fail = True - -primop IntGcdOp "gcdInt#" Dyadic Int# -> Int# -> Int# -primop IntNegOp "negateInt#" Monadic Int# -> Int# -primop IntAddCOp "addIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) -primop IntSubCOp "subIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) -primop IntMulCOp "mulIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) -primop IntGtOp ">#" Compare Int# -> Int# -> Bool -primop IntGeOp ">=#" Compare Int# -> Int# -> Bool - -primop IntEqOp "==#" Compare - Int# -> Int# -> Bool - with commutable = True - -primop IntNeOp "/=#" Compare - Int# -> Int# -> Bool - with commutable = True - -primop IntLtOp "<#" Compare Int# -> Int# -> Bool -primop IntLeOp "<=#" Compare Int# -> Int# -> Bool - -primop ChrOp "chr#" GenPrimOp Int# -> Char# - -primop Int2WordOp "int2Word#" GenPrimOp Int# -> Word# -primop Int2AddrOp "int2Addr#"GenPrimOp Int# -> Addr# -primop Int2FloatOp "int2Float#" GenPrimOp Int# -> Float# -primop Int2DoubleOp "int2Double#" GenPrimOp Int# -> Double# - -primop Int2IntegerOp "int2Integer#" - GenPrimOp Int# -> (# Int#, ByteArr# #) - with out_of_line = True - -primop ISllOp "iShiftL#" GenPrimOp Int# -> Int# -> Int# -primop ISraOp "iShiftRA#" GenPrimOp Int# -> Int# -> Int# -primop ISrlOp "iShiftRL#" GenPrimOp Int# -> Int# -> Int# - ------------------------------------------------------------------------- ---- Int64# --- ------------------------------------------------------------------------- - -#ifdef SUPPORT_LONG_LONGS -primop Int64ToIntegerOp "int64ToInteger#" GenPrimOp - Int64# -> (# Int#, ByteArr# #) - with out_of_line = True -#endif - - ------------------------------------------------------------------------- ---- Integer# --- ------------------------------------------------------------------------- - -primop IntegerAddOp "plusInteger#" GenPrimOp - Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) - with commutable = True - out_of_line = True - -primop IntegerSubOp "minusInteger#" GenPrimOp - Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) - with out_of_line = True - -primop IntegerMulOp "timesInteger#" GenPrimOp - Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) - with commutable = True - out_of_line = True - -primop IntegerGcdOp "gcdInteger#" GenPrimOp - Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) - with commutable = True - out_of_line = True - -primop IntegerIntGcdOp "gcdIntegerInt#" GenPrimOp - Int# -> ByteArr# -> Int# -> Int# - with commutable = True - -primop IntegerDivExactOp "divExactInteger#" GenPrimOp - Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) - with out_of_line = True - -primop IntegerQuotOp "quotInteger#" GenPrimOp - Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) - with out_of_line = True - -primop IntegerRemOp "remInteger#" GenPrimOp - Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) - with out_of_line = True - -primop IntegerCmpOp "cmpInteger#" GenPrimOp - Int# -> ByteArr# -> Int# -> ByteArr# -> Int# - with needs_wrapper = True - -primop IntegerCmpIntOp "cmpIntegerInt#" GenPrimOp - Int# -> ByteArr# -> Int# -> Int# - with needs_wrapper = True - -primop IntegerQuotRemOp "quotRemInteger#" GenPrimOp - Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr#, Int#, ByteArr# #) - with can_fail = True - out_of_line = True - -primop IntegerDivModOp "divModInteger#" GenPrimOp - Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr#, Int#, ByteArr# #) - with can_fail = True - out_of_line = True - -primop Integer2IntOp "integer2Int#" GenPrimOp - Int# -> ByteArr# -> Int# - with needs_wrapper = True - -primop Integer2WordOp "integer2Word#" GenPrimOp - Int# -> ByteArr# -> Word# - with needs_wrapper = True - -#ifdef SUPPORT_LONG_LONGS -primop IntegerToInt64Op "integerToInt64#" GenPrimOp - Int# -> ByteArr# -> Int64# - -primop IntegerToWord64Op "integerToWord64#" GenPrimOp - Int# -> ByteArr# -> Word64# -#endif - -primop IntegerAndOp "andInteger#" GenPrimOp - Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) - with out_of_line = True - -primop IntegerOrOp "orInteger#" GenPrimOp - Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) - with out_of_line = True - -primop IntegerXorOp "xorInteger#" GenPrimOp - Int# -> ByteArr# -> Int# -> ByteArr# -> (# Int#, ByteArr# #) - with out_of_line = True - -primop IntegerComplementOp "complementInteger#" GenPrimOp - Int# -> ByteArr# -> (# Int#, ByteArr# #) - with out_of_line = True - ------------------------------------------------------------------------- ---- Word# --- +section "Arrays" + {Operations on Array\#.} ------------------------------------------------------------------------ -primop WordAddOp "plusWord#" Dyadic Word# -> Word# -> Word# - with commutable = True - -primop WordSubOp "minusWord#" Dyadic Word# -> Word# -> Word# - -primop WordMulOp "timesWord#" Dyadic Word# -> Word# -> Word# - with commutable = True - -primop WordQuotOp "quotWord#" Dyadic Word# -> Word# -> Word# - with can_fail = True - -primop WordRemOp "remWord#" Dyadic Word# -> Word# -> Word# - with can_fail = True - -primop AndOp "and#" Dyadic Word# -> Word# -> Word# - with commutable = True - -primop OrOp "or#" Dyadic Word# -> Word# -> Word# - with commutable = True - -primop XorOp "xor#" Dyadic Word# -> Word# -> Word# - with commutable = True - -primop NotOp "not#" Monadic Word# -> Word# - -primop SllOp "shiftL#" GenPrimOp Word# -> Int# -> Word# +primop NewArrayOp "newArray#" GenPrimOp + Int# -> a -> State# s -> (# State# s, MutArr# s a #) + {Create a new mutable array of specified size (in bytes), + in the specified state thread, + with each element containing the specified initial value.} + with + strictness = { \ arity -> StrictnessInfo [wwPrim, wwLazy, wwPrim] False } + usage = { mangle NewArrayOp [mkP, mkM, mkP] mkM } + out_of_line = True -primop SrlOp "shiftRL#" GenPrimOp Word# -> Int# -> Word# +primop SameMutableArrayOp "sameMutableArray#" GenPrimOp + MutArr# s a -> MutArr# s a -> Bool + with + usage = { mangle SameMutableArrayOp [mkP, mkP] mkM } -primop Word2IntOp "word2Int#" GenPrimOp Word# -> Int# +primop ReadArrayOp "readArray#" GenPrimOp + MutArr# s a -> Int# -> State# s -> (# State# s, a #) + {Read from specified index of mutable array. Result is not yet evaluated.} + with + usage = { mangle ReadArrayOp [mkM, mkP, mkP] mkM } -primop Word2IntegerOp "word2Integer#" GenPrimOp - Word# -> (# Int#, ByteArr# #) - with out_of_line = True +primop WriteArrayOp "writeArray#" GenPrimOp + MutArr# s a -> Int# -> a -> State# s -> State# s + {Write to specified index of mutable array.} + with + usage = { mangle WriteArrayOp [mkM, mkP, mkM, mkP] mkR } + strictness = { \ arity -> StrictnessInfo [wwPrim, wwPrim, wwLazy, wwPrim] False } + has_side_effects = True -primop WordGtOp "gtWord#" Compare Word# -> Word# -> Bool -primop WordGeOp "geWord#" Compare Word# -> Word# -> Bool -primop WordEqOp "eqWord#" Compare Word# -> Word# -> Bool -primop WordNeOp "neWord#" Compare Word# -> Word# -> Bool -primop WordLtOp "ltWord#" Compare Word# -> Word# -> Bool -primop WordLeOp "leWord#" Compare Word# -> Word# -> Bool +primop IndexArrayOp "indexArray#" GenPrimOp + Array# a -> Int# -> (# a #) + {Read from specified index of immutable array. Result is packaged into + an unboxed singleton; the result itself is not yet evaluated.} + with + usage = { mangle IndexArrayOp [mkM, mkP] mkM } ------------------------------------------------------------------------- ---- Word64# --- ------------------------------------------------------------------------- +primop UnsafeFreezeArrayOp "unsafeFreezeArray#" GenPrimOp + MutArr# s a -> State# s -> (# State# s, Array# a #) + {Make a mutable array immutable, without copying.} + with + usage = { mangle UnsafeFreezeArrayOp [mkM, mkP] mkM } + has_side_effects = True -#ifdef SUPPORT_LONG_LONGS -primop Word64ToIntegerOp "word64ToInteger#" GenPrimOp - Word64# -> (# Int#, ByteArr# #) - with out_of_line = True -#endif +primop UnsafeThawArrayOp "unsafeThawArray#" GenPrimOp + Array# a -> State# s -> (# State# s, MutArr# s a #) + {Make an immutable array mutable, without copying.} + with + usage = { mangle UnsafeThawArrayOp [mkM, mkP] mkM } + out_of_line = True ------------------------------------------------------------------------ ---- Explicitly sized Int# and Word# --- ------------------------------------------------------------------------- +section "Byte Arrays" + {Operations on ByteArray\#. A ByteArray\# is a just a region of + raw memory in the garbage-collected heap, which is not scanned + for pointers. It carries its own size (in bytes). There are + three sets of operations for accessing byte array contents: + index for reading from immutable byte arrays, and read/write + for mutable byte arrays. Each set contains operations for + a range of useful primitive data types. Each operation takes + an offset measured in terms of the size fo the primitive type + being read or written.} -primop IntToInt8Op "intToInt8#" Monadic Int# -> Int# -primop IntToInt16Op "intToInt16#" Monadic Int# -> Int# -primop IntToInt32Op "intToInt32#" Monadic Int# -> Int# -primop WordToWord8Op "wordToWord8#" Monadic Word# -> Word# -primop WordToWord16Op "wordToWord16#" Monadic Word# -> Word# -primop WordToWord32Op "wordToWord32#" Monadic Word# -> Word# - ------------------------------------------------------------------------- ---- Arrays --- ------------------------------------------------------------------------ -primop NewArrayOp "newArray#" GenPrimOp - Int# -> a -> State# s -> (# State# s, MutArr# s a #) - with - strictness = { \ arity -> StrictnessInfo [wwPrim, wwLazy, wwPrim] False } - usage = { mangle NewArrayOp [mkP, mkM, mkP] mkM } - out_of_line = True - primop NewByteArrayOp_Char "newByteArray#" GenPrimOp Int# -> State# s -> (# State# s, MutByteArr# s #) + {Create a new mutable byte array of specified size (in bytes), in + the specified state thread.} with out_of_line = True primop NewPinnedByteArrayOp_Char "newPinnedByteArray#" GenPrimOp Int# -> State# s -> (# State# s, MutByteArr# s #) + {Create a mutable byte array that the GC guarantees not to move.} with out_of_line = True primop ByteArrayContents_Char "byteArrayContents#" GenPrimOp ByteArr# -> Addr# + {Intended for use with pinned arrays; otherwise very unsafe!} + +primop SameMutableByteArrayOp "sameMutableByteArray#" GenPrimOp + MutByteArr# s -> MutByteArr# s -> Bool + +primop UnsafeFreezeByteArrayOp "unsafeFreezeByteArray#" GenPrimOp + MutByteArr# s -> State# s -> (# State# s, ByteArr# #) + {Make a mutable byte array immutable, without copying.} + with + has_side_effects = True + +primop SizeofByteArrayOp "sizeofByteArray#" GenPrimOp + ByteArr# -> Int# + +primop SizeofMutableByteArrayOp "sizeofMutableByteArray#" GenPrimOp + MutByteArr# s -> Int# + primop IndexByteArrayOp_Char "indexCharArray#" GenPrimOp ByteArr# -> Int# -> Char# + {Read 8-bit character; offset in bytes.} primop IndexByteArrayOp_WideChar "indexWideCharArray#" GenPrimOp ByteArr# -> Int# -> Char# + {Read 31-bit character; offset in 4-byte words.} primop IndexByteArrayOp_Int "indexIntArray#" GenPrimOp ByteArr# -> Int# -> Int# @@ -572,12 +785,10 @@ primop IndexByteArrayOp_Int16 "indexInt16Array#" GenPrimOp ByteArr# -> Int# -> Int# primop IndexByteArrayOp_Int32 "indexInt32Array#" GenPrimOp - ByteArr# -> Int# -> Int# + ByteArr# -> Int# -> INT32 -#ifdef SUPPORT_LONG_LONGS primop IndexByteArrayOp_Int64 "indexInt64Array#" GenPrimOp - ByteArr# -> Int# -> Int64# -#endif + ByteArr# -> Int# -> INT64 primop IndexByteArrayOp_Word8 "indexWord8Array#" GenPrimOp ByteArr# -> Int# -> Word# @@ -586,19 +797,18 @@ primop IndexByteArrayOp_Word16 "indexWord16Array#" GenPrimOp ByteArr# -> Int# -> Word# primop IndexByteArrayOp_Word32 "indexWord32Array#" GenPrimOp - ByteArr# -> Int# -> Word# + ByteArr# -> Int# -> WORD32 -#ifdef SUPPORT_LONG_LONGS primop IndexByteArrayOp_Word64 "indexWord64Array#" GenPrimOp - ByteArr# -> Int# -> Word64# -#endif - + ByteArr# -> Int# -> WORD64 primop ReadByteArrayOp_Char "readCharArray#" GenPrimOp MutByteArr# s -> Int# -> State# s -> (# State# s, Char# #) + {Read 8-bit character; offset in bytes.} primop ReadByteArrayOp_WideChar "readWideCharArray#" GenPrimOp MutByteArr# s -> Int# -> State# s -> (# State# s, Char# #) + {Read 31-bit character; offset in 4-byte words.} primop ReadByteArrayOp_Int "readIntArray#" GenPrimOp MutByteArr# s -> Int# -> State# s -> (# State# s, Int# #) @@ -625,12 +835,10 @@ primop ReadByteArrayOp_Int16 "readInt16Array#" GenPrimOp MutByteArr# s -> Int# -> State# s -> (# State# s, Int# #) primop ReadByteArrayOp_Int32 "readInt32Array#" GenPrimOp - MutByteArr# s -> Int# -> State# s -> (# State# s, Int# #) + MutByteArr# s -> Int# -> State# s -> (# State# s, INT32 #) -#ifdef SUPPORT_LONG_LONGS primop ReadByteArrayOp_Int64 "readInt64Array#" GenPrimOp - MutByteArr# s -> Int# -> State# s -> (# State# s, Int64# #) -#endif + MutByteArr# s -> Int# -> State# s -> (# State# s, INT64 #) primop ReadByteArrayOp_Word8 "readWord8Array#" GenPrimOp MutByteArr# s -> Int# -> State# s -> (# State# s, Word# #) @@ -639,21 +847,19 @@ primop ReadByteArrayOp_Word16 "readWord16Array#" GenPrimOp MutByteArr# s -> Int# -> State# s -> (# State# s, Word# #) primop ReadByteArrayOp_Word32 "readWord32Array#" GenPrimOp - MutByteArr# s -> Int# -> State# s -> (# State# s, Word# #) + MutByteArr# s -> Int# -> State# s -> (# State# s, WORD32 #) -#ifdef SUPPORT_LONG_LONGS primop ReadByteArrayOp_Word64 "readWord64Array#" GenPrimOp - MutByteArr# s -> Int# -> State# s -> (# State# s, Word64# #) -#endif - - + MutByteArr# s -> Int# -> State# s -> (# State# s, WORD64 #) primop WriteByteArrayOp_Char "writeCharArray#" GenPrimOp MutByteArr# s -> Int# -> Char# -> State# s -> State# s + {Write 8-bit character; offset in bytes.} with has_side_effects = True primop WriteByteArrayOp_WideChar "writeWideCharArray#" GenPrimOp MutByteArr# s -> Int# -> Char# -> State# s -> State# s + {Write 31-bit character; offset in 4-byte words.} with has_side_effects = True primop WriteByteArrayOp_Int "writeIntArray#" GenPrimOp @@ -689,14 +895,12 @@ primop WriteByteArrayOp_Int16 "writeInt16Array#" GenPrimOp with has_side_effects = True primop WriteByteArrayOp_Int32 "writeInt32Array#" GenPrimOp - MutByteArr# s -> Int# -> Int# -> State# s -> State# s + MutByteArr# s -> Int# -> INT32 -> State# s -> State# s with has_side_effects = True -#ifdef SUPPORT_LONG_LONGS primop WriteByteArrayOp_Int64 "writeInt64Array#" GenPrimOp - MutByteArr# s -> Int# -> Int64# -> State# s -> State# s + MutByteArr# s -> Int# -> INT64 -> State# s -> State# s with has_side_effects = True -#endif primop WriteByteArrayOp_Word8 "writeWord8Array#" GenPrimOp MutByteArr# s -> Int# -> Word# -> State# s -> State# s @@ -707,21 +911,50 @@ primop WriteByteArrayOp_Word16 "writeWord16Array#" GenPrimOp with has_side_effects = True primop WriteByteArrayOp_Word32 "writeWord32Array#" GenPrimOp - MutByteArr# s -> Int# -> Word# -> State# s -> State# s + MutByteArr# s -> Int# -> WORD32 -> State# s -> State# s with has_side_effects = True -#ifdef SUPPORT_LONG_LONGS primop WriteByteArrayOp_Word64 "writeWord64Array#" GenPrimOp - MutByteArr# s -> Int# -> Word64# -> State# s -> State# s + MutByteArr# s -> Int# -> WORD64 -> State# s -> State# s with has_side_effects = True + +------------------------------------------------------------------------ +section "Addr#" + {Addr\# is an arbitrary machine address assumed to point outside + the garbage-collected heap.} +------------------------------------------------------------------------ + +primop AddrNullOp "nullAddr#" GenPrimOp Int# -> Addr# + {Returns null address. Argument is ignored (nullary primops + don't quite work!)} +primop AddrAddOp "plusAddr#" GenPrimOp Addr# -> Int# -> Addr# +primop AddrSubOp "minusAddr#" GenPrimOp Addr# -> Addr# -> Int# + {Result is meaningless if two Addr\#s are so far apart that their + difference doesn't fit in an Int\#.} +primop AddrRemOp "remAddr#" GenPrimOp Addr# -> Int# -> Int# + {Return the remainder when the Addr\# arg, treated like an Int\#, + is divided by the Int\# arg.} +#if (WORD_SIZE_IN_BITS == 32 || WORD_SIZE_IN_BITS == 64) +primop Addr2IntOp "addr2Int#" GenPrimOp Addr# -> Int# + {Coerce directly from address to int. Strongly deprecated.} +primop Int2AddrOp "int2Addr#" GenPrimOp Int# -> Addr# + {Coerce directly from int to address. Strongly deprecated.} #endif +primop AddrGtOp "gtAddr#" Compare Addr# -> Addr# -> Bool +primop AddrGeOp "geAddr#" Compare Addr# -> Addr# -> Bool +primop AddrEqOp "eqAddr#" Compare Addr# -> Addr# -> Bool +primop AddrNeOp "neAddr#" Compare Addr# -> Addr# -> Bool +primop AddrLtOp "ltAddr#" Compare Addr# -> Addr# -> Bool +primop AddrLeOp "leAddr#" Compare Addr# -> Addr# -> Bool primop IndexOffAddrOp_Char "indexCharOffAddr#" GenPrimOp Addr# -> Int# -> Char# + {Reads 8-bit character; offset in bytes.} primop IndexOffAddrOp_WideChar "indexWideCharOffAddr#" GenPrimOp Addr# -> Int# -> Char# + {Reads 31-bit character; offset in 4-byte words.} primop IndexOffAddrOp_Int "indexIntOffAddr#" GenPrimOp Addr# -> Int# -> Int# @@ -748,12 +981,10 @@ primop IndexOffAddrOp_Int16 "indexInt16OffAddr#" GenPrimOp Addr# -> Int# -> Int# primop IndexOffAddrOp_Int32 "indexInt32OffAddr#" GenPrimOp - Addr# -> Int# -> Int# + Addr# -> Int# -> INT32 -#ifdef SUPPORT_LONG_LONGS primop IndexOffAddrOp_Int64 "indexInt64OffAddr#" GenPrimOp - Addr# -> Int# -> Int64# -#endif + Addr# -> Int# -> INT64 primop IndexOffAddrOp_Word8 "indexWord8OffAddr#" GenPrimOp Addr# -> Int# -> Word# @@ -762,75 +993,18 @@ primop IndexOffAddrOp_Word16 "indexWord16OffAddr#" GenPrimOp Addr# -> Int# -> Word# primop IndexOffAddrOp_Word32 "indexWord32OffAddr#" GenPrimOp - Addr# -> Int# -> Word# + Addr# -> Int# -> WORD32 -#ifdef SUPPORT_LONG_LONGS primop IndexOffAddrOp_Word64 "indexWord64OffAddr#" GenPrimOp - Addr# -> Int# -> Word64# -#endif - - -primop EqForeignObj "eqForeignObj#" GenPrimOp - ForeignObj# -> ForeignObj# -> Bool - with commutable = True - -primop IndexOffForeignObjOp_Char "indexCharOffForeignObj#" GenPrimOp - ForeignObj# -> Int# -> Char# - -primop IndexOffForeignObjOp_WideChar "indexWideCharOffForeignObj#" GenPrimOp - ForeignObj# -> Int# -> Char# - -primop IndexOffForeignObjOp_Int "indexIntOffForeignObj#" GenPrimOp - ForeignObj# -> Int# -> Int# - -primop IndexOffForeignObjOp_Word "indexWordOffForeignObj#" GenPrimOp - ForeignObj# -> Int# -> Word# - -primop IndexOffForeignObjOp_Addr "indexAddrOffForeignObj#" GenPrimOp - ForeignObj# -> Int# -> Addr# - -primop IndexOffForeignObjOp_Float "indexFloatOffForeignObj#" GenPrimOp - ForeignObj# -> Int# -> Float# - -primop IndexOffForeignObjOp_Double "indexDoubleOffForeignObj#" GenPrimOp - ForeignObj# -> Int# -> Double# - -primop IndexOffForeignObjOp_StablePtr "indexStablePtrOffForeignObj#" GenPrimOp - ForeignObj# -> Int# -> StablePtr# a - -primop IndexOffForeignObjOp_Int8 "indexInt8OffForeignObj#" GenPrimOp - ForeignObj# -> Int# -> Int# - -primop IndexOffForeignObjOp_Int16 "indexInt16OffForeignObj#" GenPrimOp - ForeignObj# -> Int# -> Int# - -primop IndexOffForeignObjOp_Int32 "indexInt32OffForeignObj#" GenPrimOp - ForeignObj# -> Int# -> Int# - -#ifdef SUPPORT_LONG_LONGS -primop IndexOffForeignObjOp_Int64 "indexInt64OffForeignObj#" GenPrimOp - ForeignObj# -> Int# -> Int64# -#endif - -primop IndexOffForeignObjOp_Word8 "indexWord8OffForeignObj#" GenPrimOp - ForeignObj# -> Int# -> Word# - -primop IndexOffForeignObjOp_Word16 "indexWord16OffForeignObj#" GenPrimOp - ForeignObj# -> Int# -> Word# - -primop IndexOffForeignObjOp_Word32 "indexWord32OffForeignObj#" GenPrimOp - ForeignObj# -> Int# -> Word# - -#ifdef SUPPORT_LONG_LONGS -primop IndexOffForeignObjOp_Word64 "indexWord64OffForeignObj#" GenPrimOp - ForeignObj# -> Int# -> Word64# -#endif + Addr# -> Int# -> WORD64 primop ReadOffAddrOp_Char "readCharOffAddr#" GenPrimOp Addr# -> Int# -> State# s -> (# State# s, Char# #) + {Reads 8-bit character; offset in bytes.} primop ReadOffAddrOp_WideChar "readWideCharOffAddr#" GenPrimOp Addr# -> Int# -> State# s -> (# State# s, Char# #) + {Reads 31-bit character; offset in 4-byte words.} primop ReadOffAddrOp_Int "readIntOffAddr#" GenPrimOp Addr# -> Int# -> State# s -> (# State# s, Int# #) @@ -857,12 +1031,10 @@ primop ReadOffAddrOp_Int16 "readInt16OffAddr#" GenPrimOp Addr# -> Int# -> State# s -> (# State# s, Int# #) primop ReadOffAddrOp_Int32 "readInt32OffAddr#" GenPrimOp - Addr# -> Int# -> State# s -> (# State# s, Int# #) + Addr# -> Int# -> State# s -> (# State# s, INT32 #) -#ifdef SUPPORT_LONG_LONGS primop ReadOffAddrOp_Int64 "readInt64OffAddr#" GenPrimOp - Addr# -> Int# -> State# s -> (# State# s, Int64# #) -#endif + Addr# -> Int# -> State# s -> (# State# s, INT64 #) primop ReadOffAddrOp_Word8 "readWord8OffAddr#" GenPrimOp Addr# -> Int# -> State# s -> (# State# s, Word# #) @@ -871,12 +1043,10 @@ primop ReadOffAddrOp_Word16 "readWord16OffAddr#" GenPrimOp Addr# -> Int# -> State# s -> (# State# s, Word# #) primop ReadOffAddrOp_Word32 "readWord32OffAddr#" GenPrimOp - Addr# -> Int# -> State# s -> (# State# s, Word# #) + Addr# -> Int# -> State# s -> (# State# s, WORD32 #) -#ifdef SUPPORT_LONG_LONGS primop ReadOffAddrOp_Word64 "readWord64OffAddr#" GenPrimOp - Addr# -> Int# -> State# s -> (# State# s, Word64# #) -#endif + Addr# -> Int# -> State# s -> (# State# s, WORD64 #) primop WriteOffAddrOp_Char "writeCharOffAddr#" GenPrimOp @@ -924,14 +1094,12 @@ primop WriteOffAddrOp_Int16 "writeInt16OffAddr#" GenPrimOp with has_side_effects = True primop WriteOffAddrOp_Int32 "writeInt32OffAddr#" GenPrimOp - Addr# -> Int# -> Int# -> State# s -> State# s + Addr# -> Int# -> INT32 -> State# s -> State# s with has_side_effects = True -#ifdef SUPPORT_LONG_LONGS primop WriteOffAddrOp_Int64 "writeInt64OffAddr#" GenPrimOp - Addr# -> Int# -> Int64# -> State# s -> State# s + Addr# -> Int# -> INT64 -> State# s -> State# s with has_side_effects = True -#endif primop WriteOffAddrOp_Word8 "writeWord8OffAddr#" GenPrimOp Addr# -> Int# -> Word# -> State# s -> State# s @@ -942,71 +1110,103 @@ primop WriteOffAddrOp_Word16 "writeWord16OffAddr#" GenPrimOp with has_side_effects = True primop WriteOffAddrOp_Word32 "writeWord32OffAddr#" GenPrimOp - Addr# -> Int# -> Word# -> State# s -> State# s + Addr# -> Int# -> WORD32 -> State# s -> State# s with has_side_effects = True -#ifdef SUPPORT_LONG_LONGS primop WriteOffAddrOp_Word64 "writeWord64OffAddr#" GenPrimOp - Addr# -> Int# -> Word64# -> State# s -> State# s + Addr# -> Int# -> WORD64 -> State# s -> State# s with has_side_effects = True -#endif - - - -primop SameMutableArrayOp "sameMutableArray#" GenPrimOp - MutArr# s a -> MutArr# s a -> Bool - with - usage = { mangle SameMutableArrayOp [mkP, mkP] mkM } -primop SameMutableByteArrayOp "sameMutableByteArray#" GenPrimOp - MutByteArr# s -> MutByteArr# s -> Bool +------------------------------------------------------------------------ +section "ForeignObj#" + {Operations on ForeignObj\#. The indexing operations are + all deprecated.} +------------------------------------------------------------------------ -primop ReadArrayOp "readArray#" GenPrimOp - MutArr# s a -> Int# -> State# s -> (# State# s, a #) +primop MkForeignObjOp "mkForeignObj#" GenPrimOp + Addr# -> State# RealWorld -> (# State# RealWorld, ForeignObj# #) with - usage = { mangle ReadArrayOp [mkM, mkP, mkP] mkM } + has_side_effects = True + out_of_line = True -primop WriteArrayOp "writeArray#" GenPrimOp - MutArr# s a -> Int# -> a -> State# s -> State# s +primop WriteForeignObjOp "writeForeignObj#" GenPrimOp + ForeignObj# -> Addr# -> State# s -> State# s with - usage = { mangle WriteArrayOp [mkM, mkP, mkM, mkP] mkR } - strictness = { \ arity -> StrictnessInfo [wwPrim, wwPrim, wwLazy, wwPrim] False } has_side_effects = True -primop IndexArrayOp "indexArray#" GenPrimOp - Array# a -> Int# -> (# a #) - with - usage = { mangle IndexArrayOp [mkM, mkP] mkM } +primop ForeignObjToAddrOp "foreignObjToAddr#" GenPrimOp + ForeignObj# -> Addr# -primop UnsafeFreezeArrayOp "unsafeFreezeArray#" GenPrimOp - MutArr# s a -> State# s -> (# State# s, Array# a #) +primop TouchOp "touch#" GenPrimOp + o -> State# RealWorld -> State# RealWorld with - usage = { mangle UnsafeFreezeArrayOp [mkM, mkP] mkM } has_side_effects = True + strictness = { \ arity -> StrictnessInfo [wwLazy, wwPrim] False } -primop UnsafeFreezeByteArrayOp "unsafeFreezeByteArray#" GenPrimOp - MutByteArr# s -> State# s -> (# State# s, ByteArr# #) - with - has_side_effects = True +primop EqForeignObj "eqForeignObj#" GenPrimOp + ForeignObj# -> ForeignObj# -> Bool + with commutable = True -primop UnsafeThawArrayOp "unsafeThawArray#" GenPrimOp - Array# a -> State# s -> (# State# s, MutArr# s a #) - with - usage = { mangle UnsafeThawArrayOp [mkM, mkP] mkM } - out_of_line = True +primop IndexOffForeignObjOp_Char "indexCharOffForeignObj#" GenPrimOp + ForeignObj# -> Int# -> Char# + {Read 8-bit character; offset in bytes.} + +primop IndexOffForeignObjOp_WideChar "indexWideCharOffForeignObj#" GenPrimOp + ForeignObj# -> Int# -> Char# + {Read 31-bit character; offset in 4-byte words.} + +primop IndexOffForeignObjOp_Int "indexIntOffForeignObj#" GenPrimOp + ForeignObj# -> Int# -> Int# + +primop IndexOffForeignObjOp_Word "indexWordOffForeignObj#" GenPrimOp + ForeignObj# -> Int# -> Word# + +primop IndexOffForeignObjOp_Addr "indexAddrOffForeignObj#" GenPrimOp + ForeignObj# -> Int# -> Addr# + +primop IndexOffForeignObjOp_Float "indexFloatOffForeignObj#" GenPrimOp + ForeignObj# -> Int# -> Float# + +primop IndexOffForeignObjOp_Double "indexDoubleOffForeignObj#" GenPrimOp + ForeignObj# -> Int# -> Double# + +primop IndexOffForeignObjOp_StablePtr "indexStablePtrOffForeignObj#" GenPrimOp + ForeignObj# -> Int# -> StablePtr# a + +primop IndexOffForeignObjOp_Int8 "indexInt8OffForeignObj#" GenPrimOp + ForeignObj# -> Int# -> Int# + +primop IndexOffForeignObjOp_Int16 "indexInt16OffForeignObj#" GenPrimOp + ForeignObj# -> Int# -> Int# + +primop IndexOffForeignObjOp_Int32 "indexInt32OffForeignObj#" GenPrimOp + ForeignObj# -> Int# -> INT32 + +primop IndexOffForeignObjOp_Int64 "indexInt64OffForeignObj#" GenPrimOp + ForeignObj# -> Int# -> INT64 + +primop IndexOffForeignObjOp_Word8 "indexWord8OffForeignObj#" GenPrimOp + ForeignObj# -> Int# -> Word# + +primop IndexOffForeignObjOp_Word16 "indexWord16OffForeignObj#" GenPrimOp + ForeignObj# -> Int# -> Word# + +primop IndexOffForeignObjOp_Word32 "indexWord32OffForeignObj#" GenPrimOp + ForeignObj# -> Int# -> WORD32 + +primop IndexOffForeignObjOp_Word64 "indexWord64OffForeignObj#" GenPrimOp + ForeignObj# -> Int# -> WORD64 -primop SizeofByteArrayOp "sizeofByteArray#" GenPrimOp - ByteArr# -> Int# -primop SizeofMutableByteArrayOp "sizeofMutableByteArray#" GenPrimOp - MutByteArr# s -> Int# ------------------------------------------------------------------------ ---- Mutable variables --- +section "Mutable variables" + {Operations on MutVar\#s, which behave like single-element mutable arrays.} ------------------------------------------------------------------------ primop NewMutVarOp "newMutVar#" GenPrimOp a -> State# s -> (# State# s, MutVar# s a #) + {Create MutVar\# with specified initial value in specified state thread.} with usage = { mangle NewMutVarOp [mkM, mkP] mkM } strictness = { \ arity -> StrictnessInfo [wwLazy, wwPrim] False } @@ -1014,11 +1214,13 @@ primop NewMutVarOp "newMutVar#" GenPrimOp primop ReadMutVarOp "readMutVar#" GenPrimOp MutVar# s a -> State# s -> (# State# s, a #) + {Read contents of MutVar\#. Result is not yet evaluated.} with usage = { mangle ReadMutVarOp [mkM, mkP] mkM } primop WriteMutVarOp "writeMutVar#" GenPrimOp MutVar# s a -> a -> State# s -> State# s + {Write contents of MutVar\#.} with strictness = { \ arity -> StrictnessInfo [wwPrim, wwLazy, wwPrim] False } usage = { mangle WriteMutVarOp [mkM, mkM, mkP] mkR } @@ -1030,7 +1232,7 @@ primop SameMutVarOp "sameMutVar#" GenPrimOp usage = { mangle SameMutVarOp [mkP, mkP] mkM } ------------------------------------------------------------------------ ---- Exceptions --- +section "Exceptions" ------------------------------------------------------------------------ primop CatchOp "catch#" GenPrimOp @@ -1041,7 +1243,7 @@ primop CatchOp "catch#" GenPrimOp with strictness = { \ arity -> StrictnessInfo [wwLazy, wwLazy, wwPrim] False } -- Catch is actually strict in its first argument - -- but we dont want to tell the strictness + -- but we don't want to tell the strictness -- analyser about that! usage = { mangle CatchOp [mkM, mkM . (inFun CatchOp mkM mkM), mkP] mkM } -- [mkO, mkO . (inFun mkM mkO)] mkO @@ -1060,28 +1262,35 @@ primop BlockAsyncExceptionsOp "blockAsyncExceptions#" GenPrimOp (State# RealWorld -> (# State# RealWorld, a #)) -> (State# RealWorld -> (# State# RealWorld, a #)) with - strictness = { \ arity -> StrictnessInfo [wwLazy,wwPrim] False } + strictness = { \ arity -> StrictnessInfo [wwLazy] False } out_of_line = True primop UnblockAsyncExceptionsOp "unblockAsyncExceptions#" GenPrimOp (State# RealWorld -> (# State# RealWorld, a #)) -> (State# RealWorld -> (# State# RealWorld, a #)) with - strictness = { \ arity -> StrictnessInfo [wwLazy,wwPrim] False } + strictness = { \ arity -> StrictnessInfo [wwLazy] False } out_of_line = True ------------------------------------------------------------------------ ---- MVars (not the same as mutable variables!) --- +section "Synchronized Mutable Variables" + {Operations on MVar\#s, which are shared mutable variables + ({\it not} the same as MutVar\#s!). (Note: in a non-concurrent implementation, + (MVar\# a) can be represented by (MutVar\# (Maybe a)).)} ------------------------------------------------------------------------ + primop NewMVarOp "newMVar#" GenPrimOp State# s -> (# State# s, MVar# s a #) + {Create new mvar; initially empty.} with usage = { mangle NewMVarOp [mkP] mkR } out_of_line = True primop TakeMVarOp "takeMVar#" GenPrimOp MVar# s a -> State# s -> (# State# s, a #) + {If mvar is empty, block until it becomes full. + Then remove and return its contents, and set it empty.} with usage = { mangle TakeMVarOp [mkM, mkP] mkM } has_side_effects = True @@ -1089,6 +1298,8 @@ primop TakeMVarOp "takeMVar#" GenPrimOp primop TryTakeMVarOp "tryTakeMVar#" GenPrimOp MVar# s a -> State# s -> (# State# s, Int#, a #) + {If mvar is empty, immediately return with integer 0 and value undefined. + Otherwise, return with integer 1 and contents of mvar, and set mvar empty.} with usage = { mangle TryTakeMVarOp [mkM, mkP] mkM } has_side_effects = True @@ -1096,6 +1307,8 @@ primop TryTakeMVarOp "tryTakeMVar#" GenPrimOp primop PutMVarOp "putMVar#" GenPrimOp MVar# s a -> a -> State# s -> State# s + {If mvar is full, block until it becomes empty. + Then store value arg as its new contents.} with strictness = { \ arity -> StrictnessInfo [wwPrim, wwLazy, wwPrim] False } usage = { mangle PutMVarOp [mkM, mkM, mkP] mkR } @@ -1104,6 +1317,8 @@ primop PutMVarOp "putMVar#" GenPrimOp primop TryPutMVarOp "tryPutMVar#" GenPrimOp MVar# s a -> a -> State# s -> (# State# s, Int# #) + {If mvar is full, immediately return with integer 0. + Otherwise, store value arg as mvar's new contents, and return with integer 1.} with strictness = { \ arity -> StrictnessInfo [wwPrim, wwLazy, wwPrim] False } usage = { mangle TryPutMVarOp [mkM, mkM, mkP] mkR } @@ -1117,16 +1332,18 @@ primop SameMVarOp "sameMVar#" GenPrimOp primop IsEmptyMVarOp "isEmptyMVar#" GenPrimOp MVar# s a -> State# s -> (# State# s, Int# #) + {Return 1 if mvar is empty; 0 otherwise.} with usage = { mangle IsEmptyMVarOp [mkP, mkP] mkM } ------------------------------------------------------------------------ ---- delay/wait operations --- +section "Delay/wait operations" ------------------------------------------------------------------------ primop DelayOp "delay#" GenPrimOp Int# -> State# s -> State# s + {Sleep specified number of microseconds.} with needs_wrapper = True has_side_effects = True @@ -1134,6 +1351,7 @@ primop DelayOp "delay#" GenPrimOp primop WaitReadOp "waitRead#" GenPrimOp Int# -> State# s -> State# s + {Block until input is available on specified file descriptor.} with needs_wrapper = True has_side_effects = True @@ -1141,13 +1359,17 @@ primop WaitReadOp "waitRead#" GenPrimOp primop WaitWriteOp "waitWrite#" GenPrimOp Int# -> State# s -> State# s + {Block until output is possible on specified file descriptor.} with needs_wrapper = True has_side_effects = True out_of_line = True ------------------------------------------------------------------------ ---- concurrency primitives --- +section "Concurrency primitives" + {(In a non-concurrent implementation, ThreadId\# can be as singleton + type, whose (unique) value is returned by myThreadId\#. The + other operations can be omitted.)} ------------------------------------------------------------------------ primop ForkOp "fork#" GenPrimOp @@ -1175,31 +1397,7 @@ primop MyThreadIdOp "myThreadId#" GenPrimOp State# RealWorld -> (# State# RealWorld, ThreadId# #) ------------------------------------------------------------------------ ---- foreign objects --- ------------------------------------------------------------------------- - -primop MkForeignObjOp "mkForeignObj#" GenPrimOp - Addr# -> State# RealWorld -> (# State# RealWorld, ForeignObj# #) - with - has_side_effects = True - out_of_line = True - -primop WriteForeignObjOp "writeForeignObj#" GenPrimOp - ForeignObj# -> Addr# -> State# s -> State# s - with - has_side_effects = True - -primop ForeignObjToAddrOp "foreignObjToAddr#" GenPrimOp - ForeignObj# -> Addr# - -primop TouchOp "touch#" GenPrimOp - o -> State# RealWorld -> State# RealWorld - with - has_side_effects = True - strictness = { \ arity -> StrictnessInfo [wwLazy, wwPrim] False } - ------------------------------------------------------------------------- ---- Weak pointers --- +section "Weak pointers" ------------------------------------------------------------------------ -- note that tyvar "o" denotes openAlphaTyVar @@ -1229,7 +1427,7 @@ primop FinalizeWeakOp "finalizeWeak#" GenPrimOp out_of_line = True ------------------------------------------------------------------------ ---- Stable pointers and names --- +section "Stable pointers and names" ------------------------------------------------------------------------ primop MakeStablePtrOp "makeStablePtr#" GenPrimOp @@ -1272,7 +1470,8 @@ primop StableNameToIntOp "stableNameToInt#" GenPrimOp usage = { mangle StableNameToIntOp [mkP] mkR } ------------------------------------------------------------------------ ---- Unsafe pointer equality (#1 Bad Guy: Alistair Reid :) --- +section "Unsafe pointer equality" +-- (#1 Bad Guy: Alistair Reid :) ------------------------------------------------------------------------ primop ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp @@ -1281,7 +1480,7 @@ primop ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp usage = { mangle ReallyUnsafePtrEqualityOp [mkZ, mkZ] mkR } ------------------------------------------------------------------------ ---- Parallelism --- +section "Parallelism" ------------------------------------------------------------------------ primop SeqOp "seq#" GenPrimOp @@ -1305,7 +1504,7 @@ primop ParOp "par#" GenPrimOp -- name, granularity info, size of result, degree of parallelism -- Same structure as _seq_ i.e. returns Int# -- KSW: v, the second arg in parAt# and parAtForNow#, is used only to determine --- "the processor containing the expression v"; it is not evaluated +-- `the processor containing the expression v'; it is not evaluated primop ParGlobalOp "parGlobal#" GenPrimOp a -> Int# -> Int# -> Int# -> Int# -> b -> Int# @@ -1359,7 +1558,9 @@ primop ParAtForNowOp "parAtForNow#" GenPrimOp ------------------------------------------------------------------------ ---- tag to enum stuff --- +section "Tag to enum stuff" + {Convert back and forth between values of enumerated types + and small integers.} ------------------------------------------------------------------------ primop DataToTagOp "dataToTag#" GenPrimOp @@ -1370,10 +1571,32 @@ primop DataToTagOp "dataToTag#" GenPrimOp primop TagToEnumOp "tagToEnum#" GenPrimOp Int# -> a +------------------------------------------------------------------------ +section "Bytecode operations" + {Support for the bytecode interpreter and linker.} +------------------------------------------------------------------------ + -thats_all_folks +primop AddrToHValueOp "addrToHValue#" GenPrimOp + Addr# -> (# a #) + {Convert an Addr\# to a followable type.} + +primop MkApUpd0_Op "mkApUpd0#" GenPrimOp + a -> (# a #) + with + out_of_line = True + +primop NewBCOOp "newBCO#" GenPrimOp + ByteArr# -> ByteArr# -> Array# a -> ByteArr# -> State# s -> (# State# s, BCO# #) + with + has_side_effects = True + out_of_line = True ------------------------------------------------------------------------ --- --- ------------------------------------------------------------------------ +thats_all_folks + + + diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index 950d8ad..00c39a7 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -260,9 +260,13 @@ checkCOrAsmOrDotNetOrInterp other checkCg check = getDOptsTc `thenNF_Tc` \ dflags -> - case check (dopt_HscLang dflags) of - Nothing -> returnNF_Tc () - Just err -> addErrTc (text "Illegal foreign declaration:" <+> err) + let hscLang = dopt_HscLang dflags in + case hscLang of + HscNothing -> returnNF_Tc () + otherwise -> + case check hscLang of + Nothing -> returnNF_Tc () + Just err -> addErrTc (text "Illegal foreign declaration:" <+> err) \end{code} Warnings diff --git a/ghc/includes/MachDeps.h b/ghc/includes/MachDeps.h index 7d59d98..f6a9bc9 100644 --- a/ghc/includes/MachDeps.h +++ b/ghc/includes/MachDeps.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: MachDeps.h,v 1.5 2001/07/19 09:01:40 simonmar Exp $ + * $Id: MachDeps.h,v 1.6 2001/08/17 17:18:53 apt Exp $ * * (c) The GRASP/AQUA Project, Glasgow University, 1998 * (c) The GHC Team, 1998-1999 @@ -16,11 +16,21 @@ #include "config.h" + + #define CHAR_SIZE_IN_BYTES 1 #define ADDR_SIZE_IN_BYTES SIZEOF_VOID_P #define INT_SIZE_IN_BYTES SIZEOF_LONG #define WORD_SIZE_IN_BYTES SIZEOF_LONG +#ifndef WORD_SIZE_IN_BITS +#if WORD_SIZE_IN_BYTES == 4 +#define WORD_SIZE_IN_BITS 32 +#else +#define WORD_SIZE_IN_BITS 64 +#endif +#endif + #define FLOAT_SIZE_IN_BYTES SIZEOF_FLOAT #define DOUBLE_SIZE_IN_BYTES SIZEOF_DOUBLE @@ -35,10 +45,10 @@ #define ALIGNMENT_WORD16 ALIGNMENT_UNSIGNED_SHORT #if SIZEOF_UNSIGNED_INT == 4 -#define SIZEOF_INT32 ALIGNMENT_INT -#define ALIGNMENT_INT32 SIZEOF_INT -#define SIZEOF_WORD32 ALIGNMENT_UNSIGNED_INT -#define ALIGNMENT_WORD32 SIZEOF_UNSIGNED_INT +#define SIZEOF_INT32 SIZEOF_INT +#define ALIGNMENT_INT32 ALIGNMENT_INT +#define SIZEOF_WORD32 SIZEOF_UNSIGNED_INT +#define ALIGNMENT_WORD32 ALIGNMENT_UNSIGNED_INT #else #error GHC untested on this architecture: sizeof(unsigned int) != 4 #endif diff --git a/ghc/includes/PrimOps.h b/ghc/includes/PrimOps.h index a33db9c..5994453 100644 --- a/ghc/includes/PrimOps.h +++ b/ghc/includes/PrimOps.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: PrimOps.h,v 1.80 2001/08/08 10:50:37 simonmar Exp $ + * $Id: PrimOps.h,v 1.81 2001/08/17 17:18:53 apt Exp $ * * (c) The GHC Team, 1998-2000 * @@ -10,6 +10,12 @@ #ifndef PRIMOPS_H #define PRIMOPS_H +#include "MachDeps.h" + +#if WORD_SIZE_IN_BITS < 32 +#error GHC C backend requires 32+-bit words +#endif + /* ----------------------------------------------------------------------------- Helpers for the bytecode linker. -------------------------------------------------------------------------- */ @@ -225,17 +231,21 @@ typedef union { Explicitly sized Int# and Word# PrimOps. -------------------------------------------------------------------------- */ -#define intToInt8zh(r,a) r=(StgInt8)(a) -#define intToInt16zh(r,a) r=(StgInt16)(a) -#define intToInt32zh(r,a) r=(StgInt32)(a) -#define wordToWord8zh(r,a) r=(StgWord8)(a) -#define wordToWord16zh(r,a) r=(StgWord16)(a) -#define wordToWord32zh(r,a) r=(StgWord32)(a) +#define narrow8Intzh(r,a) r=(StgInt8)(a) +#define narrow16Intzh(r,a) r=(StgInt16)(a) +#define narrow32Intzh(r,a) r=(StgInt32)(a) +#define narrow8Wordzh(r,a) r=(StgWord8)(a) +#define narrow16Wordzh(r,a) r=(StgWord16)(a) +#define narrow32Wordzh(r,a) r=(StgWord32)(a) /* ----------------------------------------------------------------------------- Addr# PrimOps. -------------------------------------------------------------------------- */ +#define nullAddrzh(r,i) r=(A_)(0) +#define plusAddrzh(r,a,i) r=((void *)(a)) + (i) +#define minusAddrzh(r,a,b) r=((void *)(a)) - ((void *)(b)) +#define remAddrzh(r,a,i) r=((W_)(a))%(i) #define int2Addrzh(r,a) r=(A_)(a) #define addr2Intzh(r,a) r=(I_)(a) @@ -249,13 +259,16 @@ typedef union { #define readStablePtrOffAddrzh(r,a,i) r=((StgStablePtr *)(a))[i] #define readInt8OffAddrzh(r,a,i) r=((StgInt8 *)(a))[i] #define readInt16OffAddrzh(r,a,i) r=((StgInt16 *)(a))[i] -#define readInt32OffAddrzh(r,a,i) r=((StgInt32 *)(a))[i] #define readWord8OffAddrzh(r,a,i) r=((StgWord8 *)(a))[i] #define readWord16OffAddrzh(r,a,i) r=((StgWord16 *)(a))[i] +#define readInt32OffAddrzh(r,a,i) r=((StgInt32 *)(a))[i] #define readWord32OffAddrzh(r,a,i) r=((StgWord32 *)(a))[i] #ifdef SUPPORT_LONG_LONGS #define readInt64OffAddrzh(r,a,i) r=((LI_ *)(a))[i] #define readWord64OffAddrzh(r,a,i) r=((LW_ *)(a))[i] +#else +#define readInt64OffAddrzh(r,a,i) r=((I_ *)(a))[i] +#define readWord64OffAddrzh(r,a,i) r=((W_ *)(a))[i] #endif #define writeCharOffAddrzh(a,i,v) ((StgWord8 *)(a))[i] = (v) @@ -276,6 +289,9 @@ typedef union { #ifdef SUPPORT_LONG_LONGS #define writeInt64OffAddrzh(a,i,v) ((LI_ *)(a))[i] = (v) #define writeWord64OffAddrzh(a,i,v) ((LW_ *)(a))[i] = (v) +#else +#define writeInt64OffAddrzh(a,i,v) ((I_ *)(a))[i] = (v) +#define writeWord64OffAddrzh(a,i,v) ((W_ *)(a))[i] = (v) #endif #define indexCharOffAddrzh(r,a,i) r=((StgWord8 *)(a))[i] @@ -295,6 +311,9 @@ typedef union { #ifdef SUPPORT_LONG_LONGS #define indexInt64OffAddrzh(r,a,i) r=((LI_ *)(a))[i] #define indexWord64OffAddrzh(r,a,i) r=((LW_ *)(a))[i] +#else +#define indexInt64OffAddrzh(r,a,i) r=((I_ *)(a))[i] +#define indexWord64OffAddrzh(r,a,i) r=((W_ *)(a))[i] #endif /* ----------------------------------------------------------------------------- @@ -538,7 +557,7 @@ LI_ stg_iShiftRL64 (StgInt64, StgInt); LI_ stg_iShiftRA64 (StgInt64, StgInt); LI_ stg_intToInt64 (StgInt); -I_ stg_int64ToInt (StgInt64); +I_ stg_int64ToInt (StgInt64); LW_ stg_int64ToWord64 (StgInt64); LW_ stg_wordToWord64 (StgWord); @@ -593,10 +612,8 @@ extern I_ resetGenSymZh(void); #define readWord8Arrayzh(r,a,i) indexWord8OffAddrzh(r,BYTE_ARR_CTS(a),i) #define readWord16Arrayzh(r,a,i) indexWord16OffAddrzh(r,BYTE_ARR_CTS(a),i) #define readWord32Arrayzh(r,a,i) indexWord32OffAddrzh(r,BYTE_ARR_CTS(a),i) -#ifdef SUPPORT_LONG_LONGS #define readInt64Arrayzh(r,a,i) indexInt64OffAddrzh(r,BYTE_ARR_CTS(a),i) #define readWord64Arrayzh(r,a,i) indexWord64OffAddrzh(r,BYTE_ARR_CTS(a),i) -#endif /* result ("r") arg ignored in write macros! */ #define writeArrayzh(a,i,v) ((PP_) PTRS_ARR_CTS(a))[(i)]=(v) @@ -615,10 +632,8 @@ extern I_ resetGenSymZh(void); #define writeWord8Arrayzh(a,i,v) writeWord8OffAddrzh(BYTE_ARR_CTS(a),i,v) #define writeWord16Arrayzh(a,i,v) writeWord16OffAddrzh(BYTE_ARR_CTS(a),i,v) #define writeWord32Arrayzh(a,i,v) writeWord32OffAddrzh(BYTE_ARR_CTS(a),i,v) -#ifdef SUPPORT_LONG_LONGS #define writeInt64Arrayzh(a,i,v) writeInt64OffAddrzh(BYTE_ARR_CTS(a),i,v) #define writeWord64Arrayzh(a,i,v) writeWord64OffAddrzh(BYTE_ARR_CTS(a),i,v) -#endif #define indexArrayzh(r,a,i) r=((PP_) PTRS_ARR_CTS(a))[(i)] @@ -636,10 +651,8 @@ extern I_ resetGenSymZh(void); #define indexWord8Arrayzh(r,a,i) indexWord8OffAddrzh(r,BYTE_ARR_CTS(a),i) #define indexWord16Arrayzh(r,a,i) indexWord16OffAddrzh(r,BYTE_ARR_CTS(a),i) #define indexWord32Arrayzh(r,a,i) indexWord32OffAddrzh(r,BYTE_ARR_CTS(a),i) -#ifdef SUPPORT_LONG_LONGS #define indexInt64Arrayzh(r,a,i) indexInt64OffAddrzh(r,BYTE_ARR_CTS(a),i) #define indexWord64Arrayzh(r,a,i) indexWord64OffAddrzh(r,BYTE_ARR_CTS(a),i) -#endif /* Freezing arrays-of-ptrs requires changing an info table, for the benefit of the generational collector. It needs to scavenge mutable @@ -932,10 +945,8 @@ EXTFUN_RTS(mkForeignObjzh_fast); #define indexWord8OffForeignObjzh(r,fo,i) indexWord8OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i) #define indexWord16OffForeignObjzh(r,fo,i) indexWord16OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i) #define indexWord32OffForeignObjzh(r,fo,i) indexWord32OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i) -#ifdef SUPPORT_LONG_LONGS #define indexInt64OffForeignObjzh(r,fo,i) indexInt64OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i) #define indexWord64OffForeignObjzh(r,fo,i) indexWord64OffAddrzh(r,ForeignObj_CLOSURE_DATA(fo),i) -#endif /* ----------------------------------------------------------------------------- Constructor tags diff --git a/ghc/lib/std/Makefile b/ghc/lib/std/Makefile index 783aabe..24c9afe 100644 --- a/ghc/lib/std/Makefile +++ b/ghc/lib/std/Makefile @@ -65,7 +65,8 @@ SRC_MKDEPENDHS_OPTS += -I$(GHC_INCLUDE_DIR) #----------------------------------------------------------------------------- # Pre-processing (.pp) files -SRC_CPP_OPTS += -I$(GHC_INCLUDE_DIR) +SRC_CPP_OPTS += -I$(GHC_INCLUDE_DIR) -traditional +SRC_CPP_OPTS += ${GhcLibCppOpts} #----------------------------------------------------------------------------- # Rules diff --git a/ghc/lib/std/PrelBase.lhs b/ghc/lib/std/PrelBase.lhs index 2208f7f..4230561 100644 --- a/ghc/lib/std/PrelBase.lhs +++ b/ghc/lib/std/PrelBase.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $Id: PrelBase.lhs,v 1.50 2001/05/03 19:03:27 qrczak Exp $ +% $Id: PrelBase.lhs,v 1.51 2001/08/17 17:18:54 apt Exp $ % % (c) The University of Glasgow, 1992-2000 % @@ -465,10 +465,15 @@ zeroInt, oneInt, twoInt, maxInt, minInt :: Int zeroInt = I# 0# oneInt = I# 1# twoInt = I# 2# -#if WORD_SIZE_IN_BYTES == 4 + +{- Seems clumsy. Should perhaps put minInt and MaxInt directly into MachDeps.h -} +#if WORD_SIZE_IN_BITS == 31 +minInt = I# (-0x40000000#) +maxInt = I# 0x3FFFFFFF# +#elif WORD_SIZE_IN_BITS == 32 minInt = I# (-0x80000000#) maxInt = I# 0x7FFFFFFF# -#else +#else minInt = I# (-0x8000000000000000#) maxInt = I# 0x7FFFFFFFFFFFFFFF# #endif @@ -657,10 +662,10 @@ gtInt, geInt, eqInt, neInt, ltInt, leInt :: Int -> Int -> Bool "x# <=# x#" forall x#. x# <=# x# = True #-} -#if WORD_SIZE_IN_BYTES == 4 +#if WORD_SIZE_IN_BITS == 32 {-# RULES -"intToInt32#" forall x#. intToInt32# x# = x# -"wordToWord32#" forall x#. wordToWord32# x# = x# +"narrow32Int#" forall x#. narrow32Int# x# = x# +"narrow32Word#" forall x#. narrow32Word# x# = x# #-} #endif diff --git a/ghc/lib/std/PrelBits.lhs b/ghc/lib/std/PrelBits.lhs index d8a8ffd..68b496f 100644 --- a/ghc/lib/std/PrelBits.lhs +++ b/ghc/lib/std/PrelBits.lhs @@ -64,19 +64,12 @@ instance Bits Int where | i# >=# 0# = I# (x# `iShiftL#` i#) | otherwise = I# (x# `iShiftRA#` negateInt# i#) (I# x#) `rotate` (I# i#) = -#if WORD_SIZE_IN_BYTES == 4 I# (word2Int# ((x'# `shiftL#` i'#) `or#` - (x'# `shiftRL#` (32# -# i'#)))) + (x'# `shiftRL#` (wsib -# i'#)))) where x'# = int2Word# x# - i'# = word2Int# (int2Word# i# `and#` int2Word# 31#) -#else - I# (word2Int# ((x'# `shiftL#` i'#) `or#` - (x'# `shiftRL#` (64# -# i'#)))) - where - x'# = int2Word# x# - i'# = word2Int# (int2Word# i# `and#` int2Word# 63#) -#endif - bitSize _ = WORD_SIZE_IN_BYTES * 8 + i'# = word2Int# (int2Word# i# `and#` int2Word# (wsib -# 1#)) + wsib = WORD_SIZE_IN_BITS# {- work around preprocessor problem (??) -} + bitSize _ = WORD_SIZE_IN_BITS isSigned _ = True \end{code} diff --git a/ghc/lib/std/PrelEnum.lhs b/ghc/lib/std/PrelEnum.lhs index c0874a3..882d69a 100644 --- a/ghc/lib/std/PrelEnum.lhs +++ b/ghc/lib/std/PrelEnum.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $Id: PrelEnum.lhs,v 1.14 2001/07/24 06:31:35 ken Exp $ +% $Id: PrelEnum.lhs,v 1.15 2001/08/17 17:18:54 apt Exp $ % % (c) The University of Glasgow, 1992-2000 % @@ -314,7 +314,8 @@ instance Enum Int where fromEnum x = x {-# INLINE enumFrom #-} - enumFrom (I# x) = case maxInt of I# y -> eftInt x y + enumFrom (I# x) = eftInt x maxInt# + where I# maxInt# = maxInt -- Blarg: technically I guess enumFrom isn't strict! {-# INLINE enumFromTo #-} diff --git a/ghc/lib/std/PrelGHC.hi-boot b/ghc/lib/std/PrelGHC.hi-boot new file mode 100644 index 0000000..efedce4 --- /dev/null +++ b/ghc/lib/std/PrelGHC.hi-boot @@ -0,0 +1,1506 @@ +--------------------------------------------------------------------------- +-- PrelGHC.hi-boot +-- +-- This hand-written interface file allows you to bring into scope the +-- primitive operations and types that GHC knows about. +--------------------------------------------------------------------------- + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +__interface "std" PrelGHC 1 0 where + +__export PrelGHC + + ZLzmzgZR -- (->) + + CCallable + CReturnable + +-- Magical assert thingy + assert + + -- constructor tags + tagToEnumzh + getTagzh + dataToTagzh + + -- I/O primitives + RealWorld + realWorldzh + Statezh + + -- Concurrency primitives + ThreadIdzh + myThreadIdzh + forkzh + yieldzh + killThreadzh + blockAsyncExceptionszh + unblockAsyncExceptionszh + delayzh + waitReadzh + waitWritezh + + -- MVars + MVarzh + sameMVarzh + newMVarzh + takeMVarzh + putMVarzh + tryTakeMVarzh + tryPutMVarzh + isEmptyMVarzh + + -- Parallel + seqzh + parzh + parGlobalzh + parLocalzh + parAtzh + parAtAbszh + parAtRelzh + parAtForNowzh + + -- Character Type + Charzh + gtCharzh + geCharzh + eqCharzh + neCharzh + ltCharzh + leCharzh + ordzh + chrzh + + -- Int Type + Intzh + zgzh + zgzezh + zezezh + zszezh + zlzh + zlzezh + zpzh + zmzh + ztzh + quotIntzh + remIntzh + gcdIntzh + negateIntzh + iShiftLzh + iShiftRAzh + iShiftRLzh + addIntCzh + subIntCzh + mulIntCzh + + Wordzh + gtWordzh + geWordzh + eqWordzh + neWordzh + ltWordzh + leWordzh + plusWordzh + minusWordzh + timesWordzh + quotWordzh + remWordzh + andzh + orzh + notzh + xorzh + shiftLzh + shiftRLzh + int2Wordzh + word2Intzh + + narrow8Intzh + narrow16Intzh + narrow32Intzh + narrow8Wordzh + narrow16Wordzh + narrow32Wordzh + + + + + + + + Int64zh + Word64zh + + + Addrzh + nullAddrzh + plusAddrzh + minusAddrzh + remAddrzh + + addr2Intzh + int2Addrzh + + gtAddrzh + geAddrzh + eqAddrzh + neAddrzh + ltAddrzh + leAddrzh + + Floatzh + gtFloatzh + geFloatzh + eqFloatzh + neFloatzh + ltFloatzh + leFloatzh + plusFloatzh + minusFloatzh + timesFloatzh + divideFloatzh + negateFloatzh + float2Intzh + int2Floatzh + expFloatzh + logFloatzh + sqrtFloatzh + sinFloatzh + cosFloatzh + tanFloatzh + asinFloatzh + acosFloatzh + atanFloatzh + sinhFloatzh + coshFloatzh + tanhFloatzh + powerFloatzh + decodeFloatzh + + Doublezh + zgzhzh + zgzezhzh + zezezhzh + zszezhzh + zlzhzh + zlzezhzh + zpzhzh + zmzhzh + ztzhzh + zszhzh + negateDoublezh + double2Intzh + int2Doublezh + double2Floatzh + float2Doublezh + expDoublezh + logDoublezh + sqrtDoublezh + sinDoublezh + cosDoublezh + tanDoublezh + asinDoublezh + acosDoublezh + atanDoublezh + sinhDoublezh + coshDoublezh + tanhDoublezh + ztztzhzh + decodeDoublezh + + cmpIntegerzh + cmpIntegerIntzh + plusIntegerzh + minusIntegerzh + timesIntegerzh + gcdIntegerzh + quotIntegerzh + remIntegerzh + gcdIntegerzh + gcdIntegerIntzh + divExactIntegerzh + quotRemIntegerzh + divModIntegerzh + integer2Intzh + integer2Wordzh + int2Integerzh + word2Integerzh + + + + + + + + integerToInt64zh + integerToWord64zh + int64ToIntegerzh + word64ToIntegerzh + + andIntegerzh + orIntegerzh + xorIntegerzh + complementIntegerzh + + Arrayzh + ByteArrayzh + MutableArrayzh + MutableByteArrayzh + sameMutableArrayzh + sameMutableByteArrayzh + newArrayzh + newByteArrayzh + newPinnedByteArrayzh + byteArrayContentszh + + indexArrayzh + indexCharArrayzh + indexWideCharArrayzh + indexIntArrayzh + indexWordArrayzh + indexAddrArrayzh + indexFloatArrayzh + indexDoubleArrayzh + indexStablePtrArrayzh + indexInt8Arrayzh + indexInt16Arrayzh + indexInt32Arrayzh + indexInt64Arrayzh + indexWord8Arrayzh + indexWord16Arrayzh + indexWord32Arrayzh + indexWord64Arrayzh + + readArrayzh + readCharArrayzh + readWideCharArrayzh + readIntArrayzh + readWordArrayzh + readAddrArrayzh + readFloatArrayzh + readDoubleArrayzh + readStablePtrArrayzh + readInt8Arrayzh + readInt16Arrayzh + readInt32Arrayzh + readInt64Arrayzh + readWord8Arrayzh + readWord16Arrayzh + readWord32Arrayzh + readWord64Arrayzh + + writeArrayzh + writeCharArrayzh + writeWideCharArrayzh + writeIntArrayzh + writeWordArrayzh + writeAddrArrayzh + writeFloatArrayzh + writeDoubleArrayzh + writeStablePtrArrayzh + writeInt8Arrayzh + writeInt16Arrayzh + writeInt32Arrayzh + writeInt64Arrayzh + writeWord8Arrayzh + writeWord16Arrayzh + writeWord32Arrayzh + writeWord64Arrayzh + + indexCharOffAddrzh + indexWideCharOffAddrzh + indexIntOffAddrzh + indexWordOffAddrzh + indexAddrOffAddrzh + indexFloatOffAddrzh + indexDoubleOffAddrzh + indexStablePtrOffAddrzh + indexInt8OffAddrzh + indexInt16OffAddrzh + indexInt32OffAddrzh + indexInt64OffAddrzh + indexWord8OffAddrzh + indexWord16OffAddrzh + indexWord32OffAddrzh + indexWord64OffAddrzh + + readCharOffAddrzh + readWideCharOffAddrzh + readIntOffAddrzh + readWordOffAddrzh + readAddrOffAddrzh + readFloatOffAddrzh + readDoubleOffAddrzh + readStablePtrOffAddrzh + readInt8OffAddrzh + readInt16OffAddrzh + readInt32OffAddrzh + readInt64OffAddrzh + readWord8OffAddrzh + readWord16OffAddrzh + readWord32OffAddrzh + readWord64OffAddrzh + + writeCharOffAddrzh + writeWideCharOffAddrzh + writeIntOffAddrzh + writeWordOffAddrzh + writeAddrOffAddrzh + writeForeignObjOffAddrzh + writeFloatOffAddrzh + writeDoubleOffAddrzh + writeStablePtrOffAddrzh + writeInt8OffAddrzh + writeInt16OffAddrzh + writeInt32OffAddrzh + writeInt64OffAddrzh + writeWord8OffAddrzh + writeWord16OffAddrzh + writeWord32OffAddrzh + writeWord64OffAddrzh + + eqForeignObjzh + indexCharOffForeignObjzh + indexWideCharOffForeignObjzh + indexIntOffForeignObjzh + indexWordOffForeignObjzh + indexAddrOffForeignObjzh + indexFloatOffForeignObjzh + indexDoubleOffForeignObjzh + indexStablePtrOffForeignObjzh + indexInt8OffForeignObjzh + indexInt16OffForeignObjzh + indexInt32OffForeignObjzh + indexInt64OffForeignObjzh + indexWord8OffForeignObjzh + indexWord16OffForeignObjzh + indexWord32OffForeignObjzh + indexWord64OffForeignObjzh + + unsafeFreezzeArrayzh -- Note zz in the middle + unsafeFreezzeByteArrayzh -- Ditto + + unsafeThawArrayzh + + sizzeofByteArrayzh -- Ditto + sizzeofMutableByteArrayzh -- Ditto + + MutVarzh + newMutVarzh + readMutVarzh + writeMutVarzh + sameMutVarzh + + catchzh + raisezh + + Weakzh + mkWeakzh + deRefWeakzh + finalizzeWeakzh + + ForeignObjzh + mkForeignObjzh + writeForeignObjzh + foreignObjToAddrzh + touchzh + + StablePtrzh + makeStablePtrzh + deRefStablePtrzh + eqStablePtrzh + + StableNamezh + makeStableNamezh + eqStableNamezh + stableNameToIntzh + + reallyUnsafePtrEqualityzh + + newBCOzh + BCOzh + mkApUpd0zh + + unsafeCoercezh + addrToHValuezh +; + +-- Export PrelErr.error, so that others do not have to import PrelErr +__export PrelErr error ; + + +-------------------------------------------------- +instance {CCallable Charzh} = zdfCCallableCharzh; +instance {CCallable Doublezh} = zdfCCallableDoublezh; +instance {CCallable Floatzh} = zdfCCallableFloatzh; +instance {CCallable Intzh} = zdfCCallableIntzh; +instance {CCallable Addrzh} = zdfCCallableAddrzh; +instance {CCallable Int64zh} = zdfCCallableInt64zh; +instance {CCallable Word64zh} = zdfCCallableWord64zh; +instance {CCallable Wordzh} = zdfCCallableWordzh; +instance {CCallable ByteArrayzh} = zdfCCallableByteArrayzh; +instance __forall s => {CCallable (MutableByteArrayzh s)} = zdfCCallableMutableByteArrayzh; +instance {CCallable ForeignObjzh} = zdfCCallableForeignObjzh; +instance __forall s => {CCallable (StablePtrzh s)} = zdfCCallableStablePtrzh; +-- CCallable and CReturnable have kind (Type AnyBox) so that +-- things like Int# can be instances of CCallable. +1 class CCallable a :: ? ; +1 class CReturnable a :: ? ; + +1 assert :: __forall a => PrelBase.Bool -> a -> a ; + +-- These guys do not really exist: +-- +1 zdfCCallableCharzh :: {CCallable Charzh} ; +1 zdfCCallableDoublezh :: {CCallable Doublezh} ; +1 zdfCCallableFloatzh :: {CCallable Floatzh} ; +1 zdfCCallableIntzh :: {CCallable Intzh} ; +1 zdfCCallableAddrzh :: {CCallable Addrzh} ; +1 zdfCCallableInt64zh :: {CCallable Int64zh} ; +1 zdfCCallableWord64zh :: {CCallable Word64zh} ; +1 zdfCCallableWordzh :: {CCallable Wordzh} ; +1 zdfCCallableByteArrayzh :: {CCallable ByteArrayzh} ; +1 zdfCCallableMutableByteArrayzh :: __forall s => {CCallable (MutableByteArrayzh s)} ; +1 zdfCCallableForeignObjzh :: {CCallable ForeignObjzh} ; +1 zdfCCallableStablePtrzh :: __forall a => {CCallable (StablePtrzh a)} ; diff --git a/ghc/lib/std/PrelGHC.hi-boot.pp b/ghc/lib/std/PrelGHC.hi-boot.pp index 3dbacc3..5880ec1 100644 --- a/ghc/lib/std/PrelGHC.hi-boot.pp +++ b/ghc/lib/std/PrelGHC.hi-boot.pp @@ -5,8 +5,7 @@ -- primitive operations and types that GHC knows about. --------------------------------------------------------------------------- -#include "config.h" -#include "Derived.h" +#include "MachDeps.h" __interface "std" PrelGHC 1 0 where @@ -116,25 +115,38 @@ __export PrelGHC int2Wordzh word2Intzh + narrow8Intzh + narrow16Intzh + narrow32Intzh + narrow8Wordzh + narrow16Wordzh + narrow32Wordzh + +#if WORD_SIZE_IN_BITS < 32 + Int32zh + Word32zh +#endif + +#if WORD_SIZE_IN_BITS < 64 Int64zh Word64zh - - intToInt8zh - intToInt16zh - intToInt32zh - wordToWord8zh - wordToWord16zh - wordToWord32zh +#endif Addrzh + nullAddrzh + plusAddrzh + minusAddrzh + remAddrzh +#if (WORD_SIZE_IN_BITS == 32 || WORD_SIZE_IN_BITS == 64) + addr2Intzh + int2Addrzh +#endif gtAddrzh geAddrzh eqAddrzh neAddrzh ltAddrzh leAddrzh - int2Addrzh - addr2Intzh Floatzh gtFloatzh @@ -213,7 +225,13 @@ __export PrelGHC integer2Wordzh int2Integerzh word2Integerzh -#ifdef SUPPORT_LONG_LONGS +#if WORD_SIZE_IN_BITS < 32 + integerToInt32zh + integerToWord32zh + int32ToIntegerzh + word32ToIntegerzh +#endif +#if WORD_SIZE_IN_BITS < 64 integerToInt64zh integerToWord64zh int64ToIntegerzh @@ -247,15 +265,11 @@ __export PrelGHC indexInt8Arrayzh indexInt16Arrayzh indexInt32Arrayzh -#ifdef SUPPORT_LONG_LONGS indexInt64Arrayzh -#endif indexWord8Arrayzh indexWord16Arrayzh indexWord32Arrayzh -#ifdef SUPPORT_LONG_LONGS indexWord64Arrayzh -#endif readArrayzh readCharArrayzh @@ -269,15 +283,11 @@ __export PrelGHC readInt8Arrayzh readInt16Arrayzh readInt32Arrayzh -#ifdef SUPPORT_LONG_LONGS readInt64Arrayzh -#endif readWord8Arrayzh readWord16Arrayzh readWord32Arrayzh -#ifdef SUPPORT_LONG_LONGS readWord64Arrayzh -#endif writeArrayzh writeCharArrayzh @@ -291,15 +301,11 @@ __export PrelGHC writeInt8Arrayzh writeInt16Arrayzh writeInt32Arrayzh -#ifdef SUPPORT_LONG_LONGS writeInt64Arrayzh -#endif writeWord8Arrayzh writeWord16Arrayzh writeWord32Arrayzh -#ifdef SUPPORT_LONG_LONGS writeWord64Arrayzh -#endif indexCharOffAddrzh indexWideCharOffAddrzh @@ -312,15 +318,11 @@ __export PrelGHC indexInt8OffAddrzh indexInt16OffAddrzh indexInt32OffAddrzh -#ifdef SUPPORT_LONG_LONGS indexInt64OffAddrzh -#endif indexWord8OffAddrzh indexWord16OffAddrzh indexWord32OffAddrzh -#ifdef SUPPORT_LONG_LONGS indexWord64OffAddrzh -#endif readCharOffAddrzh readWideCharOffAddrzh @@ -333,15 +335,11 @@ __export PrelGHC readInt8OffAddrzh readInt16OffAddrzh readInt32OffAddrzh -#ifdef SUPPORT_LONG_LONGS readInt64OffAddrzh -#endif readWord8OffAddrzh readWord16OffAddrzh readWord32OffAddrzh -#ifdef SUPPORT_LONG_LONGS readWord64OffAddrzh -#endif writeCharOffAddrzh writeWideCharOffAddrzh @@ -355,15 +353,11 @@ __export PrelGHC writeInt8OffAddrzh writeInt16OffAddrzh writeInt32OffAddrzh -#ifdef SUPPORT_LONG_LONGS writeInt64OffAddrzh -#endif writeWord8OffAddrzh writeWord16OffAddrzh writeWord32OffAddrzh -#ifdef SUPPORT_LONG_LONGS writeWord64OffAddrzh -#endif eqForeignObjzh indexCharOffForeignObjzh @@ -377,15 +371,11 @@ __export PrelGHC indexInt8OffForeignObjzh indexInt16OffForeignObjzh indexInt32OffForeignObjzh -#ifdef SUPPORT_LONG_LONGS indexInt64OffForeignObjzh -#endif indexWord8OffForeignObjzh indexWord16OffForeignObjzh indexWord32OffForeignObjzh -#ifdef SUPPORT_LONG_LONGS indexWord64OffForeignObjzh -#endif unsafeFreezzeArrayzh -- Note zz in the middle unsafeFreezzeByteArrayzh -- Ditto diff --git a/ghc/lib/std/PrelInt.lhs b/ghc/lib/std/PrelInt.lhs index bd292b0..f5be4f4 100644 --- a/ghc/lib/std/PrelInt.lhs +++ b/ghc/lib/std/PrelInt.lhs @@ -38,17 +38,17 @@ instance Show Int8 where showsPrec p x = showsPrec p (fromIntegral x :: Int) instance Num Int8 where - (I8# x#) + (I8# y#) = I8# (intToInt8# (x# +# y#)) - (I8# x#) - (I8# y#) = I8# (intToInt8# (x# -# y#)) - (I8# x#) * (I8# y#) = I8# (intToInt8# (x# *# y#)) - negate (I8# x#) = I8# (intToInt8# (negateInt# x#)) + (I8# x#) + (I8# y#) = I8# (narrow8Int# (x# +# y#)) + (I8# x#) - (I8# y#) = I8# (narrow8Int# (x# -# y#)) + (I8# x#) * (I8# y#) = I8# (narrow8Int# (x# *# y#)) + negate (I8# x#) = I8# (narrow8Int# (negateInt# x#)) abs x | x >= 0 = x | otherwise = negate x signum x | x > 0 = 1 signum 0 = 0 signum _ = -1 - fromInteger (S# i#) = I8# (intToInt8# i#) - fromInteger (J# s# d#) = I8# (intToInt8# (integer2Int# s# d#)) + fromInteger (S# i#) = I8# (narrow8Int# i#) + fromInteger (J# s# d#) = I8# (narrow8Int# (integer2Int# s# d#)) instance Real Int8 where toRational x = toInteger x % 1 @@ -70,24 +70,24 @@ instance Enum Int8 where instance Integral Int8 where quot x@(I8# x#) y@(I8# y#) - | y /= 0 = I8# (intToInt8# (x# `quotInt#` y#)) + | y /= 0 = I8# (narrow8Int# (x# `quotInt#` y#)) | otherwise = divZeroError "quot{Int8}" x rem x@(I8# x#) y@(I8# y#) - | y /= 0 = I8# (intToInt8# (x# `remInt#` y#)) + | y /= 0 = I8# (narrow8Int# (x# `remInt#` y#)) | otherwise = divZeroError "rem{Int8}" x div x@(I8# x#) y@(I8# y#) - | y /= 0 = I8# (intToInt8# (x# `divInt#` y#)) + | y /= 0 = I8# (narrow8Int# (x# `divInt#` y#)) | otherwise = divZeroError "div{Int8}" x mod x@(I8# x#) y@(I8# y#) - | y /= 0 = I8# (intToInt8# (x# `modInt#` y#)) + | y /= 0 = I8# (narrow8Int# (x# `modInt#` y#)) | otherwise = divZeroError "mod{Int8}" x quotRem x@(I8# x#) y@(I8# y#) - | y /= 0 = (I8# (intToInt8# (x# `quotInt#` y#)), - I8# (intToInt8# (x# `remInt#` y#))) + | y /= 0 = (I8# (narrow8Int# (x# `quotInt#` y#)), + I8# (narrow8Int# (x# `remInt#` y#))) | otherwise = divZeroError "quotRem{Int8}" x divMod x@(I8# x#) y@(I8# y#) - | y /= 0 = (I8# (intToInt8# (x# `divInt#` y#)), - I8# (intToInt8# (x# `modInt#` y#))) + | y /= 0 = (I8# (narrow8Int# (x# `divInt#` y#)), + I8# (narrow8Int# (x# `modInt#` y#))) | otherwise = divZeroError "divMod{Int8}" x toInteger (I8# x#) = S# x# @@ -111,20 +111,20 @@ instance Bits Int8 where (I8# x#) `xor` (I8# y#) = I8# (word2Int# (int2Word# x# `xor#` int2Word# y#)) complement (I8# x#) = I8# (word2Int# (int2Word# x# `xor#` int2Word# (-1#))) (I8# x#) `shift` (I# i#) - | i# >=# 0# = I8# (intToInt8# (x# `iShiftL#` i#)) + | i# >=# 0# = I8# (narrow8Int# (x# `iShiftL#` i#)) | otherwise = I8# (x# `iShiftRA#` negateInt# i#) (I8# x#) `rotate` (I# i#) = - I8# (intToInt8# (word2Int# ((x'# `shiftL#` i'#) `or#` + I8# (narrow8Int# (word2Int# ((x'# `shiftL#` i'#) `or#` (x'# `shiftRL#` (8# -# i'#))))) where - x'# = wordToWord8# (int2Word# x#) + x'# = narrow8Word# (int2Word# x#) i'# = word2Int# (int2Word# i# `and#` int2Word# 7#) bitSize _ = 8 isSigned _ = True {-# RULES "fromIntegral/Int8->Int8" fromIntegral = id :: Int8 -> Int8 -"fromIntegral/a->Int8" fromIntegral = \x -> case fromIntegral x of I# x# -> I8# (intToInt8# x#) +"fromIntegral/a->Int8" fromIntegral = \x -> case fromIntegral x of I# x# -> I8# (narrow8Int# x#) "fromIntegral/Int8->a" fromIntegral = \(I8# x#) -> fromIntegral (I# x#) #-} @@ -144,17 +144,17 @@ instance Show Int16 where showsPrec p x = showsPrec p (fromIntegral x :: Int) instance Num Int16 where - (I16# x#) + (I16# y#) = I16# (intToInt16# (x# +# y#)) - (I16# x#) - (I16# y#) = I16# (intToInt16# (x# -# y#)) - (I16# x#) * (I16# y#) = I16# (intToInt16# (x# *# y#)) - negate (I16# x#) = I16# (intToInt16# (negateInt# x#)) + (I16# x#) + (I16# y#) = I16# (narrow16Int# (x# +# y#)) + (I16# x#) - (I16# y#) = I16# (narrow16Int# (x# -# y#)) + (I16# x#) * (I16# y#) = I16# (narrow16Int# (x# *# y#)) + negate (I16# x#) = I16# (narrow16Int# (negateInt# x#)) abs x | x >= 0 = x | otherwise = negate x signum x | x > 0 = 1 signum 0 = 0 signum _ = -1 - fromInteger (S# i#) = I16# (intToInt16# i#) - fromInteger (J# s# d#) = I16# (intToInt16# (integer2Int# s# d#)) + fromInteger (S# i#) = I16# (narrow16Int# i#) + fromInteger (J# s# d#) = I16# (narrow16Int# (integer2Int# s# d#)) instance Real Int16 where toRational x = toInteger x % 1 @@ -176,24 +176,24 @@ instance Enum Int16 where instance Integral Int16 where quot x@(I16# x#) y@(I16# y#) - | y /= 0 = I16# (intToInt16# (x# `quotInt#` y#)) + | y /= 0 = I16# (narrow16Int# (x# `quotInt#` y#)) | otherwise = divZeroError "quot{Int16}" x rem x@(I16# x#) y@(I16# y#) - | y /= 0 = I16# (intToInt16# (x# `remInt#` y#)) + | y /= 0 = I16# (narrow16Int# (x# `remInt#` y#)) | otherwise = divZeroError "rem{Int16}" x div x@(I16# x#) y@(I16# y#) - | y /= 0 = I16# (intToInt16# (x# `divInt#` y#)) + | y /= 0 = I16# (narrow16Int# (x# `divInt#` y#)) | otherwise = divZeroError "div{Int16}" x mod x@(I16# x#) y@(I16# y#) - | y /= 0 = I16# (intToInt16# (x# `modInt#` y#)) + | y /= 0 = I16# (narrow16Int# (x# `modInt#` y#)) | otherwise = divZeroError "mod{Int16}" x quotRem x@(I16# x#) y@(I16# y#) - | y /= 0 = (I16# (intToInt16# (x# `quotInt#` y#)), - I16# (intToInt16# (x# `remInt#` y#))) + | y /= 0 = (I16# (narrow16Int# (x# `quotInt#` y#)), + I16# (narrow16Int# (x# `remInt#` y#))) | otherwise = divZeroError "quotRem{Int16}" x divMod x@(I16# x#) y@(I16# y#) - | y /= 0 = (I16# (intToInt16# (x# `divInt#` y#)), - I16# (intToInt16# (x# `modInt#` y#))) + | y /= 0 = (I16# (narrow16Int# (x# `divInt#` y#)), + I16# (narrow16Int# (x# `modInt#` y#))) | otherwise = divZeroError "divMod{Int16}" x toInteger (I16# x#) = S# x# @@ -217,13 +217,13 @@ instance Bits Int16 where (I16# x#) `xor` (I16# y#) = I16# (word2Int# (int2Word# x# `xor#` int2Word# y#)) complement (I16# x#) = I16# (word2Int# (int2Word# x# `xor#` int2Word# (-1#))) (I16# x#) `shift` (I# i#) - | i# >=# 0# = I16# (intToInt16# (x# `iShiftL#` i#)) + | i# >=# 0# = I16# (narrow16Int# (x# `iShiftL#` i#)) | otherwise = I16# (x# `iShiftRA#` negateInt# i#) (I16# x#) `rotate` (I# i#) = - I16# (intToInt16# (word2Int# ((x'# `shiftL#` i'#) `or#` + I16# (narrow16Int# (word2Int# ((x'# `shiftL#` i'#) `or#` (x'# `shiftRL#` (16# -# i'#))))) where - x'# = wordToWord16# (int2Word# x#) + x'# = narrow16Word# (int2Word# x#) i'# = word2Int# (int2Word# i# `and#` int2Word# 15#) bitSize _ = 16 isSigned _ = True @@ -232,7 +232,7 @@ instance Bits Int16 where "fromIntegral/Word8->Int16" fromIntegral = \(W8# x#) -> I16# (word2Int# x#) "fromIntegral/Int8->Int16" fromIntegral = \(I8# x#) -> I16# x# "fromIntegral/Int16->Int16" fromIntegral = id :: Int16 -> Int16 -"fromIntegral/a->Int16" fromIntegral = \x -> case fromIntegral x of I# x# -> I16# (intToInt16# x#) +"fromIntegral/a->Int16" fromIntegral = \x -> case fromIntegral x of I# x# -> I16# (narrow16Int# x#) "fromIntegral/Int16->a" fromIntegral = \(I16# x#) -> fromIntegral (I# x#) #-} @@ -240,35 +240,173 @@ instance Bits Int16 where -- type Int32 ------------------------------------------------------------------------ +#if WORD_SIZE_IN_BITS < 32 + +data Int32 = I32# Int32# + +instance Eq Int32 where + (I32# x#) == (I32# y#) = x# `eqInt32#` y# + (I32# x#) /= (I32# y#) = x# `neInt32#` y# + +instance Ord Int32 where + (I32# x#) < (I32# y#) = x# `ltInt32#` y# + (I32# x#) <= (I32# y#) = x# `leInt32#` y# + (I32# x#) > (I32# y#) = x# `gtInt32#` y# + (I32# x#) >= (I32# y#) = x# `geInt32#` y# + +instance Show Int32 where + showsPrec p x = showsPrec p (toInteger x) + +instance Num Int32 where + (I32# x#) + (I32# y#) = I32# (x# `plusInt32#` y#) + (I32# x#) - (I32# y#) = I32# (x# `minusInt32#` y#) + (I32# x#) * (I32# y#) = I32# (x# `timesInt32#` y#) + negate (I32# x#) = I32# (negateInt32# x#) + abs x | x >= 0 = x + | otherwise = negate x + signum x | x > 0 = 1 + signum 0 = 0 + signum _ = -1 + fromInteger (S# i#) = I32# (intToInt32# i#) + fromInteger (J# s# d#) = I32# (integerToInt32# s# d#) + +instance Enum Int32 where + succ x + | x /= maxBound = x + 1 + | otherwise = succError "Int32" + pred x + | x /= minBound = x - 1 + | otherwise = predError "Int32" + toEnum (I# i#) = I32# (intToInt32# i#) + fromEnum x@(I32# x#) + | x >= fromIntegral (minBound::Int) && x <= fromIntegral (maxBound::Int) + = I# (int32ToInt# x#) + | otherwise = fromEnumError "Int32" x + enumFrom = integralEnumFrom + enumFromThen = integralEnumFromThen + enumFromTo = integralEnumFromTo + enumFromThenTo = integralEnumFromThenTo + +instance Integral Int32 where + quot x@(I32# x#) y@(I32# y#) + | y /= 0 = I32# (x# `quotInt32#` y#) + | otherwise = divZeroError "quot{Int32}" x + rem x@(I32# x#) y@(I32# y#) + | y /= 0 = I32# (x# `remInt32#` y#) + | otherwise = divZeroError "rem{Int32}" x + div x@(I32# x#) y@(I32# y#) + | y /= 0 = I32# (x# `divInt32#` y#) + | otherwise = divZeroError "div{Int32}" x + mod x@(I32# x#) y@(I32# y#) + | y /= 0 = I32# (x# `modInt32#` y#) + | otherwise = divZeroError "mod{Int32}" x + quotRem x@(I32# x#) y@(I32# y#) + | y /= 0 = (I32# (x# `quotInt32#` y#), I32# (x# `remInt32#` y#)) + | otherwise = divZeroError "quotRem{Int32}" x + divMod x@(I32# x#) y@(I32# y#) + | y /= 0 = (I32# (x# `divInt32#` y#), I32# (x# `modInt32#` y#)) + | otherwise = divZeroError "divMod{Int32}" x + toInteger x@(I32# x#) + | x >= fromIntegral (minBound::Int) && x <= fromIntegral (maxBound::Int) + = S# (int32ToInt# x#) + | otherwise = case int32ToInteger# x# of (# s, d #) -> J# s d + +divInt32#, modInt32# :: Int32# -> Int32# -> Int32# +x# `divInt32#` y# + | (x# `gtInt32#` intToInt32# 0#) && (y# `ltInt32#` intToInt32# 0#) + = ((x# `minusInt32#` y#) `minusInt32#` intToInt32# 1#) `quotInt32#` y# + | (x# `ltInt32#` intToInt32# 0#) && (y# `gtInt32#` intToInt32# 0#) + = ((x# `minusInt32#` y#) `plusInt32#` intToInt32# 1#) `quotInt32#` y# + | otherwise = x# `quotInt32#` y# +x# `modInt32#` y# + | (x# `gtInt32#` intToInt32# 0#) && (y# `ltInt32#` intToInt32# 0#) || + (x# `ltInt32#` intToInt32# 0#) && (y# `gtInt32#` intToInt32# 0#) + = if r# `neInt32#` intToInt32# 0# then r# `plusInt32#` y# else intToInt32# 0# + | otherwise = r# + where + r# = x# `remInt32#` y# + +instance Read Int32 where + readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s] + +instance Bits Int32 where + (I32# x#) .&. (I32# y#) = I32# (word32ToInt32# (int32ToWord32# x# `and32#` int32ToWord32# y#)) + (I32# x#) .|. (I32# y#) = I32# (word32ToInt32# (int32ToWord32# x# `or32#` int32ToWord32# y#)) + (I32# x#) `xor` (I32# y#) = I32# (word32ToInt32# (int32ToWord32# x# `xor32#` int32ToWord32# y#)) + complement (I32# x#) = I32# (word32ToInt32# (not32# (int32ToWord32# x#))) + (I32# x#) `shift` (I# i#) + | i# >=# 0# = I32# (x# `iShiftL32#` i#) + | otherwise = I32# (x# `iShiftRA32#` negateInt# i#) + (I32# x#) `rotate` (I# i#) = + I32# (word32ToInt32# ((x'# `shiftL32#` i'#) `or32#` + (x'# `shiftRL32#` (32# -# i'#)))) + where + x'# = int32ToWord32# x# + i'# = word2Int# (int2Word# i# `and#` int2Word# 63#) + bitSize _ = 32 + isSigned _ = True + +foreign import "stg_eqInt32" unsafe eqInt32# :: Int32# -> Int32# -> Bool +foreign import "stg_neInt32" unsafe neInt32# :: Int32# -> Int32# -> Bool +foreign import "stg_ltInt32" unsafe ltInt32# :: Int32# -> Int32# -> Bool +foreign import "stg_leInt32" unsafe leInt32# :: Int32# -> Int32# -> Bool +foreign import "stg_gtInt32" unsafe gtInt32# :: Int32# -> Int32# -> Bool +foreign import "stg_geInt32" unsafe geInt32# :: Int32# -> Int32# -> Bool +foreign import "stg_plusInt32" unsafe plusInt32# :: Int32# -> Int32# -> Int32# +foreign import "stg_minusInt32" unsafe minusInt32# :: Int32# -> Int32# -> Int32# +foreign import "stg_timesInt32" unsafe timesInt32# :: Int32# -> Int32# -> Int32# +foreign import "stg_negateInt32" unsafe negateInt32# :: Int32# -> Int32# +foreign import "stg_quotInt32" unsafe quotInt32# :: Int32# -> Int32# -> Int32# +foreign import "stg_remInt32" unsafe remInt32# :: Int32# -> Int32# -> Int32# +foreign import "stg_intToInt32" unsafe intToInt32# :: Int# -> Int32# +foreign import "stg_int32ToInt" unsafe int32ToInt# :: Int32# -> Int# +foreign import "stg_wordToWord32" unsafe wordToWord32# :: Word# -> Word32# +foreign import "stg_int32ToWord32" unsafe int32ToWord32# :: Int32# -> Word32# +foreign import "stg_word32ToInt32" unsafe word32ToInt32# :: Word32# -> Int32# +foreign import "stg_and32" unsafe and32# :: Word32# -> Word32# -> Word32# +foreign import "stg_or32" unsafe or32# :: Word32# -> Word32# -> Word32# +foreign import "stg_xor32" unsafe xor32# :: Word32# -> Word32# -> Word32# +foreign import "stg_not32" unsafe not32# :: Word32# -> Word32# +foreign import "stg_iShiftL32" unsafe iShiftL32# :: Int32# -> Int# -> Int32# +foreign import "stg_iShiftRA32" unsafe iShiftRA32# :: Int32# -> Int# -> Int32# +foreign import "stg_shiftL32" unsafe shiftL32# :: Word32# -> Int# -> Word32# +foreign import "stg_shiftRL32" unsafe shiftRL32# :: Word32# -> Int# -> Word32# + +{-# RULES +"fromIntegral/Int->Int32" fromIntegral = \(I# x#) -> I32# (intToInt32# x#) +"fromIntegral/Word->Int32" fromIntegral = \(W# x#) -> I32# (word32ToInt32# (wordToWord32# x#)) +"fromIntegral/Word32->Int32" fromIntegral = \(W32# x#) -> I32# (word32ToInt32# x#) +"fromIntegral/Int32->Int" fromIntegral = \(I32# x#) -> I# (int32ToInt# x#) +"fromIntegral/Int32->Word" fromIntegral = \(I32# x#) -> W# (int2Word# (int32ToInt# x#)) +"fromIntegral/Int32->Word32" fromIntegral = \(I32# x#) -> W32# (int32ToWord32# x#) +"fromIntegral/Int32->Int32" fromIntegral = id :: Int32 -> Int32 + #-} + +#else + -- Int32 is represented in the same way as Int. -#if WORD_SIZE_IN_BYTES == 8 +#if WORD_SIZE_IN_BITS > 32 -- Operations may assume and must ensure that it holds only values -- from its logical range. #endif data Int32 = I32# Int# deriving (Eq, Ord) -instance CCallable Int32 -instance CReturnable Int32 - instance Show Int32 where showsPrec p x = showsPrec p (fromIntegral x :: Int) instance Num Int32 where - (I32# x#) + (I32# y#) = I32# (intToInt32# (x# +# y#)) - (I32# x#) - (I32# y#) = I32# (intToInt32# (x# -# y#)) - (I32# x#) * (I32# y#) = I32# (intToInt32# (x# *# y#)) - negate (I32# x#) = I32# (intToInt32# (negateInt# x#)) + (I32# x#) + (I32# y#) = I32# (narrow32Int# (x# +# y#)) + (I32# x#) - (I32# y#) = I32# (narrow32Int# (x# -# y#)) + (I32# x#) * (I32# y#) = I32# (narrow32Int# (x# *# y#)) + negate (I32# x#) = I32# (narrow32Int# (negateInt# x#)) abs x | x >= 0 = x | otherwise = negate x signum x | x > 0 = 1 signum 0 = 0 signum _ = -1 - fromInteger (S# i#) = I32# (intToInt32# i#) - fromInteger (J# s# d#) = I32# (intToInt32# (integer2Int# s# d#)) - -instance Real Int32 where - toRational x = toInteger x % 1 + fromInteger (S# i#) = I32# (narrow32Int# i#) + fromInteger (J# s# d#) = I32# (narrow32Int# (integer2Int# s# d#)) instance Enum Int32 where succ x @@ -277,7 +415,7 @@ instance Enum Int32 where pred x | x /= minBound = x - 1 | otherwise = predError "Int32" -#if WORD_SIZE_IN_BYTES == 4 +#if WORD_SIZE_IN_BITS == 32 toEnum (I# i#) = I32# i# #else toEnum i@(I# i#) @@ -291,38 +429,27 @@ instance Enum Int32 where instance Integral Int32 where quot x@(I32# x#) y@(I32# y#) - | y /= 0 = I32# (intToInt32# (x# `quotInt#` y#)) + | y /= 0 = I32# (narrow32Int# (x# `quotInt#` y#)) | otherwise = divZeroError "quot{Int32}" x rem x@(I32# x#) y@(I32# y#) - | y /= 0 = I32# (intToInt32# (x# `remInt#` y#)) + | y /= 0 = I32# (narrow32Int# (x# `remInt#` y#)) | otherwise = divZeroError "rem{Int32}" x div x@(I32# x#) y@(I32# y#) - | y /= 0 = I32# (intToInt32# (x# `divInt#` y#)) + | y /= 0 = I32# (narrow32Int# (x# `divInt#` y#)) | otherwise = divZeroError "div{Int32}" x mod x@(I32# x#) y@(I32# y#) - | y /= 0 = I32# (intToInt32# (x# `modInt#` y#)) + | y /= 0 = I32# (narrow32Int# (x# `modInt#` y#)) | otherwise = divZeroError "mod{Int32}" x quotRem x@(I32# x#) y@(I32# y#) - | y /= 0 = (I32# (intToInt32# (x# `quotInt#` y#)), - I32# (intToInt32# (x# `remInt#` y#))) + | y /= 0 = (I32# (narrow32Int# (x# `quotInt#` y#)), + I32# (narrow32Int# (x# `remInt#` y#))) | otherwise = divZeroError "quotRem{Int32}" x divMod x@(I32# x#) y@(I32# y#) - | y /= 0 = (I32# (intToInt32# (x# `divInt#` y#)), - I32# (intToInt32# (x# `modInt#` y#))) + | y /= 0 = (I32# (narrow32Int# (x# `divInt#` y#)), + I32# (narrow32Int# (x# `modInt#` y#))) | otherwise = divZeroError "divMod{Int32}" x toInteger (I32# x#) = S# x# -instance Bounded Int32 where - minBound = -0x80000000 - maxBound = 0x7FFFFFFF - -instance Ix Int32 where - range (m,n) = [m..n] - index b@(m,_) i - | inRange b i = fromIntegral (i - m) - | otherwise = indexError b i "Int32" - inRange (m,n) i = m <= i && i <= n - instance Read Int32 where readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s] @@ -332,13 +459,13 @@ instance Bits Int32 where (I32# x#) `xor` (I32# y#) = I32# (word2Int# (int2Word# x# `xor#` int2Word# y#)) complement (I32# x#) = I32# (word2Int# (int2Word# x# `xor#` int2Word# (-1#))) (I32# x#) `shift` (I# i#) - | i# >=# 0# = I32# (intToInt32# (x# `iShiftL#` i#)) + | i# >=# 0# = I32# (narrow32Int# (x# `iShiftL#` i#)) | otherwise = I32# (x# `iShiftRA#` negateInt# i#) (I32# x#) `rotate` (I# i#) = - I32# (intToInt32# (word2Int# ((x'# `shiftL#` i'#) `or#` + I32# (narrow32Int# (word2Int# ((x'# `shiftL#` i'#) `or#` (x'# `shiftRL#` (32# -# i'#))))) where - x'# = wordToWord32# (int2Word# x#) + x'# = narrow32Word# (int2Word# x#) i'# = word2Int# (int2Word# i# `and#` int2Word# 31#) bitSize _ = 32 isSigned _ = True @@ -349,15 +476,34 @@ instance Bits Int32 where "fromIntegral/Int8->Int32" fromIntegral = \(I8# x#) -> I32# x# "fromIntegral/Int16->Int32" fromIntegral = \(I16# x#) -> I32# x# "fromIntegral/Int32->Int32" fromIntegral = id :: Int32 -> Int32 -"fromIntegral/a->Int32" fromIntegral = \x -> case fromIntegral x of I# x# -> I32# (intToInt32# x#) +"fromIntegral/a->Int32" fromIntegral = \x -> case fromIntegral x of I# x# -> I32# (narrow32Int# x#) "fromIntegral/Int32->a" fromIntegral = \(I32# x#) -> fromIntegral (I# x#) #-} +#endif + +instance CCallable Int32 +instance CReturnable Int32 + +instance Real Int32 where + toRational x = toInteger x % 1 + +instance Bounded Int32 where + minBound = -0x80000000 + maxBound = 0x7FFFFFFF + +instance Ix Int32 where + range (m,n) = [m..n] + index b@(m,_) i + | inRange b i = fromIntegral (i - m) + | otherwise = indexError b i "Int32" + inRange (m,n) i = m <= i && i <= n + ------------------------------------------------------------------------ -- type Int64 ------------------------------------------------------------------------ -#if WORD_SIZE_IN_BYTES == 4 +#if WORD_SIZE_IN_BITS < 64 data Int64 = I64# Int64# @@ -424,10 +570,11 @@ instance Integral Int64 where | y /= 0 = (I64# (x# `divInt64#` y#), I64# (x# `modInt64#` y#)) | otherwise = divZeroError "divMod{Int64}" x toInteger x@(I64# x#) - | x >= -0x80000000 && x <= 0x7FFFFFFF + | x >= fromIntegral (minBound::Int) && x <= fromIntegral (maxBound::Int) = S# (int64ToInt# x#) | otherwise = case int64ToInteger# x# of (# s, d #) -> J# s d + divInt64#, modInt64# :: Int64# -> Int64# -> Int64# x# `divInt64#` y# | (x# `gtInt64#` intToInt64# 0#) && (y# `ltInt64#` intToInt64# 0#) @@ -499,7 +646,11 @@ foreign import "stg_shiftRL64" unsafe shiftRL64# :: Word64# -> Int# -> W "fromIntegral/Int64->Int64" fromIntegral = id :: Int64 -> Int64 #-} -#else +#else + +-- Int64 is represented in the same way as Int. +-- Operations may assume and must ensure that it holds only values +-- from its logical range. data Int64 = I64# Int# deriving (Eq, Ord) diff --git a/ghc/lib/std/PrelPtr.lhs b/ghc/lib/std/PrelPtr.lhs index e81e960..cbf076c 100644 --- a/ghc/lib/std/PrelPtr.lhs +++ b/ghc/lib/std/PrelPtr.lhs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: PrelPtr.lhs,v 1.2 2001/04/13 21:37:43 panne Exp $ +-- $Id: PrelPtr.lhs,v 1.3 2001/08/17 17:18:54 apt Exp $ -- -- (c) 2000 -- @@ -17,23 +17,22 @@ import PrelBase data Ptr a = Ptr Addr# deriving (Eq, Ord) nullPtr :: Ptr a -nullPtr = Ptr (int2Addr# 0#) +nullPtr = Ptr (nullAddr# 0#) castPtr :: Ptr a -> Ptr b castPtr (Ptr addr) = Ptr addr plusPtr :: Ptr a -> Int -> Ptr b -plusPtr (Ptr addr) (I# d) = Ptr (int2Addr# (addr2Int# addr +# d)) +plusPtr (Ptr addr) (I# d) = Ptr (plusAddr# addr d) alignPtr :: Ptr a -> Int -> Ptr a alignPtr addr@(Ptr a) (I# i) - = case addr2Int# a of { ai -> - case remInt# ai i of { + = case remAddr# a i of { 0# -> addr; - n -> Ptr (int2Addr# (ai +# (i -# n))) }} + n -> Ptr (plusAddr# a (i -# n)) } minusPtr :: Ptr a -> Ptr b -> Int -minusPtr (Ptr a1) (Ptr a2) = I# (addr2Int# a1 -# addr2Int# a2) +minusPtr (Ptr a1) (Ptr a2) = I# (minusAddr# a1 a2) instance CCallable (Ptr a) instance CReturnable (Ptr a) @@ -44,7 +43,7 @@ instance CReturnable (Ptr a) data FunPtr a = FunPtr Addr# deriving (Eq, Ord) nullFunPtr :: FunPtr a -nullFunPtr = FunPtr (int2Addr# 0#) +nullFunPtr = FunPtr (nullAddr# 0#) castFunPtr :: FunPtr a -> FunPtr b castFunPtr (FunPtr addr) = FunPtr addr @@ -58,3 +57,4 @@ castPtrToFunPtr (Ptr addr) = FunPtr addr instance CCallable (FunPtr a) instance CReturnable (FunPtr a) \end{code} + diff --git a/ghc/lib/std/PrelStorable.lhs b/ghc/lib/std/PrelStorable.lhs index 92a39b0..0166232 100644 --- a/ghc/lib/std/PrelStorable.lhs +++ b/ghc/lib/std/PrelStorable.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $Id: PrelStorable.lhs,v 1.8 2001/07/24 06:31:35 ken Exp $ +% $Id: PrelStorable.lhs,v 1.9 2001/08/17 17:18:54 apt Exp $ % % (c) The FFI task force, 2000 % @@ -220,30 +220,20 @@ readStablePtrOffPtr (Ptr a) (I# i) = IO $ \s -> case readStablePtrOffAddr# a i s of (# s2, x #) -> (# s2, StablePtr x #) readInt8OffPtr (Ptr a) (I# i) = IO $ \s -> case readInt8OffAddr# a i s of (# s2, x #) -> (# s2, I8# x #) -readInt16OffPtr (Ptr a) (I# i) - = IO $ \s -> case readInt16OffAddr# a i s of (# s2, x #) -> (# s2, I16# x #) -readInt32OffPtr (Ptr a) (I# i) - = IO $ \s -> case readInt32OffAddr# a i s of (# s2, x #) -> (# s2, I32# x #) -#if WORD_SIZE_IN_BYTES == 4 -readInt64OffPtr (Ptr a) (I# i) - = IO $ \s -> case readInt64OffAddr# a i s of (# s2, x #) -> (# s2, I64# x #) -#else -readInt64OffPtr (Ptr a) (I# i) - = IO $ \s -> case readIntOffAddr# a i s of (# s2, x #) -> (# s2, I64# x #) -#endif readWord8OffPtr (Ptr a) (I# i) = IO $ \s -> case readWord8OffAddr# a i s of (# s2, x #) -> (# s2, W8# x #) +readInt16OffPtr (Ptr a) (I# i) + = IO $ \s -> case readInt16OffAddr# a i s of (# s2, x #) -> (# s2, I16# x #) readWord16OffPtr (Ptr a) (I# i) = IO $ \s -> case readWord16OffAddr# a i s of (# s2, x #) -> (# s2, W16# x #) +readInt32OffPtr (Ptr a) (I# i) + = IO $ \s -> case readInt32OffAddr# a i s of (# s2, x #) -> (# s2, I32# x #) readWord32OffPtr (Ptr a) (I# i) = IO $ \s -> case readWord32OffAddr# a i s of (# s2, x #) -> (# s2, W32# x #) -#if WORD_SIZE_IN_BYTES == 4 +readInt64OffPtr (Ptr a) (I# i) + = IO $ \s -> case readInt64OffAddr# a i s of (# s2, x #) -> (# s2, I64# x #) readWord64OffPtr (Ptr a) (I# i) = IO $ \s -> case readWord64OffAddr# a i s of (# s2, x #) -> (# s2, W64# x #) -#else -readWord64OffPtr (Ptr a) (I# i) - = IO $ \s -> case readWordOffAddr# a i s of (# s2, x #) -> (# s2, W64# x #) -#endif writeWideCharOffPtr :: Ptr Char -> Int -> Char -> IO () writeIntOffPtr :: Ptr Int -> Int -> Int -> IO () @@ -280,30 +270,20 @@ writeStablePtrOffPtr (Ptr a) (I# i) (StablePtr x) = IO $ \s -> case writeStablePtrOffAddr# a i x s of s2 -> (# s2 , () #) writeInt8OffPtr (Ptr a) (I# i) (I8# x) = IO $ \s -> case writeInt8OffAddr# a i x s of s2 -> (# s2, () #) -writeInt16OffPtr (Ptr a) (I# i) (I16# x) - = IO $ \s -> case writeInt16OffAddr# a i x s of s2 -> (# s2, () #) -writeInt32OffPtr (Ptr a) (I# i) (I32# x) - = IO $ \s -> case writeInt32OffAddr# a i x s of s2 -> (# s2, () #) -#if WORD_SIZE_IN_BYTES == 4 -writeInt64OffPtr (Ptr a) (I# i) (I64# x) - = IO $ \s -> case writeInt64OffAddr# a i x s of s2 -> (# s2, () #) -#else -writeInt64OffPtr (Ptr a) (I# i) (I64# x) - = IO $ \s -> case writeIntOffAddr# a i x s of s2 -> (# s2, () #) -#endif writeWord8OffPtr (Ptr a) (I# i) (W8# x) = IO $ \s -> case writeWord8OffAddr# a i x s of s2 -> (# s2, () #) +writeInt16OffPtr (Ptr a) (I# i) (I16# x) + = IO $ \s -> case writeInt16OffAddr# a i x s of s2 -> (# s2, () #) writeWord16OffPtr (Ptr a) (I# i) (W16# x) = IO $ \s -> case writeWord16OffAddr# a i x s of s2 -> (# s2, () #) +writeInt32OffPtr (Ptr a) (I# i) (I32# x) + = IO $ \s -> case writeInt32OffAddr# a i x s of s2 -> (# s2, () #) writeWord32OffPtr (Ptr a) (I# i) (W32# x) = IO $ \s -> case writeWord32OffAddr# a i x s of s2 -> (# s2, () #) -#if WORD_SIZE_IN_BYTES == 4 +writeInt64OffPtr (Ptr a) (I# i) (I64# x) + = IO $ \s -> case writeInt64OffAddr# a i x s of s2 -> (# s2, () #) writeWord64OffPtr (Ptr a) (I# i) (W64# x) = IO $ \s -> case writeWord64OffAddr# a i x s of s2 -> (# s2, () #) -#else -writeWord64OffPtr (Ptr a) (I# i) (W64# x) - = IO $ \s -> case writeWordOffAddr# a i x s of s2 -> (# s2, () #) -#endif #endif /* __GLASGOW_HASKELL__ */ \end{code} diff --git a/ghc/lib/std/PrelWord.lhs b/ghc/lib/std/PrelWord.lhs index 0a8bc1d..5cefedb 100644 --- a/ghc/lib/std/PrelWord.lhs +++ b/ghc/lib/std/PrelWord.lhs @@ -131,7 +131,9 @@ instance Integral Word where instance Bounded Word where minBound = 0 -#if WORD_SIZE_IN_BYTES == 4 +#if WORD_SIZE_IN_BITS == 31 + maxBound = 0x7FFFFFFF +#elif WORD_SIZE_IN_BITS == 32 maxBound = 0xFFFFFFFF #else maxBound = 0xFFFFFFFFFFFFFFFF @@ -155,16 +157,11 @@ instance Bits Word where (W# x#) `shift` (I# i#) | i# >=# 0# = W# (x# `shiftL#` i#) | otherwise = W# (x# `shiftRL#` negateInt# i#) -#if WORD_SIZE_IN_BYTES == 4 - (W# x#) `rotate` (I# i#) = W# ((x# `shiftL#` i'#) `or#` (x# `shiftRL#` (32# -# i'#))) + (W# x#) `rotate` (I# i#) = W# ((x# `shiftL#` i'#) `or#` (x# `shiftRL#` (wsib -# i'#))) where - i'# = word2Int# (int2Word# i# `and#` int2Word# 31#) -#else - (W# x#) `rotate` (I# i#) = W# ((x# `shiftL#` i'#) `or#` (x# `shiftRL#` (64# -# i'#))) - where - i'# = word2Int# (int2Word# i# `and#` int2Word# 63#) -#endif - bitSize _ = WORD_SIZE_IN_BYTES * 8 + i'# = word2Int# (int2Word# i# `and#` int2Word# (wsib -# 1#)) + wsib = WORD_SIZE_IN_BITS# {- work around preprocessor problem (??) -} + bitSize _ = WORD_SIZE_IN_BITS isSigned _ = False {-# RULES @@ -189,15 +186,15 @@ instance Show Word8 where showsPrec p x = showsPrec p (fromIntegral x :: Int) instance Num Word8 where - (W8# x#) + (W8# y#) = W8# (wordToWord8# (x# `plusWord#` y#)) - (W8# x#) - (W8# y#) = W8# (wordToWord8# (x# `minusWord#` y#)) - (W8# x#) * (W8# y#) = W8# (wordToWord8# (x# `timesWord#` y#)) - negate (W8# x#) = W8# (wordToWord8# (int2Word# (negateInt# (word2Int# x#)))) + (W8# x#) + (W8# y#) = W8# (narrow8Word# (x# `plusWord#` y#)) + (W8# x#) - (W8# y#) = W8# (narrow8Word# (x# `minusWord#` y#)) + (W8# x#) * (W8# y#) = W8# (narrow8Word# (x# `timesWord#` y#)) + negate (W8# x#) = W8# (narrow8Word# (int2Word# (negateInt# (word2Int# x#)))) abs x = x signum 0 = 0 signum _ = 1 - fromInteger (S# i#) = W8# (wordToWord8# (int2Word# i#)) - fromInteger (J# s# d#) = W8# (wordToWord8# (integer2Word# s# d#)) + fromInteger (S# i#) = W8# (narrow8Word# (int2Word# i#)) + fromInteger (J# s# d#) = W8# (narrow8Word# (integer2Word# s# d#)) instance Real Word8 where toRational x = toInteger x % 1 @@ -258,9 +255,9 @@ instance Bits Word8 where (W8# x#) `xor` (W8# y#) = W8# (x# `xor#` y#) complement (W8# x#) = W8# (x# `xor#` mb#) where W8# mb# = maxBound (W8# x#) `shift` (I# i#) - | i# >=# 0# = W8# (wordToWord8# (x# `shiftL#` i#)) + | i# >=# 0# = W8# (narrow8Word# (x# `shiftL#` i#)) | otherwise = W8# (x# `shiftRL#` negateInt# i#) - (W8# x#) `rotate` (I# i#) = W8# (wordToWord8# ((x# `shiftL#` i'#) `or#` + (W8# x#) `rotate` (I# i#) = W8# (narrow8Word# ((x# `shiftL#` i'#) `or#` (x# `shiftRL#` (8# -# i'#)))) where i'# = word2Int# (int2Word# i# `and#` int2Word# 7#) @@ -270,7 +267,7 @@ instance Bits Word8 where {-# RULES "fromIntegral/Word8->Word8" fromIntegral = id :: Word8 -> Word8 "fromIntegral/Word8->Integer" fromIntegral = toInteger :: Word8 -> Integer -"fromIntegral/a->Word8" fromIntegral = \x -> case fromIntegral x of W# x# -> W8# (wordToWord8# x#) +"fromIntegral/a->Word8" fromIntegral = \x -> case fromIntegral x of W# x# -> W8# (narrow8Word# x#) "fromIntegral/Word8->a" fromIntegral = \(W8# x#) -> fromIntegral (W# x#) #-} @@ -290,15 +287,15 @@ instance Show Word16 where showsPrec p x = showsPrec p (fromIntegral x :: Int) instance Num Word16 where - (W16# x#) + (W16# y#) = W16# (wordToWord16# (x# `plusWord#` y#)) - (W16# x#) - (W16# y#) = W16# (wordToWord16# (x# `minusWord#` y#)) - (W16# x#) * (W16# y#) = W16# (wordToWord16# (x# `timesWord#` y#)) - negate (W16# x#) = W16# (wordToWord16# (int2Word# (negateInt# (word2Int# x#)))) + (W16# x#) + (W16# y#) = W16# (narrow16Word# (x# `plusWord#` y#)) + (W16# x#) - (W16# y#) = W16# (narrow16Word# (x# `minusWord#` y#)) + (W16# x#) * (W16# y#) = W16# (narrow16Word# (x# `timesWord#` y#)) + negate (W16# x#) = W16# (narrow16Word# (int2Word# (negateInt# (word2Int# x#)))) abs x = x signum 0 = 0 signum _ = 1 - fromInteger (S# i#) = W16# (wordToWord16# (int2Word# i#)) - fromInteger (J# s# d#) = W16# (wordToWord16# (integer2Word# s# d#)) + fromInteger (S# i#) = W16# (narrow16Word# (int2Word# i#)) + fromInteger (J# s# d#) = W16# (narrow16Word# (integer2Word# s# d#)) instance Real Word16 where toRational x = toInteger x % 1 @@ -359,9 +356,9 @@ instance Bits Word16 where (W16# x#) `xor` (W16# y#) = W16# (x# `xor#` y#) complement (W16# x#) = W16# (x# `xor#` mb#) where W16# mb# = maxBound (W16# x#) `shift` (I# i#) - | i# >=# 0# = W16# (wordToWord16# (x# `shiftL#` i#)) + | i# >=# 0# = W16# (narrow16Word# (x# `shiftL#` i#)) | otherwise = W16# (x# `shiftRL#` negateInt# i#) - (W16# x#) `rotate` (I# i#) = W16# (wordToWord16# ((x# `shiftL#` i'#) `or#` + (W16# x#) `rotate` (I# i#) = W16# (narrow16Word# ((x# `shiftL#` i'#) `or#` (x# `shiftRL#` (16# -# i'#)))) where i'# = word2Int# (int2Word# i# `and#` int2Word# 15#) @@ -372,7 +369,7 @@ instance Bits Word16 where "fromIntegral/Word8->Word16" fromIntegral = \(W8# x#) -> W16# x# "fromIntegral/Word16->Word16" fromIntegral = id :: Word16 -> Word16 "fromIntegral/Word16->Integer" fromIntegral = toInteger :: Word16 -> Integer -"fromIntegral/a->Word16" fromIntegral = \x -> case fromIntegral x of W# x# -> W16# (wordToWord16# x#) +"fromIntegral/a->Word16" fromIntegral = \x -> case fromIntegral x of W# x# -> W16# (narrow16Word# x#) "fromIntegral/Word16->a" fromIntegral = \(W16# x#) -> fromIntegral (W# x#) #-} @@ -380,37 +377,140 @@ instance Bits Word16 where -- type Word32 ------------------------------------------------------------------------ +#if WORD_SIZE_IN_BITS < 32 + +data Word32 = W32# Word32# + +instance Eq Word32 where + (W32# x#) == (W32# y#) = x# `eqWord32#` y# + (W32# x#) /= (W32# y#) = x# `neWord32#` y# + +instance Ord Word32 where + (W32# x#) < (W32# y#) = x# `ltWord32#` y# + (W32# x#) <= (W32# y#) = x# `leWord32#` y# + (W32# x#) > (W32# y#) = x# `gtWord32#` y# + (W32# x#) >= (W32# y#) = x# `geWord32#` y# + +instance Num Word32 where + (W32# x#) + (W32# y#) = W32# (int32ToWord32# (word32ToInt32# x# `plusInt32#` word32ToInt32# y#)) + (W32# x#) - (W32# y#) = W32# (int32ToWord32# (word32ToInt32# x# `minusInt32#` word32ToInt32# y#)) + (W32# x#) * (W32# y#) = W32# (int32ToWord32# (word32ToInt32# x# `timesInt32#` word32ToInt32# y#)) + negate (W32# x#) = W32# (int32ToWord32# (negateInt32# (word32ToInt32# x#))) + abs x = x + signum 0 = 0 + signum _ = 1 + fromInteger (S# i#) = W32# (int32ToWord32# (intToInt32# i#)) + fromInteger (J# s# d#) = W32# (integerToWord32# s# d#) + +instance Enum Word32 where + succ x + | x /= maxBound = x + 1 + | otherwise = succError "Word32" + pred x + | x /= minBound = x - 1 + | otherwise = predError "Word32" + toEnum i@(I# i#) + | i >= 0 = W32# (wordToWord32# (int2Word# i#)) + | otherwise = toEnumError "Word32" i (minBound::Word32, maxBound::Word32) + fromEnum x@(W32# x#) + | x <= fromIntegral (maxBound::Int) + = I# (word2Int# (word32ToWord# x#)) + | otherwise = fromEnumError "Word32" x + enumFrom = integralEnumFrom + enumFromThen = integralEnumFromThen + enumFromTo = integralEnumFromTo + enumFromThenTo = integralEnumFromThenTo + +instance Integral Word32 where + quot x@(W32# x#) y@(W32# y#) + | y /= 0 = W32# (x# `quotWord32#` y#) + | otherwise = divZeroError "quot{Word32}" x + rem x@(W32# x#) y@(W32# y#) + | y /= 0 = W32# (x# `remWord32#` y#) + | otherwise = divZeroError "rem{Word32}" x + div x@(W32# x#) y@(W32# y#) + | y /= 0 = W32# (x# `quotWord32#` y#) + | otherwise = divZeroError "div{Word32}" x + mod x@(W32# x#) y@(W32# y#) + | y /= 0 = W32# (x# `remWord32#` y#) + | otherwise = divZeroError "mod{Word32}" x + quotRem x@(W32# x#) y@(W32# y#) + | y /= 0 = (W32# (x# `quotWord32#` y#), W32# (x# `remWord32#` y#)) + | otherwise = divZeroError "quotRem{Word32}" x + divMod x@(W32# x#) y@(W32# y#) + | y /= 0 = (W32# (x# `quotWord32#` y#), W32# (x# `remWord32#` y#)) + | otherwise = divZeroError "quotRem{Word32}" x + toInteger x@(W32# x#) + | x <= fromIntegral (maxBound::Int) = S# (word2Int# (word32ToWord# x#)) + | otherwise = case word32ToInteger# x# of (# s, d #) -> J# s d + +instance Bits Word32 where + (W32# x#) .&. (W32# y#) = W32# (x# `and32#` y#) + (W32# x#) .|. (W32# y#) = W32# (x# `or32#` y#) + (W32# x#) `xor` (W32# y#) = W32# (x# `xor32#` y#) + complement (W32# x#) = W32# (not32# x#) + (W32# x#) `shift` (I# i#) + | i# >=# 0# = W32# (x# `shiftL32#` i#) + | otherwise = W32# (x# `shiftRL32#` negateInt# i#) + (W32# x#) `rotate` (I# i#) = W32# ((x# `shiftL32#` i'#) `or32#` + (x# `shiftRL32#` (32# -# i'#))) + where + i'# = word2Int# (int2Word# i# `and#` int2Word# 63#) + bitSize _ = 32 + isSigned _ = False + +foreign import "stg_eqWord32" unsafe eqWord32# :: Word32# -> Word32# -> Bool +foreign import "stg_neWord32" unsafe neWord32# :: Word32# -> Word32# -> Bool +foreign import "stg_ltWord32" unsafe ltWord32# :: Word32# -> Word32# -> Bool +foreign import "stg_leWord32" unsafe leWord32# :: Word32# -> Word32# -> Bool +foreign import "stg_gtWord32" unsafe gtWord32# :: Word32# -> Word32# -> Bool +foreign import "stg_geWord32" unsafe geWord32# :: Word32# -> Word32# -> Bool +foreign import "stg_int32ToWord32" unsafe int32ToWord32# :: Int32# -> Word32# +foreign import "stg_word32ToInt32" unsafe word32ToInt32# :: Word32# -> Int32# +foreign import "stg_intToInt32" unsafe intToInt32# :: Int# -> Int32# +foreign import "stg_wordToWord32" unsafe wordToWord32# :: Word# -> Word32# +foreign import "stg_word32ToWord" unsafe word32ToWord# :: Word32# -> Word# +foreign import "stg_plusInt32" unsafe plusInt32# :: Int32# -> Int32# -> Int32# +foreign import "stg_minusInt32" unsafe minusInt32# :: Int32# -> Int32# -> Int32# +foreign import "stg_timesInt32" unsafe timesInt32# :: Int32# -> Int32# -> Int32# +foreign import "stg_negateInt32" unsafe negateInt32# :: Int32# -> Int32# +foreign import "stg_quotWord32" unsafe quotWord32# :: Word32# -> Word32# -> Word32# +foreign import "stg_remWord32" unsafe remWord32# :: Word32# -> Word32# -> Word32# +foreign import "stg_and32" unsafe and32# :: Word32# -> Word32# -> Word32# +foreign import "stg_or32" unsafe or32# :: Word32# -> Word32# -> Word32# +foreign import "stg_xor32" unsafe xor32# :: Word32# -> Word32# -> Word32# +foreign import "stg_not32" unsafe not32# :: Word32# -> Word32# +foreign import "stg_shiftL32" unsafe shiftL32# :: Word32# -> Int# -> Word32# +foreign import "stg_shiftRL32" unsafe shiftRL32# :: Word32# -> Int# -> Word32# + +{-# RULES +"fromIntegral/Int->Word32" fromIntegral = \(I# x#) -> W32# (int32ToWord32# (intToInt32# x#)) +"fromIntegral/Word->Word32" fromIntegral = \(W# x#) -> W32# (wordToWord32# x#) +"fromIntegral/Word32->Int" fromIntegral = \(W32# x#) -> I# (word2Int# (word32ToWord# x#)) +"fromIntegral/Word32->Word" fromIntegral = \(W32# x#) -> W# (word32ToWord# x#) +"fromIntegral/Word32->Word32" fromIntegral = id :: Word32 -> Word32 + #-} + +#else + -- Word32 is represented in the same way as Word. -#if WORD_SIZE_IN_BYTES == 8 +#if WORD_SIZE_IN_BITS > 32 -- Operations may assume and must ensure that it holds only values -- from its logical range. #endif data Word32 = W32# Word# deriving (Eq, Ord) -instance CCallable Word32 -instance CReturnable Word32 - -instance Show Word32 where -#if WORD_SIZE_IN_BYTES == 4 - showsPrec p x = showsPrec p (toInteger x) -#else - showsPrec p x = showsPrec p (fromIntegral x :: Int) -#endif - instance Num Word32 where - (W32# x#) + (W32# y#) = W32# (wordToWord32# (x# `plusWord#` y#)) - (W32# x#) - (W32# y#) = W32# (wordToWord32# (x# `minusWord#` y#)) - (W32# x#) * (W32# y#) = W32# (wordToWord32# (x# `timesWord#` y#)) - negate (W32# x#) = W32# (wordToWord32# (int2Word# (negateInt# (word2Int# x#)))) + (W32# x#) + (W32# y#) = W32# (narrow32Word# (x# `plusWord#` y#)) + (W32# x#) - (W32# y#) = W32# (narrow32Word# (x# `minusWord#` y#)) + (W32# x#) * (W32# y#) = W32# (narrow32Word# (x# `timesWord#` y#)) + negate (W32# x#) = W32# (narrow32Word# (int2Word# (negateInt# (word2Int# x#)))) abs x = x signum 0 = 0 signum _ = 1 - fromInteger (S# i#) = W32# (wordToWord32# (int2Word# i#)) - fromInteger (J# s# d#) = W32# (wordToWord32# (integer2Word# s# d#)) - -instance Real Word32 where - toRational x = toInteger x % 1 + fromInteger (S# i#) = W32# (narrow32Word# (int2Word# i#)) + fromInteger (J# s# d#) = W32# (narrow32Word# (integer2Word# s# d#)) instance Enum Word32 where succ x @@ -421,12 +521,12 @@ instance Enum Word32 where | otherwise = predError "Word32" toEnum i@(I# i#) | i >= 0 -#if WORD_SIZE_IN_BYTES == 8 +#if WORD_SIZE_IN_BITS > 32 && i <= fromIntegral (maxBound::Word32) #endif = W32# (int2Word# i#) | otherwise = toEnumError "Word32" i (minBound::Word32, maxBound::Word32) -#if WORD_SIZE_IN_BYTES == 4 +#if WORD_SIZE_IN_BITS == 32 fromEnum x@(W32# x#) | x <= fromIntegral (maxBound::Int) = I# (word2Int# x#) @@ -461,7 +561,7 @@ instance Integral Word32 where | y /= 0 = (W32# (x# `quotWord#` y#), W32# (x# `remWord#` y#)) | otherwise = divZeroError "quotRem{Word32}" x toInteger (W32# x#) -#if WORD_SIZE_IN_BYTES == 4 +#if WORD_SIZE_IN_BITS == 32 | i# >=# 0# = S# i# | otherwise = case word2Integer# x# of (# s, d #) -> J# s d where @@ -470,33 +570,15 @@ instance Integral Word32 where = S# (word2Int# x#) #endif -instance Bounded Word32 where - minBound = 0 - maxBound = 0xFFFFFFFF - -instance Ix Word32 where - range (m,n) = [m..n] - index b@(m,_) i - | inRange b i = fromIntegral (i - m) - | otherwise = indexError b i "Word32" - inRange (m,n) i = m <= i && i <= n - -instance Read Word32 where -#if WORD_SIZE_IN_BYTES == 4 - readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s] -#else - readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s] -#endif - instance Bits Word32 where (W32# x#) .&. (W32# y#) = W32# (x# `and#` y#) (W32# x#) .|. (W32# y#) = W32# (x# `or#` y#) (W32# x#) `xor` (W32# y#) = W32# (x# `xor#` y#) complement (W32# x#) = W32# (x# `xor#` mb#) where W32# mb# = maxBound (W32# x#) `shift` (I# i#) - | i# >=# 0# = W32# (wordToWord32# (x# `shiftL#` i#)) + | i# >=# 0# = W32# (narrow32Word# (x# `shiftL#` i#)) | otherwise = W32# (x# `shiftRL#` negateInt# i#) - (W32# x#) `rotate` (I# i#) = W32# (wordToWord32# ((x# `shiftL#` i'#) `or#` + (W32# x#) `rotate` (I# i#) = W32# (narrow32Word# ((x# `shiftL#` i'#) `or#` (x# `shiftRL#` (32# -# i'#)))) where i'# = word2Int# (int2Word# i# `and#` int2Word# 31#) @@ -508,15 +590,49 @@ instance Bits Word32 where "fromIntegral/Word16->Word32" fromIntegral = \(W16# x#) -> W32# x# "fromIntegral/Word32->Word32" fromIntegral = id :: Word32 -> Word32 "fromIntegral/Word32->Integer" fromIntegral = toInteger :: Word32 -> Integer -"fromIntegral/a->Word32" fromIntegral = \x -> case fromIntegral x of W# x# -> W32# (wordToWord32# x#) +"fromIntegral/a->Word32" fromIntegral = \x -> case fromIntegral x of W# x# -> W32# (narrow32Word# x#) "fromIntegral/Word32->a" fromIntegral = \(W32# x#) -> fromIntegral (W# x#) #-} +#endif + +instance CCallable Word32 +instance CReturnable Word32 + +instance Show Word32 where +#if WORD_SIZE_IN_BITS < 33 + showsPrec p x = showsPrec p (toInteger x) +#else + showsPrec p x = showsPrec p (fromIntegral x :: Int) +#endif + + +instance Real Word32 where + toRational x = toInteger x % 1 + +instance Bounded Word32 where + minBound = 0 + maxBound = 0xFFFFFFFF + +instance Ix Word32 where + range (m,n) = [m..n] + index b@(m,_) i + | inRange b i = fromIntegral (i - m) + | otherwise = indexError b i "Word32" + inRange (m,n) i = m <= i && i <= n + +instance Read Word32 where +#if WORD_SIZE_IN_BITS < 33 + readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s] +#else + readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s] +#endif + ------------------------------------------------------------------------ -- type Word64 ------------------------------------------------------------------------ -#if WORD_SIZE_IN_BYTES == 4 +#if WORD_SIZE_IN_BITS < 64 data Word64 = W64# Word64# @@ -606,13 +722,13 @@ foreign import "stg_gtWord64" unsafe gtWord64# :: Word64# -> Word64# - foreign import "stg_geWord64" unsafe geWord64# :: Word64# -> Word64# -> Bool foreign import "stg_int64ToWord64" unsafe int64ToWord64# :: Int64# -> Word64# foreign import "stg_word64ToInt64" unsafe word64ToInt64# :: Word64# -> Int64# +foreign import "stg_intToInt64" unsafe intToInt64# :: Int# -> Int64# +foreign import "stg_wordToWord64" unsafe wordToWord64# :: Word# -> Word64# +foreign import "stg_word64ToWord" unsafe word64ToWord# :: Word64# -> Word# foreign import "stg_plusInt64" unsafe plusInt64# :: Int64# -> Int64# -> Int64# foreign import "stg_minusInt64" unsafe minusInt64# :: Int64# -> Int64# -> Int64# foreign import "stg_timesInt64" unsafe timesInt64# :: Int64# -> Int64# -> Int64# foreign import "stg_negateInt64" unsafe negateInt64# :: Int64# -> Int64# -foreign import "stg_intToInt64" unsafe intToInt64# :: Int# -> Int64# -foreign import "stg_wordToWord64" unsafe wordToWord64# :: Word# -> Word64# -foreign import "stg_word64ToWord" unsafe word64ToWord# :: Word64# -> Word# foreign import "stg_quotWord64" unsafe quotWord64# :: Word64# -> Word64# -> Word64# foreign import "stg_remWord64" unsafe remWord64# :: Word64# -> Word64# -> Word64# foreign import "stg_and64" unsafe and64# :: Word64# -> Word64# -> Word64# @@ -632,6 +748,10 @@ foreign import "stg_shiftRL64" unsafe shiftRL64# :: Word64# -> Int# -> W #else +-- Word64 is represented in the same way as Word. +-- Operations may assume and must ensure that it holds only values +-- from its logical range. + data Word64 = W64# Word# deriving (Eq, Ord) instance Num Word64 where diff --git a/ghc/tests/mk/boilerplate.mk b/ghc/tests/mk/boilerplate.mk index e0e590b..b6ffc5b 100644 --- a/ghc/tests/mk/boilerplate.mk +++ b/ghc/tests/mk/boilerplate.mk @@ -22,7 +22,7 @@ TOP:=$(TEST_TOP) HC=$(GHC_INPLACE) # we don't want recompilation checking in here -SRC_HC_OPTS += -no-recomp +SRC_HC_OPTS += -no-recomp # ----------------------------------------------------------------- # Everything after this point diff --git a/ghc/utils/genprimopcode/Main.hs b/ghc/utils/genprimopcode/Main.hs index 5100abf..2e79230 100644 --- a/ghc/utils/genprimopcode/Main.hs +++ b/ghc/utils/genprimopcode/Main.hs @@ -22,8 +22,7 @@ main = getArgs >>= \args -> do s <- getContents let pres = parse pTop "" s case pres of - Left err -> do putStr "parse error at " - print err + Left err -> error ("parse error at " ++ (show err)) Right p_o_specs -> myseq (sanityTop p_o_specs) ( case head args of @@ -78,8 +77,8 @@ main = getArgs >>= \args -> "--make-haskell-wrappers" -> putStr (gen_wrappers p_o_specs) - "--make-latex-table" - -> putStr (gen_latex_table p_o_specs) + "--make-latex-doc" + -> putStr (gen_latex_doc p_o_specs) ) @@ -96,35 +95,163 @@ known_args "--primop-tag", "--primop-list", "--make-haskell-wrappers", - "--make-latex-table" + "--make-latex-doc" ] ------------------------------------------------------------------ -- Code generators ----------------------------------------------- ------------------------------------------------------------------ -gen_latex_table (Info defaults pos) - = "\\begin{tabular}{|l|l|}\n" - ++ "\\hline\nName &\t Type\\\\\n\\hline\n" - ++ (concat (map f pos)) - ++ "\\end{tabular}" - where - f spec = "@" ++ (encode (name spec)) ++ "@ &\t@" ++ (pty (ty spec)) ++ "@\\\\\n" - encode s = s - pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2 - pty t = pbty t - pbty (TyApp tc ts) = (encode tc) ++ (concat (map (' ':) (map paty ts))) - pbty (TyUTup ts) = (mkUtupnm (length ts)) ++ (concat (map (' ':) (map paty ts))) - pbty t = paty t - paty (TyVar tv) = encode tv - paty t = "(" ++ pty t ++ ")" - mkUtupnm 1 = "ZL#z32U#ZR" - mkUtupnm n = "Z" ++ (show (n-1)) ++ "U" - -gen_wrappers (Info defaults pos) +gen_latex_doc (Info defaults entries) + = "\\primopdefaults{" + ++ mk_options defaults + ++ "}\n" + ++ (concat (map mk_entry entries)) + where mk_entry (PrimOpSpec {cons=cons,name=name,ty=ty,cat=cat,desc=desc,opts=opts}) = + "\\primopdesc{" + ++ latex_encode cons ++ "}{" + ++ latex_encode name ++ "}{" + ++ latex_encode (zencode name) ++ "}{" + ++ latex_encode (show cat) ++ "}{" + ++ latex_encode (mk_source_ty ty) ++ "}{" + ++ latex_encode (mk_core_ty ty) ++ "}{" + ++ desc ++ "}{" + ++ mk_options opts + ++ "}\n" + mk_entry (Section {title=title,desc=desc}) = + "\\primopsection{" + ++ latex_encode title ++ "}{" + ++ desc ++ "}\n" + mk_source_ty t = pty t + where pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2 + pty t = pbty t + pbty (TyApp tc ts) = tc ++ (concat (map (' ':) (map paty ts))) + pbty (TyUTup ts) = "(# " ++ (concat (intersperse "," (map pty ts))) ++ " #)" + pbty t = paty t + paty (TyVar tv) = tv + paty t = "(" ++ pty t ++ ")" + + mk_core_ty t = foralls ++ (pty t) + where pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2 + pty t = pbty t + pbty (TyApp tc ts) = (zencode tc) ++ (concat (map (' ':) (map paty ts))) + pbty (TyUTup ts) = (zencode (utuplenm (length ts))) ++ (concat ((map (' ':) (map paty ts)))) + pbty t = paty t + paty (TyVar tv) = zencode tv + paty (TyApp tc []) = zencode tc + paty t = "(" ++ pty t ++ ")" + utuplenm 1 = "(# #)" + utuplenm n = "(#" ++ (replicate (n-1) ',') ++ "#)" + foralls = if tvars == [] then "" else "%forall " ++ (tbinds tvars) + tvars = tvars_of t + tbinds [] = ". " + tbinds ("o":tbs) = "(o::?) " ++ (tbinds tbs) + tbinds (tv:tbs) = tv ++ " " ++ (tbinds tbs) + tvars_of (TyF t1 t2) = tvars_of t1 `union` tvars_of t2 + tvars_of (TyApp tc ts) = foldl union [] (map tvars_of ts) + tvars_of (TyUTup ts) = foldr union [] (map tvars_of ts) + tvars_of (TyVar tv) = [tv] + + mk_options opts = + "\\primoptions{" + ++ mk_has_side_effects opts ++ "}{" + ++ mk_out_of_line opts ++ "}{" + ++ mk_commutable opts ++ "}{" + ++ mk_needs_wrapper opts ++ "}{" + ++ mk_can_fail opts ++ "}{" + ++ latex_encode (mk_strictness opts) ++ "}{" + ++ latex_encode (mk_usage opts) + ++ "}" + + mk_has_side_effects opts = mk_bool_opt opts "has_side_effects" "Has side effects." "Has no side effects." + mk_out_of_line opts = mk_bool_opt opts "out_of_line" "Implemented out of line." "Implemented in line." + mk_commutable opts = mk_bool_opt opts "commutable" "Commutable." "Not commutable." + mk_needs_wrapper opts = mk_bool_opt opts "needs_wrapper" "Needs wrapper." "Needs no wrapper." + mk_can_fail opts = mk_bool_opt opts "can_fail" "Can fail." "Cannot fail." + + mk_bool_opt opts opt_name if_true if_false = + case lookup_attrib opt_name opts of + Just (OptionTrue _) -> if_true + Just (OptionFalse _) -> if_false + Nothing -> "" + + mk_strictness opts = + case lookup_attrib "strictness" opts of + Just (OptionString _ s) -> s -- for now + Nothing -> "" + + mk_usage opts = + case lookup_attrib "usage" opts of + Just (OptionString _ s) -> s -- for now + Nothing -> "" + + zencode cs = + case maybe_tuple cs of + Just n -> n -- Tuples go to Z2T etc + Nothing -> concat (map encode_ch cs) + where + maybe_tuple "(# #)" = Just("Z1H") + maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of + (n, '#' : ')' : cs) -> Just ('Z' : shows (n+1) "H") + other -> Nothing + maybe_tuple "()" = Just("Z0T") + maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of + (n, ')' : cs) -> Just ('Z' : shows (n+1) "T") + other -> Nothing + maybe_tuple other = Nothing + + count_commas :: Int -> String -> (Int, String) + count_commas n (',' : cs) = count_commas (n+1) cs + count_commas n cs = (n,cs) + + unencodedChar :: Char -> Bool -- True for chars that don't need encoding + unencodedChar 'Z' = False + unencodedChar 'z' = False + unencodedChar c = isAlphaNum c + + encode_ch :: Char -> String + encode_ch c | unencodedChar c = [c] -- Common case first + + -- Constructors + encode_ch '(' = "ZL" -- Needed for things like (,), and (->) + encode_ch ')' = "ZR" -- For symmetry with ( + encode_ch '[' = "ZM" + encode_ch ']' = "ZN" + encode_ch ':' = "ZC" + encode_ch 'Z' = "ZZ" + + -- Variables + encode_ch 'z' = "zz" + encode_ch '&' = "za" + encode_ch '|' = "zb" + encode_ch '^' = "zc" + encode_ch '$' = "zd" + encode_ch '=' = "ze" + encode_ch '>' = "zg" + encode_ch '#' = "zh" + encode_ch '.' = "zi" + encode_ch '<' = "zl" + encode_ch '-' = "zm" + encode_ch '!' = "zn" + encode_ch '+' = "zp" + encode_ch '\'' = "zq" + encode_ch '\\' = "zr" + encode_ch '/' = "zs" + encode_ch '*' = "zt" + encode_ch '_' = "zu" + encode_ch '%' = "zv" + encode_ch c = 'z' : shows (ord c) "U" + + latex_encode [] = [] + latex_encode (c:cs) | c `elem` "#$%&_^{}" = "\\" ++ c:(latex_encode cs) + latex_encode ('~':cs) = "\\verb!~!" ++ (latex_encode cs) + latex_encode ('\\':cs) = "$\\backslash$" ++ (latex_encode cs) + latex_encode (c:cs) = c:(latex_encode cs) + +gen_wrappers (Info defaults entries) = "module PrelPrimopWrappers where\n" ++ "import qualified PrelGHC\n" - ++ unlines (map f (filter (not.dodgy) pos)) + ++ unlines (map f (filter (not.dodgy) (filter is_primop entries))) where f spec = let args = map (\n -> "a" ++ show n) [1 .. arity (ty spec)] src_name = wrap (name spec) @@ -145,30 +272,30 @@ gen_wrappers (Info defaults pos) ] -gen_primop_list (Info defaults pos) +gen_primop_list (Info defaults entries) = unlines ( - [ " [" ++ cons (head pos) ] + [ " [" ++ cons first ] ++ - map (\pi -> " , " ++ cons pi) (tail pos) + map (\pi -> " , " ++ cons pi) rest ++ [ " ]" ] - ) + ) where (first:rest) = filter is_primop entries -gen_primop_tag (Info defaults pos) - = unlines (zipWith f pos [1..]) +gen_primop_tag (Info defaults entries) + = unlines (zipWith f (filter is_primop entries) [1..]) where f i n = "tagOf_PrimOp " ++ cons i ++ " = _ILIT(" ++ show n ++ ") :: FastInt" -gen_data_decl (Info defaults pos) - = let conss = map cons pos +gen_data_decl (Info defaults entries) + = let conss = map cons (filter is_primop entries) in "data PrimOp\n = " ++ head conss ++ "\n" ++ unlines (map (" | "++) (tail conss)) gen_switch_from_attribs :: String -> String -> Info -> String -gen_switch_from_attribs attrib_name fn_name (Info defaults pos) +gen_switch_from_attribs attrib_name fn_name (Info defaults entries) = let defv = lookup_attrib attrib_name defaults - alts = catMaybes (map mkAlt pos) + alts = catMaybes (map mkAlt (filter is_primop entries)) getAltRhs (OptionFalse _) = "False" getAltRhs (OptionTrue _) = "True" @@ -179,9 +306,6 @@ gen_switch_from_attribs attrib_name fn_name (Info defaults pos) Nothing -> Nothing Just xx -> Just (fn_name ++ " " ++ cons po ++ " = " ++ getAltRhs xx) - lookup_attrib nm [] = Nothing - lookup_attrib nm (a:as) - = if get_attrib_name a == nm then Just a else lookup_attrib nm as in case defv of Nothing -> error ("gen_switch_from: " ++ attrib_name) @@ -194,8 +318,8 @@ gen_switch_from_attribs attrib_name fn_name (Info defaults pos) ------------------------------------------------------------------ -gen_primop_info (Info defaults pos) - = unlines (map mkPOItext pos) +gen_primop_info (Info defaults entries) + = unlines (map mkPOItext (filter is_primop entries)) mkPOItext i = mkPOI_LHS_text i ++ mkPOI_RHS_text i @@ -237,9 +361,11 @@ ppTyVar "o" = "openAlphaTyVar" ppType (TyApp "Bool" []) = "boolTy" ppType (TyApp "Int#" []) = "intPrimTy" +ppType (TyApp "Int32#" []) = "int32PrimTy" ppType (TyApp "Int64#" []) = "int64PrimTy" ppType (TyApp "Char#" []) = "charPrimTy" ppType (TyApp "Word#" []) = "wordPrimTy" +ppType (TyApp "Word32#" []) = "word32PrimTy" ppType (TyApp "Word64#" []) = "word64PrimTy" ppType (TyApp "Addr#" []) = "addrPrimTy" ppType (TyApp "Float#" []) = "floatPrimTy" @@ -304,18 +430,24 @@ arity = length . fst . flatTys -- info for all primops; the totality of the info in primops.txt(.pp) data Info - = Info [Option] [PrimOpSpec] -- defaults, primops + = Info [Option] [Entry] -- defaults, primops deriving Show -- info for one primop -data PrimOpSpec +data Entry = PrimOpSpec { cons :: String, -- PrimOp name name :: String, -- name in prog text ty :: Ty, -- type cat :: Category, -- category + desc :: String, -- description opts :: [Option] } -- default overrides + | Section { title :: String, -- section title + desc :: String } -- description deriving Show +is_primop (PrimOpSpec _ _ _ _ _ _) = True +is_primop _ = False + -- a binding of property to value data Option = OptionFalse String -- name = False @@ -360,8 +492,9 @@ myseqAll (():ys) x = myseqAll ys x myseqAll [] x = x sanityTop :: Info -> () -sanityTop (Info defs primops) +sanityTop (Info defs entries) = let opt_names = map get_attrib_name defs + primops = filter is_primop entries in if length opt_names /= length (nub opt_names) then error ("non-unique default attribute names: " ++ show opt_names ++ "\n") @@ -398,6 +531,10 @@ get_attrib_name (OptionFalse nm) = nm get_attrib_name (OptionTrue nm) = nm get_attrib_name (OptionString nm _) = nm +lookup_attrib nm [] = Nothing +lookup_attrib nm (a:as) + = if get_attrib_name a == nm then Just a else lookup_attrib nm as + ------------------------------------------------------------------ -- The parser ---------------------------------------------------- ------------------------------------------------------------------ @@ -405,10 +542,18 @@ get_attrib_name (OptionString nm _) = nm -- Due to lack of proper lexing facilities, a hack to zap any -- leading comments pTop :: Parser Info -pTop = then4 (\_ ds ss _ -> Info ds ss) - pCommentAndWhitespace pDefaults (many pPrimOpSpec) +pTop = then4 (\_ ds es _ -> Info ds es) + pCommentAndWhitespace pDefaults (many pEntry) (lit "thats_all_folks") +pEntry :: Parser Entry +pEntry + = alts [pPrimOpSpec, pSection] + +pSection :: Parser Entry +pSection = then3 (\_ n d -> Section {title = n, desc = d}) + (lit "section") stringLiteral pDesc + pDefaults :: Parser [Option] pDefaults = then2 sel22 (lit "defaults") (many pOption) @@ -421,12 +566,12 @@ pOption pName (lit "=") pStuffBetweenBraces ] -pPrimOpSpec :: Parser PrimOpSpec +pPrimOpSpec :: Parser Entry pPrimOpSpec - = then6 (\_ c n k t o -> PrimOpSpec { cons = c, name = n, ty = t, - cat = k, opts = o } ) + = then7 (\_ c n k t d o -> PrimOpSpec { cons = c, name = n, ty = t, + cat = k, desc = d, opts = o } ) (lit "primop") pConstructor stringLiteral - pCategory pType pOptions + pCategory pType pDesc pOptions pOptions :: Parser [Option] pOptions = optdef [] (then2 sel22 (lit "with") (many pOption)) @@ -440,10 +585,28 @@ pCategory apply (const GenPrimOp) (lit "GenPrimOp") ] +pDesc :: Parser String +pDesc = optdef "" pStuffBetweenBraces + +pStuffBetweenBraces :: Parser String pStuffBetweenBraces - = lexeme (then3 sel23 - (char '{') (many (satisfy (not . (== '}')))) - (char '}')) + = lexeme ( + do char '{' + ass <- many pInsides + char '}' + return (concat ass) ) + +pInsides :: Parser String +pInsides + = (do char '{' + stuff <- many pInsides + char '}' + return ("{" ++ (concat stuff) ++ "}")) + <|> + (do c <- satisfy (/= '}') + return [c]) + + ------------------- -- Parsing types -- @@ -475,7 +638,7 @@ ppT = alts [apply TyVar pTyvar, apply (\tc -> TyApp tc []) pTycon ] -pTyvar = sat (`notElem` ["primop","with"]) pName +pTyvar = sat (`notElem` ["section","primop","with"]) pName pTycon = pConstructor pName = lexeme (then2 (:) lower (many isIdChar)) pConstructor = lexeme (then2 (:) upper (many isIdChar)) @@ -508,6 +671,9 @@ then5 f p1 p2 p3 p4 p5 then6 f p1 p2 p3 p4 p5 p6 = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; x4 <- p4 ; x5 <- p5 ; x6 <- p6 return (f x1 x2 x3 x4 x5 x6) +then7 f p1 p2 p3 p4 p5 p6 p7 + = do x1 <- p1 ; x2 <- p2 ; x3 <- p3 ; x4 <- p4 ; x5 <- p5 ; x6 <- p6 ; x7 <- p7 + return (f x1 x2 x3 x4 x5 x6 x7) opt p = (do x <- p; return (Just x)) <|> return Nothing optdef d p -- 1.7.10.4