[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: Kill off gen_bytearray_addr_access_ops.py
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Jul 24 12:37:46 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
b6b7ec71 by Matthew Craven at 2023-07-24T08:37:34-04:00
Kill off gen_bytearray_addr_access_ops.py
The relevant primop descriptions are now
generated directly by genprimopcode.
This makes progress toward fixing #23490, but it is not
a complete fix since there is more than one way in which
cabal-reinstall (hadrian/build build-cabal) is broken.
- - - - -
2bc0c367 by Matthew Pickering at 2023-07-24T08:37:35-04:00
compiler: Remove unused `containers.h` include
Fixes #23712
- - - - -
17 changed files:
- − compiler/GHC/Builtin/gen_bytearray_addr_access_ops.py
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/Data/Word64Map.hs
- compiler/GHC/Data/Word64Map/Internal.hs
- compiler/GHC/Data/Word64Map/Lazy.hs
- compiler/GHC/Data/Word64Map/Strict.hs
- compiler/GHC/Data/Word64Map/Strict/Internal.hs
- compiler/GHC/Data/Word64Set.hs
- compiler/GHC/Data/Word64Set/Internal.hs
- compiler/GHC/Utils/Containers/Internal/BitUtil.hs
- compiler/GHC/Utils/Containers/Internal/StrictPair.hs
- hadrian/src/Rules/Generate.hs
- + utils/genprimopcode/AccessOps.hs
- utils/genprimopcode/Lexer.x
- utils/genprimopcode/Parser.y
- utils/genprimopcode/ParserM.hs
- utils/genprimopcode/genprimopcode.cabal
Changes:
=====================================
compiler/GHC/Builtin/gen_bytearray_addr_access_ops.py deleted
=====================================
@@ -1,201 +0,0 @@
-#!/usr/bin/env python
-# -*- coding: utf-8 -*-
-
-# This script generates the primop descriptions for many similar ByteArray#
-# and Addr# access operations. Its output is #include-d into primops.txt.pp.
-
-from typing import Optional, NamedTuple
-import textwrap
-import argparse
-
-arg_parser = argparse.ArgumentParser()
-arg_parser.add_argument('addr_or_bytearray',
- choices = ["addr-access-ops", "bytearray-access-ops"],
- )
-arg_parser.add_argument('output_file',
- type=argparse.FileType('w'),
- metavar='FILE',
- )
-args = arg_parser.parse_args()
-write = args.output_file.write
-
-
-
-write('''
--- Do not edit.
--- This file is generated by compiler/GHC/Builtin/gen_bytearray_addr_access_ops.py.
--- (The build system should take care of this for you.)
-
-''')
-
-class ElementType(NamedTuple):
- name: str
- rep_ty: str
- desc: str
- width: Optional[int]
-
-MACH_WORD = None
-
-element_types = [
- # (name, representation type, human description, width)
- #
- # width in bytes.
- # width == None denotes machine word
-
- ElementType("Char", "Char#", "8-bit character", 1),
- ElementType("WideChar", "Char#", "32-bit character", 4),
- ElementType("Int", "Int#", "word-sized integer", MACH_WORD),
- ElementType("Word", "Word#", "word-sized unsigned integer", MACH_WORD),
- ElementType("Addr", "Addr#", "machine address", MACH_WORD),
- ElementType("Float", "Float#", "single-precision floating-point value", 4),
- ElementType("Double", "Double#", "double-precision floating-point value", 8),
- ElementType("StablePtr", "StablePtr# a", "'StablePtr#' value", MACH_WORD),
-]
-
-for n in [8,16,32,64]:
- element_types += [
- ElementType(f"Int{n}", f"Int{n}#",
- f"{n}-bit signed integer", n // 8),
- ElementType(f"Word{n}", f"Word{n}#",
- f"{n}-bit unsigned integer", n // 8)
- ]
-
-def pretty_offset(n: Optional[int]) -> str:
- if n == MACH_WORD:
- return 'machine words'
- elif n == 1:
- return 'bytes'
- else:
- return f'{n}-byte words'
-
-def get_align_warn(n: ElementType) -> str:
- if n.width == 1:
- return ''
- return '''
- On some platforms, the access may fail
- for an insufficiently aligned @Addr#@.
- '''
-
-def print_block(template: str, **kwargs) -> None:
- write(textwrap.dedent(template.format(**kwargs)).lstrip())
- write('\n')
-
-def header(s: str):
- write('\n')
- print_block('''
- ------------------------------------
- -- {s}
- ------------------------------------
- ''', s=s)
-
-if args.addr_or_bytearray == "bytearray-access-ops":
- header("ByteArray# operations")
-
- header('aligned index operations')
- for t in element_types:
- offset = pretty_offset(t.width)
- print_block('''
- primop IndexByteArrayOp_{name} "index{name}Array#" GenPrimOp
- ByteArray# -> Int# -> {rep_ty}
- {{Read a {desc}; offset in {offset}.}}
- with can_fail = True
- ''', offset = offset, **t._asdict())
-
- header('unaligned index operations')
- for t in element_types:
- if t.name in ['Int8', 'Word8']: continue
- print_block('''
- primop IndexByteArrayOp_Word8As{name} "indexWord8ArrayAs{name}#" GenPrimOp
- ByteArray# -> Int# -> {rep_ty}
- {{Read a {desc}; offset in bytes.}}
- with can_fail = True
- ''', **t._asdict())
-
- header('aligned read operations')
- for t in element_types:
- offset = pretty_offset(t.width)
- print_block('''
- primop ReadByteArrayOp_{name} "read{name}Array#" GenPrimOp
- MutableByteArray# s -> Int# -> State# s -> (# State# s, {rep_ty} #)
- {{Read a {desc}; offset in {offset}.}}
- with has_side_effects = True
- can_fail = True
- ''', offset = offset, **t._asdict())
-
- header('unaligned read operations')
- for t in element_types:
- if t.name in ['Int8', 'Word8']: continue
- print_block('''
- primop ReadByteArrayOp_Word8As{name} "readWord8ArrayAs{name}#" GenPrimOp
- MutableByteArray# s -> Int# -> State# s -> (# State# s, {rep_ty} #)
- {{Read a {desc}; offset in bytes.}}
- with has_side_effects = True
- can_fail = True
- ''', **t._asdict())
-
- header('aligned write operations')
- for t in element_types:
- offset = pretty_offset(t.width)
- print_block('''
- primop WriteByteArrayOp_{name} "write{name}Array#" GenPrimOp
- MutableByteArray# s -> Int# -> {rep_ty} -> State# s -> State# s
- {{Write a {desc}; offset in {offset}.}}
- with has_side_effects = True
- can_fail = True
- ''', offset = offset, **t._asdict())
-
- header('unaligned write operations')
- for t in element_types:
- if t.name in ['Int8', 'Word8']: continue
- print_block('''
- primop WriteByteArrayOp_Word8As{name} "writeWord8ArrayAs{name}#" GenPrimOp
- MutableByteArray# s -> Int# -> {rep_ty} -> State# s -> State# s
- {{Write a {desc}; offset in bytes.}}
- with has_side_effects = True
- can_fail = True
- ''', **t._asdict())
-
-
-else: # addr_or_bytearray == "addr-access-ops":
- header("Addr# access operations")
-
- header('aligned index operations')
- for t in element_types:
- offset = pretty_offset(t.width)
- align_warn = get_align_warn(t)
- print_block('''
- primop IndexOffAddrOp_{name} "index{name}OffAddr#" GenPrimOp
- Addr# -> Int# -> {rep_ty}
- {{ Read a {desc}; offset in {offset}.
- {align_warn}
- }}
- with can_fail = True
- ''', offset = offset, align_warn = align_warn, **t._asdict())
-
- header('aligned read operations')
- for t in element_types:
- offset = pretty_offset(t.width)
- align_warn = get_align_warn(t)
- print_block('''
- primop ReadOffAddrOp_{name} "read{name}OffAddr#" GenPrimOp
- Addr# -> Int# -> State# s -> (# State# s, {rep_ty} #)
- {{ Read a {desc}; offset in {offset}.
- {align_warn}
- }}
- with has_side_effects = True
- can_fail = True
- ''', offset = offset, align_warn = align_warn, **t._asdict())
-
- header('aligned write operations')
- for t in element_types:
- offset = pretty_offset(t.width)
- align_warn = get_align_warn(t)
- print_block('''
- primop WriteOffAddrOp_{name} "write{name}OffAddr#" GenPrimOp
- Addr# -> Int# -> {rep_ty} -> State# s -> State# s
- {{ Write a {desc}; offset in {offset}.
- {align_warn}
- }}
- with has_side_effects = True
- can_fail = True
- ''', offset = offset, align_warn = align_warn, **t._asdict())
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -1956,7 +1956,11 @@ primop GetSizeofMutableByteArrayOp "getSizeofMutableByteArray#" GenPrimOp
@since 0.5.0.0}
-#include "bytearray-access-ops.txt.pp"
+
+bytearray_access_ops
+-- This generates a whole bunch of primops;
+-- see utils/genprimopcode/AccessOps.hs
+
primop CompareByteArraysOp "compareByteArrays#" GenPrimOp
ByteArray# -> Int# -> ByteArray# -> Int# -> Int# -> Int#
@@ -2259,7 +2263,11 @@ primop AddrNeOp "neAddr#" Compare Addr# -> Addr# -> Int#
primop AddrLtOp "ltAddr#" Compare Addr# -> Addr# -> Int#
primop AddrLeOp "leAddr#" Compare Addr# -> Addr# -> Int#
-#include "addr-access-ops.txt.pp"
+
+addr_access_ops
+-- This generates a whole bunch of primops;
+-- see utils/genprimopcode/AccessOps.hs
+
primop InterlockedExchange_Addr "atomicExchangeAddrAddr#" GenPrimOp
Addr# -> Addr# -> State# s -> (# State# s, Addr# #)
=====================================
compiler/GHC/Data/Word64Map.hs
=====================================
@@ -8,7 +8,6 @@
{-# LANGUAGE MonoLocalBinds #-}
#endif
-#include "containers.h"
-----------------------------------------------------------------------------
-- |
=====================================
compiler/GHC/Data/Word64Map/Internal.hs
=====================================
@@ -14,7 +14,6 @@
{-# OPTIONS_HADDOCK not-home #-}
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
-#include "containers.h"
-----------------------------------------------------------------------------
-- |
=====================================
compiler/GHC/Data/Word64Map/Lazy.hs
=====================================
@@ -3,7 +3,6 @@
{-# LANGUAGE Safe #-}
#endif
-#include "containers.h"
-----------------------------------------------------------------------------
-- |
=====================================
compiler/GHC/Data/Word64Map/Strict.hs
=====================================
@@ -4,8 +4,6 @@
{-# LANGUAGE Trustworthy #-}
#endif
-#include "containers.h"
-
-----------------------------------------------------------------------------
-- |
-- Module : Data.Word64Map.Strict
=====================================
compiler/GHC/Data/Word64Map/Strict/Internal.hs
=====================================
@@ -4,8 +4,6 @@
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
-#include "containers.h"
-
-----------------------------------------------------------------------------
-- |
-- Module : Data.Word64Map.Strict.Internal
=====================================
compiler/GHC/Data/Word64Set.hs
=====================================
@@ -3,8 +3,6 @@
{-# LANGUAGE Safe #-}
#endif
-#include "containers.h"
-
-----------------------------------------------------------------------------
-- |
-- Module : Data.Word64Set
=====================================
compiler/GHC/Data/Word64Set/Internal.hs
=====================================
@@ -12,8 +12,6 @@
{-# OPTIONS_HADDOCK not-home #-}
-#include "containers.h"
-
-----------------------------------------------------------------------------
-- |
-- Module : Data.Word64Set.Internal
=====================================
compiler/GHC/Utils/Containers/Internal/BitUtil.hs
=====================================
@@ -6,8 +6,6 @@
{-# LANGUAGE Safe #-}
#endif
-#include "containers.h"
-
-----------------------------------------------------------------------------
-- |
-- Module : Utils.Containers.Internal.BitUtil
=====================================
compiler/GHC/Utils/Containers/Internal/StrictPair.hs
=====================================
@@ -3,8 +3,6 @@
{-# LANGUAGE Safe #-}
#endif
-#include "containers.h"
-
-- | A strict pair
module GHC.Utils.Containers.Internal.StrictPair (StrictPair(..), toPair) where
=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -38,17 +38,6 @@ primopsSource = "compiler/GHC/Builtin/primops.txt.pp"
primopsTxt :: Stage -> FilePath
primopsTxt stage = buildDir (vanillaContext stage compiler) -/- "primops.txt"
-accessOpsSource :: FilePath
-accessOpsSource = "compiler/GHC/Builtin/gen_bytearray_addr_access_ops.py"
-
-byteArrayAccessOpsTxt :: Stage -> FilePath
-byteArrayAccessOpsTxt stage
- = buildDir (vanillaContext stage compiler) -/- "bytearray-access-ops.txt.pp"
-
-addrAccessOpsTxt :: Stage -> FilePath
-addrAccessOpsTxt stage
- = buildDir (vanillaContext stage compiler) -/- "addr-access-ops.txt.pp"
-
isGeneratedCmmFile :: FilePath -> Bool
isGeneratedCmmFile file = takeBaseName file == "AutoApply"
@@ -159,21 +148,8 @@ generatePackageCode context@(Context stage pkg _ _) = do
root -/- "**" -/- dir -/- "GHC/Platform/Host.hs" %> go generatePlatformHostHs
when (pkg == compiler) $ do
- let ba_ops_txt = root -/- byteArrayAccessOpsTxt stage
- let addr_ops_txt = root -/- addrAccessOpsTxt stage
- ba_ops_txt %> \file -> do
- need [accessOpsSource]
- runBuilder Python
- [accessOpsSource, "bytearray-access-ops", file]
- [] []
- addr_ops_txt %> \file -> do
- need [accessOpsSource]
- runBuilder Python
- [accessOpsSource, "addr-access-ops", file]
- [] []
root -/- primopsTxt stage %> \file -> do
- need $ [primopsSource, ba_ops_txt, addr_ops_txt]
- -- ba_ops_txt and addr_ops_txt get #include-d
+ need $ [primopsSource]
build $ target context HsCpp [primopsSource] [file]
when (pkg == rts) $ do
=====================================
utils/genprimopcode/AccessOps.hs
=====================================
@@ -0,0 +1,250 @@
+module AccessOps (byteArrayAccessOps, addrAccessOps) where
+
+import Syntax
+
+data ElementType = MkElementType
+ { elt_name :: String
+ , elt_rep_ty :: Ty
+ , elt_desc :: String
+ , elt_width :: Maybe Int
+ }
+
+machWord :: Maybe Int
+machWord = Nothing
+
+strToTy :: String -> Ty
+strToTy s = TyApp (TyCon s) []
+
+elementTypes :: [ElementType]
+elementTypes =
+ [ MkElementType "Char" (strToTy "Char#" ) "an 8-bit character" (Just 1)
+ , MkElementType "WideChar" (strToTy "Char#" ) "a 32-bit character" (Just 4)
+ , MkElementType "Int" (strToTy "Int#" ) "a word-sized integer" machWord
+ , MkElementType "Word" (strToTy "Word#" ) "a word-sized unsigned integer" machWord
+ , MkElementType "Addr" (strToTy "Addr#" ) "a machine address" machWord
+ , MkElementType "Float" (strToTy "Float#" ) "a single-precision floating-point value" (Just 4)
+ , MkElementType "Double" (strToTy "Double#") "a double-precision floating-point value" (Just 8)
+ , MkElementType "StablePtr" (TyApp (TyCon "StablePtr#") [TyVar "a"])
+ "a 'StablePtr#' value" machWord
+ ] ++ do
+ n <- [8, 16, 32, 64]
+ let mkDesc suff = (if n == 8 then "an " else "a ") ++ shows n suff
+ [ MkElementType
+ { elt_name = "Int" ++ show n
+ , elt_rep_ty = strToTy $ "Int" ++ shows n "#"
+ , elt_desc = mkDesc "-bit signed integer"
+ , elt_width = Just (n `quot` 8)
+ },
+ MkElementType
+ { elt_name = "Word" ++ show n
+ , elt_rep_ty = strToTy $ "Word" ++ shows n "#"
+ , elt_desc = mkDesc "-bit unsigned integer"
+ , elt_width = Just (n `quot` 8)
+ }
+ ]
+
+unalignedElementTypes :: [ElementType]
+unalignedElementTypes
+ = filter (\e -> elt_name e `notElem` ["Int8", "Word8"]) elementTypes
+--unalignedElementTypes = filter (\e -> elt_width e /= Just 1) elementTypes
+
+prettyOffset :: ElementType -> String
+prettyOffset e = case elt_width e of
+ Nothing -> "machine words"
+ Just 1 -> "bytes"
+ Just n -> shows n "-byte words"
+
+getAlignWarn :: ElementType -> String
+getAlignWarn e = case elt_width e of
+ Just 1 -> ""
+ _ -> "On some platforms, the access may fail\n"
+ ++ "for an insufficiently aligned @Addr#@."
+
+mutableByteArrayS :: Ty
+mutableByteArrayS = TyApp (TyCon "MutableByteArray#") [TyVar "s"]
+
+stateS :: Ty
+stateS = TyApp (TyCon "State#") [TyVar "s"]
+
+readResTy :: ElementType -> Ty
+readResTy e = TyF stateS (TyUTup [stateS, elt_rep_ty e])
+
+writeResTy :: ElementType -> Ty
+writeResTy e = TyF (elt_rep_ty e) (TyF stateS stateS)
+
+
+
+mkIndexByteArrayOp :: ElementType -> Entry
+mkIndexByteArrayOp e = PrimOpSpec
+ { cons = "IndexByteArrayOp_" ++ elt_name e
+ , name = "index" ++ elt_name e ++ "Array#"
+ , ty = TyF (strToTy "ByteArray#")
+ $ TyF (strToTy "Int#")
+ (elt_rep_ty e)
+ , cat = GenPrimOp
+ , desc = "Read " ++ elt_desc e ++ "; offset in " ++ prettyOffset e ++ "."
+ , opts = [OptionTrue "can_fail"]
+ }
+
+mkUnalignedIndexByteArrayOp :: ElementType -> Entry
+mkUnalignedIndexByteArrayOp e = PrimOpSpec
+ { cons = "IndexByteArrayOp_Word8As" ++ elt_name e
+ , name = "indexWord8ArrayAs" ++ elt_name e ++ "#"
+ , ty = TyF (strToTy "ByteArray#")
+ $ TyF (strToTy "Int#")
+ (elt_rep_ty e)
+ , cat = GenPrimOp
+ , desc = "Read " ++ elt_desc e ++ "; offset in bytes."
+ , opts = [OptionTrue "can_fail"]
+ }
+
+mkReadByteArrayOp :: ElementType -> Entry
+mkReadByteArrayOp e = PrimOpSpec
+ { cons = "ReadByteArrayOp_" ++ elt_name e
+ , name = "read" ++ elt_name e ++ "Array#"
+ , ty = TyF mutableByteArrayS
+ $ TyF (strToTy "Int#")
+ $ readResTy e
+ , cat = GenPrimOp
+ , desc = "Read " ++ elt_desc e ++ "; offset in " ++ prettyOffset e ++ "."
+ , opts = [OptionTrue "can_fail", OptionTrue "has_side_effects"]
+ }
+
+mkUnalignedReadByteArrayOp :: ElementType -> Entry
+mkUnalignedReadByteArrayOp e = PrimOpSpec
+ { cons = "ReadByteArrayOp_Word8As" ++ elt_name e
+ , name = "readWord8ArrayAs" ++ elt_name e ++ "#"
+ , ty = TyF mutableByteArrayS
+ $ TyF (strToTy "Int#")
+ $ readResTy e
+ , cat = GenPrimOp
+ , desc = "Read " ++ elt_desc e ++ "; offset in bytes."
+ , opts = [OptionTrue "can_fail", OptionTrue "has_side_effects"]
+ }
+
+mkWriteByteArrayOp :: ElementType -> Entry
+mkWriteByteArrayOp e = PrimOpSpec
+ { cons = "WriteByteArrayOp_" ++ elt_name e
+ , name = "write" ++ elt_name e ++ "Array#"
+ , ty = TyF mutableByteArrayS
+ $ TyF (strToTy "Int#")
+ $ writeResTy e
+ , cat = GenPrimOp
+ , desc = "Write " ++ elt_desc e ++ "; offset in " ++ prettyOffset e ++ "."
+ , opts = [OptionTrue "can_fail", OptionTrue "has_side_effects"]
+ }
+
+mkUnalignedWriteByteArrayOp :: ElementType -> Entry
+mkUnalignedWriteByteArrayOp e = PrimOpSpec
+ { cons = "WriteByteArrayOp_Word8As" ++ elt_name e
+ , name = "writeWord8ArrayAs" ++ elt_name e ++ "#"
+ , ty = TyF mutableByteArrayS
+ $ TyF (strToTy "Int#")
+ $ writeResTy e
+ , cat = GenPrimOp
+ , desc = "Write " ++ elt_desc e ++ "; offset in bytes."
+ , opts = [OptionTrue "can_fail", OptionTrue "has_side_effects"]
+ }
+
+
+byteArrayAccessOps :: [Entry]
+byteArrayAccessOps
+ = map mkIndexByteArrayOp elementTypes
+ ++ map mkUnalignedIndexByteArrayOp unalignedElementTypes
+ ++ map mkReadByteArrayOp elementTypes
+ ++ map mkUnalignedReadByteArrayOp unalignedElementTypes
+ ++ map mkWriteByteArrayOp elementTypes
+ ++ map mkUnalignedWriteByteArrayOp unalignedElementTypes
+
+
+
+mkIndexOffAddrOp :: ElementType -> Entry
+mkIndexOffAddrOp e = PrimOpSpec
+ { cons = "IndexOffAddrOp_" ++ elt_name e
+ , name = "index" ++ elt_name e ++ "OffAddr#"
+ , ty = TyF (strToTy "Addr#")
+ $ TyF (strToTy "Int#")
+ (elt_rep_ty e)
+ , cat = GenPrimOp
+ , desc = "Read " ++ elt_desc e ++ "; offset in " ++ prettyOffset e ++ ".\n\n"
+ ++ getAlignWarn e
+ , opts = [OptionTrue "can_fail"]
+ }
+
+{-
+mkUnalignedIndexOffAddrOp :: ElementType -> Entry
+mkUnalignedIndexOffAddrOp e = PrimOpSpec
+ { cons = "IndexOffAddrOp_Word8As" ++ elt_name e
+ , name = "indexWord8OffAddrAs" ++ elt_name e ++ "#"
+ , ty = TyF (strToTy "Addr#")
+ $ TyF (strToTy "Int#")
+ (elt_rep_ty e)
+ , cat = GenPrimOp
+ , desc = "Read " ++ elt_desc e ++ "; offset in bytes."
+ , opts = [OptionTrue "can_fail"]
+ }
+-}
+
+mkReadOffAddrOp :: ElementType -> Entry
+mkReadOffAddrOp e = PrimOpSpec
+ { cons = "ReadOffAddrOp_" ++ elt_name e
+ , name = "read" ++ elt_name e ++ "OffAddr#"
+ , ty = TyF (strToTy "Addr#")
+ $ TyF (strToTy "Int#")
+ $ readResTy e
+ , cat = GenPrimOp
+ , desc = "Read " ++ elt_desc e ++ "; offset in " ++ prettyOffset e ++ ".\n\n"
+ ++ getAlignWarn e
+ , opts = [OptionTrue "can_fail", OptionTrue "has_side_effects"]
+ }
+
+{-
+mkUnalignedReadOffAddrOp :: ElementType -> Entry
+mkUnalignedReadOffAddrOp e = PrimOpSpec
+ { cons = "ReadOffAddrOp_Word8As" ++ elt_name e
+ , name = "readWord8OffAddrAs" ++ elt_name e ++ "#"
+ , ty = TyF (strToTy "Addr#")
+ $ TyF (strToTy "Int#")
+ $ readResTy e
+ , cat = GenPrimOp
+ , desc = "Read " ++ elt_desc e ++ "; offset in bytes."
+ , opts = [OptionTrue "can_fail", OptionTrue "has_side_effects"]
+ }
+-}
+
+mkWriteOffAddrOp :: ElementType -> Entry
+mkWriteOffAddrOp e = PrimOpSpec
+ { cons = "WriteOffAddrOp_" ++ elt_name e
+ , name = "write" ++ elt_name e ++ "OffAddr#"
+ , ty = TyF (strToTy "Addr#")
+ $ TyF (strToTy "Int#")
+ $ writeResTy e
+ , cat = GenPrimOp
+ , desc = "Write " ++ elt_desc e ++ "; offset in " ++ prettyOffset e ++ ".\n\n"
+ ++ getAlignWarn e
+ , opts = [OptionTrue "can_fail", OptionTrue "has_side_effects"]
+ }
+
+{-
+mkUnalignedWriteOffAddrOp :: ElementType -> Entry
+mkUnalignedWriteOffAddrOp e = PrimOpSpec
+ { cons = "WriteOffAddrOp_Word8As" ++ elt_name e
+ , name = "writeWord8OffAddrAs" ++ elt_name e ++ "#"
+ , ty = TyF (strToTy "Addr#")
+ $ TyF (strToTy "Int#")
+ $ writeResTy e
+ , cat = GenPrimOp
+ , desc = "Write " ++ elt_desc e ++ "; offset in bytes."
+ , opts = [OptionTrue "can_fail", OptionTrue "has_side_effects"]
+ }
+-}
+
+
+addrAccessOps :: [Entry]
+addrAccessOps
+ = map mkIndexOffAddrOp elementTypes
+-- ++ map mkUnalignedIndexOffAddrOp unalignedElementTypes
+ ++ map mkReadOffAddrOp elementTypes
+-- ++ map mkUnalignedReadOffAddrOp unalignedElementTypes
+ ++ map mkWriteOffAddrOp elementTypes
+-- ++ map mkUnalignedWriteOffAddrOp unalignedElementTypes
=====================================
utils/genprimopcode/Lexer.x
=====================================
@@ -52,6 +52,8 @@ words :-
<0> "infixr" { mkT TInfixR }
<0> "Nothing" { mkT TNothing }
<0> "vector" { mkT TVector }
+ <0> "bytearray_access_ops" { mkT TByteArrayAccessOps }
+ <0> "addr_access_ops" { mkT TAddrAccessOps }
<0> "thats_all_folks" { mkT TThatsAllFolks }
<0> "SCALAR" { mkT TSCALAR }
<0> "VECTOR" { mkT TVECTOR }
=====================================
utils/genprimopcode/Parser.y
=====================================
@@ -5,6 +5,8 @@ import Lexer (lex_tok)
import ParserM (Token(..), ParserM, run_parser, get_pos, show_pos,
happyError)
import Syntax
+
+import AccessOps
}
%name parsex
@@ -47,6 +49,8 @@ import Syntax
SCALAR { TSCALAR }
VECTOR { TVECTOR }
VECTUPLE { TVECTUPLE }
+ bytearray_access_ops { TByteArrayAccessOps }
+ addr_access_ops { TAddrAccessOps }
thats_all_folks { TThatsAllFolks }
lowerName { TLowerName $$ }
upperName { TUpperName $$ }
@@ -83,8 +87,13 @@ pInfix : infix integer { Just $ Fixity NoSourceText $2 InfixN }
pEntries :: { [Entry] }
pEntries : pEntry pEntries { $1 : $2 }
+ | pAccessOps pEntries { $1 ++ $2 }
| {- empty -} { [] }
+pAccessOps :: { [Entry] }
+pAccessOps : bytearray_access_ops { byteArrayAccessOps }
+ | addr_access_ops { addrAccessOps }
+
pEntry :: { Entry }
pEntry : pPrimOpSpec { $1 }
| pPrimTypeSpec { $1 }
@@ -148,7 +157,7 @@ pVectors : pVector ',' pVectors { [$1] ++ $3 }
pVector :: { (String, String, Int) }
pVector : '<' upperName ',' upperName ',' integer '>' { ($2, $4, $6) }
-
+
pType :: { Ty }
pType : paT '->' pType { TyF $1 $3 }
| paT '=>' pType { TyC $1 $3 }
=====================================
utils/genprimopcode/ParserM.hs
=====================================
@@ -98,6 +98,8 @@ data Token = TEOF
| TFalse
| TCompare
| TGenPrimOp
+ | TByteArrayAccessOps
+ | TAddrAccessOps
| TThatsAllFolks
| TLowerName String
| TUpperName String
=====================================
utils/genprimopcode/genprimopcode.cabal
=====================================
@@ -28,6 +28,7 @@ Executable genprimopcode
Parser
ParserM
Syntax
+ AccessOps
Build-Depends: base >= 4 && < 5,
array
if flag(build-tool-depends)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/86cd1f6cdebcc8ef365b1d1289a176ee834e551e...2bc0c36754f086d0b65a39a558e1391b0ac67ffa
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/86cd1f6cdebcc8ef365b1d1289a176ee834e551e...2bc0c36754f086d0b65a39a558e1391b0ac67ffa
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230724/92ba53b6/attachment-0001.html>
More information about the ghc-commits
mailing list