├── .arcconfig ├── .github └── workflows │ └── validate.yml ├── .gitignore ├── LICENSE ├── Makefile ├── Makefile.inc ├── Makefile.nhc98 ├── README.rst ├── Setup.hs ├── cabal.haskell-ci ├── cabal.project ├── cbits └── utils.c ├── changelog.md ├── data └── template-hsc.h ├── ghc.mk ├── hsc2hs.cabal ├── hsc2hs.wrapper ├── src ├── ATTParser.hs ├── C.hs ├── Common.hs ├── Compat │ ├── ResponseFile.hs │ └── TempFile.hs ├── CrossCodegen.hs ├── DirectCodegen.hs ├── Flags.hs ├── HSCParser.hs ├── Main.hs └── UtilsCodegen.hs └── test ├── BDD.hs ├── Spec.hs └── asm ├── Makefile ├── aarch64-ios.s ├── aarch64.s ├── alpha-linux.s ├── arm-ios.s ├── arm.s ├── hppa-linux.s ├── ia64-linux.s ├── m68k-linux.s ├── mips-linux.s ├── mips64-linux.s ├── nios2-linux.s ├── powerpc-linux.s ├── powerpc64-linux.s ├── powerpc64le-linux.s ├── s390-linux.s ├── s390x-linux.s ├── sh4-linux.s ├── sparc-linux.s ├── sparc64-linux.s ├── tmp.c ├── x86-linux.s ├── x86_64-linux.s ├── x86_64-mac.s └── x86_64-mingw32.s /.arcconfig: -------------------------------------------------------------------------------- 1 | { 2 | "project.name" : "hsc2hs", 3 | "repository.callsign" : "HSCHS", 4 | "phabricator.uri" : "https://phabricator.haskell.org" 5 | } 6 | -------------------------------------------------------------------------------- /.github/workflows/validate.yml: -------------------------------------------------------------------------------- 1 | name: build 2 | on: 3 | push: 4 | branches: 5 | - master 6 | pull_request: 7 | types: 8 | - opened 9 | - synchronize 10 | jobs: 11 | build: 12 | runs-on: ${{ matrix.os }} 13 | strategy: 14 | matrix: 15 | ghc: ['9.2.3', '9.4.5', '9.6.6', '9.8.4', '9.10.1'] 16 | cabal: ['3.14.1.1'] 17 | os: [ubuntu-latest, macOS-latest, windows-latest] 18 | exclude: 19 | - os: macOS-latest 20 | ghc: '9.2.3' 21 | name: "${{ matrix.os }} - ${{ matrix.ghc }}" 22 | steps: 23 | - uses: actions/checkout@v4 24 | - name: Setup Haskell 25 | uses: haskell-actions/setup@v2 26 | with: 27 | ghc-version: ${{ matrix.ghc }} 28 | cabal-version: ${{ matrix.cabal }} 29 | - run: cabal check 30 | - run: cabal update 31 | - run: cabal build 32 | - run: cabal test --test-show-details=direct --verbose 33 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | cabal.project.local~ 21 | .HTF/ 22 | .ghc.environment.* 23 | .vscode -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The Glasgow Haskell Compiler License 2 | 3 | Copyright 2002, The University Court of the University of Glasgow. 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | - Redistributions of source code must retain the above copyright notice, 10 | this list of conditions and the following disclaimer. 11 | 12 | - Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | - Neither name of the University nor the names of its contributors may be 17 | used to endorse or promote products derived from this software without 18 | specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF 21 | GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, 22 | INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 23 | FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 24 | UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE 25 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 26 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 27 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 28 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 29 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 30 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH 31 | DAMAGE. 32 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # ----------------------------------------------------------------------------- 2 | # 3 | # (c) 2009 The University of Glasgow 4 | # 5 | # This file is part of the GHC build system. 6 | # 7 | # To understand how the build system works and how to modify it, see 8 | # http://hackage.haskell.org/trac/ghc/wiki/Building/Architecture 9 | # http://hackage.haskell.org/trac/ghc/wiki/Building/Modifying 10 | # 11 | # ----------------------------------------------------------------------------- 12 | 13 | dir = utils/hsc2hs 14 | TOP = ../.. 15 | include $(TOP)/mk/sub-makefile.mk 16 | -------------------------------------------------------------------------------- /Makefile.inc: -------------------------------------------------------------------------------- 1 | ifeq "" "${MKDIR}" 2 | MKDIR:=$(shell pwd) 3 | #MKDIR:=$(PWD) 4 | else 5 | MKDIR:=$(patsubst %/$(notdir ${MKDIR}),%, ${MKDIR}) 6 | endif 7 | include ${MKDIR}/Makefile.inc 8 | -------------------------------------------------------------------------------- /Makefile.nhc98: -------------------------------------------------------------------------------- 1 | include Makefile.inc 2 | 3 | OBJDIR = ${BUILDDIR}/obj/hsc2hs 4 | TARGET = ${DST}/hsc2hs$(EXE) 5 | 6 | SRCS = Main.hs 7 | FROMC = ../libraries/base/System/Console/GetOpt.$C \ 8 | ../libraries/directory/System/Directory.$C \ 9 | ../libraries/base/Data/List.$C \ 10 | ../libraries/process/System/Cmd.$C \ 11 | ../libraries/base/System/IO.$C \ 12 | ../libraries/base/Control/Monad.$C \ 13 | ../libraries/base/Control/Exception/Base.$C \ 14 | ../libraries/base/Foreign/C/String.$C \ 15 | ../libraries/base/Foreign/Marshal/Alloc.$C \ 16 | ../libraries/base/System/Posix/Internals.$C \ 17 | ../libraries/filepath/System/FilePath/Posix.$C \ 18 | ../libraries/base/Foreign/Marshal/Array.$C \ 19 | ../libraries/base/Foreign/Marshal/Utils.$C \ 20 | ../libraries/base/NHC/PosixTypes.$C \ 21 | ../libraries/base/Data/Typeable.$C \ 22 | ../libraries/base/Data/HashTable.$C \ 23 | ../libraries/base/NHC/SizedTypes.$C \ 24 | ../libraries/base/Data/Bits.$C \ 25 | ../libraries/base/Foreign/C/Types.$C 26 | 27 | FMERROR = ../libraries/base/Foreign/Marshal/Error.$C 28 | SIERROR = ../libraries/base/System/IO/Error.$C 29 | FCERROR = ../libraries/base/Foreign/C/Error.$C 30 | 31 | #REALC = ../libraries/base/cbits/dirUtils.c 32 | 33 | CINCLUDES = -I../libraries/base/include -I../libraries/directory/include 34 | 35 | # ../libraries/base/Control/Exception.$C \ 36 | # ../libraries/base/System/Posix/Types.$C \ 37 | 38 | ifeq "$(findstring ghc, ${HC})" "ghc" 39 | HFLAGS = $(shell $(LOCAL)fixghc $(GHCSYM) -package base -package lang -package process -package directory ) 40 | export HFLAGS 41 | endif 42 | ifeq "$(findstring hbc, ${HC})" "hbc" 43 | HFLAGS = 44 | export HFLAGS 45 | endif 46 | ifeq "$(findstring nhc98, ${HC})" "nhc98" 47 | HFLAGS = -package base -package filepath -package directory -package process +CTS -H4M -CTS 48 | export HFLAGS 49 | endif 50 | 51 | all: $(TARGET) 52 | install: $(TARGET) 53 | cfiles: cleanC $(SRCS) 54 | $(HMAKE) -hc=$(LOCAL)nhc98 -package base -package filepath \ 55 | -package directory -package process -DBUILD_NHC -C Main.hs 56 | clean: 57 | -rm -f *.hi *.o $(OBJDIR)/*.o 58 | cleanC: clean 59 | -rm -f *.hc *.c 60 | realclean: clean cleanC 61 | -rm -f $(OBJDIR)/Main$(EXE) 62 | 63 | $(TARGET): $(OBJDIR) $(SRCS) 64 | $(HMAKE) -hc=$(HC) Main -d$(OBJDIR) -DBUILD_NHC \ 65 | $(shell echo "${BUILDOPTS}") $(HFLAGS) $(CYGFLAG) 66 | mv $(OBJDIR)/Main$(EXE) $(TARGET) 67 | $(HOSTSTRIP) $(TARGET) 68 | 69 | $(OBJDIR): 70 | mkdir -p $(OBJDIR) 71 | 72 | fromC: $(OBJDIR) 73 | cp $(FROMC) . 74 | cp $(FMERROR) ./FMError.$C 75 | cp $(SIERROR) ./SIError.$C 76 | cp $(FCERROR) ./FCError.$C 77 | $(LOCAL)nhc98 -cpp -o $(TARGET) -d$(OBJDIR) $(CINCLUDES) *.$C $(REALC) 78 | $(HOSTSTRIP) $(TARGET) 79 | 80 | -------------------------------------------------------------------------------- /README.rst: -------------------------------------------------------------------------------- 1 | ``hsc2hs``: Haskell Pre-processor for C FFI bindings 2 | #################################################### 3 | |Hackage| |Linux build| |Windows build| 4 | 5 | The ``hsc2hs`` command can be used to automate some parts of the process 6 | of writing Haskell bindings to C code. It reads an almost-Haskell source 7 | with embedded special constructs, and outputs a real Haskell file with 8 | these constructs processed, based on information taken from some C 9 | headers. The extra constructs deal with accessing C data from Haskell. 10 | 11 | It may also output a C file which contains additional C functions to be 12 | linked into the program, together with a C header that gets included 13 | into the C code to which the Haskell module will be compiled (when 14 | compiled via C) and into the C file. These two files are created when 15 | the ``#def`` construct is used (see below). 16 | 17 | Actually ``hsc2hs`` does not output the Haskell file directly. It 18 | creates a C program that includes the headers, gets automatically 19 | compiled and run. That program outputs the Haskell code. 20 | 21 | In the following, "Haskell file" is the main output (usually a ``.hs`` 22 | file), "compiled Haskell file" is the Haskell file after ``ghc`` has 23 | compiled it to C (i.e. a ``.hc`` file), "C program" is the program that 24 | outputs the Haskell file, "C file" is the optionally generated C file, 25 | and "C header" is its header file. 26 | 27 | .. contents:: 28 | 29 | Command line syntax 30 | ~~~~~~~~~~~~~~~~~~~ 31 | 32 | ``hsc2hs`` takes input files as arguments, and flags that modify its 33 | behavior: 34 | 35 | ``-o FILE``, ``--output=FILE`` 36 | Name of the Haskell file. 37 | 38 | ``-t FILE``, ``--template=FILE`` 39 | The template file (see below). 40 | 41 | ``-c PROG``, ``--cc=PROG`` 42 | The C compiler to use (default: ``gcc``) 43 | 44 | ``-l PROG``, ``--ld=PROG`` 45 | The linker to use (default: ``gcc``). 46 | 47 | ``-C FLAG``, ``--cflag=FLAG`` 48 | An extra flag to pass to the C compiler. 49 | 50 | ``-I DIR`` 51 | Passed to the C compiler. 52 | 53 | ``-L FLAG``, ``--lflag=FLAG`` 54 | An extra flag to pass to the linker. 55 | 56 | ``-i FILE``, ``--include=FILE`` 57 | As if the appropriate ``#include`` directive was placed in the 58 | source. 59 | 60 | ``-D NAME[=VALUE]``, ``--define=NAME[=VALUE]`` 61 | As if the appropriate ``#define`` directive was placed in the 62 | source. 63 | 64 | ``--no-compile`` 65 | Stop after writing out the intermediate C program to disk. The file 66 | name for the intermediate C program is the input file name with 67 | ``.hsc`` replaced with ``_hsc_make.c``. 68 | 69 | ``-k``, ``--keep-files`` 70 | Proceed as normal, but do not delete any intermediate files. 71 | 72 | ``-x``, ``--cross-compile`` 73 | Activate cross-compilation mode (see `cross-compilation`_). 74 | 75 | ``--cross-safe`` 76 | Restrict the .hsc directives to those supported by the 77 | ``--cross-compile`` mode (see `cross-compilation`_). This should be 78 | useful if your ``.hsc`` files must be safely cross-compiled and you 79 | wish to keep non-cross-compilable constructs from creeping into 80 | them. 81 | 82 | ``-?``, ``--help`` 83 | Display a summary of the available flags and exit successfully. 84 | 85 | ``-V``, ``--version`` 86 | Output version information and exit successfully. 87 | 88 | The input file should end with .hsc (it should be plain Haskell source 89 | only; literate Haskell is not supported at the moment). Output files by 90 | default get names with the ``.hsc`` suffix replaced: 91 | 92 | +--------------+----------------+ 93 | | ``.hs`` | Haskell file | 94 | +--------------+----------------+ 95 | | ``_hsc.h`` | C header | 96 | +--------------+----------------+ 97 | | ``_hsc.c`` | C file | 98 | +--------------+----------------+ 99 | 100 | The C program is compiled using the Haskell compiler. This provides the 101 | include path to ``HsFFI.h`` which is automatically included into the C 102 | program. 103 | 104 | Input syntax 105 | ~~~~~~~~~~~~ 106 | 107 | All special processing is triggered by the ``#`` operator. To output a 108 | literal ``#``, write it twice: ``##``. Inside string literals and 109 | comments ``#`` characters are not processed. 110 | 111 | A ``#`` is followed by optional spaces and tabs, an alphanumeric keyword 112 | that describes the kind of processing, and its arguments. Arguments look 113 | like C expressions separated by commas (they are not written inside 114 | parens). They extend up to the nearest unmatched ``)``, ``]`` or ``}``, 115 | or to the end of line if it occurs outside any ``() [] {} '' "" /**/`` 116 | and is not preceded by a backslash. Backslash-newline pairs are 117 | stripped. 118 | 119 | In addition ``#{stuff}`` is equivalent to ``#stuff`` except that it's 120 | self-delimited and thus needs not to be placed at the end of line or in 121 | some brackets. 122 | 123 | Meanings of specific keywords: 124 | 125 | ``#include ``, ``#include "file.h"`` 126 | The specified file gets included into the C program, the compiled 127 | Haskell file, and the C header. ```` is included 128 | automatically. 129 | 130 | ``#define ⟨name⟩``, ``#define ⟨name ⟨value⟩``, ``#undef ⟨name⟩`` 131 | Similar to ``#include``. Note that ``#includes`` and ``#defines`` 132 | may be put in the same file twice so they should not assume 133 | otherwise. 134 | 135 | ``#let ⟨name⟩ ⟨parameters⟩ = "⟨definition⟩"`` 136 | Defines a macro to be applied to the Haskell source. Parameter names 137 | are comma-separated, not inside parens. Such macro is invoked as 138 | other ``#``-constructs, starting with ``#name``. The definition will 139 | be put in the C program inside parens as arguments of ``printf``. To 140 | refer to a parameter, close the quote, put a parameter name and open 141 | the quote again, to let C string literals concatenate. Or use 142 | ``printf``'s format directives. Values of arguments must be given as 143 | strings, unless the macro stringifies them itself using the C 144 | preprocessor's ``#parameter`` syntax. 145 | 146 | ``#def ⟨C_definition⟩`` 147 | The definition (of a function, variable, struct or typedef) is 148 | written to the C file, and its prototype or extern declaration to 149 | the C header. Inline functions are handled correctly. struct 150 | definitions and typedefs are written to the C program too. The 151 | ``inline``, ``struct`` or ``typedef`` keyword must come just after 152 | ``def``. 153 | 154 | ``#if ⟨condition⟩``, ``#ifdef ⟨name⟩``, ``#ifndef ⟨name⟩``, ``#elif ⟨condition⟩``, ``#else``, ``#endif``, ``#error ⟨message⟩``, ``#warning ⟨message⟩`` 155 | Conditional compilation directives are passed unmodified to the C 156 | program, C file, and C header. Putting them in the C program means 157 | that appropriate parts of the Haskell file will be skipped. 158 | 159 | ``#const ⟨C_expression⟩`` 160 | The expression must be convertible to ``long`` or ``unsigned long``. 161 | Its value (literal or negated literal) will be output. 162 | 163 | ``#const_str ⟨C_expression⟩`` 164 | The expression must be convertible to const char pointer. Its value 165 | (string literal) will be output. 166 | 167 | ``#type ⟨C_type⟩`` 168 | A Haskell equivalent of the C numeric type will be output. It will 169 | be one of ``{Int,Word}{8,16,32,64}``, ``Float``, ``Double``, 170 | ``LDouble``. 171 | 172 | ``#peek ⟨struct_type⟩, ⟨field⟩`` 173 | A function that peeks a field of a C struct will be output. It will 174 | have the type ``Storable b => Ptr a -> IO b``. The intention is that 175 | ``#peek`` and ``#poke`` can be used for implementing the operations 176 | of class ``Storable`` for a given C struct (see the 177 | ``Foreign.Storable`` module in the library documentation). 178 | 179 | ``#poke ⟨struct_type⟩, ⟨field⟩`` 180 | Similarly for poke. It will have the type 181 | ``Storable b => Ptr a -> b -> IO ()``. 182 | 183 | ``#ptr ⟨struct_type⟩, ⟨field⟩`` 184 | Makes a pointer to a field struct. It will have the type 185 | ``Ptr a -> Ptr b``. 186 | 187 | ``#offset ⟨struct_type⟩, ⟨field⟩`` 188 | Computes the offset, in bytes, of ``field`` in ``struct_type``. It 189 | will have type ``Int``. 190 | 191 | ``#size ⟨struct_type⟩`` 192 | Computes the size, in bytes, of ``struct_type``. It will have type 193 | ``Int``. 194 | 195 | ``#alignment ⟨struct_type⟩`` 196 | Computes the alignment, in bytes, of ``struct_type``. It will have type 197 | ``Int``. 198 | 199 | ``#enum ⟨type⟩, ⟨constructor⟩, ⟨value⟩, ⟨value⟩, ...`` 200 | A shortcut for multiple definitions which use ``#const``. Each 201 | ``value`` is a name of a C integer constant, e.g. enumeration value. 202 | The name will be translated to Haskell by making each letter 203 | following an underscore uppercase, making all the rest lowercase, 204 | and removing underscores. You can supply a different translation by 205 | writing ``hs_name = c_value`` instead of a ``value``, in which case 206 | ``c_value`` may be an arbitrary expression. The ``hs_name`` will be 207 | defined as having the specified ``type``. Its definition is the 208 | specified ``constructor`` (which in fact may be an expression or be 209 | empty) applied to the appropriate integer value. You can have 210 | multiple ``#enum`` definitions with the same ``type``; this 211 | construct does not emit the type definition itself. 212 | 213 | Custom constructs 214 | ~~~~~~~~~~~~~~~~~ 215 | 216 | ``#const``, ``#type``, ``#peek``, ``#poke`` and ``#ptr`` are not 217 | hardwired into the ``hsc2hs``, but are defined in a C template that is 218 | included in the C program: ``template-hsc.h``. Custom constructs and 219 | templates can be used too. Any ``#``\-construct with unknown key is 220 | expected to be handled by a C template. 221 | 222 | A C template should define a macro or function with name prefixed by 223 | ``hsc_`` that handles the construct by emitting the expansion to stdout. 224 | See ``template-hsc.h`` for examples. 225 | 226 | Such macros can also be defined directly in the source. They are useful 227 | for making a ``#let``\-like macro whose expansion uses other ``#let`` 228 | macros. Plain ``#let`` prepends ``hsc_`` to the macro name and wraps the 229 | definition in a ``printf`` call. 230 | 231 | .. _cross-compilation: 232 | 233 | Cross-compilation 234 | ~~~~~~~~~~~~~~~~~ 235 | 236 | ``hsc2hs`` normally operates by creating, compiling, and running a C 237 | program. That approach doesn't work when cross-compiling — in this 238 | case, the C compiler's generates code for the target machine, not the 239 | host machine. For this situation, there's a special mode 240 | ``hsc2hs --cross-compile`` which can generate the .hs by extracting 241 | information from compilations only — specifically, whether or not 242 | compilation fails. 243 | 244 | Only a subset of ``.hsc`` syntax is supported by ``--cross-compile``. 245 | The following are unsupported: 246 | 247 | - ``#{const_str}`` 248 | - ``#{let}`` 249 | - ``#{def}`` 250 | - Custom constructs 251 | 252 | .. |Hackage| image:: https://img.shields.io/hackage/v/hsc2hs.svg 253 | :target: http://hackage.haskell.org/package/hsc2hs 254 | .. |Linux build| image:: https://github.com/haskell/hsc2hs/actions/workflows/haskell-ci.yml/badge.svg 255 | :target: https://github.com/haskell/hsc2hs/actions/workflows/haskell-ci.yml 256 | .. |Windows build| image:: https://ci.appveyor.com/api/projects/status/ee434vcpvit2qeqh?svg=true 257 | :target: https://ci.appveyor.com/project/RyanGlScott/hsc2hs 258 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | branches: master 2 | installed: +all 3 | 4 | -- constraint-set containers-0.7 5 | -- ghc: >= 8.2 6 | -- constraints: containers ^>= 0.7 7 | -- tests: True 8 | -- run-tests: True 9 | -- 10 | -- raw-project 11 | -- allow-newer: containers 12 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | -------------------------------------------------------------------------------- /cbits/utils.c: -------------------------------------------------------------------------------- 1 | /* ---------------------------------------------------------------------------- 2 | (c) The University of Glasgow 2006, Lifted from Bases 3 | 4 | Useful Win32 bits 5 | ------------------------------------------------------------------------- */ 6 | 7 | #if defined(_WIN32) 8 | 9 | #include "HsBase.h" 10 | #include 11 | #include 12 | /* Using Secure APIs */ 13 | #define MINGW_HAS_SECURE_API 1 14 | #include 15 | #include 16 | 17 | /* Copied from getTempFileNameErrorNo in base's cbits/Win32Utils.c in GHC 8.10. 18 | Check there for any bugfixes first and please keep in sync when making 19 | changes. */ 20 | 21 | bool __get_temp_file_name (wchar_t* pathName, wchar_t* prefix, 22 | wchar_t* suffix, uint32_t uUnique, 23 | wchar_t* tempFileName) 24 | { 25 | int retry = 5; 26 | bool success = false; 27 | while (retry > 0 && !success) 28 | { 29 | // TODO: This needs to handle long file names. 30 | if (!GetTempFileNameW(pathName, prefix, uUnique, tempFileName)) 31 | { 32 | maperrno(); 33 | return false; 34 | } 35 | 36 | wchar_t* drive = malloc (sizeof(wchar_t) * _MAX_DRIVE); 37 | wchar_t* dir = malloc (sizeof(wchar_t) * _MAX_DIR); 38 | wchar_t* fname = malloc (sizeof(wchar_t) * _MAX_FNAME); 39 | if (_wsplitpath_s (tempFileName, drive, _MAX_DRIVE, dir, _MAX_DIR, 40 | fname, _MAX_FNAME, NULL, 0) != 0) 41 | { 42 | success = false; 43 | maperrno (); 44 | } 45 | else 46 | { 47 | wchar_t* temp = _wcsdup (tempFileName); 48 | if (wcsnlen(drive, _MAX_DRIVE) == 0) 49 | swprintf_s(tempFileName, MAX_PATH, L"%s\%s%s", 50 | dir, fname, suffix); 51 | else 52 | swprintf_s(tempFileName, MAX_PATH, L"%s\%s\%s%s", 53 | drive, dir, fname, suffix); 54 | success 55 | = MoveFileExW(temp, tempFileName, MOVEFILE_WRITE_THROUGH 56 | | MOVEFILE_COPY_ALLOWED) != 0; 57 | errno = 0; 58 | if (!success && (GetLastError () != ERROR_FILE_EXISTS || --retry < 0)) 59 | { 60 | success = false; 61 | maperrno (); 62 | DeleteFileW (temp); 63 | } 64 | 65 | 66 | free(temp); 67 | } 68 | 69 | free(drive); 70 | free(dir); 71 | free(fname); 72 | } 73 | 74 | return success; 75 | } 76 | #endif -------------------------------------------------------------------------------- /changelog.md: -------------------------------------------------------------------------------- 1 | ## 0.68.10 2 | 3 | - Further improve robustness of detection of pointer types in `--cross` mode. 4 | 5 | - Compatibility with new `base` versions 6 | 7 | ## 0.68.9 8 | 9 | - Improve robustness of detection of pointer types in `--cross` mode. 10 | 11 | ## 0.68.8 12 | 13 | - Process flags in order, now the last of `--compiler`, `--linker`, 14 | `--template` is used. (#35) 15 | 16 | - WINIO: Make sure that with we don't use the TEMP workaround (#52) 17 | 18 | ## 0.68.7 19 | 20 | - The C compiler is now assumed to be called `cc` instead of `gcc` 21 | by default (#42) 22 | 23 | - Fix race condition when using response files (#30) 24 | 25 | - Add extra diagnostics when `hsc2hs` sub-process fails 26 | and make TempFile creation fully atomic on Windows. See (#33) 27 | 28 | ## 0.68.6 29 | 30 | - Supports generation of response files to avoid system filepath 31 | limits (#22, #23) 32 | 33 | - Fix non-deterministic failures for response file handlings (#29) 34 | 35 | - Temporary file removals on Windows are not a bit more reliable and should 36 | throw less access denied errors. See #25 and 37 | ([#9775](https://gitlab.haskell.org/ghc/ghc/issues/9775)) 38 | 39 | - Accept a leading single quote for data constructor promotion (#13, #17) 40 | 41 | - Support `MonadFail` / base-4.13 42 | 43 | - Include template file as first header in hsc2hs generated C file (#28) 44 | 45 | - On Windows define `__USE_MINGW_ANSI_STDIO` to 1 instead of 0 when not already 46 | defined in standard template header. This is a more modern default (#28) 47 | 48 | ## 0.68.5 49 | 50 | - Support response files regardless of which GHC `hsc2hs` was compiled 51 | with ([#15758](https://ghc.haskell.org/trac/ghc/ticket/15758)) 52 | 53 | - Support for non-x86 platforms should be significantly more robust due to 54 | improvements in `hsc2hs`'s assembly parser 55 | 56 | - Add support for haskell files that use a leading single quote for promoted 57 | data constructors. 58 | 59 | ## 0.68.4 60 | 61 | - Add support to read command line arguments supplied via response files 62 | ([#13896](https://ghc.haskell.org/trac/ghc/ticket/13388)) 63 | 64 | ## 0.68.2 65 | 66 | - Support GHC 8.2.1 67 | 68 | - Make `hsc_alignment` macro work in clang 69 | ([D3346](https://phabricator.haskell.org/D3346)) 70 | 71 | - Track column numbers to improve GHC's caret diagnostic display 72 | ([#13388](https://ghc.haskell.org/trac/ghc/ticket/13388)) 73 | 74 | ## 0.68.1 75 | 76 | - Fix type signature of generated `main` test function 77 | to avoid C compiler warnings about unused `argc`/`argv` 78 | function parameters during feature testing. 79 | 80 | - Double-escape paths used to build call to `hsc_line` 81 | ([#12504](http://ghc.haskell.org/ticket/12504)) 82 | -------------------------------------------------------------------------------- /data/template-hsc.h: -------------------------------------------------------------------------------- 1 | /* This header will cause a mismatch with any mingw-w64 header by including a 2 | system header and then getting included before user headers in the hsc file. 3 | So let's define the default to be mingw-w64 C99 so we have any hope of 4 | getting GHC to compile with GCC 9+. */ 5 | #if defined(_WIN32) && !defined(__USE_MINGW_ANSI_STDIO) 6 | # define __USE_MINGW_ANSI_STDIO 1 7 | #endif 8 | 9 | /* We need stddef to be able to use size_t. Hopefully this won't cause 10 | any problems along the lines of ghc trac #2897. */ 11 | #include 12 | 13 | /* hsc_* are defined in the generated utils.c */ 14 | int hsc_printf(const char *format, ...); 15 | int hsc_toupper(int c); 16 | int hsc_tolower(int c); 17 | int hsc_putchar(int c); 18 | /* "void" should really be "FILE", but we aren't able to refer to "FILE" 19 | as we don't want to include here */ 20 | int hsc_fputs(const char *s, void *stream); 21 | /* "void" should really be "FILE", but we aren't able to refer to "FILE" 22 | as we don't want to include here */ 23 | void *hsc_stdout(void); 24 | 25 | /* For the single-argument macros we make the macros variadic (the 26 | argument is x... rather than simply x) so that arguments containing 27 | commas work. See trac #590. */ 28 | 29 | #ifndef offsetof 30 | #define offsetof(t, f) ((size_t) &((t *)0)->f) 31 | #endif 32 | 33 | #if __NHC__ 34 | #define hsc_line(line, file) \ 35 | hsc_printf ("# %d \"%s\"\n", line, file); 36 | #define hsc_column(column) 37 | #else 38 | #define hsc_line(line, file) \ 39 | hsc_printf ("{-# LINE %d \"%s\" #-}\n", line, file); 40 | #define hsc_column(column) \ 41 | hsc_printf ("{-# COLUMN %d #-}", column); 42 | #endif 43 | 44 | #define hsc_const(x...) \ 45 | if ((x) < 0) \ 46 | hsc_printf ("%lld", (long long)(x)); \ 47 | else \ 48 | hsc_printf ("%llu", (unsigned long long)(x)); 49 | 50 | #define hsc_const_str(x...) \ 51 | { \ 52 | const char *s = (x); \ 53 | hsc_printf ("\""); \ 54 | while (*s != '\0') \ 55 | { \ 56 | if (*s == '"' || *s == '\\') \ 57 | hsc_printf ("\\%c", *s); \ 58 | else if (*s >= 0x20 && *s <= 0x7E) \ 59 | hsc_printf ("%c", *s); \ 60 | else \ 61 | hsc_printf ("\\%d%s", \ 62 | (unsigned char) *s, \ 63 | s[1] >= '0' && s[1] <= '9' ? "\\&" : ""); \ 64 | ++s; \ 65 | } \ 66 | hsc_printf ("\""); \ 67 | } 68 | 69 | #define hsc_type(t...) \ 70 | if ((t)(int)(t)1.4 == (t)1.4) \ 71 | hsc_printf ("%s%lu", \ 72 | (t)(-1) < (t)0 ? "Int" : "Word", \ 73 | (unsigned long)sizeof (t) * 8); \ 74 | else \ 75 | hsc_printf ("%s", \ 76 | sizeof (t) > sizeof (double) ? "LDouble" : \ 77 | sizeof (t) == sizeof (double) ? "Double" : \ 78 | "Float"); 79 | 80 | #define hsc_peek(t, f) \ 81 | hsc_printf ("(\\hsc_ptr -> peekByteOff hsc_ptr %ld)", \ 82 | (long) offsetof (t, f)); 83 | 84 | #define hsc_poke(t, f) \ 85 | hsc_printf ("(\\hsc_ptr -> pokeByteOff hsc_ptr %ld)", \ 86 | (long) offsetof (t, f)); 87 | 88 | #define hsc_ptr(t, f) \ 89 | hsc_printf ("(\\hsc_ptr -> hsc_ptr `plusPtr` %ld)", \ 90 | (long) offsetof (t, f)); 91 | 92 | #define hsc_offset(t, f) \ 93 | hsc_printf("(%ld)", (long) offsetof (t, f)); 94 | 95 | #define hsc_size(t...) \ 96 | hsc_printf("(%ld)", (long) sizeof(t)); 97 | 98 | #define hsc_alignment(x...) \ 99 | do { \ 100 | struct __anon_x__ { \ 101 | char a; \ 102 | x b; \ 103 | }; \ 104 | hsc_printf("%lu", (unsigned long)offsetof(struct __anon_x__, b)); \ 105 | } while (0) 106 | 107 | #define hsc_enum(t, f, print_name, x) \ 108 | print_name; \ 109 | hsc_printf (" :: %s\n", #t); \ 110 | print_name; \ 111 | hsc_printf (" = %s ", #f); \ 112 | if ((x) < 0) \ 113 | hsc_printf ("(%lld)\n", (long long)(x)); \ 114 | else \ 115 | hsc_printf ("%llu\n", (unsigned long long)(x)); 116 | 117 | #define hsc_haskellize(x...) \ 118 | { \ 119 | const char *s = (x); \ 120 | int upper = 0; \ 121 | if (*s != '\0') \ 122 | { \ 123 | hsc_putchar (hsc_tolower (*s)); \ 124 | ++s; \ 125 | while (*s != '\0') \ 126 | { \ 127 | if (*s == '_') \ 128 | upper = 1; \ 129 | else \ 130 | { \ 131 | hsc_putchar (upper ? hsc_toupper (*s) \ 132 | : hsc_tolower (*s)); \ 133 | upper = 0; \ 134 | } \ 135 | ++s; \ 136 | } \ 137 | } \ 138 | } 139 | -------------------------------------------------------------------------------- /ghc.mk: -------------------------------------------------------------------------------- 1 | utils/hsc2hs_USES_CABAL = YES 2 | utils/hsc2hs_PACKAGE = hsc2hs 3 | 4 | utils/hsc2hs_dist_PROGNAME = hsc2hs 5 | utils/hsc2hs_dist-install_PROGNAME = hsc2hs 6 | 7 | utils/hsc2hs_dist_SHELL_WRAPPER = YES 8 | utils/hsc2hs_dist_INSTALL_INPLACE = YES 9 | 10 | utils/hsc2hs_dist-install_SHELL_WRAPPER = YES 11 | utils/hsc2hs_dist-install_INSTALL_INPLACE = NO 12 | 13 | ifeq "$(Stage1Only)" "YES" 14 | utils/hsc2hs_dist_INSTALL = YES 15 | utils/hsc2hs_dist-install_INSTALL = NO 16 | else 17 | utils/hsc2hs_dist_INSTALL = NO 18 | utils/hsc2hs_dist-install_INSTALL = YES 19 | endif 20 | 21 | $(eval $(call build-prog,utils/hsc2hs,dist,0)) 22 | $(eval $(call build-prog,utils/hsc2hs,dist-install,1)) 23 | 24 | # After build-prog above 25 | utils/hsc2hs_dist-install_MODULES = $(utils/hsc2hs_dist_MODULES) 26 | 27 | utils/hsc2hs_template=$(INPLACE_TOPDIR)/template-hsc.h 28 | 29 | # Here we encode the cc and linker options into the wrapper for the released 30 | # hsc2hs binary using a HSC2HS_EXTRA variable. 31 | # For the stage0 wrapper (built in dist), we don't do this, because the build 32 | # system uses it for all stages and passes the right options for each stage 33 | # on the command line 34 | define utils/hsc2hs_dist-install_SHELL_WRAPPER_EXTRA 35 | echo 'HSC2HS_EXTRA="$(addprefix --cflag=,$(CONF_CC_OPTS_STAGE1)) $(addprefix --lflag=,$(CONF_GCC_LINKER_OPTS_STAGE1))"' >> "$(WRAPPER)" 36 | endef 37 | 38 | ifneq "$(BINDIST)" "YES" 39 | 40 | $(hsc2hs_INPLACE) : | $(utils/hsc2hs_template) 41 | 42 | # When invoked in the source tree, hsc2hs will try to link in 43 | # extra-libs from the packages, including libgmp.a. So we need a 44 | # dependency to ensure these libs are built before we invoke hsc2hs: 45 | $(hsc2hs_INPLACE) : $(OTHER_LIBS) 46 | 47 | $(utils/hsc2hs_template) : utils/hsc2hs/data/template-hsc.h | $$(dir $$@)/. 48 | "$(CP)" $< $@ 49 | 50 | endif 51 | 52 | install: install_utils/hsc2hs_dist_install 53 | 54 | .PHONY: install_utils/hsc2hs_dist_install 55 | install_utils/hsc2hs_dist_install: utils/hsc2hs/data/template-hsc.h 56 | $(INSTALL_HEADER) $(INSTALL_OPTS) $< "$(DESTDIR)$(topdir)" 57 | 58 | BINDIST_EXTRAS += utils/hsc2hs/data/template-hsc.h 59 | 60 | -------------------------------------------------------------------------------- /hsc2hs.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | Name: hsc2hs 3 | Version: 0.68.10 4 | x-revision: 3 5 | 6 | Copyright: 2000, Marcin Kowalczyk 7 | License: BSD3 8 | License-File: LICENSE 9 | Author: Marcin Kowalczyk 10 | Maintainer: ghc-devs@haskell.org 11 | Synopsis: A preprocessor that helps with writing Haskell bindings to C code 12 | Bug-Reports: https://github.com/haskell/hsc2hs/issues 13 | Description: 14 | The hsc2hs program can be used to automate some parts of the 15 | process of writing Haskell bindings to C code. It reads an 16 | almost-Haskell source file with embedded special constructs, and 17 | outputs a real Haskell file with these constructs processed, based 18 | on information taken from some C headers. The extra constructs 19 | provide Haskell counterparts of C types, values of C constants, 20 | including sizes of C types, and access to fields of C structs. 21 | . 22 | For more details, see the 23 | 24 | in the GHC User's Guide. 25 | Category: Development 26 | Data-Dir: data/ 27 | Data-Files: template-hsc.h 28 | build-type: Simple 29 | 30 | tested-with: 31 | GHC == 9.12.1 32 | GHC == 9.10.1 33 | GHC == 9.8.2 34 | GHC == 9.6.6 35 | GHC == 9.4.8 36 | GHC == 9.2.8 37 | GHC == 9.0.2 38 | GHC == 8.10.7 39 | GHC == 8.8.4 40 | GHC == 8.6.5 41 | GHC == 8.4.4 42 | GHC == 8.2.2 43 | GHC == 8.0.2 44 | 45 | extra-source-files: 46 | changelog.md 47 | test/asm/*.s 48 | 49 | flag in-ghc-tree 50 | description: Are we in a GHC tree? 51 | default: False 52 | manual: True 53 | 54 | source-repository head 55 | Type: git 56 | Location: https://github.com/haskell/hsc2hs.git 57 | 58 | Executable hsc2hs 59 | Default-Language: Haskell2010 60 | Main-Is: Main.hs 61 | Hs-Source-Dirs: src/ 62 | Other-Modules: 63 | C 64 | Common 65 | CrossCodegen 66 | DirectCodegen 67 | Flags 68 | HSCParser 69 | ATTParser 70 | UtilsCodegen 71 | Compat.ResponseFile 72 | Compat.TempFile 73 | Paths_hsc2hs 74 | 75 | c-sources: 76 | cbits/utils.c 77 | 78 | Other-Extensions: CPP, NoMonomorphismRestriction 79 | 80 | Build-Depends: base >= 4.3.0 && < 4.22, 81 | containers >= 0.4.0 && < 0.9, 82 | directory >= 1.1.0 && < 1.4, 83 | filepath >= 1.2.0 && < 1.6, 84 | process >= 1.1.0 && < 1.7 85 | 86 | if os(windows) 87 | -- N.B. Job object support was irreparably broken prior to 1.6.8. 88 | -- See https://github.com/haskell/process/issues/167. 89 | Build-Depends: process >= 1.6.8 && < 1.7 90 | 91 | ghc-options: -Wall 92 | if flag(in-ghc-tree) 93 | cpp-options: -DIN_GHC_TREE 94 | 95 | test-suite spec 96 | main-is: Spec.hs 97 | hs-source-dirs: src/ test/ 98 | other-modules: ATTParser Flags BDD 99 | ghc-options: -Wall -threaded 100 | type: exitcode-stdio-1.0 101 | build-depends: base >= 4.3.0 && < 4.22, 102 | tasty >= 1.5 && < 1.6, 103 | tasty-hunit >= 0.10 && < 0.11 104 | 105 | default-language: Haskell2010 106 | -------------------------------------------------------------------------------- /hsc2hs.wrapper: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | tflag="--template=$topdir/template-hsc.h" 4 | Iflag="-I$topdir/include/" 5 | 6 | read_response() { 7 | response_file=$1 8 | if [ -f "$response_file" ]; then 9 | while read -r arg; do 10 | case "$arg" in 11 | -t*) tflag=;; 12 | --template=*) tflag=;; 13 | @*) read_response "${arg#"@"}" ;; 14 | --) break;; 15 | esac 16 | done < "$response_file" 17 | fi 18 | } 19 | 20 | for arg do 21 | case "$arg" in 22 | -t*) tflag=;; 23 | --template=*) tflag=;; 24 | @*) read_response "${arg#"@"}" ;; 25 | --) break;; 26 | esac 27 | done 28 | 29 | exec "$executablename" ${tflag:+"$tflag"} $HSC2HS_EXTRA ${1+"$@"} "$Iflag" 30 | -------------------------------------------------------------------------------- /src/ATTParser.hs: -------------------------------------------------------------------------------- 1 | -- A rather crude asm parser. 2 | -- 3 | -- 4 | -- we only handle a subset of AT&T assembly 5 | -- right now. This is what gcc and clang can 6 | -- emit. For clang using llvm-ir might be 7 | -- even better. For gcc gimple if that can 8 | -- be consumed reliably somehow. 9 | -- 10 | -- For now we'll rely on the at&t assembly 11 | -- to be sufficient for constants. 12 | -- 13 | 14 | 15 | module ATTParser where 16 | 17 | import Control.Applicative ((<|>)) 18 | import Data.Word (Word32, Word64) 19 | import Data.Int (Int64) 20 | import Data.Char (isDigit, isSpace) 21 | import Data.Bits (shiftL, shiftR, (.|.)) 22 | import Data.Maybe (fromMaybe) 23 | 24 | data Inst = Ident String 25 | | Long Word32 26 | | Quad Word64 27 | | Ref String 28 | | Ascii String 29 | deriving Show 30 | 31 | mkLong :: Word32 -> Inst 32 | mkLong = Long 33 | mkQuad :: Word64 -> Inst 34 | mkQuad = Quad 35 | -- | turn @x@ and @(x)@ into @Ref x@. 36 | -- The (x) syntax can be found in mips assembly. 37 | mkRef :: String -> Inst 38 | mkRef ('(':r) | (')':r') <- reverse r = Ref $ reverse r' 39 | mkRef r = Ref r 40 | 41 | mkAscii :: String -> Inst 42 | mkAscii = Ascii 43 | 44 | type ASM = [(String, Inst)] 45 | 46 | isIdent :: Inst -> Bool 47 | isIdent (Ident _) = True 48 | isIdent _ = False 49 | 50 | trim :: String -> String 51 | trim = reverse . dropWhile (`elem` " \t") . reverse . dropWhile (`elem` " \t") 52 | -- | generalized @words@. 53 | words' :: (a -> Bool) -> [a] -> [[a]] 54 | words' p s = case dropWhile p s of 55 | [] -> [] 56 | s' -> w : words' p s'' 57 | where (w, s'') = break p s' 58 | 59 | isNumber :: String -> Bool 60 | isNumber ('-':x) = all isDigit x 61 | isNumber ('+':x) = all isDigit x 62 | isNumber x = all isDigit x 63 | 64 | -- | process the assembly instructions, filtering out 65 | -- identifiers and constant values. 66 | preprocess :: String -> [Inst] 67 | preprocess [] = [] 68 | preprocess ('\t':attr) = let (h, t) = break isSpace attr 69 | in case h:words' (=='\t') t of 70 | -- 8 byte values 71 | (".quad":x:_) | isNumber (w x) -> [mkQuad $ read (w x)] 72 | | otherwise -> [mkRef $ (w x)] 73 | (".xword":x:_)| isNumber (w x) -> [mkQuad $ read (w x)] 74 | | otherwise -> [mkRef $ (w x)] 75 | (".8byte":x:_)| isNumber (w x) -> [mkQuad $ read (w x)] 76 | | otherwise -> [mkRef $ (w x)] 77 | ("data8":x:_) | isNumber (w x) -> [mkQuad $ read (w x)] 78 | | otherwise -> [mkRef $ (w x)] 79 | 80 | -- 4 byte values 81 | (".long":x:_) | isNumber (w x) -> [mkLong $ read (w x)] 82 | | otherwise -> [mkRef $ (w x)] 83 | (".word":x:_) | isNumber (w x) -> [mkLong $ read (w x)] 84 | | otherwise -> [mkRef $ (w x)] 85 | (".4byte":x:_)| isNumber (w x) -> [mkLong $ read (w x)] 86 | | otherwise -> [mkRef $ (w x)] 87 | 88 | (".space":x:_)| (w x) == "4" -> [mkLong 0] 89 | | (w x) == "8" -> [mkQuad 0] 90 | (".skip":x:_) | (w x) == "4" -> [mkLong 0] 91 | | (w x) == "8" -> [mkQuad 0] 92 | 93 | (".ascii":x:_) -> [mkAscii $ read x] 94 | (".asciz":x:_) -> [mkAscii $ read x ++ "\0"] 95 | -- found on nios, sh4, alpha, mk68k; all without \0. 96 | (".string":x:_) -> [mkAscii $ read x ++ "\0"] 97 | -- found on hppa 98 | (".stringz":x:_) -> [mkAscii $ read x ++ "\0"] 99 | -- ia64 100 | ("stringz":x:_) -> [mkAscii $ read x ++ "\0"] 101 | _ -> [] 102 | where 103 | w x = case words x of 104 | [] -> error $ "preprocess: expected some non-space characters, " 105 | ++ "but got spaces only in '" ++ x ++ "'" 106 | hd : _ -> hd 107 | preprocess ('.':'z':'e':'r':'o':'f':'i':'l':'l':' ':x) = case words' (==',') x of 108 | (_seg:_sect:sym:size:_) | size == "4" -> [Ident sym, mkLong 0] 109 | | size == "8" -> [Ident sym, mkQuad 0] 110 | _ -> [] 111 | preprocess (c:cs) | not (isSpace c) = [Ident $ takeWhile (/= ':') (c:cs)] 112 | | otherwise = [] 113 | 114 | -- | turn the list of instructions into an associated list 115 | parseInsts :: [Inst] -> [(String, Inst)] 116 | parseInsts [] = [] 117 | parseInsts (Ident name:xs) = case break isIdent xs of 118 | ([], xs') -> parseInsts xs' 119 | (is, xs') -> (name, combineInst is):parseInsts xs' 120 | parseInsts _ = error "Invalid instructions" 121 | 122 | -- | combine instructions (e.g. two long into a quad) 123 | combineInst :: [Inst] -> Inst 124 | combineInst [Quad i] = Quad i 125 | combineInst [Long i] = Quad (fromIntegral i) 126 | combineInst [Long h, Long l] = Quad $ (shiftL (fromIntegral h) 32) .|. fromIntegral l 127 | combineInst [Ref s] = Ref s 128 | combineInst [Ascii s] = Ascii s 129 | combineInst is = error $ "Cannot combine instructions: " ++ show is 130 | 131 | -- | inline references 132 | inlineRef :: [(String, Inst)] -> [(String, Inst)] 133 | inlineRef xs = map go xs 134 | where go (k, Ref name) = (k, fromMaybe (error $ "failed to find reference " ++ show name) $ lookup name xs) 135 | go x = x 136 | 137 | fixWordOrder :: [(String, Inst)] -> [(String, Inst)] 138 | fixWordOrder xs = case lookupInteger "___hsc2hs_BOM___" xs of 139 | Just 1 -> map go xs 140 | _ -> xs 141 | where go (k, Quad w) = (k, Quad $ shiftL w 32 .|. shiftR w 32) 142 | go x = x 143 | 144 | parse :: FilePath -> IO [(String, Inst)] 145 | parse f = (fixWordOrder . inlineRef . parseInsts . concatMap preprocess . lines) `fmap` readFile f 146 | 147 | -- | lookup a symbol without or with underscore prefix 148 | lookup_ :: String -> [(String,b)] -> Maybe b 149 | lookup_ k l = lookup k l <|> lookup ("_" ++ k) l 150 | 151 | lookupString :: String -> [(String, Inst)] -> Maybe String 152 | lookupString k l = case (lookup_ k l) of 153 | Just (Ascii s) -> Just s 154 | _ -> Nothing 155 | 156 | lookupInteger :: String -> [(String, Inst)] -> Maybe Integer 157 | lookupInteger k l = case (lookup_ k l, lookup_ (k ++ "___hsc2hs_sign___") l) of 158 | (Just (Quad i), Just (Quad 1)) -> Just (fromIntegral (fromIntegral i :: Int64)) 159 | (Just (Quad i), _) -> Just (fromIntegral i) 160 | _ -> Nothing 161 | -------------------------------------------------------------------------------- /src/C.hs: -------------------------------------------------------------------------------- 1 | module C where 2 | 3 | {- 4 | The standard mode for hsc2hs: generates a C file which is 5 | compiled and run; the output of that program is the .hs file. 6 | -} 7 | 8 | import Data.Char ( isSpace, intToDigit, ord ) 9 | import Data.List ( intersperse ) 10 | import System.FilePath ( splitFileName ) 11 | 12 | import HSCParser ( SourcePos(..), Token(..) ) 13 | import Flags 14 | 15 | outTemplateHeaderCProg :: FilePath -> String 16 | outTemplateHeaderCProg template = "#include \"" ++ template ++ "\"\n" 17 | 18 | outFlagHeaderCProg :: Flag -> String 19 | outFlagHeaderCProg (Include f) = "#include "++f++"\n" 20 | outFlagHeaderCProg (Define n Nothing) = "#define "++n++" 1\n" 21 | outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n" 22 | outFlagHeaderCProg _ = "" 23 | 24 | outHeaderCProg :: (SourcePos, String, String) -> String 25 | outHeaderCProg (pos, key, arg) = case key of 26 | "include" -> outCLine pos++"#include "++arg++"\n" 27 | "define" -> outCLine pos++"#define "++arg++"\n" 28 | "undef" -> outCLine pos++"#undef "++arg++"\n" 29 | "def" -> case arg of 30 | 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n" 31 | 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n" 32 | _ -> "" 33 | _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n" 34 | "let" -> case break (== '=') arg of 35 | (_, "") -> "" 36 | (header, _:body) -> case break isSpace header of 37 | (name, args) -> 38 | outCLine pos++ 39 | "#define hsc_"++name++"("++dropWhile isSpace args++") " ++ 40 | "hsc_printf ("++joinLines body++");\n" 41 | _ -> "" 42 | where 43 | joinLines = concat . intersperse " \\\n" . lines 44 | 45 | outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String 46 | outHeaderHs flags inH toks = 47 | case inH of 48 | Nothing -> concatMap outFlag flags++concatMap outSpecial toks 49 | Just _ -> "" 50 | where 51 | outFlag (Define n Nothing) = outOption ("-optc-D"++n) 52 | outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v) 53 | outFlag _ = "" 54 | outSpecial (pos, key, arg) = case key of 55 | "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg) 56 | | otherwise -> "" 57 | _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n" 58 | _ -> "" 59 | goodForOptD arg = case arg of 60 | "" -> True 61 | c:_ | isSpace c -> True 62 | '(':_ -> False 63 | _:s -> goodForOptD s 64 | toOptD arg = case break isSpace arg of 65 | (name, "") -> name 66 | (name, _:value) -> name++'=':dropWhile isSpace value 67 | outOption s = 68 | " hsc_printf (\"{-# OPTIONS_GHC %s #-}\\n\", \""++ 69 | showCString s++"\");\n" 70 | 71 | outTokenHs :: Bool -- ^ enable COLUMN pragmas? 72 | -> (ShowS, (Bool, Bool)) 73 | -> Token 74 | -> (ShowS, (Bool, Bool)) 75 | outTokenHs enableCol (out, state) (Text pos txt) = 76 | (out . showString str, state') 77 | where 78 | (str, state') = outTextHs state pos txt outText outHsLine 79 | (if enableCol then outHsColumn else const "") 80 | outText s = " hsc_fputs (\""++showCString s++"\", hsc_stdout());\n" 81 | outTokenHs _ (out, (rowSync, colSync)) (Special pos key arg) = 82 | (out . showString str, (rowSync && null str, colSync && null str)) 83 | where 84 | str = case key of 85 | "include" -> "" 86 | "define" -> "" 87 | "undef" -> "" 88 | "def" -> "" 89 | _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n" 90 | "let" -> "" 91 | "enum" -> outCLine pos++outEnum arg 92 | _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n" 93 | 94 | -- | Output a 'Text' 'Token' literally, making use of the three given output 95 | -- functions. The state contains @(lineSync, colSync)@, which indicate 96 | -- whether the line number and column number in the input are synchronized 97 | -- with those of the output. 98 | outTextHs :: (Bool, Bool) -- ^ state @(lineSync, colSync)@ 99 | -> SourcePos -- ^ original position of the token 100 | -> String -- ^ text of the token 101 | -> (String -> String) -- ^ output text 102 | -> (SourcePos -> String) -- ^ output LINE pragma 103 | -> (Int -> String) -- ^ output COLUMN pragma 104 | -> (String, (Bool, Bool)) 105 | outTextHs (lineSync, colSync) pos@(SourcePos _ _ col) txt 106 | outText outLine outColumn = 107 | -- Ensure COLUMN pragmas are always inserted right before an identifier. 108 | -- They are never inserted in the middle of whitespace, as that could ruin 109 | -- the indentation. 110 | case break (== '\n') spaces of 111 | (_, "") -> 112 | case break (== '\n') rest of 113 | ("", _) -> 114 | ( outText spaces 115 | , (lineSync, colSync) ) 116 | (_, "") -> 117 | ( (outText spaces++ 118 | updateCol++ 119 | outText rest) 120 | , (lineSync, True) ) 121 | (firstRest, nl:restRest) -> 122 | ( (outText spaces++ 123 | updateCol++ 124 | outText (firstRest++[nl])++ 125 | updateLine++ 126 | outText restRest) 127 | , (True, True) ) 128 | (firstSpaces, nl:restSpaces) -> 129 | ( (outText (firstSpaces++[nl])++ 130 | updateLine++ 131 | outText (restSpaces++rest)) 132 | , (True, True) ) 133 | where 134 | (spaces, rest) = span isSpace txt 135 | updateLine | lineSync = "" 136 | | otherwise = outLine pos 137 | updateCol | colSync = "" 138 | | otherwise = outColumn (col + length spaces) 139 | 140 | parseEnum :: String -> Maybe (String,String,[(Maybe String,String)]) 141 | parseEnum arg = 142 | case break (== ',') arg of 143 | (_, []) -> Nothing 144 | (t, _:afterT) -> case break (== ',') afterT of 145 | (f, afterF) -> let 146 | enums [] = [] 147 | enums (_:s) = case break (== ',') s of 148 | (enum, rest) -> let 149 | this = case break (== '=') $ dropWhile isSpace enum of 150 | (name, []) -> (Nothing, name) 151 | (hsName, _:cName) -> (Just hsName, cName) 152 | in this:enums rest 153 | in Just (t, f, enums afterF) 154 | 155 | outEnum :: String -> String 156 | outEnum arg = case parseEnum arg of 157 | Nothing -> "" 158 | Just (t,f,enums) -> 159 | flip concatMap enums $ \(maybeHsName, cName) -> 160 | case maybeHsName of 161 | Nothing -> 162 | " hsc_enum ("++t++", "++f++", " ++ 163 | "hsc_haskellize (\""++cName++"\"), "++ 164 | cName++");\n" 165 | Just hsName -> 166 | " hsc_enum ("++t++", "++f++", " ++ 167 | "hsc_printf (\"%s\", \""++hsName++"\"), "++ 168 | cName++");\n" 169 | 170 | outFlagH :: Flag -> String 171 | outFlagH (Include f) = "#include "++f++"\n" 172 | outFlagH (Define n Nothing) = "#define "++n++" 1\n" 173 | outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n" 174 | outFlagH _ = "" 175 | 176 | outTokenH :: (SourcePos, String, String) -> String 177 | outTokenH (pos, key, arg) = 178 | case key of 179 | "include" -> outCLine pos++"#include "++arg++"\n" 180 | "define" -> outCLine pos++"#define " ++arg++"\n" 181 | "undef" -> outCLine pos++"#undef " ++arg++"\n" 182 | "def" -> outCLine pos++case arg of 183 | 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n" 184 | 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n" 185 | 'i':'n':'l':'i':'n':'e':' ':_ -> 186 | "#ifdef __GNUC__\n" ++ 187 | "extern\n" ++ 188 | "#endif\n"++ 189 | arg++"\n" 190 | _ -> "extern "++header++";\n" 191 | where header = takeWhile (\c -> c /= '{' && c /= '=') arg 192 | _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n" 193 | _ -> "" 194 | 195 | outTokenC :: (SourcePos, String, String) -> String 196 | outTokenC (pos, key, arg) = 197 | case key of 198 | "def" -> case arg of 199 | 's':'t':'r':'u':'c':'t':' ':_ -> "" 200 | 't':'y':'p':'e':'d':'e':'f':' ':_ -> "" 201 | 'i':'n':'l':'i':'n':'e':' ':arg' -> 202 | case span (\c -> c /= '{' && c /= '=') arg' of 203 | (header, body) -> 204 | outCLine pos++ 205 | "#ifndef __GNUC__\n" ++ 206 | "extern inline\n" ++ 207 | "#endif\n"++ 208 | header++ 209 | "\n#ifndef __GNUC__\n" ++ 210 | ";\n" ++ 211 | "#else\n"++ 212 | body++ 213 | "\n#endif\n" 214 | _ -> outCLine pos++arg++"\n" 215 | _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n" 216 | _ -> "" 217 | 218 | conditional :: String -> Bool 219 | conditional "if" = True 220 | conditional "ifdef" = True 221 | conditional "ifndef" = True 222 | conditional "elif" = True 223 | conditional "else" = True 224 | conditional "endif" = True 225 | conditional "error" = True 226 | conditional "warning" = True 227 | conditional _ = False 228 | 229 | outCLine :: SourcePos -> String 230 | outCLine (SourcePos name line _) = 231 | "#line "++show line++" \""++showCString (snd (splitFileName name))++"\"\n" 232 | 233 | outHsLine :: SourcePos -> String 234 | outHsLine (SourcePos name line _) = 235 | " hsc_line ("++show (line + 1)++", \""++ 236 | (showCString . showCString) name ++ "\");\n" 237 | 238 | outHsColumn :: Int -> String 239 | outHsColumn column = 240 | " hsc_column ("++show column++");\n" 241 | 242 | showCString :: String -> String 243 | showCString = concatMap showCChar 244 | where 245 | showCChar '\"' = "\\\"" 246 | showCChar '\'' = "\\\'" 247 | showCChar '?' = "\\?" 248 | showCChar '\\' = "\\\\" 249 | showCChar c | c >= ' ' && c <= '~' = [c] 250 | showCChar '\a' = "\\a" 251 | showCChar '\b' = "\\b" 252 | showCChar '\f' = "\\f" 253 | showCChar '\n' = "\\n\"\n \"" 254 | showCChar '\r' = "\\r" 255 | showCChar '\t' = "\\t" 256 | showCChar '\v' = "\\v" 257 | showCChar c = ['\\', 258 | intToDigit (ord c `quot` 64), 259 | intToDigit (ord c `quot` 8 `mod` 8), 260 | intToDigit (ord c `mod` 8)] 261 | -------------------------------------------------------------------------------- /src/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Common where 3 | 4 | #if MIN_VERSION_base(4,6,0) 5 | import Prelude hiding ( Foldable(..) ) 6 | #else 7 | import Data.List ( foldl' ) 8 | #endif 9 | import qualified Control.Exception as Exception 10 | import qualified Compat.TempFile as Compat 11 | import Control.Monad ( when ) 12 | import Data.Char ( isSpace ) 13 | import Data.Foldable ( Foldable(..) ) 14 | import System.IO 15 | #if defined(mingw32_HOST_OS) 16 | import Control.Concurrent ( threadDelay ) 17 | import System.IO.Error ( isPermissionError ) 18 | #endif 19 | import System.Process ( createProcess, waitForProcess 20 | , proc, CreateProcess(..), StdStream(..) ) 21 | import System.Exit ( ExitCode(..), exitWith ) 22 | import System.Directory ( removeFile ) 23 | 24 | die :: String -> IO a 25 | die s = hPutStr stderr s >> exitWith (ExitFailure 1) 26 | 27 | default_compiler :: String 28 | default_compiler = "cc" 29 | 30 | ------------------------------------------------------------------------ 31 | -- Write the output files. 32 | 33 | writeBinaryFile :: FilePath -> String -> IO () 34 | writeBinaryFile fp str = withBinaryFile fp WriteMode $ \h -> hPutStr h str 35 | 36 | rawSystemL :: FilePath -> FilePath -> String -> Bool -> FilePath -> [String] -> IO () 37 | rawSystemL outDir outBase action flg prog args = withResponseFile outDir outBase args $ \rspFile -> do 38 | let cmdLine = prog++" "++unwords args 39 | when flg $ hPutStrLn stderr ("Executing: (@" ++ rspFile ++ ") " ++ cmdLine) 40 | (_ ,_ ,progerr ,ph) <- createProcess (proc prog ['@':rspFile]) 41 | -- Because of the response files being written and removed after the process 42 | -- terminates we now need to use process jobs here to correctly wait for all 43 | -- child processes to terminate. Not doing so would causes a race condition 44 | -- between the last child dieing and not holding a lock on the response file 45 | -- and the response file getting deleted. 46 | { std_err = CreatePipe 47 | #if MIN_VERSION_process(1,5,0) 48 | , use_process_jobs = True 49 | #endif 50 | } 51 | errdata <- maybeReadHandle progerr 52 | exitStatus <- waitForProcess ph 53 | case exitStatus of 54 | ExitFailure exitCode -> 55 | do die $ action ++ " failed " 56 | ++ "(exit code " ++ show exitCode ++ ")\n" 57 | ++ "rsp file was: " ++ show rspFile ++ "\n" 58 | ++ "command was: " ++ cmdLine ++ "\n" 59 | ++ "error: " ++ errdata ++ "\n" 60 | _ -> return () 61 | 62 | 63 | rawSystemWithStdOutL :: FilePath -> FilePath -> String -> Bool -> FilePath -> [String] -> FilePath -> IO () 64 | rawSystemWithStdOutL outDir outBase action flg prog args outFile = withResponseFile outDir outBase args $ \rspFile -> do 65 | let cmdLine = prog++" "++unwords args++" >"++outFile 66 | when flg (hPutStrLn stderr ("Executing: (@" ++ rspFile ++ ") " ++ cmdLine)) 67 | hOut <- openFile outFile WriteMode 68 | (_ ,_ ,progerr , process) <- 69 | -- We use createProcess here instead of runProcess since we need to specify 70 | -- a custom CreateProcess structure to turn on use_process_jobs when 71 | -- available. 72 | createProcess 73 | (proc prog ['@':rspFile]) 74 | { std_out = UseHandle hOut, std_err = CreatePipe 75 | #if MIN_VERSION_process(1,5,0) 76 | , use_process_jobs = True 77 | #endif 78 | } 79 | errdata <- maybeReadHandle progerr 80 | exitStatus <- waitForProcess process 81 | hClose hOut 82 | case exitStatus of 83 | ExitFailure exitCode -> 84 | do die $ action ++ " failed " 85 | ++ "(exit code " ++ show exitCode ++ ")\n" 86 | ++ "rsp file was: " ++ show rspFile ++ "\n" 87 | ++ "output file:" ++ show outFile ++ "\n" 88 | ++ "command was: " ++ cmdLine ++ "\n" 89 | ++ "error: " ++ errdata ++ "\n" 90 | _ -> return () 91 | 92 | maybeReadHandle :: Maybe Handle -> IO String 93 | maybeReadHandle Nothing = return "" 94 | maybeReadHandle (Just h) = do 95 | str <- hGetContents h 96 | -- Pipes have a buffer, once buffer gets full writes to the pipe block 97 | -- until the data currently in the buffer is read. To ensure we don't 98 | -- block indefinitely we need to actually read from the pipe we requested. 99 | -- Because of the lazy IO, hGetContents doesn't actually drain handle. 100 | -- See https://github.com/haskell/hsc2hs/issues/47 101 | Exception.evaluate (rnf str `seq` str) 102 | where 103 | rnf :: String -> () 104 | rnf [] = () 105 | rnf (c:cs) = c `seq` rnf cs 106 | 107 | -- delay the cleanup of generated files until the end; attempts to 108 | -- get around intermittent failure to delete files which has 109 | -- just been exec'ed by a sub-process (Win32 only.) 110 | finallyRemove :: FilePath -> IO a -> IO a 111 | finallyRemove fp act = 112 | Exception.bracket_ (return fp) 113 | (noisyRemove fp) 114 | act 115 | where 116 | max_retries :: Int 117 | max_retries = 5 118 | 119 | noisyRemove :: FilePath -> IO () 120 | noisyRemove fpath = 121 | catchIO (removeFileInternal max_retries fpath) 122 | (\ e -> hPutStrLn stderr ("Failed to remove file " ++ fpath ++ "; error= " ++ show e)) 123 | removeFileInternal _retries path = do 124 | #if defined(mingw32_HOST_OS) 125 | -- On Windows we have to retry the delete a couple of times. 126 | -- The reason for this is that a FileDelete command just marks a 127 | -- file for deletion. The file is really only removed when the last 128 | -- handle to the file is closed. Unfortunately there are a lot of 129 | -- system services that can have a file temporarily opened using a shared 130 | -- read-only lock, such as the built in AV and search indexer. 131 | -- 132 | -- We can't really guarantee that these are all off, so what we can do is 133 | -- whenever after an rm the file still exists to try again and wait a bit. 134 | res <- Exception.try $ removeFile path 135 | case res of 136 | Right a -> return a 137 | Left ex | isPermissionError ex && _retries > 1 -> do 138 | let retries' = _retries - 1 139 | threadDelay ((max_retries - retries') * 200) 140 | removeFileInternal retries' path 141 | | otherwise -> Exception.throw ex 142 | #else 143 | removeFile path 144 | #endif 145 | 146 | catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a 147 | catchIO = Exception.catch 148 | 149 | onlyOne :: String -> IO a 150 | onlyOne what = die ("Only one "++what++" may be specified\n") 151 | 152 | -- response file handling borrowed from cabal's at Distribution.Simple.Program.ResponseFile 153 | 154 | withTempFile :: FilePath -- ^ Temp dir to create the file in 155 | -> FilePath -- ^ Name of the hsc file being processed or template 156 | -> String -- ^ Template for temp file 157 | -> Int -- ^ Random seed for tmp name 158 | -> (FilePath -> Handle -> IO a) -> IO a 159 | withTempFile tmpDir _outBase template _seed action = do 160 | Exception.bracket 161 | (Compat.openTempFile tmpDir template) 162 | (\(name, handle) -> finallyRemove name $ hClose handle) 163 | (uncurry action) 164 | 165 | withResponseFile :: 166 | FilePath -- ^ Working directory to create response file in. 167 | -> FilePath -- ^ Template for response file name. 168 | -> [String] -- ^ Arguments to put into response file. 169 | -> (FilePath -> IO a) 170 | -> IO a 171 | withResponseFile workDir outBase arguments f = 172 | withTempFile workDir outBase "hsc2hscall.rsp" (length arguments) $ \responseFileName hf -> do 173 | let responseContents = unlines $ map escapeResponseFileArg arguments 174 | hPutStr hf responseContents 175 | hClose hf 176 | f responseFileName 177 | 178 | -- Support a gcc-like response file syntax. Each separate 179 | -- argument and its possible parameter(s), will be separated in the 180 | -- response file by an actual newline; all other whitespace, 181 | -- single quotes, double quotes, and the character used for escaping 182 | -- (backslash) are escaped. The called program will need to do a similar 183 | -- inverse operation to de-escape and re-constitute the argument list. 184 | escapeResponseFileArg :: String -> String 185 | escapeResponseFileArg = reverse . foldl' escape [] 186 | where 187 | escape :: String -> Char -> String 188 | escape cs c = 189 | case c of 190 | '\\' -> c:'\\':cs 191 | '\'' -> c:'\\':cs 192 | '"' -> c:'\\':cs 193 | _ | isSpace c -> c:'\\':cs 194 | | otherwise -> c:cs 195 | -------------------------------------------------------------------------------- /src/Compat/ResponseFile.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | -- taken from base-4.12.0.0's "GHC.ResponseFile" 5 | 6 | module Compat.ResponseFile ( getArgsWithResponseFiles ) where 7 | 8 | #if MIN_VERSION_base(4,12,0) 9 | 10 | import GHC.ResponseFile (getArgsWithResponseFiles) 11 | 12 | #else 13 | 14 | import Control.Exception 15 | import Data.Char (isSpace) 16 | import System.Environment (getArgs) 17 | import System.Exit (exitFailure) 18 | import System.IO 19 | 20 | {-| 21 | Like 'getArgs', but can also read arguments supplied via response files. 22 | 23 | 24 | For example, consider a program @foo@: 25 | 26 | @ 27 | main :: IO () 28 | main = do 29 | args <- getArgsWithResponseFiles 30 | putStrLn (show args) 31 | @ 32 | 33 | 34 | And a response file @args.txt@: 35 | 36 | @ 37 | --one 1 38 | --'two' 2 39 | --"three" 3 40 | @ 41 | 42 | Then the result of invoking @foo@ with @args.txt@ is: 43 | 44 | > > ./foo @args.txt 45 | > ["--one","1","--two","2","--three","3"] 46 | 47 | -} 48 | getArgsWithResponseFiles :: IO [String] 49 | getArgsWithResponseFiles = getArgs >>= expandResponse 50 | 51 | -- | Given a string of concatenated strings, separate each by removing 52 | -- a layer of /quoting/ and\/or /escaping/ of certain characters. 53 | -- 54 | -- These characters are: any whitespace, single quote, double quote, 55 | -- and the backslash character. The backslash character always 56 | -- escapes (i.e., passes through without further consideration) the 57 | -- character which follows. Characters can also be escaped in blocks 58 | -- by quoting (i.e., surrounding the blocks with matching pairs of 59 | -- either single- or double-quotes which are not themselves escaped). 60 | -- 61 | -- Any whitespace which appears outside of either of the quoting and 62 | -- escaping mechanisms, is interpreted as having been added by this 63 | -- special concatenation process to designate where the boundaries 64 | -- are between the original, un-concatenated list of strings. These 65 | -- added whitespace characters are removed from the output. 66 | -- 67 | -- > unescapeArgs "hello\\ \\\"world\\\"\n" == escapeArgs "hello \"world\"" 68 | unescapeArgs :: String -> [String] 69 | unescapeArgs = filter (not . null) . unescape 70 | 71 | -- | Arguments which look like '@foo' will be replaced with the 72 | -- contents of file @foo@. A gcc-like syntax for response files arguments 73 | -- is expected. This must re-constitute the argument list by doing an 74 | -- inverse of the escaping mechanism done by the calling-program side. 75 | -- 76 | -- We quit if the file is not found or reading somehow fails. 77 | -- (A convenience routine for haddock or possibly other clients) 78 | expandResponse :: [String] -> IO [String] 79 | expandResponse = fmap concat . mapM expand 80 | where 81 | expand :: String -> IO [String] 82 | expand ('@':f) = readFileExc f >>= return . unescapeArgs 83 | expand x = return [x] 84 | 85 | readFileExc f = 86 | readFile f `Control.Exception.catch` \(e :: IOException) -> do 87 | hPutStrLn stderr $ "Error while expanding response file: " ++ show e 88 | exitFailure 89 | 90 | data Quoting = NoneQ | SngQ | DblQ 91 | 92 | unescape :: String -> [String] 93 | unescape args = reverse . map reverse $ go args NoneQ False [] [] 94 | where 95 | -- n.b., the order of these cases matters; these are cribbed from gcc 96 | -- case 1: end of input 97 | go [] _q _bs a as = a:as 98 | -- case 2: back-slash escape in progress 99 | go (c:cs) q True a as = go cs q False (c:a) as 100 | -- case 3: no back-slash escape in progress, but got a back-slash 101 | go (c:cs) q False a as 102 | | '\\' == c = go cs q True a as 103 | -- case 4: single-quote escaping in progress 104 | go (c:cs) SngQ False a as 105 | | '\'' == c = go cs NoneQ False a as 106 | | otherwise = go cs SngQ False (c:a) as 107 | -- case 5: double-quote escaping in progress 108 | go (c:cs) DblQ False a as 109 | | '"' == c = go cs NoneQ False a as 110 | | otherwise = go cs DblQ False (c:a) as 111 | -- case 6: no escaping is in progress 112 | go (c:cs) NoneQ False a as 113 | | isSpace c = go cs NoneQ False [] (a:as) 114 | | '\'' == c = go cs SngQ False a as 115 | | '"' == c = go cs DblQ False a as 116 | | otherwise = go cs NoneQ False (c:a) as 117 | 118 | #endif 119 | -------------------------------------------------------------------------------- /src/Compat/TempFile.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #if __GLASGOW_HASKELL__ >= 704 3 | {-# LANGUAGE Safe #-} 4 | #endif 5 | 6 | -- This module backports `openTempFile` from GHC 8.10 to hsc2hs in order to get 7 | -- an atomic `openTempFile` implementation on Windows when using older GHC 8 | -- compilers. 9 | -- See also https://gitlab.haskell.org/ghc/ghc/issues/10731 10 | -- 11 | -- When hsc2hs supports GHC 8.10 as minimum then this module can be removed. 12 | -- When using WINIO we MUST use the version in base so force it to be used. 13 | -- WINIO is supported in GHC 8.12+ so the extra check is just for sanity. 14 | module Compat.TempFile ( 15 | openBinaryTempFile, 16 | openTempFile 17 | ) where 18 | 19 | #if !MIN_VERSION_base(4,14,0) && defined(mingw32_HOST_OS) \ 20 | && !defined(__IO_MANAGER_WINIO__) 21 | #define NEEDS_TEMP_WORKAROUND 1 22 | #else 23 | #define NEEDS_TEMP_WORKAROUND 0 24 | #endif 25 | 26 | #if NEEDS_TEMP_WORKAROUND 27 | import Data.Bits 28 | import Foreign.C.Error 29 | import Foreign.C.String 30 | import Foreign.C.Types 31 | import Foreign.Ptr 32 | import Foreign.Marshal.Alloc 33 | import Foreign.Storable 34 | import GHC.IO.Encoding 35 | import GHC.IO.IOMode 36 | import qualified GHC.IO.FD as FD 37 | import qualified GHC.IO.Handle.FD as POSIX 38 | import System.Posix.Internals 39 | import System.Posix.Types 40 | #else 41 | import qualified System.IO as IOUtils 42 | #endif 43 | 44 | import GHC.IO.Handle 45 | 46 | -- | The function creates a temporary file in ReadWrite mode. 47 | -- The created file isn\'t deleted automatically, so you need to delete it manually. 48 | -- 49 | -- The file is created with permissions such that only the current 50 | -- user can read\/write it. 51 | -- 52 | -- With some exceptions (see below), the file will be created securely 53 | -- in the sense that an attacker should not be able to cause 54 | -- openTempFile to overwrite another file on the filesystem using your 55 | -- credentials, by putting symbolic links (on Unix) in the place where 56 | -- the temporary file is to be created. On Unix the @O_CREAT@ and 57 | -- @O_EXCL@ flags are used to prevent this attack, but note that 58 | -- @O_EXCL@ is sometimes not supported on NFS filesystems, so if you 59 | -- rely on this behaviour it is best to use local filesystems only. 60 | -- 61 | openTempFile :: FilePath -- ^ Directory in which to create the file 62 | -> String -- ^ File name template. If the template is \"foo.ext\" then 63 | -- the created file will be \"fooXXX.ext\" where XXX is some 64 | -- random number. Note that this should not contain any path 65 | -- separator characters. 66 | -> IO (FilePath, Handle) 67 | openTempFile tmp_dir template 68 | #if NEEDS_TEMP_WORKAROUND 69 | = openTempFile' "openTempFile" tmp_dir template False 0o600 70 | #else 71 | = IOUtils.openTempFile tmp_dir template 72 | #endif 73 | 74 | -- | Like 'openTempFile', but opens the file in binary mode. See 'openBinaryFile' for more comments. 75 | openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle) 76 | openBinaryTempFile tmp_dir template 77 | #if NEEDS_TEMP_WORKAROUND 78 | = openTempFile' "openBinaryTempFile" tmp_dir template True 0o600 79 | #else 80 | = IOUtils.openBinaryTempFile tmp_dir template 81 | #endif 82 | 83 | 84 | #if NEEDS_TEMP_WORKAROUND 85 | openTempFile' :: String -> FilePath -> String -> Bool -> CMode 86 | -> IO (FilePath, Handle) 87 | openTempFile' loc tmp_dir template binary mode 88 | | pathSeparator template 89 | = error $ "openTempFile': Template string must not contain path separator characters: "++template 90 | | otherwise = findTempName 91 | where 92 | -- We split off the last extension, so we can use .foo.ext files 93 | -- for temporary files (hidden on Unix OSes). Unfortunately we're 94 | -- below filepath in the hierarchy here. 95 | (prefix, suffix) = 96 | case break (== '.') $ reverse template of 97 | -- First case: template contains no '.'s. Just re-reverse it. 98 | (rev_suffix, "") -> (reverse rev_suffix, "") 99 | -- Second case: template contains at least one '.'. Strip the 100 | -- dot from the prefix and prepend it to the suffix (if we don't 101 | -- do this, the unique number will get added after the '.' and 102 | -- thus be part of the extension, which is wrong.) 103 | (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix) 104 | -- Otherwise, something is wrong, because (break (== '.')) should 105 | -- always return a pair with either the empty string or a string 106 | -- beginning with '.' as the second component. 107 | _ -> error "bug in System.IO.openTempFile" 108 | findTempName = do 109 | let label = if null prefix then "ghc" else prefix 110 | withCWString tmp_dir $ \c_tmp_dir -> 111 | withCWString label $ \c_template -> 112 | withCWString suffix $ \c_suffix -> 113 | -- FIXME: revisit this when new I/O manager in place and use a UUID 114 | -- based one when we are no longer MAX_PATH bound. 115 | allocaBytes (sizeOf (undefined :: CWchar) * 260) $ \c_str -> do 116 | res <- c_getTempFileNameErrorNo c_tmp_dir c_template c_suffix 0 117 | c_str 118 | if not res 119 | then do errno <- getErrno 120 | ioError (errnoToIOError loc errno Nothing (Just tmp_dir)) 121 | else do filename <- peekCWString c_str 122 | handleResults filename 123 | 124 | handleResults filename = do 125 | let oflags1 = rw_flags .|. o_EXCL 126 | binary_flags 127 | | binary = o_BINARY 128 | | otherwise = 0 129 | oflags = oflags1 .|. binary_flags 130 | fd <- withFilePath filename $ \ f -> c_open f oflags mode 131 | case fd < 0 of 132 | True -> do errno <- getErrno 133 | ioError (errnoToIOError loc errno Nothing (Just tmp_dir)) 134 | False -> 135 | do (fD,fd_type) <- FD.mkFD fd ReadWriteMode Nothing{-no stat-} 136 | False{-is_socket-} 137 | True{-is_nonblock-} 138 | 139 | enc <- getLocaleEncoding 140 | h <- POSIX.mkHandleFromFD fD fd_type filename ReadWriteMode 141 | False{-set non-block-} (Just enc) 142 | 143 | return (filename, h) 144 | 145 | foreign import ccall "__get_temp_file_name" c_getTempFileNameErrorNo 146 | :: CWString -> CWString -> CWString -> CUInt -> Ptr CWchar -> IO Bool 147 | 148 | pathSeparator :: String -> Bool 149 | pathSeparator template = any (\x-> x == '/' || x == '\\') template 150 | 151 | output_flags = std_flags 152 | 153 | -- XXX Copied from GHC.Handle 154 | std_flags, output_flags, rw_flags :: CInt 155 | std_flags = o_NONBLOCK .|. o_NOCTTY 156 | rw_flags = output_flags .|. o_RDWR 157 | #endif /* NEEDS_TEMP_WORKAROUND */ 158 | -------------------------------------------------------------------------------- /src/CrossCodegen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoMonomorphismRestriction #-} 2 | 3 | module CrossCodegen where 4 | 5 | {- 6 | A special cross-compilation mode for hsc2hs, which generates a .hs 7 | file without needing to run the executables that the C compiler 8 | outputs. 9 | 10 | Instead, it uses the output of compilations only -- specifically, 11 | whether compilation fails. This is the same trick that autoconf uses 12 | when cross compiling; if you want to know if sizeof(int) <= 4, then try 13 | compiling: 14 | 15 | > int x() { 16 | > static int ary[1 - 2*(sizeof(int) <= 4)]; 17 | > } 18 | 19 | and see if it fails. If you want to know sizeof(int), then 20 | repeatedly apply this kind of test with differing values, using 21 | binary search. 22 | -} 23 | 24 | import Prelude hiding (concatMap) 25 | import System.IO (hPutStr, openFile, IOMode(..), hClose) 26 | import System.Directory (removeFile) 27 | import Data.Char (toLower,toUpper,isSpace) 28 | import Control.Exception (assert, onException) 29 | import Control.Monad (when, liftM, forM, ap) 30 | import Control.Applicative as AP (Applicative(..)) 31 | import Data.Foldable (concatMap) 32 | import Data.Maybe (fromMaybe) 33 | import qualified Data.Sequence as S 34 | import Data.Sequence ((|>),ViewL(..)) 35 | import System.Exit ( ExitCode(..) ) 36 | import System.Process 37 | 38 | import C 39 | import Common 40 | import Flags 41 | import HSCParser 42 | 43 | import qualified ATTParser as ATT 44 | 45 | -- A monad over IO for performing tests; keeps the command line flags 46 | -- and a state counter for unique filename generation. 47 | -- equivalent to ErrorT String (StateT Int (ReaderT TestMonadEnv IO)) 48 | newtype TestMonad a = TestMonad { runTest :: TestMonadEnv -> Int -> IO (Either String a, Int) } 49 | 50 | instance Functor TestMonad where 51 | fmap = liftM 52 | 53 | instance Applicative TestMonad where 54 | pure a = TestMonad (\_ c -> pure (Right a, c)) 55 | (<*>) = ap 56 | 57 | instance Monad TestMonad where 58 | return = AP.pure 59 | x >>= fn = TestMonad (\e c -> (runTest x e c) >>= 60 | (\(a,c') -> either (\err -> return (Left err, c')) 61 | (\result -> runTest (fn result) e c') 62 | a)) 63 | 64 | data TestMonadEnv = TestMonadEnv { 65 | testIsVerbose_ :: Bool, 66 | testLogNestCount_ :: Int, 67 | testKeepFiles_ :: Bool, 68 | testGetBaseName_ :: FilePath, 69 | testGetFlags_ :: [Flag], 70 | testGetConfig_ :: Config, 71 | testGetCompiler_ :: FilePath 72 | } 73 | 74 | testAsk :: TestMonad TestMonadEnv 75 | testAsk = TestMonad (\e c -> return (Right e, c)) 76 | 77 | testIsVerbose :: TestMonad Bool 78 | testIsVerbose = testIsVerbose_ `fmap` testAsk 79 | 80 | testGetCompiler :: TestMonad FilePath 81 | testGetCompiler = testGetCompiler_ `fmap` testAsk 82 | 83 | testKeepFiles :: TestMonad Bool 84 | testKeepFiles = testKeepFiles_ `fmap` testAsk 85 | 86 | testGetFlags :: TestMonad [Flag] 87 | testGetFlags = testGetFlags_ `fmap` testAsk 88 | 89 | testGetConfig :: TestMonad Config 90 | testGetConfig = testGetConfig_ `fmap` testAsk 91 | 92 | testGetBaseName :: TestMonad FilePath 93 | testGetBaseName = testGetBaseName_ `fmap` testAsk 94 | 95 | testIncCount :: TestMonad Int 96 | testIncCount = TestMonad (\_ c -> let next=succ c 97 | in next `seq` return (Right c, next)) 98 | testFail' :: String -> TestMonad a 99 | testFail' s = TestMonad (\_ c -> return (Left s, c)) 100 | 101 | testFail :: SourcePos -> String -> TestMonad a 102 | testFail (SourcePos file line _) s = testFail' (file ++ ":" ++ show line ++ " " ++ s) 103 | 104 | -- liftIO for TestMonad 105 | liftTestIO :: IO a -> TestMonad a 106 | liftTestIO x = TestMonad (\_ c -> x >>= \r -> return (Right r, c)) 107 | 108 | -- finally for TestMonad 109 | testFinally :: TestMonad a -> TestMonad b -> TestMonad a 110 | testFinally action cleanup = do r <- action `testOnException` cleanup 111 | _ <- cleanup 112 | return r 113 | 114 | -- onException for TestMonad. This rolls back the state on an 115 | -- IO exception, which isn't great but shouldn't matter for now 116 | -- since only the test count is stored there. 117 | testOnException :: TestMonad a -> TestMonad b -> TestMonad a 118 | testOnException action cleanup = TestMonad (\e c -> runTest action e c 119 | `onException` runTest cleanup e c >>= \(actionResult,c') -> 120 | case actionResult of 121 | Left _ -> do (_,c'') <- runTest cleanup e c' 122 | return (actionResult,c'') 123 | Right _ -> return (actionResult,c')) 124 | 125 | -- prints the string to stdout if verbose mode is enabled. 126 | -- Maintains a nesting count and pads with spaces so that: 127 | -- testLog "a" $ 128 | -- testLog "b" $ return () 129 | -- will print 130 | -- a 131 | -- b 132 | testLog :: String -> TestMonad a -> TestMonad a 133 | testLog s a = TestMonad (\e c -> do let verbose = testIsVerbose_ e 134 | nestCount = testLogNestCount_ e 135 | when verbose $ putStrLn $ (concat $ replicate nestCount " ") ++ s 136 | runTest a (e { testLogNestCount_ = nestCount+1 }) c) 137 | 138 | testLog' :: String -> TestMonad () 139 | testLog' s = testLog s (return ()) 140 | 141 | testLogAtPos :: SourcePos -> String -> TestMonad a -> TestMonad a 142 | testLogAtPos (SourcePos file line _) s a = testLog (file ++ ":" ++ show line ++ " " ++ s) a 143 | 144 | -- Given a list of file suffixes, will generate a list of filenames 145 | -- which are all unique and have the given suffixes. On exit from this 146 | -- action, all those files will be removed (unless keepFiles is active) 147 | makeTest :: [String] -> ([String] -> TestMonad a) -> TestMonad a 148 | makeTest fileSuffixes fn = do 149 | c <- testIncCount 150 | fileBase <- testGetBaseName 151 | keepFiles <- testKeepFiles 152 | let files = zipWith (++) (repeat (fileBase ++ show c)) fileSuffixes 153 | testFinally (fn files) 154 | (when (not keepFiles) 155 | (mapM_ removeOrIgnore files)) 156 | where 157 | removeOrIgnore f = liftTestIO (catchIO (removeFile f) (const $ return ())) 158 | -- Convert from lists to tuples (to avoid "incomplete pattern" warnings in the callers) 159 | makeTest2 :: (String,String) -> ((String,String) -> TestMonad a) -> TestMonad a 160 | makeTest2 (a,b) fn = makeTest [a,b] helper 161 | where helper [a',b'] = fn (a',b') 162 | helper _ = error "makeTest: internal error" 163 | makeTest3 :: (String,String,String) -> ((String,String,String) -> TestMonad a) -> TestMonad a 164 | makeTest3 (a,b,c) fn = makeTest [a,b,c] helper 165 | where helper [a',b',c'] = fn (a',b',c') 166 | helper _ = error "makeTest: internal error" 167 | 168 | -- A Zipper over lists. Unlike ListZipper, this separates at the type level 169 | -- a list which may have a currently focused item (Zipper a) from 170 | -- a list which _definitely_ has a focused item (ZCursor a), so 171 | -- that zNext can be total. 172 | data Zipper a = End { zEnd :: S.Seq a } 173 | | Zipper (ZCursor a) 174 | 175 | data ZCursor a = ZCursor { zCursor :: a, 176 | zAbove :: S.Seq a, -- elements prior to the cursor 177 | -- in regular order (not reversed!) 178 | zBelow :: S.Seq a -- elements after the cursor 179 | } 180 | 181 | zipFromList :: [a] -> Zipper a 182 | zipFromList [] = End S.empty 183 | zipFromList (l:ls) = Zipper (ZCursor l S.empty (S.fromList ls)) 184 | 185 | zNext :: ZCursor a -> Zipper a 186 | zNext (ZCursor c above below) = 187 | case S.viewl below of 188 | S.EmptyL -> End (above |> c) 189 | c' :< below' -> Zipper (ZCursor c' (above |> c) below') 190 | 191 | -- Generates the .hs file from the .hsc file, by looping over each 192 | -- Special element and calling outputSpecial to find out what it needs. 193 | diagnose :: String -> (String -> TestMonad ()) -> [Token] -> TestMonad () 194 | diagnose inputFilename output input = do 195 | checkValidity input 196 | output ("{-# LINE 1 \"" ++ inputFilename ++ "\" #-}\n") 197 | loop (True, True) (zipFromList input) 198 | 199 | where 200 | loop _ (End _) = return () 201 | loop state@(lineSync, colSync) 202 | (Zipper z@ZCursor {zCursor=Special _ key _}) = 203 | case key of 204 | _ | key `elem` ["if","ifdef","ifndef","elif","else"] -> do 205 | condHolds <- checkConditional z 206 | if condHolds 207 | then loop state (zNext z) 208 | else loop state =<< either testFail' return 209 | (skipFalseConditional (zNext z)) 210 | "endif" -> loop state (zNext z) 211 | _ -> do 212 | sync <- outputSpecial output z 213 | loop (lineSync && sync, colSync && sync) (zNext z) 214 | loop state (Zipper z@ZCursor {zCursor=Text pos txt}) = do 215 | state' <- outputText state output pos txt 216 | loop state' (zNext z) 217 | 218 | outputSpecial :: (String -> TestMonad ()) -> ZCursor Token -> TestMonad Bool 219 | outputSpecial output (z@ZCursor {zCursor=Special pos@(SourcePos file line _) key value}) = 220 | case key of 221 | "const" -> outputConst value show >> return False 222 | "offset" -> outputConst ("offsetof(" ++ value ++ ")") (\i -> "(" ++ show i ++ ")") >> return False 223 | "size" -> outputConst ("sizeof(" ++ value ++ ")") (\i -> "(" ++ show i ++ ")") >> return False 224 | "alignment" -> outputConst (alignment value) show >> return False 225 | "peek" -> outputConst ("offsetof(" ++ value ++ ")") 226 | (\i -> "(\\hsc_ptr -> peekByteOff hsc_ptr " ++ show i ++ ")") >> return False 227 | "poke" -> outputConst ("offsetof(" ++ value ++ ")") 228 | (\i -> "(\\hsc_ptr -> pokeByteOff hsc_ptr " ++ show i ++ ")") >> return False 229 | "ptr" -> outputConst ("offsetof(" ++ value ++ ")") 230 | (\i -> "(\\hsc_ptr -> hsc_ptr `plusPtr` " ++ show i ++ ")") >> return False 231 | "type" -> computeType z >>= output >> return False 232 | "enum" -> computeEnum z >>= output >> return False 233 | "error" -> testFail pos ("#error " ++ value) 234 | "warning" -> liftTestIO $ putStrLn (file ++ ":" ++ show line ++ " warning: " ++ value) >> return True 235 | "include" -> return True 236 | "define" -> return True 237 | "undef" -> return True 238 | _ -> testFail pos ("directive " ++ key ++ " cannot be handled in cross-compilation mode") 239 | where outputConst value' formatter = computeConst z value' >>= (output . formatter) 240 | outputSpecial _ _ = error "outputSpecial's argument isn't a Special" 241 | 242 | outputText :: (Bool, Bool) -> (String -> TestMonad ()) -> SourcePos -> String 243 | -> TestMonad (Bool, Bool) 244 | outputText state output pos txt = do 245 | enableCol <- fmap cColumn testGetConfig 246 | let outCol col | enableCol = "{-# COLUMN " ++ show col ++ " #-}" 247 | | otherwise = "" 248 | let outLine (SourcePos file line _) = "{-# LINE " ++ show (line + 1) ++ 249 | " \"" ++ file ++ "\" #-}\n" 250 | let (s, state') = outTextHs state pos txt id outLine outCol 251 | output s 252 | return state' 253 | 254 | -- Bleh, messy. For each test we're compiling, we have a specific line of 255 | -- code that may cause compiler errors -- that's the test we want to perform. 256 | -- However, we *really* don't want any other kinds of compiler errors sneaking 257 | -- in (which might be e.g. due to the user's syntax errors) or we'll make the 258 | -- wrong conclusions on our tests. 259 | -- 260 | -- So before we compile any of the tests, take a pass over the whole file and 261 | -- generate a .c file which should fail if there are any syntax errors in what 262 | -- the user gave us. Hopefully, then the only reason our later compilations 263 | -- might fail is the particular reason we want. 264 | -- 265 | -- Another approach would be to try to parse the stdout of GCC and diagnose 266 | -- whether the error is the one we want. That's tricky because of localization 267 | -- etc. etc., though it would be less nerve-wracking. FYI it's not the approach 268 | -- that autoconf went with. 269 | checkValidity :: [Token] -> TestMonad () 270 | checkValidity input = do 271 | config <- testGetConfig 272 | flags <- testGetFlags 273 | let test = outTemplateHeaderCProg (cTemplate config) ++ 274 | concatMap outFlagHeaderCProg flags ++ 275 | concatMap (uncurry (outValidityCheck (cViaAsm config))) (zip input [0..]) 276 | testLog ("checking for compilation errors") $ do 277 | success <- makeTest2 (".c",".o") $ \(cFile,oFile) -> do 278 | liftTestIO $ writeBinaryFile cFile test 279 | compiler <- testGetCompiler 280 | runCompiler compiler 281 | (["-S" | cViaAsm config ]++ 282 | ["-c",cFile,"-o",oFile]++ 283 | [f | CompFlag f <- flags]) 284 | Nothing 285 | when (not success) $ testFail' "compilation failed" 286 | testLog' "compilation is error-free" 287 | 288 | outValidityCheck :: Bool -> Token -> Int -> String 289 | outValidityCheck viaAsm s@(Special pos key value) uniq = 290 | case key of 291 | "const" -> checkValidConst value 292 | "offset" -> checkValidConst ("offsetof(" ++ value ++ ")") 293 | "size" -> checkValidConst ("sizeof(" ++ value ++ ")") 294 | "alignment" -> checkValidConst (alignment value) 295 | "peek" -> checkValidConst ("offsetof(" ++ value ++ ")") 296 | "poke" -> checkValidConst ("offsetof(" ++ value ++ ")") 297 | "ptr" -> checkValidConst ("offsetof(" ++ value ++ ")") 298 | "type" -> checkValidType 299 | "enum" -> checkValidEnum 300 | _ -> outHeaderCProg' s 301 | where 302 | checkValidConst value' = if viaAsm 303 | then validConstTestViaAsm (show uniq) value' ++ "\n" 304 | else "void _hsc2hs_test" ++ show uniq ++ "()\n{\n" ++ validConstTest value' ++ "}\n" 305 | checkValidType = "void _hsc2hs_test" ++ show uniq ++ "()\n{\n" ++ outCLine pos ++ " (void)(" ++ value ++ ")1;\n}\n"; 306 | checkValidEnum = 307 | case parseEnum value of 308 | Nothing -> "" 309 | Just (_,_,enums) | viaAsm -> 310 | concatMap (\(hName,cName) -> validConstTestViaAsm (fromMaybe "noKey" (ATT.trim `fmap` hName) ++ show uniq) cName) enums 311 | Just (_,_,enums) -> 312 | "void _hsc2hs_test" ++ show uniq ++ "()\n{\n" ++ 313 | concatMap (\(_,cName) -> validConstTest cName) enums ++ 314 | "}\n" 315 | 316 | -- we want this to fail if the value is syntactically invalid or isn't a constant 317 | validConstTest value' = outCLine pos ++ " {\n static int test_array[(" ++ value' ++ ") > 0 ? 2 : 1];\n (void)test_array;\n }\n" 318 | validConstTestViaAsm name value' = outCLine pos ++ "\nextern long long _hsc2hs_test_" ++ name ++";\n" 319 | ++ "long long _hsc2hs_test_" ++ name ++ " = (" ++ value' ++ ");\n" 320 | 321 | outValidityCheck _ (Text _ _) _ = "" 322 | 323 | -- Skips over some #if or other conditional that we found to be false. 324 | -- I.e. the argument should be a zipper whose cursor is one past the #if, 325 | -- and returns a zipper whose cursor points at the next item which 326 | -- could possibly be compiled. 327 | skipFalseConditional :: Zipper Token -> Either String (Zipper Token) 328 | skipFalseConditional (End _) = Left "unterminated endif" 329 | skipFalseConditional (Zipper z@(ZCursor {zCursor=Special _ key _})) = 330 | case key of 331 | "if" -> either Left skipFalseConditional $ skipFullConditional 0 (zNext z) 332 | "ifdef" -> either Left skipFalseConditional $ skipFullConditional 0 (zNext z) 333 | "ifndef" -> either Left skipFalseConditional $ skipFullConditional 0 (zNext z) 334 | "elif" -> Right $ Zipper z 335 | "else" -> Right $ Zipper z 336 | "endif" -> Right $ zNext z 337 | _ -> skipFalseConditional (zNext z) 338 | skipFalseConditional (Zipper z) = skipFalseConditional (zNext z) 339 | 340 | -- Skips over an #if all the way to the #endif 341 | skipFullConditional :: Int -> Zipper Token -> Either String (Zipper Token) 342 | skipFullConditional _ (End _) = Left "unterminated endif" 343 | skipFullConditional nest (Zipper z@(ZCursor {zCursor=Special _ key _})) = 344 | case key of 345 | "if" -> skipFullConditional (nest+1) (zNext z) 346 | "ifdef" -> skipFullConditional (nest+1) (zNext z) 347 | "ifndef" -> skipFullConditional (nest+1) (zNext z) 348 | "endif" | nest > 0 -> skipFullConditional (nest-1) (zNext z) 349 | "endif" | otherwise -> Right $ zNext z 350 | _ -> skipFullConditional nest (zNext z) 351 | skipFullConditional nest (Zipper z) = skipFullConditional nest (zNext z) 352 | 353 | data IntegerConstant = Signed Integer | 354 | Unsigned Integer deriving (Show) 355 | -- Prints an syntatically valid integer in C 356 | cShowInteger :: IntegerConstant -> String 357 | cShowInteger (Signed x) | x < 0 = "(" ++ show (x+1) ++ "-1)" 358 | -- Trick to avoid overflowing large integer constants 359 | -- http://www.hardtoc.com/archives/119 360 | cShowInteger (Signed x) = show x 361 | cShowInteger (Unsigned x) = show x ++ "u" 362 | 363 | data IntegerComparison = GreaterOrEqual IntegerConstant | 364 | LessOrEqual IntegerConstant 365 | instance Show IntegerComparison where 366 | showsPrec _ (GreaterOrEqual c) = showString "`GreaterOrEqual` " . shows c 367 | showsPrec _ (LessOrEqual c) = showString "`LessOrEqual` " . shows c 368 | 369 | cShowCmpTest :: IntegerComparison -> String 370 | cShowCmpTest (GreaterOrEqual x) = ">=" ++ cShowInteger x 371 | cShowCmpTest (LessOrEqual x) = "<=" ++ cShowInteger x 372 | 373 | -- The cursor should point at #{const SOME_VALUE} or something like that. 374 | -- Determines the value of SOME_VALUE using binary search; this 375 | -- is a trick which is cribbed from autoconf's AC_COMPUTE_INT. 376 | computeConst :: ZCursor Token -> String -> TestMonad Integer 377 | computeConst zOrig@(ZCursor (Special pos _ _) _ _) value = 378 | testLogAtPos pos ("computing " ++ value) $ do 379 | config <- testGetConfig 380 | int <- case cViaAsm config of 381 | True -> runCompileAsmIntegerTest z 382 | False -> do nonNegative <- compareConst z (GreaterOrEqual (Signed 0)) 383 | integral <- checkValueIsIntegral z nonNegative 384 | when (not integral) $ testFail pos $ value ++ " is not an integer" 385 | (lower,upper) <- bracketBounds z nonNegative 386 | binarySearch z nonNegative lower upper 387 | testLog' $ "result: " ++ show int 388 | return int 389 | where -- replace the Special's value with the provided value; e.g. the special 390 | -- is #{size SOMETHING} and we might replace value with "sizeof(SOMETHING)". 391 | z = zOrig {zCursor=specialSetValue value (zCursor zOrig)} 392 | specialSetValue v (Special p k _) = Special p k v 393 | specialSetValue _ _ = error "computeConst argument isn't a Special" 394 | computeConst _ _ = error "computeConst argument isn't a Special" 395 | 396 | -- Binary search, once we've bracketed the integer. 397 | binarySearch :: ZCursor Token -> Bool -> Integer -> Integer -> TestMonad Integer 398 | binarySearch _ _ l u | l == u = return l 399 | binarySearch z nonNegative l u = do 400 | let mid :: Integer 401 | mid = (l+u+1) `div` 2 402 | inTopHalf <- compareConst z (GreaterOrEqual $ (if nonNegative then Unsigned else Signed) mid) 403 | let (l',u') = if inTopHalf then (mid,u) else (l,(mid-1)) 404 | assert (l < mid && mid <= u && -- @l < mid <= u@ 405 | l <= l' && l' <= u' && u' <= u && -- @l <= l' <= u' <= u@ 406 | u'-l' < u-l) -- @|u' - l'| < |u - l|@ 407 | (binarySearch z nonNegative l' u') 408 | 409 | -- Establishes bounds on the unknown integer. By searching increasingly 410 | -- large powers of 2, it'll bracket an integer x by lower & upper 411 | -- such that lower <= x <= upper. 412 | -- 413 | -- Assumes 2's complement integers. 414 | bracketBounds :: ZCursor Token -> Bool -> TestMonad (Integer, Integer) 415 | bracketBounds z nonNegative = do 416 | let -- test against integers 2**x-1 when positive, and 2**x when negative, 417 | -- to avoid generating constants that'd overflow the machine's integers. 418 | -- I.e. suppose we're searching for #{const INT_MAX} (e.g. 2^32-1). 419 | -- If we're comparing against all 2**x-1, we'll stop our search 420 | -- before we ever overflow int. 421 | powersOfTwo = iterate (\a -> 2*a) 1 422 | positiveBounds = map pred powersOfTwo 423 | negativeBounds = map negate powersOfTwo 424 | 425 | -- Test each element of the bounds list until we find one that exceeds 426 | -- the integer. 427 | loop cmp inner (maybeOuter:bounds') = do 428 | outerBounded <- compareConst z (cmp maybeOuter) 429 | if outerBounded 430 | then return (inner,maybeOuter) 431 | else loop cmp maybeOuter bounds' 432 | loop _ _ _ = error "bracketBounds: infinite list exhausted" 433 | 434 | if nonNegative 435 | then do (inner,outer) <- loop (LessOrEqual . Unsigned) (-1) positiveBounds 436 | return (inner+1,outer) 437 | else do (inner,outer) <- loop (GreaterOrEqual . Signed) 0 negativeBounds 438 | return (outer,inner-1) 439 | 440 | -- For #{enum} codegen; mimics template-hsc.h's hsc_haskellize 441 | haskellize :: String -> String 442 | haskellize [] = [] 443 | haskellize (firstLetter:next) = toLower firstLetter : loop False next 444 | where loop _ [] = [] 445 | loop _ ('_':as) = loop True as 446 | loop upper (a:as) = (if upper then toUpper a else toLower a) : loop False as 447 | 448 | -- For #{enum} codegen; in normal hsc2hs, any whitespace in the enum types & 449 | -- constructors will be mangled by the C preprocessor. This mimics the same 450 | -- mangling. 451 | stringify :: String -> String 452 | -- Spec: stringify = unwords . words 453 | stringify = go False . dropWhile isSpace 454 | where 455 | go _haveSpace [] = [] 456 | go haveSpace (x:xs) 457 | | isSpace x = go True xs 458 | | otherwise = if haveSpace 459 | then ' ' : x : go False xs 460 | else x : go False xs 461 | 462 | -- For #{alignment} codegen; mimic's template-hsc.h's hsc_alignment 463 | alignment :: String -> String 464 | alignment t = "offsetof(struct {char x__; " ++ t ++ " (y__); }, y__)" 465 | 466 | computeEnum :: ZCursor Token -> TestMonad String 467 | computeEnum z@(ZCursor (Special _ _ enumText) _ _) = 468 | case parseEnum enumText of 469 | Nothing -> return "" 470 | Just (enumType,constructor,enums) -> 471 | concatM enums $ \(maybeHsName, cName) -> do 472 | constValue <- computeConst z cName 473 | let hsName = fromMaybe (haskellize cName) maybeHsName 474 | return $ 475 | hsName ++ " :: " ++ stringify enumType ++ "\n" ++ 476 | hsName ++ " = " ++ stringify constructor ++ " " ++ showsPrec 11 constValue "\n" 477 | where concatM l = liftM concat . forM l 478 | computeEnum _ = error "computeEnum argument isn't a Special" 479 | 480 | -- Implementation of #{type}, using computeConst 481 | computeType :: ZCursor Token -> TestMonad String 482 | computeType z@(ZCursor (Special pos _ value) _ _) = do 483 | testLogAtPos pos ("computing type of " ++ value) $ do 484 | integral <- testLog ("checking if type " ++ value ++ " is an integer") $ do 485 | success <- runCompileBooleanTest z $ "(" ++ value ++ ")(int)(" ++ value ++ ")1.4 == (" ++ value ++ ")1.4" 486 | testLog' $ "result: " ++ (if success then "integer" else "pointer or floating") 487 | return success 488 | typeRet <- if integral 489 | then do 490 | signed <- testLog ("checking if type " ++ value ++ " is signed") $ do 491 | success <- runCompileBooleanTest z $ "(" ++ value ++ ")(-1) < (" ++ value ++ ")0" 492 | testLog' $ "result: " ++ (if success then "signed" else "unsigned") 493 | return success 494 | size <- computeConst z ("sizeof(" ++ value ++ ")") 495 | return $ (if signed then "Int" else "Word") ++ (show (size * 8)) 496 | else do 497 | pointer <- testLog ("checking if type " ++ value ++ " is a pointer") $ do 498 | success <- runCompileIsPointerTest z value 499 | testLog' $ "result: " ++ (if success then "pointer" else "floating") 500 | return success 501 | if pointer 502 | then return "CUIntPtr" 503 | else do 504 | let checkSize test = testLog ("checking if " ++ test) $ do 505 | success <- runCompileBooleanTest z test 506 | testLog' $ "result: " ++ show success 507 | return success 508 | ldouble <- checkSize ("sizeof(" ++ value ++ ") > sizeof(double)") 509 | if ldouble 510 | then return "LDouble" 511 | else do 512 | double <- checkSize ("sizeof(" ++ value ++ ") == sizeof(double)") 513 | if double 514 | then return "Double" 515 | else return "Float" 516 | testLog' $ "result: " ++ typeRet 517 | return typeRet 518 | computeType _ = error "computeType argument isn't a Special" 519 | 520 | outHeaderCProg' :: Token -> String 521 | outHeaderCProg' (Special pos key value) = outHeaderCProg (pos,key,value) 522 | outHeaderCProg' _ = "" 523 | 524 | -- Checks if an #if/#ifdef etc. etc. is true by inserting a #error 525 | -- and seeing if the compile fails. 526 | checkConditional :: ZCursor Token -> TestMonad Bool 527 | checkConditional (ZCursor s@(Special pos key value) above below) = do 528 | config <- testGetConfig 529 | flags <- testGetFlags 530 | let test = outTemplateHeaderCProg (cTemplate config) ++ 531 | (concatMap outFlagHeaderCProg flags) ++ 532 | (concatMap outHeaderCProg' above) ++ 533 | outHeaderCProg' s ++ "#error T\n" ++ 534 | (concatMap outHeaderCProg' below) 535 | testLogAtPos pos ("checking #" ++ key ++ " " ++ value) $ do 536 | condTrue <- not `fmap` runCompileTest test 537 | testLog' $ "result: " ++ show condTrue 538 | return condTrue 539 | checkConditional _ = error "checkConditional argument isn't a Special" 540 | 541 | -- Make sure the value we're trying to binary search isn't floating point. 542 | checkValueIsIntegral :: ZCursor Token -> Bool -> TestMonad Bool 543 | checkValueIsIntegral z@(ZCursor (Special _ _ value) _ _) nonNegative = do 544 | let intType = if nonNegative then "unsigned long long" else "long long" 545 | testLog ("checking if " ++ value ++ " is an integer") $ do 546 | success <- runCompileBooleanTest z $ "(" ++ intType ++ ")(" ++ value ++ ") == (" ++ value ++ ")" 547 | testLog' $ "result: " ++ (if success then "integer" else "floating") 548 | return success 549 | checkValueIsIntegral _ _ = error "checkConditional argument isn't a Special" 550 | 551 | compareConst :: ZCursor Token -> IntegerComparison -> TestMonad Bool 552 | compareConst z@(ZCursor (Special _ _ value) _ _) cmpTest = do 553 | testLog ("checking " ++ value ++ " " ++ show cmpTest) $ do 554 | success <- runCompileBooleanTest z $ "(" ++ value ++ ") " ++ cShowCmpTest cmpTest 555 | testLog' $ "result: " ++ show success 556 | return success 557 | compareConst _ _ = error "compareConst argument isn't a Special" 558 | 559 | -- Given a compile-time constant with boolean type, this extracts the 560 | -- value of the constant by compiling a .c file only. 561 | -- 562 | -- The trick comes from autoconf: use the fact that the compiler must 563 | -- perform constant arithmetic for computation of array dimensions, and 564 | -- will generate an error if the array has negative size. 565 | runCompileBooleanTest :: ZCursor Token -> String -> TestMonad Bool 566 | runCompileBooleanTest (ZCursor s above below) booleanTest = do 567 | config <- testGetConfig 568 | flags <- testGetFlags 569 | let test = -- all the surrounding code 570 | outTemplateHeaderCProg (cTemplate config) ++ 571 | (concatMap outFlagHeaderCProg flags) ++ 572 | (concatMap outHeaderCProg' above) ++ 573 | outHeaderCProg' s ++ 574 | -- the test 575 | "int _hsc2hs_test() {\n" ++ 576 | " static int test_array[1 - 2 * !(" ++ booleanTest ++ ")];\n" ++ 577 | " return test_array[0];\n" ++ 578 | "}\n" ++ 579 | (concatMap outHeaderCProg' below) 580 | runCompileTest test 581 | 582 | runCompileIsPointerTest :: ZCursor Token -> String -> TestMonad Bool 583 | runCompileIsPointerTest (ZCursor s above below) ty = do 584 | config <- testGetConfig 585 | flags <- testGetFlags 586 | let test = -- all the surrounding code 587 | outTemplateHeaderCProg (cTemplate config) ++ 588 | (concatMap outFlagHeaderCProg flags) ++ 589 | (concatMap outHeaderCProg' above) ++ 590 | outHeaderCProg' s ++ 591 | -- the test 592 | "void *_hsc2hs_test(" ++ ty ++ " val) {\n" ++ 593 | " return val;\n" ++ 594 | "}\n" ++ 595 | (concatMap outHeaderCProg' below) 596 | runCompileTest test 597 | 598 | runCompileAsmIntegerTest :: ZCursor Token -> TestMonad Integer 599 | runCompileAsmIntegerTest (ZCursor s@(Special _ _ value) above below) = do 600 | config <- testGetConfig 601 | flags <- testGetFlags 602 | let key = "___hsc2hs_int_test" 603 | let test = -- all the surrounding code 604 | outTemplateHeaderCProg (cTemplate config) ++ 605 | (concatMap outFlagHeaderCProg flags) ++ 606 | (concatMap outHeaderCProg' above) ++ 607 | outHeaderCProg' s ++ 608 | -- the test 609 | "extern unsigned long long ___hsc2hs_BOM___;\n" ++ 610 | "unsigned long long ___hsc2hs_BOM___ = 0x100000000;\n" ++ 611 | "extern unsigned long long " ++ key ++ "___hsc2hs_sign___;\n" ++ 612 | "unsigned long long " ++ key ++ "___hsc2hs_sign___ = (" ++ value ++ ") < 0;\n" ++ 613 | "extern unsigned long long " ++ key ++ ";\n" ++ 614 | "unsigned long long " ++ key ++ " = (" ++ value ++ ");\n"++ 615 | (concatMap outHeaderCProg' below) 616 | runCompileExtract key test 617 | runCompileAsmIntegerTest _ = error "runCompileAsmIntegerTestargument isn't a Special" 618 | 619 | runCompileExtract :: String -> String -> TestMonad Integer 620 | runCompileExtract k testStr = do 621 | makeTest3 (".c", ".s", ".txt") $ \(cFile, sFile, stdout) -> do 622 | liftTestIO $ writeBinaryFile cFile testStr 623 | flags <- testGetFlags 624 | compiler <- testGetCompiler 625 | _ <- runCompiler compiler 626 | (["-S", "-c", cFile, "-o", sFile] ++ [f | CompFlag f <- flags]) 627 | (Just stdout) 628 | asm <- liftTestIO $ ATT.parse sFile 629 | return $ fromMaybe (error "Failed to extract integer") (ATT.lookupInteger k asm) 630 | 631 | runCompileTest :: String -> TestMonad Bool 632 | runCompileTest testStr = do 633 | makeTest3 (".c", ".o",".txt") $ \(cFile,oFile,stdout) -> do 634 | liftTestIO $ writeBinaryFile cFile testStr 635 | flags <- testGetFlags 636 | compiler <- testGetCompiler 637 | runCompiler compiler 638 | (["-c",cFile,"-o",oFile]++[f | CompFlag f <- flags]) 639 | (Just stdout) 640 | 641 | runCompiler :: FilePath -> [String] -> Maybe FilePath -> TestMonad Bool 642 | runCompiler prog args mStdoutFile = do 643 | let cmdLine = showCommandForUser prog args 644 | testLog ("executing: " ++ cmdLine) $ liftTestIO $ do 645 | mHOut <- case mStdoutFile of 646 | Nothing -> return Nothing 647 | Just stdoutFile -> liftM Just $ openFile stdoutFile WriteMode 648 | process <- runProcess prog args Nothing Nothing Nothing mHOut mHOut 649 | case mHOut of 650 | Just hOut -> hClose hOut 651 | Nothing -> return () 652 | exitStatus <- waitForProcess process 653 | return $ case exitStatus of 654 | ExitSuccess -> True 655 | ExitFailure _ -> False 656 | 657 | -- The main driver for cross-compilation mode 658 | outputCross :: Config -> String -> String -> String -> String -> [Token] -> IO () 659 | outputCross config outName outDir outBase inName toks = 660 | runTestMonad $ do 661 | file <- liftTestIO $ openFile outName WriteMode 662 | (diagnose inName (liftTestIO . hPutStr file) toks 663 | `testFinally` (liftTestIO $ hClose file)) 664 | `testOnException` (liftTestIO $ removeFile outName) -- cleanup on errors 665 | where 666 | tmenv = TestMonadEnv (cVerbose config) 0 (cKeepFiles config) (outDir++outBase++"_hsc_test") (cFlags config) config (cCompiler config) 667 | runTestMonad x = runTest x tmenv 0 >>= (handleError . fst) 668 | 669 | handleError (Left e) = die (e++"\n") 670 | handleError (Right ()) = return () 671 | -------------------------------------------------------------------------------- /src/DirectCodegen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module DirectCodegen where 3 | 4 | {- 5 | The standard mode for hsc2hs: generates a C file which is 6 | compiled and run; the output of that program is the .hs file. 7 | -} 8 | 9 | #if MIN_VERSION_base(4,6,0) 10 | import Prelude hiding ( Foldable(..) ) 11 | #else 12 | import Data.List ( foldl' ) 13 | #endif 14 | import Data.Char ( isAlphaNum, toUpper ) 15 | import Data.Foldable ( Foldable(..) ) 16 | import Control.Monad ( when, forM_ ) 17 | 18 | import System.Exit ( ExitCode(..), exitWith ) 19 | import System.FilePath ( normalise ) 20 | 21 | import C 22 | import Common 23 | import Flags 24 | import HSCParser 25 | import UtilsCodegen 26 | 27 | outputDirect :: Config -> FilePath -> FilePath -> FilePath -> String -> [Token] -> IO () 28 | outputDirect config outName outDir outBase name toks = do 29 | 30 | let beVerbose = cVerbose config 31 | flags = cFlags config 32 | enableCol = cColumn config 33 | cProgName = outDir++outBase++"_hsc_make.c" 34 | oProgName = outDir++outBase++"_hsc_make.o" 35 | progName = outDir++outBase++"_hsc_make" 36 | #if defined(mingw32_HOST_OS) || defined(__CYGWIN32__) 37 | -- This is a real hack, but the quoting mechanism used for calling the C preprocesseor 38 | -- via GHC has changed a few times, so this seems to be the only way... :-P * * * 39 | ++ ".exe" 40 | #endif 41 | outHFile = outBase++"_hsc.h" 42 | outHName = outDir++outHFile 43 | outCName = outDir++outBase++"_hsc.c" 44 | 45 | let execProgName 46 | | null outDir = normalise ("./" ++ progName) 47 | | otherwise = progName 48 | 49 | let specials = [(pos, key, arg) | Special pos key arg <- toks] 50 | 51 | let needsC = any (\(_, key, _) -> key == "def") specials 52 | needsH = needsC 53 | possiblyRemove = if cKeepFiles config 54 | then flip const 55 | else finallyRemove 56 | 57 | let includeGuard = map fixChar outHName 58 | where 59 | fixChar c | isAlphaNum c = toUpper c 60 | | otherwise = '_' 61 | 62 | when (cCrossSafe config) $ 63 | forM_ specials (\ (SourcePos file line _,key,_) -> 64 | when (not $ key `elem` ["const","offset","size","alignment","peek","poke","ptr", 65 | "type","enum","error","warning","include","define","undef", 66 | "if","ifdef","ifndef", "elif","else","endif"]) $ 67 | die (file ++ ":" ++ show line ++ " directive \"" ++ key ++ "\" is not safe for cross-compilation")) 68 | 69 | writeBinaryFile cProgName $ 70 | outTemplateHeaderCProg (cTemplate config)++ 71 | concatMap outFlagHeaderCProg flags++ 72 | concatMap outHeaderCProg specials++ 73 | "\nint main (void)\n{\n"++ 74 | outHeaderHs flags (if needsH then Just outHName else Nothing) specials++ 75 | outHsLine (SourcePos name 0 1)++ 76 | fst (foldl' (outTokenHs enableCol) (id, (True, True)) toks) ""++ 77 | " return 0;\n}\n" 78 | 79 | when (cNoCompile config) $ exitWith ExitSuccess 80 | 81 | rawSystemL outDir outBase ("compiling " ++ cProgName) beVerbose 82 | (cCompiler config) 83 | ( ["-c"] 84 | ++ [cProgName] 85 | ++ ["-o", oProgName] 86 | ++ [f | CompFlag f <- flags] 87 | ) 88 | possiblyRemove cProgName $ 89 | withUtilsObject config outDir outBase $ \oUtilsName -> do 90 | 91 | rawSystemL outDir outBase ("linking " ++ oProgName) beVerbose 92 | (cLinker config) 93 | ( [oProgName, oUtilsName] 94 | ++ ["-o", progName] 95 | ++ [f | LinkFlag f <- flags] 96 | ) 97 | possiblyRemove oProgName $ do 98 | 99 | rawSystemWithStdOutL outDir outBase ("running " ++ execProgName) beVerbose execProgName [] outName 100 | possiblyRemove progName $ do 101 | 102 | when needsH $ writeBinaryFile outHName $ 103 | "#ifndef "++includeGuard++"\n" ++ 104 | "#define "++includeGuard++"\n" ++ 105 | "#include \n" ++ 106 | "#if __NHC__\n" ++ 107 | "#undef HsChar\n" ++ 108 | "#define HsChar int\n" ++ 109 | "#endif\n" ++ 110 | concatMap outFlagH flags++ 111 | concatMap outTokenH specials++ 112 | "#endif\n" 113 | 114 | when needsC $ writeBinaryFile outCName $ 115 | "#include \""++outHFile++"\"\n"++ 116 | concatMap outTokenC specials 117 | -- NB. outHFile not outHName; works better when processed 118 | -- by gcc or mkdependC. 119 | -------------------------------------------------------------------------------- /src/Flags.hs: -------------------------------------------------------------------------------- 1 | 2 | module Flags where 3 | 4 | import System.Console.GetOpt 5 | 6 | data Mode 7 | = Help 8 | | Version 9 | | UseConfig (ConfigM Maybe) 10 | 11 | 12 | newtype Id a = Id { fromId :: a } 13 | type Config = ConfigM Id 14 | 15 | data ConfigM m = Config { 16 | cmTemplate :: m FilePath, 17 | cmCompiler :: m FilePath, 18 | cmLinker :: m FilePath, 19 | cKeepFiles :: Bool, 20 | cNoCompile :: Bool, 21 | cCrossCompile :: Bool, 22 | cViaAsm :: Bool, 23 | cCrossSafe :: Bool, 24 | cColumn :: Bool, 25 | cVerbose :: Bool, 26 | cFlags :: [Flag] 27 | } 28 | 29 | cTemplate :: ConfigM Id -> FilePath 30 | cTemplate c = fromId $ cmTemplate c 31 | 32 | cCompiler :: ConfigM Id -> FilePath 33 | cCompiler c = fromId $ cmCompiler c 34 | 35 | cLinker :: ConfigM Id -> FilePath 36 | cLinker c = fromId $ cmLinker c 37 | 38 | emptyMode :: Mode 39 | emptyMode = UseConfig $ Config { 40 | cmTemplate = Nothing, 41 | cmCompiler = Nothing, 42 | cmLinker = Nothing, 43 | cKeepFiles = False, 44 | cNoCompile = False, 45 | cCrossCompile = False, 46 | cViaAsm = False, 47 | cCrossSafe = False, 48 | cColumn = False, 49 | cVerbose = False, 50 | cFlags = [] 51 | } 52 | 53 | data Flag 54 | = CompFlag String 55 | | LinkFlag String 56 | | Include String 57 | | Define String (Maybe String) 58 | | Output String 59 | deriving (Eq, Show) 60 | 61 | options :: [OptDescr (Mode -> Mode)] 62 | options = [ 63 | Option ['o'] ["output"] (ReqArg (addFlag . Output) "FILE") 64 | "name of main output file", 65 | Option ['t'] ["template"] (ReqArg (withConfig . setTemplate) "FILE") 66 | "template file", 67 | Option ['c'] ["cc"] (ReqArg (withConfig . setCompiler) "PROG") 68 | "C compiler to use", 69 | Option ['l'] ["ld"] (ReqArg (withConfig . setLinker) "PROG") 70 | "linker to use", 71 | Option ['C'] ["cflag"] (ReqArg (addFlag . CompFlag) "FLAG") 72 | "flag to pass to the C compiler", 73 | Option ['I'] [] (ReqArg (addFlag . CompFlag . ("-I"++)) "DIR") 74 | "passed to the C compiler", 75 | Option ['L'] ["lflag"] (ReqArg (addFlag . LinkFlag) "FLAG") 76 | "flag to pass to the linker", 77 | Option ['i'] ["include"] (ReqArg (addFlag . include) "FILE") 78 | "as if placed in the source", 79 | Option ['D'] ["define"] (ReqArg (addFlag . define) "NAME[=VALUE]") 80 | "as if placed in the source", 81 | Option [] ["no-compile"] (NoArg (withConfig $ setNoCompile True)) 82 | "stop after writing *_hsc_make.c", 83 | Option ['x'] ["cross-compile"] (NoArg (withConfig $ setCrossCompile True)) 84 | "activate cross-compilation mode", 85 | Option [] ["via-asm"] (NoArg (withConfig $ setViaAsm True)) 86 | "use a crude asm parser to compute constants when cross compiling", 87 | Option [] ["cross-safe"] (NoArg (withConfig $ setCrossSafe True)) 88 | "restrict .hsc directives to those supported by --cross-compile", 89 | Option ['k'] ["keep-files"] (NoArg (withConfig $ setKeepFiles True)) 90 | "do not remove temporary files", 91 | Option [] ["column"] (NoArg (withConfig $ setColumn True)) 92 | "annotate output with COLUMN pragmas (requires GHC 8.2)", 93 | Option ['v'] ["verbose"] (NoArg (withConfig $ setVerbose True)) 94 | "dump commands to stderr", 95 | Option ['?'] ["help"] (NoArg (setMode Help)) 96 | "display this help and exit", 97 | Option ['V'] ["version"] (NoArg (setMode Version)) 98 | "output version information and exit" ] 99 | 100 | addFlag :: Flag -> Mode -> Mode 101 | addFlag f (UseConfig c) = UseConfig $ c { cFlags = cFlags c ++ [f]} 102 | addFlag _ mode = mode 103 | 104 | setMode :: Mode -> Mode -> Mode 105 | setMode Help _ = Help 106 | setMode _ Help = Help 107 | setMode Version _ = Version 108 | setMode (UseConfig {}) _ = error "setMode: UseConfig: Can't happen" 109 | 110 | withConfig :: (ConfigM Maybe -> ConfigM Maybe) -> Mode -> Mode 111 | withConfig f (UseConfig c) = UseConfig $ f c 112 | withConfig _ m = m 113 | 114 | setTemplate :: FilePath -> ConfigM Maybe -> ConfigM Maybe 115 | setTemplate fp c = c { cmTemplate = Just fp } 116 | 117 | setCompiler :: FilePath -> ConfigM Maybe -> ConfigM Maybe 118 | setCompiler fp c = c { cmCompiler = Just fp } 119 | 120 | setLinker :: FilePath -> ConfigM Maybe -> ConfigM Maybe 121 | setLinker fp c = c { cmLinker = Just fp } 122 | 123 | setKeepFiles :: Bool -> ConfigM Maybe -> ConfigM Maybe 124 | setKeepFiles b c = c { cKeepFiles = b } 125 | 126 | setNoCompile :: Bool -> ConfigM Maybe -> ConfigM Maybe 127 | setNoCompile b c = c { cNoCompile = b } 128 | 129 | setCrossCompile :: Bool -> ConfigM Maybe -> ConfigM Maybe 130 | setCrossCompile b c = c { cCrossCompile = b } 131 | 132 | setViaAsm :: Bool -> ConfigM Maybe -> ConfigM Maybe 133 | setViaAsm b c = c { cViaAsm = b } 134 | 135 | setCrossSafe :: Bool -> ConfigM Maybe -> ConfigM Maybe 136 | setCrossSafe b c = c { cCrossSafe = b } 137 | 138 | setColumn :: Bool -> ConfigM Maybe -> ConfigM Maybe 139 | setColumn b c = c { cColumn = b } 140 | 141 | setVerbose :: Bool -> ConfigM Maybe -> ConfigM Maybe 142 | setVerbose v c = c { cVerbose = v } 143 | 144 | include :: String -> Flag 145 | include s@('\"':_) = Include s 146 | include s@('<' :_) = Include s 147 | include s = Include ("\""++s++"\"") 148 | 149 | define :: String -> Flag 150 | define s = case break (== '=') s of 151 | (name, []) -> Define name Nothing 152 | (name, _:value) -> Define name (Just value) 153 | 154 | -------------------------------------------------------------------------------- /src/HSCParser.hs: -------------------------------------------------------------------------------- 1 | module HSCParser where 2 | import Control.Applicative hiding ( many ) 3 | import Control.Monad ( MonadPlus(..), liftM, liftM2, ap ) 4 | import Data.Char ( isAlpha, isAlphaNum, isSpace, isDigit ) 5 | 6 | ------------------------------------------------------------------------ 7 | -- A deterministic parser which remembers the text which has been parsed. 8 | 9 | newtype Parser a = Parser (SourcePos -> String -> ParseResult a) 10 | 11 | runParser :: Parser a -> String -> String -> ParseResult a 12 | runParser (Parser p) file_name = p (SourcePos file_name 1 1) 13 | 14 | data ParseResult a = Success !SourcePos String String a 15 | | Failure !SourcePos String 16 | 17 | data SourcePos = SourcePos String !Int !Int 18 | 19 | updatePos :: SourcePos -> Char -> SourcePos 20 | updatePos (SourcePos name line col) ch = case ch of 21 | '\n' -> SourcePos name (line + 1) 1 22 | _ -> SourcePos name line (col + 1) 23 | 24 | instance Functor Parser where 25 | fmap = liftM 26 | 27 | instance Applicative Parser where 28 | pure a = Parser $ \pos s -> Success pos [] s a 29 | (<*>) = ap 30 | 31 | instance Monad Parser where 32 | return = pure 33 | Parser m >>= k = 34 | Parser $ \pos s -> case m pos s of 35 | Success pos' out1 s' a -> case k a of 36 | Parser k' -> case k' pos' s' of 37 | Success pos'' out2 imp'' b -> 38 | Success pos'' (out1++out2) imp'' b 39 | Failure pos'' msg -> Failure pos'' msg 40 | Failure pos' msg -> Failure pos' msg 41 | 42 | failp :: String -> Parser a 43 | failp msg = Parser $ \pos _ -> Failure pos msg 44 | 45 | instance Alternative Parser where 46 | empty = mzero 47 | (<|>) = mplus 48 | 49 | instance MonadPlus Parser where 50 | mzero = failp "mzero" 51 | Parser m `mplus` Parser n = 52 | Parser $ \pos s -> case m pos s of 53 | success@(Success _ _ _ _) -> success 54 | Failure _ _ -> n pos s 55 | 56 | getPos :: Parser SourcePos 57 | getPos = Parser $ \pos s -> Success pos [] s pos 58 | 59 | setPos :: SourcePos -> Parser () 60 | setPos pos = Parser $ \_ s -> Success pos [] s () 61 | 62 | message :: Parser a -> String -> Parser a 63 | Parser m `message` msg = 64 | Parser $ \pos s -> case m pos s of 65 | success@(Success _ _ _ _) -> success 66 | Failure pos' _ -> Failure pos' msg 67 | 68 | catchOutput_ :: Parser a -> Parser String 69 | catchOutput_ (Parser m) = 70 | Parser $ \pos s -> case m pos s of 71 | Success pos' out s' _ -> Success pos' [] s' out 72 | Failure pos' msg -> Failure pos' msg 73 | 74 | fakeOutput :: Parser a -> String -> Parser a 75 | Parser m `fakeOutput` out = 76 | Parser $ \pos s -> case m pos s of 77 | Success pos' _ s' a -> Success pos' out s' a 78 | Failure pos' msg -> Failure pos' msg 79 | 80 | lookAhead :: Parser String 81 | lookAhead = Parser $ \pos s -> Success pos [] s s 82 | 83 | satisfy :: (Char -> Bool) -> Parser Char 84 | satisfy p = 85 | Parser $ \pos s -> case s of 86 | c:cs | p c -> Success (updatePos pos c) [c] cs c 87 | _ -> Failure pos "Bad character" 88 | 89 | satisfy_ :: (Char -> Bool) -> Parser () 90 | satisfy_ p = satisfy p >> return () 91 | 92 | char_ :: Char -> Parser () 93 | char_ c = do 94 | satisfy_ (== c) `message` (show c++" expected") 95 | 96 | anyChar_ :: Parser () 97 | anyChar_ = do 98 | satisfy_ (const True) `message` "Unexpected end of file" 99 | 100 | any2Chars_ :: Parser () 101 | any2Chars_ = anyChar_ >> anyChar_ 102 | 103 | any3Chars_ :: Parser () 104 | any3Chars_ = anyChar_ >> anyChar_ >> anyChar_ 105 | 106 | many :: Parser a -> Parser [a] 107 | many p = many1 p `mplus` return [] 108 | 109 | many1 :: Parser a -> Parser [a] 110 | many1 p = liftM2 (:) p (many p) 111 | 112 | many_ :: Parser a -> Parser () 113 | many_ p = many1_ p `mplus` return () 114 | 115 | many1_ :: Parser a -> Parser () 116 | many1_ p = p >> many_ p 117 | 118 | manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String 119 | manySatisfy = many . satisfy 120 | manySatisfy1 = many1 . satisfy 121 | 122 | manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser () 123 | manySatisfy_ = many_ . satisfy 124 | manySatisfy1_ = many1_ . satisfy 125 | 126 | ------------------------------------------------------------------------ 127 | -- Parser of hsc syntax. 128 | 129 | data Token 130 | = Text SourcePos String 131 | | Special SourcePos String String 132 | 133 | tokenIsSpecial :: Token -> Bool 134 | tokenIsSpecial (Text {}) = False 135 | tokenIsSpecial (Special {}) = True 136 | 137 | parser :: Parser [Token] 138 | parser = do 139 | pos <- getPos 140 | t <- catchOutput_ text 141 | s <- lookAhead 142 | rest <- case s of 143 | [] -> return [] 144 | _:_ -> liftM2 (:) (special `fakeOutput` []) parser 145 | return (if null t then rest else Text pos t : rest) 146 | 147 | text :: Parser () 148 | text = do 149 | s <- lookAhead 150 | case s of 151 | [] -> return () 152 | c:_ | isAlpha c || c == '_' -> do 153 | anyChar_ 154 | manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'') 155 | text 156 | c:_ | isHsSymbol c -> do 157 | symb <- catchOutput_ (manySatisfy_ isHsSymbol) 158 | case symb of 159 | "#" -> return () 160 | '-':'-':symb' | all (== '-') symb' -> do 161 | return () `fakeOutput` symb 162 | manySatisfy_ (/= '\n') 163 | text 164 | _ -> do 165 | return () `fakeOutput` unescapeHashes symb 166 | text 167 | '\"':_ -> do anyChar_; hsString '\"'; text 168 | -- See Note [Single Quotes] 169 | '\'':'\\':_ -> do anyChar_; hsString '\''; text -- Case 1 170 | '\'':_:'\'':_ -> do any3Chars_; text -- Case 2 171 | '\'':d:_ | isSpace d -> do -- Case 3 172 | any2Chars_ 173 | manySatisfy_ (\c' -> isSpace c') 174 | manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'') 175 | text 176 | '\'':_ -> do -- Case 4 177 | anyChar_ 178 | manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'') 179 | text 180 | '{':'-':_ -> do 181 | any2Chars_ 182 | linePragma `mplus` columnPragma `mplus` hsComment 183 | text 184 | _:_ -> do anyChar_; text 185 | 186 | {- Note [Single Quotes] 187 | ~~~~~~~~~~~~~~~~~~~~~~~ 188 | hsc2hs performs some tricks to figure out if we are looking at character 189 | literal or a promoted data constructor. In order, the cases considered are: 190 | 191 | 1. quote-backslash: An escape sequence character literal. Since these 192 | escape sequences have several different possible lengths, hsc2hs relies 193 | on hsString to consume everything after this until another single quote 194 | is encountered. See Note [Handling escaped characters]. 195 | 2. quote-any-quote: A character literal. Consumes the triplet. 196 | 3. quote-space: Here, the order of the patterns becomes important. This 197 | case and the case below handle promoted data constructors. This one 198 | is to handle data constructor that end in a quote. They have special 199 | syntax for promotion that requires adding a leading space. After an 200 | arbitrary number of initial space characters, consume 201 | all alphanumeric characters and quotes, considering them part of the 202 | identifier. 203 | 4. quote: If nothing else matched, we assume we are dealing with a normal 204 | promoted data constructor. Consume all alphanumeric characters and 205 | quotes, considering them part of the identifier. 206 | 207 | Here are some lines of code for which at one of the described cases 208 | would be matched at some point: 209 | 210 | data Foo = Foo' | Bar 211 | 212 | main :: IO () 213 | main = do 214 | 1> putChar '\NUL' 215 | 2> putChar 'x' 216 | 3> let y = Proxy :: Proxy ' Foo' 217 | 4> let x = Proxy :: Proxy 'Bar 218 | pure () 219 | -} 220 | 221 | hsString :: Char -> Parser () 222 | hsString quote = do 223 | s <- lookAhead 224 | case s of 225 | [] -> return () 226 | c:_ | c == quote -> anyChar_ 227 | -- See Note [Handling escaped characters] 228 | '\\':c:_ 229 | | isSpace c -> do 230 | anyChar_ 231 | manySatisfy_ isSpace 232 | char_ '\\' `mplus` return () 233 | hsString quote 234 | | otherwise -> do any2Chars_; hsString quote 235 | _:_ -> do anyChar_; hsString quote 236 | 237 | {- Note [Handling escaped characters] 238 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 239 | There are several accepted escape codes for string and character literals. 240 | The function hsString handles all escape sequences that start with space 241 | in its first guard and all others in the otherwise guard. It only needs 242 | to consume two characters to handle these non-space-prefixed escape 243 | sequences correctly. Consider these examples: 244 | 245 | * Single Character: \t -> 246 | * Multiple Characters: \DEL -> EL 247 | * Decimal: \1789 -> 789 248 | * Hexadecimal: \xbeef -> beef 249 | * Octal: \o3576 -> 3576 250 | 251 | Crucially, none of these suffixes left after dropping the leading two 252 | characters ever contain single quote, double quote, or backslash. 253 | Consequently, these leftover characters will be matched by the 254 | final pattern match (_:_) in hsString since the call to any2Chars_ 255 | is followed by recursing. 256 | -} 257 | 258 | hsComment :: Parser () 259 | hsComment = do 260 | s <- lookAhead 261 | case s of 262 | [] -> return () 263 | '-':'}':_ -> any2Chars_ 264 | '{':'-':_ -> do any2Chars_; hsComment; hsComment 265 | _:_ -> do anyChar_; hsComment 266 | 267 | linePragma :: Parser () 268 | linePragma = do 269 | char_ '#' 270 | manySatisfy_ isSpace 271 | satisfy_ (\c -> c == 'L' || c == 'l') 272 | satisfy_ (\c -> c == 'I' || c == 'i') 273 | satisfy_ (\c -> c == 'N' || c == 'n') 274 | satisfy_ (\c -> c == 'E' || c == 'e') 275 | manySatisfy1_ isSpace 276 | line <- liftM read $ manySatisfy1 isDigit 277 | manySatisfy1_ isSpace 278 | char_ '\"' 279 | name <- manySatisfy (/= '\"') 280 | char_ '\"' 281 | manySatisfy_ isSpace 282 | char_ '#' 283 | char_ '-' 284 | char_ '}' 285 | setPos (SourcePos name (line - 1) 1) 286 | 287 | columnPragma :: Parser () 288 | columnPragma = do 289 | char_ '#' 290 | manySatisfy_ isSpace 291 | satisfy_ (\c -> c == 'C' || c == 'c') 292 | satisfy_ (\c -> c == 'O' || c == 'o') 293 | satisfy_ (\c -> c == 'L' || c == 'l') 294 | satisfy_ (\c -> c == 'U' || c == 'u') 295 | satisfy_ (\c -> c == 'M' || c == 'm') 296 | satisfy_ (\c -> c == 'N' || c == 'n') 297 | manySatisfy1_ isSpace 298 | column <- liftM read $ manySatisfy1 isDigit 299 | manySatisfy_ isSpace 300 | char_ '#' 301 | char_ '-' 302 | char_ '}' 303 | SourcePos name line _ <- getPos 304 | setPos (SourcePos name line column) 305 | 306 | isHsSymbol :: Char -> Bool 307 | isHsSymbol '!' = True; isHsSymbol '#' = True; isHsSymbol '$' = True 308 | isHsSymbol '%' = True; isHsSymbol '&' = True; isHsSymbol '*' = True 309 | isHsSymbol '+' = True; isHsSymbol '.' = True; isHsSymbol '/' = True 310 | isHsSymbol '<' = True; isHsSymbol '=' = True; isHsSymbol '>' = True 311 | isHsSymbol '?' = True; isHsSymbol '@' = True; isHsSymbol '\\' = True 312 | isHsSymbol '^' = True; isHsSymbol '|' = True; isHsSymbol '-' = True 313 | isHsSymbol '~' = True 314 | isHsSymbol _ = False 315 | 316 | unescapeHashes :: String -> String 317 | unescapeHashes [] = [] 318 | unescapeHashes ('#':'#':s) = '#' : unescapeHashes s 319 | unescapeHashes (c:s) = c : unescapeHashes s 320 | 321 | lookAheadC :: Parser String 322 | lookAheadC = liftM joinLines lookAhead 323 | where 324 | joinLines [] = [] 325 | joinLines ('\\':'\n':s) = joinLines s 326 | joinLines (c:s) = c : joinLines s 327 | 328 | satisfyC :: (Char -> Bool) -> Parser Char 329 | satisfyC p = do 330 | s <- lookAhead 331 | case s of 332 | '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p 333 | _ -> satisfy p 334 | 335 | satisfyC_ :: (Char -> Bool) -> Parser () 336 | satisfyC_ p = satisfyC p >> return () 337 | 338 | charC_ :: Char -> Parser () 339 | charC_ c = satisfyC_ (== c) `message` (show c++" expected") 340 | 341 | anyCharC_ :: Parser () 342 | anyCharC_ = satisfyC_ (const True) `message` "Unexpected end of file" 343 | 344 | any2CharsC_ :: Parser () 345 | any2CharsC_ = anyCharC_ >> anyCharC_ 346 | 347 | manySatisfyC :: (Char -> Bool) -> Parser String 348 | manySatisfyC = many . satisfyC 349 | 350 | manySatisfyC_ :: (Char -> Bool) -> Parser () 351 | manySatisfyC_ = many_ . satisfyC 352 | 353 | special :: Parser Token 354 | special = do 355 | manySatisfyC_ (\c -> isSpace c && c /= '\n') 356 | s <- lookAheadC 357 | case s of 358 | '{':_ -> do 359 | anyCharC_ 360 | manySatisfyC_ isSpace 361 | sp <- keyArg (== '\n') 362 | charC_ '}' 363 | return sp 364 | _ -> keyArg (const False) 365 | 366 | keyArg :: (Char -> Bool) -> Parser Token 367 | keyArg eol = do 368 | pos <- getPos 369 | key <- keyword `message` "hsc keyword or '{' expected" 370 | manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c') 371 | arg <- catchOutput_ (argument eol) 372 | return (Special pos key arg) 373 | 374 | keyword :: Parser String 375 | keyword = do 376 | c <- satisfyC (\c' -> isAlpha c' || c' == '_') 377 | cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_') 378 | return (c:cs) 379 | 380 | argument :: (Char -> Bool) -> Parser () 381 | argument eol = do 382 | s <- lookAheadC 383 | case s of 384 | [] -> return () 385 | c:_ | eol c -> do anyCharC_; argument eol 386 | '\n':_ -> return () 387 | '\"':_ -> do anyCharC_; cString '\"'; argument eol 388 | '\'':_ -> do anyCharC_; cString '\''; argument eol 389 | '(':_ -> do anyCharC_; nested ')'; argument eol 390 | ')':_ -> return () 391 | '/':'*':_ -> do any2CharsC_; cComment; argument eol 392 | '/':'/':_ -> do 393 | any2CharsC_; manySatisfyC_ (/= '\n'); argument eol 394 | '[':_ -> do anyCharC_; nested ']'; argument eol 395 | ']':_ -> return () 396 | '{':_ -> do anyCharC_; nested '}'; argument eol 397 | '}':_ -> return () 398 | _:_ -> do anyCharC_; argument eol 399 | 400 | nested :: Char -> Parser () 401 | nested c = do argument (== '\n'); charC_ c 402 | 403 | cComment :: Parser () 404 | cComment = do 405 | s <- lookAheadC 406 | case s of 407 | [] -> return () 408 | '*':'/':_ -> do any2CharsC_ 409 | _:_ -> do anyCharC_; cComment 410 | 411 | cString :: Char -> Parser () 412 | cString quote = do 413 | s <- lookAheadC 414 | case s of 415 | [] -> return () 416 | c:_ | c == quote -> anyCharC_ 417 | '\\':_:_ -> do any2CharsC_; cString quote 418 | _:_ -> do anyCharC_; cString quote 419 | 420 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | ------------------------------------------------------------------------ 4 | -- Program for converting .hsc files to .hs files, by converting the 5 | -- file into a C program which is run to generate the Haskell source. 6 | -- Certain items known only to the C compiler can then be used in 7 | -- the Haskell module; for example #defined constants, byte offsets 8 | -- within structures, etc. 9 | -- 10 | -- See the documentation in the Users' Guide for more details. 11 | 12 | import Control.Monad ( liftM, forM_ ) 13 | import Data.List ( isSuffixOf ) 14 | import System.Console.GetOpt 15 | 16 | -- If we ware building the hsc2hs 17 | -- binary for binary distribution 18 | -- in the GHC tree. Obtain 19 | -- the path to the @$topdir/lib@ 20 | -- folder, and try to locate the 21 | -- @template-hsc.h@ there. 22 | -- 23 | -- XXX: Note this does not work 24 | -- on windows due to for 25 | -- symlinks. See Trac #14483. 26 | 27 | #if defined(mingw32_HOST_OS) 28 | import Foreign 29 | import Foreign.C.String 30 | #endif 31 | import System.Directory ( doesFileExist, findExecutable ) 32 | import System.Environment ( getProgName ) 33 | import System.Exit ( ExitCode(..), exitWith ) 34 | import System.FilePath ( normalise, splitFileName, splitExtension ) 35 | import System.IO 36 | 37 | #ifdef BUILD_NHC 38 | import System.Directory ( getCurrentDirectory ) 39 | #else 40 | import Paths_hsc2hs as Main ( getDataFileName, version ) 41 | import Data.Version ( showVersion ) 42 | #endif 43 | #if defined(IN_GHC_TREE) 44 | import System.Environment ( getExecutablePath ) 45 | import System.FilePath ( takeDirectory, () ) 46 | #endif 47 | 48 | import Common 49 | import Compat.ResponseFile ( getArgsWithResponseFiles ) 50 | import CrossCodegen 51 | import DirectCodegen 52 | import Flags 53 | import HSCParser 54 | 55 | #ifdef mingw32_HOST_OS 56 | # if defined(i386_HOST_ARCH) 57 | # define WINDOWS_CCONV stdcall 58 | # elif defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) 59 | # define WINDOWS_CCONV ccall 60 | # else 61 | # error Unknown mingw32 arch 62 | # endif 63 | #endif 64 | 65 | #ifdef BUILD_NHC 66 | getDataFileName s = do here <- getCurrentDirectory 67 | return (here++"/"++s) 68 | #endif 69 | 70 | versionString :: String 71 | versionString = "hsc2hs version " ++ showVersion version ++ "\n" 72 | 73 | main :: IO () 74 | main = do 75 | prog <- getProgramName 76 | let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]\n" 77 | usage = usageInfo header options 78 | args <- getArgsWithResponseFiles 79 | let (fs, files, errs) = getOpt Permute options args 80 | let mode = foldl (\m f -> f m) emptyMode fs 81 | case mode of 82 | Help -> bye usage 83 | Version -> bye versionString 84 | UseConfig config -> 85 | case (files, errs) of 86 | ((_:_), []) -> processFiles config files usage 87 | (_, _ ) -> die (concat errs ++ usage) 88 | 89 | getProgramName :: IO String 90 | getProgramName = liftM (`withoutSuffix` "-bin") getProgName 91 | where str `withoutSuffix` suff 92 | | suff `isSuffixOf` str = take (length str - length suff) str 93 | | otherwise = str 94 | 95 | bye :: String -> IO a 96 | bye s = putStr s >> exitWith ExitSuccess 97 | 98 | processFiles :: ConfigM Maybe -> [FilePath] -> String -> IO () 99 | processFiles configM files usage = do 100 | mb_libdir <- getLibDir 101 | 102 | (template, extraFlags) <- findTemplate usage mb_libdir configM 103 | compiler <- findCompiler mb_libdir configM 104 | let linker = case cmLinker configM of 105 | Nothing -> compiler 106 | Just l -> l 107 | config = Config { 108 | cmTemplate = Id template, 109 | cmCompiler = Id compiler, 110 | cmLinker = Id linker, 111 | cKeepFiles = cKeepFiles configM, 112 | cNoCompile = cNoCompile configM, 113 | cCrossCompile = cCrossCompile configM, 114 | cViaAsm = cViaAsm configM, 115 | cCrossSafe = cCrossSafe configM, 116 | cColumn = cColumn configM, 117 | cVerbose = cVerbose configM, 118 | cFlags = cFlags configM ++ extraFlags 119 | } 120 | 121 | let outputter = if cCrossCompile config then outputCross else outputDirect 122 | 123 | forM_ files (\name -> do 124 | (outName, outDir, outBase) <- case [f | Output f <- cFlags config] of 125 | [] -> if not (null ext) && last ext == 'c' 126 | then return (dir++base++init ext, dir, base) 127 | else 128 | if ext == ".hs" 129 | then return (dir++base++"_out.hs", dir, base) 130 | else return (dir++base++".hs", dir, base) 131 | where 132 | (dir, file) = splitFileName name 133 | (base, ext) = splitExtension file 134 | [f] -> let 135 | (dir, file) = splitFileName f 136 | (base, _) = splitExtension file 137 | in return (f, dir, base) 138 | _ -> onlyOne "output file" 139 | let file_name = normalise name 140 | toks <- parseFile file_name 141 | outputter config outName outDir outBase file_name toks) 142 | 143 | findTemplate :: String -> Maybe FilePath -> ConfigM Maybe 144 | -> IO (FilePath, [Flag]) 145 | findTemplate usage mb_libdir config 146 | = -- If there's no template specified on the commandline, try to locate it 147 | case cmTemplate config of 148 | Just t -> 149 | return (t, []) 150 | Nothing -> do 151 | -- If there is no Template flag explicitly specified, try 152 | -- to find one. We first look near the executable. This only 153 | -- works on Win32 or Hugs (getExecDir). If this finds a template 154 | -- file then it's certainly the one we want, even if hsc2hs isn't 155 | -- installed where we told Cabal it would be installed. 156 | -- 157 | -- Next we try the location we told Cabal about. 158 | -- 159 | -- If IN_GHC_TREE is defined (-fin-ghc-tree), we also try to locate 160 | -- the template in the `baseDir`, as provided by the `ghc-boot` 161 | -- library. Note that this is a hack to work around only partial 162 | -- relocatable support in cabal, and is here to allow the hsc2hs 163 | -- built and shipped with ghc to be relocatable with the ghc 164 | -- binary distribution it ships with. 165 | -- 166 | -- If neither of the above work, then hopefully we're on Unix and 167 | -- there's a wrapper script which specifies an explicit template flag. 168 | mb_templ1 <- 169 | case mb_libdir of 170 | Nothing -> return Nothing 171 | Just path -> do 172 | -- Euch, this is horrible. Unfortunately 173 | -- Paths_hsc2hs isn't too useful for a 174 | -- relocatable binary, though. 175 | let 176 | templ1 = path ++ "/template-hsc.h" 177 | incl = path ++ "/include/" 178 | exists1 <- doesFileExist templ1 179 | if exists1 180 | then return $ Just (templ1, CompFlag ("-I" ++ incl)) 181 | else return Nothing 182 | mb_templ2 <- case mb_templ1 of 183 | Just (templ1, incl) -> 184 | return $ Just (templ1, [incl]) 185 | Nothing -> do 186 | templ2 <- getDataFileName "template-hsc.h" 187 | exists2 <- doesFileExist templ2 188 | if exists2 189 | then return $ Just (templ2, []) 190 | else return Nothing 191 | case mb_templ2 of 192 | Just x -> return x 193 | #if defined(IN_GHC_TREE) 194 | Nothing -> do 195 | -- XXX: this will *not* work on windows for symlinks, until `getExecutablePath` in `base` is 196 | -- fixed. The alternative would be to bring the whole logic from the SysTools module in here 197 | -- which is rather excessive. See Trac #14483. 198 | let getBaseDir = Just . (\p -> p "lib") . takeDirectory . takeDirectory <$> getExecutablePath 199 | mb_templ3 <- fmap ( "template-hsc.h") <$> getBaseDir 200 | mb_exists3 <- mapM doesFileExist mb_templ3 201 | case (mb_templ3, mb_exists3) of 202 | (Just templ3, Just True) -> return (templ3, []) 203 | _ -> die ("No template specified, and template-hsc.h not located.\n\n" ++ usage) 204 | #else 205 | Nothing -> die ("No template specified, and template-hsc.h not located.\n\n" ++ usage) 206 | #endif 207 | 208 | findCompiler :: Maybe FilePath -> ConfigM Maybe -> IO FilePath 209 | findCompiler mb_libdir config 210 | = case cmCompiler config of 211 | Just c -> return c 212 | Nothing -> 213 | do let search_path = do 214 | mb_path <- findExecutable default_compiler 215 | case mb_path of 216 | Nothing -> 217 | die ("Can't find "++default_compiler++"\n") 218 | Just path -> return path 219 | -- if this hsc2hs is part of a GHC installation on 220 | -- Windows, then we should use the mingw gcc that 221 | -- comes with GHC (#3929) 222 | inplaceGccs = case mb_libdir of 223 | Nothing -> [] 224 | Just d -> [d ++ "/../mingw/bin/gcc.exe"] 225 | search [] = search_path 226 | search (x : xs) = do b <- doesFileExist x 227 | if b then return x else search xs 228 | search inplaceGccs 229 | 230 | parseFile :: String -> IO [Token] 231 | parseFile name 232 | = do h <- openBinaryFile name ReadMode 233 | -- use binary mode so we pass through UTF-8, see GHC ticket #3837 234 | -- But then on Windows we end up turning things like 235 | -- #let alignment t = e^M 236 | -- into 237 | -- #define hsc_alignment(t ) printf ( e^M); 238 | -- which gcc doesn't like, so strip out any ^M characters. 239 | s <- hGetContents h 240 | let s' = filter ('\r' /=) s 241 | case runParser parser name s' of 242 | Success _ _ _ toks -> return toks 243 | Failure (SourcePos name' line col) msg -> 244 | die (name'++":"++show line++":"++show col++": "++msg++"\n") 245 | 246 | getLibDir :: IO (Maybe String) 247 | getLibDir = fmap (fmap (++ "/lib")) $ getExecDir "/bin/hsc2hs.exe" 248 | 249 | -- (getExecDir cmd) returns the directory in which the current 250 | -- executable, which should be called 'cmd', is running 251 | -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd, 252 | -- you'll get "/a/b/c" back as the result 253 | getExecDir :: String -> IO (Maybe String) 254 | getExecDir cmd = 255 | getExecPath >>= maybe (return Nothing) removeCmdSuffix 256 | where initN n = reverse . drop n . reverse 257 | removeCmdSuffix = return . Just . initN (length cmd) . normalise 258 | 259 | getExecPath :: IO (Maybe String) 260 | #if defined(mingw32_HOST_OS) 261 | getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32. 262 | where 263 | try_size size = allocaArray (fromIntegral size) $ \buf -> do 264 | ret <- c_GetModuleFileName nullPtr buf size 265 | case ret of 266 | 0 -> return Nothing 267 | _ | ret < size -> fmap Just $ peekCWString buf 268 | | otherwise -> try_size (size * 2) 269 | 270 | foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW" 271 | c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 272 | #else 273 | getExecPath = return Nothing 274 | #endif 275 | -------------------------------------------------------------------------------- /src/UtilsCodegen.hs: -------------------------------------------------------------------------------- 1 | module UtilsCodegen where 2 | 3 | {- 4 | Generate the utility code for hsc2hs. 5 | 6 | We don't want to include C headers in template-hsc.h 7 | See GHC trac #2897 8 | -} 9 | 10 | import Control.Monad 11 | 12 | import C 13 | import Common 14 | import Flags 15 | 16 | withUtilsObject :: Config -> FilePath -> FilePath 17 | -> (FilePath -> IO a) 18 | -> IO a 19 | withUtilsObject config outDir outBase f = do 20 | 21 | let beVerbose = cVerbose config 22 | flags = cFlags config 23 | possiblyRemove = if cKeepFiles config 24 | then flip const 25 | else finallyRemove 26 | cUtilsName = outDir ++ outBase ++ "_hsc_utils.c" 27 | oUtilsName = outDir ++ outBase ++ "_hsc_utils.o" 28 | 29 | possiblyRemove cUtilsName $ do 30 | writeBinaryFile cUtilsName $ unlines $ 31 | -- These header will cause a mismatch with any mingw-w64 header by 32 | -- including system headers before user headers in the hsc file. 33 | -- We *MUST* include user headers *BEFORE* automatic ones. */ 34 | [outTemplateHeaderCProg (cTemplate config), 35 | "", 36 | "#include ", 37 | "#include ", 38 | "#include ", 39 | "#include ", 40 | "#include ", 41 | "", 42 | "int hsc_printf(const char *format, ...) {", 43 | " int r;", 44 | " va_list argp;", 45 | " va_start(argp, format);", 46 | " r = vprintf(format, argp);", 47 | " va_end(argp);", 48 | " return r;", 49 | "}", 50 | "", 51 | "int hsc_toupper(int c) {", 52 | " return toupper(c);", 53 | "}", 54 | "", 55 | "int hsc_tolower(int c) {", 56 | " return tolower(c);", 57 | "}", 58 | "", 59 | "int hsc_putchar(int c) {", 60 | " return putchar(c);", 61 | "}", 62 | "", 63 | -- "void" should really be "FILE", but we aren't able to 64 | -- refer to "FILE" in template-hsc.h as we don't want to 65 | -- include there. We cast to FILE * so as to 66 | -- allow compiling with g++. 67 | "int hsc_fputs(const char *s, void *stream) {", 68 | " return fputs(s, (FILE *)stream);", 69 | "}", 70 | "", 71 | -- "void" should really be "FILE", but we aren't able to 72 | -- refer to "FILE" in template-hsc.h as we don't want to 73 | -- include there. We explicitly cast to void * 74 | -- to allow compiling with g++. 75 | "void *hsc_stdout(void) {", 76 | " return (void *)stdout;", 77 | "}" 78 | ] 79 | 80 | possiblyRemove oUtilsName $ do 81 | unless (cNoCompile config) $ 82 | rawSystemL outDir (outBase ++ "_utils") ("compiling " ++ cUtilsName) 83 | beVerbose 84 | (cCompiler config) 85 | (["-c", cUtilsName, "-o", oUtilsName] ++ 86 | [cFlag | CompFlag cFlag <- flags]) 87 | 88 | f oUtilsName 89 | -------------------------------------------------------------------------------- /test/BDD.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE GADTs #-} 4 | module BDD where 5 | 6 | import Control.Monad (ap) 7 | import Test.Tasty 8 | import Test.Tasty.HUnit 9 | 10 | #if !MIN_VERSION_base(4,8,0) 11 | import Control.Applicative (Applicative (..)) 12 | #endif 13 | 14 | #if MIN_VERSION_base(4,9,0) 15 | import GHC.Stack (HasCallStack) 16 | #define HASCALLSTACK , HasCallStack 17 | #else 18 | #define HASCALLSTACK 19 | #endif 20 | 21 | ------------------------------------------------------------------------------- 22 | -- HSpec like DSL for test-framework 23 | ------------------------------------------------------------------------------- 24 | 25 | specMain :: TestM () -> IO () 26 | specMain t = runTestM t >>= defaultMain . testGroup "specs" 27 | 28 | newtype TestM a = TestM { unTestM :: [TestTree] -> IO ([TestTree], a) } 29 | deriving (Functor) 30 | 31 | -- accumulating in reverse order. 32 | tell1 :: TestTree -> TestM () 33 | tell1 t = TestM $ \ts -> return (t : ts, ()) 34 | 35 | instance Applicative TestM where 36 | pure = return 37 | (<*>) = ap 38 | 39 | instance Monad TestM where 40 | return x = TestM $ \xs -> return (xs, x) 41 | 42 | m >>= k = TestM $ \xs -> do 43 | (ys, x) <- unTestM m xs 44 | unTestM (k x) ys 45 | 46 | runTestM :: TestM () -> IO [TestTree] 47 | runTestM (TestM m) = fmap (reverse . fst) (m []) 48 | 49 | runIO :: IO a -> TestM a 50 | runIO m = TestM $ \ts -> do 51 | x <- m 52 | return (ts, x) 53 | 54 | ------------------------------------------------------------------------------- 55 | -- describe, it 56 | ------------------------------------------------------------------------------- 57 | 58 | describe :: TestName -> TestM () -> TestM () 59 | describe n t = do 60 | t' <- runIO (runTestM t) 61 | tell1 $ testGroup n t' 62 | 63 | it :: TestName -> Assertion -> TestM () 64 | it n assertion = tell1 $ testCase n assertion 65 | 66 | shouldBe :: (Eq a, Show a HASCALLSTACK) => a -> a -> Assertion 67 | shouldBe = (@?=) 68 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import BDD 4 | import ATTParser 5 | import Flags 6 | 7 | import Control.Monad (forM_) 8 | import System.Console.GetOpt 9 | 10 | main :: IO () 11 | main = specMain $ do 12 | describe "asm parser" $ do 13 | -- 64bit 14 | forM_ [("x86_64 linux", "test/asm/x86_64-linux.s") 15 | ,("x86_64 macos", "test/asm/x86_64-mac.s") 16 | ,("x86_64 mingw", "test/asm/x86_64-mingw32.s") 17 | ,("aarch64 ios", "test/asm/aarch64-ios.s") 18 | ,("aarch64 linux","test/asm/aarch64.s") 19 | ,("sparc64 linux","test/asm/sparc64-linux.s") 20 | ,("mips64 linux", "test/asm/mips64-linux.s") 21 | ,("powerpc64 linux","test/asm/powerpc64-linux.s") 22 | ,("powerpc64le linux","test/asm/powerpc64le-linux.s") 23 | ,("hppa linux", "test/asm/hppa-linux.s") 24 | ,("m68k linux", "test/asm/m68k-linux.s") 25 | ,("alpha linux", "test/asm/alpha-linux.s") 26 | ,("ia64 linux", "test/asm/ia64-linux.s") 27 | ,("nios2 linux", "test/asm/nios2-linux.s") 28 | ,("s390 linux", "test/asm/s390-linux.s") 29 | ,("s390x linux", "test/asm/s390x-linux.s") 30 | ,("sh4 linux", "test/asm/sh4-linux.s") 31 | ] 32 | $ \(d, f) ->do 33 | describe d $ do 34 | x <- runIO $ parse f 35 | 36 | it "x should be 1" $ do 37 | lookupInteger "x" x `shouldBe` (Just 1) 38 | it "z should be 0xffffffffffffffff" $ do 39 | lookupInteger "y" x `shouldBe` (Just 0xffffffffffffffff) 40 | it "z should be -1" $ do 41 | lookupInteger "z" x `shouldBe` (Just (-1)) 42 | 43 | it "t should be \"Hello World\\\"\\n\\0\"" $ do 44 | lookupString "t" x `shouldBe` (Just "Hello World\" 12345\0") 45 | -- 32 bit 46 | forM_ [("arm ios", "test/asm/arm-ios.s") 47 | ,("arm linux", "test/asm/arm.s") 48 | ,("x86 linux", "test/asm/x86-linux.s") 49 | ,("sparc linux", "test/asm/sparc-linux.s") 50 | ,("mips linux", "test/asm/mips-linux.s") 51 | ,("powerpc linux","test/asm/powerpc-linux.s") 52 | ] 53 | $ \(d, f) ->do 54 | describe d $ do 55 | x <- runIO $ parse f 56 | 57 | it "x should be 1" $ do 58 | lookupInteger "x" x `shouldBe` (Just 1) 59 | it "z should be 0xffffffff" $ do 60 | lookupInteger "y" x `shouldBe` (Just 0xffffffff) 61 | it "z should be -1" $ do 62 | lookupInteger "z" x `shouldBe` (Just (-1)) 63 | 64 | it "t should be \"Hello World\\\"\\n\\0\"" $ do 65 | lookupString "t" x `shouldBe` (Just "Hello World\" 12345\0") 66 | 67 | describe "flags" $ do 68 | it "are processed in order" $ do 69 | -- at the moment this test fails (issue #35) 70 | let (fs, files, errs) = getOpt Permute options 71 | [ "--cc=gcc", "--cc=clang" 72 | , "--include=", "--include=" 73 | , "--template", "template1", "--template=template2" 74 | ] 75 | let mode = foldl (\m f -> f m) emptyMode fs 76 | 77 | configModeMaybe mode cmCompiler `shouldBe` Just "clang" 78 | configModeMaybe mode cmTemplate `shouldBe` Just "template2" 79 | configMode mode cFlags `shouldBe` Just [Include "", Include ""] 80 | 81 | files `shouldBe` [] 82 | errs `shouldBe` [] 83 | 84 | configMode :: Mode -> (ConfigM Maybe -> a) -> Maybe a 85 | configMode (UseConfig c) f = Just (f c) 86 | configMode _ _ = Nothing 87 | 88 | configModeMaybe :: Mode -> (ConfigM Maybe -> Maybe a) -> Maybe a 89 | configModeMaybe (UseConfig c) f = f c 90 | configModeMaybe _ _ = Nothing 91 | -------------------------------------------------------------------------------- /test/asm/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | clang -target arm-linux-gnueabihf -S -c tmp.c -o arm.s 3 | clang -target aarch64-linux-gnueabihf -S -c tmp.c -o aarch64.s 4 | clang -target arm64-apple-ios -S -c tmp.c -o aarch64-ios.s 5 | clang -target armv7-apple-ios -S -c tmp.c -o arm-ios.s 6 | x86_64-w64-mingw32-gcc -S -c tmp.c -o x86_64-mingw32.s 7 | clang -target i386-unknown-linux -S -c tmp.c -o x86-linux.s 8 | clang -target x86_64-apple-macos -S -c tmp.c -o x86_64-mac.s 9 | clang -target i386-unknown-linux -S -c tmp.c -o x86-linux.s 10 | clang -target x86_64-unknown-linux -S -c tmp.c -o x86_64-linux.s 11 | clang -target sparc-unknown-linux -S -c tmp.c -o sparc-linux.s 12 | clang -target sparc64-unknown-linux -S -c tmp.c -o sparc64-linux.s 13 | clang -target mips-unknown-linux -S -c tmp.c -o mips-linux.s 14 | clang -target mips64-unknown-linux -S -c tmp.c -o mips64-linux.s 15 | clang -target powerpc-unknown-linux -S -c tmp.c -o powerpc-linux.s 16 | clang -target powerpc64-unknown-linux -S -c tmp.c -o powerpc64-linux.s 17 | clang -target powerpc64le-unknown-linux -S -c tmp.c -o powerpc64le-linux.s 18 | hppa-unknown-linux-gnu-gcc -S -c tmp.c -o hppa-linux.s 19 | m68k-unknown-linux-gnu-gcc -S -c tmp.c -o m68k-linux.s 20 | alpha-unknown-linux-gnu-gcc -S -c tmp.c -o alpha-linux.s 21 | ia64-unknown-linux-gnu-gcc -S -c tmp.c -o ia64-linux.s 22 | nios2-unknown-linux-gnu-gcc -S -c tmp.c -o nios2-linux.s 23 | s390-unknown-linux-gnu-gcc -S -c tmp.c -o s390-linux.s 24 | s390x-unknown-linux-gnu-gcc -S -c tmp.c -o s390x-linux.s 25 | sh4-unknown-linux-gnu-gcc -S -c tmp.c -o sh4-linux.s 26 | -------------------------------------------------------------------------------- /test/asm/aarch64-ios.s: -------------------------------------------------------------------------------- 1 | .section __TEXT,__text,regular,pure_instructions 2 | .ios_version_min 7, 0 3 | .section __DATA,__data 4 | .globl ____hsc2hs_BOM___ ; @___hsc2hs_BOM___ 5 | .p2align 3 6 | ____hsc2hs_BOM___: 7 | .quad 4294967296 ; 0x100000000 8 | 9 | .globl _x___hsc2hs_sign___ ; @x___hsc2hs_sign___ 10 | .zerofill __DATA,__common,_x___hsc2hs_sign___,8,3 11 | .globl _x ; @x 12 | .p2align 3 13 | _x: 14 | .quad 1 ; 0x1 15 | 16 | .globl _y___hsc2hs_sign___ ; @y___hsc2hs_sign___ 17 | .zerofill __DATA,__common,_y___hsc2hs_sign___,8,3 18 | .globl _y ; @y 19 | .p2align 3 20 | _y: 21 | .quad -1 ; 0xffffffffffffffff 22 | 23 | .globl _z___hsc2hs_sign___ ; @z___hsc2hs_sign___ 24 | .p2align 3 25 | _z___hsc2hs_sign___: 26 | .quad 1 ; 0x1 27 | 28 | .globl _z ; @z 29 | .p2align 3 30 | _z: 31 | .quad -1 ; 0xffffffffffffffff 32 | 33 | .section __TEXT,__cstring,cstring_literals 34 | l_.str: ; @.str 35 | .asciz "Hello World\" 12345" 36 | 37 | .section __DATA,__data 38 | .globl _t ; @t 39 | .p2align 3 40 | _t: 41 | .quad l_.str 42 | 43 | 44 | .subsections_via_symbols 45 | -------------------------------------------------------------------------------- /test/asm/aarch64.s: -------------------------------------------------------------------------------- 1 | .text 2 | .file "tmp.c" 3 | .type ___hsc2hs_BOM___,@object // @___hsc2hs_BOM___ 4 | .data 5 | .globl ___hsc2hs_BOM___ 6 | .p2align 3 7 | ___hsc2hs_BOM___: 8 | .xword 4294967296 // 0x100000000 9 | .size ___hsc2hs_BOM___, 8 10 | 11 | .type x___hsc2hs_sign___,@object // @x___hsc2hs_sign___ 12 | .bss 13 | .globl x___hsc2hs_sign___ 14 | .p2align 3 15 | x___hsc2hs_sign___: 16 | .xword 0 // 0x0 17 | .size x___hsc2hs_sign___, 8 18 | 19 | .type x,@object // @x 20 | .data 21 | .globl x 22 | .p2align 3 23 | x: 24 | .xword 1 // 0x1 25 | .size x, 8 26 | 27 | .type y___hsc2hs_sign___,@object // @y___hsc2hs_sign___ 28 | .bss 29 | .globl y___hsc2hs_sign___ 30 | .p2align 3 31 | y___hsc2hs_sign___: 32 | .xword 0 // 0x0 33 | .size y___hsc2hs_sign___, 8 34 | 35 | .type y,@object // @y 36 | .data 37 | .globl y 38 | .p2align 3 39 | y: 40 | .xword -1 // 0xffffffffffffffff 41 | .size y, 8 42 | 43 | .type z___hsc2hs_sign___,@object // @z___hsc2hs_sign___ 44 | .globl z___hsc2hs_sign___ 45 | .p2align 3 46 | z___hsc2hs_sign___: 47 | .xword 1 // 0x1 48 | .size z___hsc2hs_sign___, 8 49 | 50 | .type z,@object // @z 51 | .globl z 52 | .p2align 3 53 | z: 54 | .xword -1 // 0xffffffffffffffff 55 | .size z, 8 56 | 57 | .type .L.str,@object // @.str 58 | .section .rodata.str1.1,"aMS",@progbits,1 59 | .L.str: 60 | .asciz "Hello World\" 12345" 61 | .size .L.str, 19 62 | 63 | .type t,@object // @t 64 | .data 65 | .globl t 66 | .p2align 3 67 | t: 68 | .xword .L.str 69 | .size t, 8 70 | 71 | 72 | .ident "clang version 5.0.1 (tags/RELEASE_501/final)" 73 | .section ".note.GNU-stack","",@progbits 74 | -------------------------------------------------------------------------------- /test/asm/alpha-linux.s: -------------------------------------------------------------------------------- 1 | .set noreorder 2 | .set volatile 3 | .set noat 4 | .set nomacro 5 | .arch ev4 6 | .globl ___hsc2hs_BOM___ 7 | .section .sdata,"aws",@progbits 8 | .align 3 9 | .type ___hsc2hs_BOM___, @object 10 | .size ___hsc2hs_BOM___, 8 11 | ___hsc2hs_BOM___: 12 | .quad 4294967296 13 | .globl x___hsc2hs_sign___ 14 | .section .sbss,"aw" 15 | .type x___hsc2hs_sign___, @object 16 | .size x___hsc2hs_sign___, 8 17 | .align 3 18 | x___hsc2hs_sign___: 19 | .zero 8 20 | .globl x 21 | .section .sdata 22 | .align 3 23 | .type x, @object 24 | .size x, 8 25 | x: 26 | .quad 1 27 | .globl y___hsc2hs_sign___ 28 | .section .sbss,"aw" 29 | .type y___hsc2hs_sign___, @object 30 | .size y___hsc2hs_sign___, 8 31 | .align 3 32 | y___hsc2hs_sign___: 33 | .zero 8 34 | .globl y 35 | .section .sdata 36 | .align 3 37 | .type y, @object 38 | .size y, 8 39 | y: 40 | .quad -1 41 | .globl z___hsc2hs_sign___ 42 | .align 3 43 | .type z___hsc2hs_sign___, @object 44 | .size z___hsc2hs_sign___, 8 45 | z___hsc2hs_sign___: 46 | .quad 1 47 | .globl z 48 | .align 3 49 | .type z, @object 50 | .size z, 8 51 | z: 52 | .quad -1 53 | .globl t 54 | .section .rodata 55 | $LC0: 56 | .string "Hello World\" 12345" 57 | .section .sdata 58 | .align 3 59 | .type t, @object 60 | .size t, 8 61 | t: 62 | .quad $LC0 63 | .ident "GCC: (Gentoo 7.2.0-r1 p1.1) 7.2.0" 64 | .section .note.GNU-stack,"",@progbits 65 | -------------------------------------------------------------------------------- /test/asm/arm-ios.s: -------------------------------------------------------------------------------- 1 | .section __TEXT,__text,regular,pure_instructions 2 | .ios_version_min 5, 0 3 | .syntax unified 4 | .section __DATA,__data 5 | .globl ____hsc2hs_BOM___ @ @___hsc2hs_BOM___ 6 | .p2align 3 7 | ____hsc2hs_BOM___: 8 | .long 0 @ 0x100000000 9 | .long 1 10 | 11 | .globl _x___hsc2hs_sign___ @ @x___hsc2hs_sign___ 12 | .zerofill __DATA,__common,_x___hsc2hs_sign___,8,3 13 | .globl _x @ @x 14 | .p2align 3 15 | _x: 16 | .long 1 @ 0x1 17 | .long 0 18 | 19 | .globl _y___hsc2hs_sign___ @ @y___hsc2hs_sign___ 20 | .zerofill __DATA,__common,_y___hsc2hs_sign___,8,3 21 | .globl _y @ @y 22 | .p2align 3 23 | _y: 24 | .long 4294967295 @ 0xffffffff 25 | .long 0 26 | 27 | .globl _z___hsc2hs_sign___ @ @z___hsc2hs_sign___ 28 | .p2align 3 29 | _z___hsc2hs_sign___: 30 | .long 1 @ 0x1 31 | .long 0 32 | 33 | .globl _z @ @z 34 | .p2align 3 35 | _z: 36 | .long 4294967295 @ 0xffffffffffffffff 37 | .long 4294967295 38 | 39 | .section __TEXT,__cstring,cstring_literals 40 | L_.str: @ @.str 41 | .asciz "Hello World\" 12345" 42 | 43 | .section __DATA,__data 44 | .globl _t @ @t 45 | .p2align 2 46 | _t: 47 | .long L_.str 48 | 49 | 50 | .subsections_via_symbols 51 | -------------------------------------------------------------------------------- /test/asm/arm.s: -------------------------------------------------------------------------------- 1 | .text 2 | .syntax unified 3 | .eabi_attribute 67, "2.09" @ Tag_conformance 4 | .cpu arm1176jzf-s 5 | .eabi_attribute 6, 6 @ Tag_CPU_arch 6 | .eabi_attribute 8, 1 @ Tag_ARM_ISA_use 7 | .eabi_attribute 9, 1 @ Tag_THUMB_ISA_use 8 | .fpu vfpv2 9 | .eabi_attribute 34, 0 @ Tag_CPU_unaligned_access 10 | .eabi_attribute 68, 1 @ Tag_Virtualization_use 11 | .eabi_attribute 17, 1 @ Tag_ABI_PCS_GOT_use 12 | .eabi_attribute 20, 2 @ Tag_ABI_FP_denormal 13 | .eabi_attribute 21, 0 @ Tag_ABI_FP_exceptions 14 | .eabi_attribute 23, 3 @ Tag_ABI_FP_number_model 15 | .eabi_attribute 24, 1 @ Tag_ABI_align_needed 16 | .eabi_attribute 25, 1 @ Tag_ABI_align_preserved 17 | .eabi_attribute 28, 1 @ Tag_ABI_VFP_args 18 | .eabi_attribute 38, 1 @ Tag_ABI_FP_16bit_format 19 | .eabi_attribute 18, 4 @ Tag_ABI_PCS_wchar_t 20 | .eabi_attribute 26, 2 @ Tag_ABI_enum_size 21 | .eabi_attribute 14, 0 @ Tag_ABI_PCS_R9_use 22 | .file "tmp.c" 23 | .type ___hsc2hs_BOM___,%object @ @___hsc2hs_BOM___ 24 | .data 25 | .globl ___hsc2hs_BOM___ 26 | .p2align 3 27 | ___hsc2hs_BOM___: 28 | .long 0 @ 0x100000000 29 | .long 1 30 | .size ___hsc2hs_BOM___, 8 31 | 32 | .type x___hsc2hs_sign___,%object @ @x___hsc2hs_sign___ 33 | .bss 34 | .globl x___hsc2hs_sign___ 35 | .p2align 3 36 | x___hsc2hs_sign___: 37 | .long 0 @ 0x0 38 | .long 0 39 | .size x___hsc2hs_sign___, 8 40 | 41 | .type x,%object @ @x 42 | .data 43 | .globl x 44 | .p2align 3 45 | x: 46 | .long 1 @ 0x1 47 | .long 0 48 | .size x, 8 49 | 50 | .type y___hsc2hs_sign___,%object @ @y___hsc2hs_sign___ 51 | .bss 52 | .globl y___hsc2hs_sign___ 53 | .p2align 3 54 | y___hsc2hs_sign___: 55 | .long 0 @ 0x0 56 | .long 0 57 | .size y___hsc2hs_sign___, 8 58 | 59 | .type y,%object @ @y 60 | .data 61 | .globl y 62 | .p2align 3 63 | y: 64 | .long 4294967295 @ 0xffffffff 65 | .long 0 66 | .size y, 8 67 | 68 | .type z___hsc2hs_sign___,%object @ @z___hsc2hs_sign___ 69 | .globl z___hsc2hs_sign___ 70 | .p2align 3 71 | z___hsc2hs_sign___: 72 | .long 1 @ 0x1 73 | .long 0 74 | .size z___hsc2hs_sign___, 8 75 | 76 | .type z,%object @ @z 77 | .globl z 78 | .p2align 3 79 | z: 80 | .long 4294967295 @ 0xffffffffffffffff 81 | .long 4294967295 82 | .size z, 8 83 | 84 | .type .L.str,%object @ @.str 85 | .section .rodata.str1.1,"aMS",%progbits,1 86 | .L.str: 87 | .asciz "Hello World\" 12345" 88 | .size .L.str, 19 89 | 90 | .type t,%object @ @t 91 | .data 92 | .globl t 93 | .p2align 2 94 | t: 95 | .long .L.str 96 | .size t, 4 97 | 98 | 99 | .ident "clang version 5.0.1 (tags/RELEASE_501/final)" 100 | .section ".note.GNU-stack","",%progbits 101 | -------------------------------------------------------------------------------- /test/asm/hppa-linux.s: -------------------------------------------------------------------------------- 1 | .LEVEL 1.1 2 | .globl ___hsc2hs_BOM___ 3 | .data 4 | .align 8 5 | .type ___hsc2hs_BOM___, @object 6 | .size ___hsc2hs_BOM___, 8 7 | ___hsc2hs_BOM___: 8 | .word 1 9 | .word 0 10 | .globl x___hsc2hs_sign___ 11 | .section .bss 12 | .align 8 13 | .type x___hsc2hs_sign___, @object 14 | .size x___hsc2hs_sign___, 8 15 | .align 8 16 | x___hsc2hs_sign___: 17 | .block 8 18 | .globl x 19 | .data 20 | .align 8 21 | .type x, @object 22 | .size x, 8 23 | x: 24 | .word 0 25 | .word 1 26 | .globl y___hsc2hs_sign___ 27 | .section .bss 28 | .align 8 29 | .type y___hsc2hs_sign___, @object 30 | .size y___hsc2hs_sign___, 8 31 | .align 8 32 | y___hsc2hs_sign___: 33 | .block 8 34 | .globl y 35 | .data 36 | .align 8 37 | .type y, @object 38 | .size y, 8 39 | y: 40 | .word -1 41 | .word -1 42 | .globl z___hsc2hs_sign___ 43 | .align 8 44 | .type z___hsc2hs_sign___, @object 45 | .size z___hsc2hs_sign___, 8 46 | z___hsc2hs_sign___: 47 | .word 0 48 | .word 1 49 | .globl z 50 | .align 8 51 | .type z, @object 52 | .size z, 8 53 | z: 54 | .word -1 55 | .word -1 56 | .globl t 57 | .section .rodata 58 | .align 4 59 | .LC0: 60 | .stringz "Hello World\" 12345" 61 | .section .data.rel.local,"aw",@progbits 62 | .align 4 63 | .type t, @object 64 | .size t, 4 65 | t: 66 | .word .LC0 67 | .ident "GCC: (Gentoo 7.2.0-r1 p1.1) 7.2.0" 68 | -------------------------------------------------------------------------------- /test/asm/ia64-linux.s: -------------------------------------------------------------------------------- 1 | .file "tmp.c" 2 | .pred.safe_across_calls p1-p5,p16-p63 3 | .text 4 | .global ___hsc2hs_BOM___# 5 | .section .sdata,"aws",@progbits 6 | .align 8 7 | .type ___hsc2hs_BOM___#, @object 8 | .size ___hsc2hs_BOM___#, 8 9 | ___hsc2hs_BOM___: 10 | data8 4294967296 11 | .global x___hsc2hs_sign___# 12 | .section .sbss,"aws",@nobits 13 | .align 8 14 | .type x___hsc2hs_sign___#, @object 15 | .size x___hsc2hs_sign___#, 8 16 | x___hsc2hs_sign___: 17 | .skip 8 18 | .global x# 19 | .section .sdata 20 | .align 8 21 | .type x#, @object 22 | .size x#, 8 23 | x: 24 | data8 1 25 | .global y___hsc2hs_sign___# 26 | .section .sbss 27 | .align 8 28 | .type y___hsc2hs_sign___#, @object 29 | .size y___hsc2hs_sign___#, 8 30 | y___hsc2hs_sign___: 31 | .skip 8 32 | .global y# 33 | .section .sdata 34 | .align 8 35 | .type y#, @object 36 | .size y#, 8 37 | y: 38 | data8 -1 39 | .global z___hsc2hs_sign___# 40 | .align 8 41 | .type z___hsc2hs_sign___#, @object 42 | .size z___hsc2hs_sign___#, 8 43 | z___hsc2hs_sign___: 44 | data8 1 45 | .global z# 46 | .align 8 47 | .type z#, @object 48 | .size z#, 8 49 | z: 50 | data8 -1 51 | .global t# 52 | .section .rodata 53 | .align 8 54 | .LC0: 55 | stringz "Hello World\" 12345" 56 | .section .sdata 57 | .align 8 58 | .type t#, @object 59 | .size t#, 8 60 | t: 61 | data8 .LC0 62 | .ident "GCC: (Gentoo 7.3.0 p1.0) 7.3.0" 63 | .section .note.GNU-stack,"",@progbits 64 | -------------------------------------------------------------------------------- /test/asm/m68k-linux.s: -------------------------------------------------------------------------------- 1 | #NO_APP 2 | .file "tmp.c" 3 | .globl ___hsc2hs_BOM___ 4 | .data 5 | .align 2 6 | .type ___hsc2hs_BOM___, @object 7 | .size ___hsc2hs_BOM___, 8 8 | ___hsc2hs_BOM___: 9 | .long 1 10 | .long 0 11 | .globl x___hsc2hs_sign___ 12 | .section .bss 13 | .align 2 14 | .type x___hsc2hs_sign___, @object 15 | .size x___hsc2hs_sign___, 8 16 | x___hsc2hs_sign___: 17 | .zero 8 18 | .globl x 19 | .data 20 | .align 2 21 | .type x, @object 22 | .size x, 8 23 | x: 24 | .long 0 25 | .long 1 26 | .globl y___hsc2hs_sign___ 27 | .section .bss 28 | .align 2 29 | .type y___hsc2hs_sign___, @object 30 | .size y___hsc2hs_sign___, 8 31 | y___hsc2hs_sign___: 32 | .zero 8 33 | .globl y 34 | .data 35 | .align 2 36 | .type y, @object 37 | .size y, 8 38 | y: 39 | .long -1 40 | .long -1 41 | .globl z___hsc2hs_sign___ 42 | .align 2 43 | .type z___hsc2hs_sign___, @object 44 | .size z___hsc2hs_sign___, 8 45 | z___hsc2hs_sign___: 46 | .long 0 47 | .long 1 48 | .globl z 49 | .align 2 50 | .type z, @object 51 | .size z, 8 52 | z: 53 | .long -1 54 | .long -1 55 | .globl t 56 | .section .rodata 57 | .LC0: 58 | .string "Hello World\" 12345" 59 | .section .data.rel.local,"aw",@progbits 60 | .align 2 61 | .type t, @object 62 | .size t, 4 63 | t: 64 | .long .LC0 65 | .ident "GCC: (Gentoo 7.2.0-r1 p1.1) 7.2.0" 66 | .section .note.GNU-stack,"",@progbits 67 | -------------------------------------------------------------------------------- /test/asm/mips-linux.s: -------------------------------------------------------------------------------- 1 | .text 2 | .abicalls 3 | .option pic0 4 | .section .mdebug.abi32,"",@progbits 5 | .nan legacy 6 | .file "tmp.c" 7 | .type ___hsc2hs_BOM___,@object # @___hsc2hs_BOM___ 8 | .data 9 | .globl ___hsc2hs_BOM___ 10 | .p2align 3 11 | ___hsc2hs_BOM___: 12 | .8byte 4294967296 # 0x100000000 13 | .size ___hsc2hs_BOM___, 8 14 | 15 | .type x___hsc2hs_sign___,@object # @x___hsc2hs_sign___ 16 | .bss 17 | .globl x___hsc2hs_sign___ 18 | .p2align 3 19 | x___hsc2hs_sign___: 20 | .8byte 0 # 0x0 21 | .size x___hsc2hs_sign___, 8 22 | 23 | .type x,@object # @x 24 | .data 25 | .globl x 26 | .p2align 3 27 | x: 28 | .8byte 1 # 0x1 29 | .size x, 8 30 | 31 | .type y___hsc2hs_sign___,@object # @y___hsc2hs_sign___ 32 | .bss 33 | .globl y___hsc2hs_sign___ 34 | .p2align 3 35 | y___hsc2hs_sign___: 36 | .8byte 0 # 0x0 37 | .size y___hsc2hs_sign___, 8 38 | 39 | .type y,@object # @y 40 | .data 41 | .globl y 42 | .p2align 3 43 | y: 44 | .8byte 4294967295 # 0xffffffff 45 | .size y, 8 46 | 47 | .type z___hsc2hs_sign___,@object # @z___hsc2hs_sign___ 48 | .globl z___hsc2hs_sign___ 49 | .p2align 3 50 | z___hsc2hs_sign___: 51 | .8byte 1 # 0x1 52 | .size z___hsc2hs_sign___, 8 53 | 54 | .type z,@object # @z 55 | .globl z 56 | .p2align 3 57 | z: 58 | .8byte -1 # 0xffffffffffffffff 59 | .size z, 8 60 | 61 | .type $.str,@object # @.str 62 | .section .rodata.str1.1,"aMS",@progbits,1 63 | $.str: 64 | .asciz "Hello World\" 12345" 65 | .size $.str, 19 66 | 67 | .type t,@object # @t 68 | .data 69 | .globl t 70 | .p2align 2 71 | t: 72 | .4byte ($.str) 73 | .size t, 4 74 | 75 | 76 | .ident "clang version 5.0.1 (tags/RELEASE_501/final)" 77 | .section ".note.GNU-stack","",@progbits 78 | .text 79 | -------------------------------------------------------------------------------- /test/asm/mips64-linux.s: -------------------------------------------------------------------------------- 1 | .text 2 | .abicalls 3 | .section .mdebug.abi64,"",@progbits 4 | .nan legacy 5 | .file "tmp.c" 6 | .type ___hsc2hs_BOM___,@object 7 | .data 8 | .globl ___hsc2hs_BOM___ 9 | .p2align 3 10 | ___hsc2hs_BOM___: 11 | .8byte 4294967296 12 | .size ___hsc2hs_BOM___, 8 13 | 14 | .type x___hsc2hs_sign___,@object 15 | .bss 16 | .globl x___hsc2hs_sign___ 17 | .p2align 3 18 | x___hsc2hs_sign___: 19 | .8byte 0 20 | .size x___hsc2hs_sign___, 8 21 | 22 | .type x,@object 23 | .data 24 | .globl x 25 | .p2align 3 26 | x: 27 | .8byte 1 28 | .size x, 8 29 | 30 | .type y___hsc2hs_sign___,@object 31 | .bss 32 | .globl y___hsc2hs_sign___ 33 | .p2align 3 34 | y___hsc2hs_sign___: 35 | .8byte 0 36 | .size y___hsc2hs_sign___, 8 37 | 38 | .type y,@object 39 | .data 40 | .globl y 41 | .p2align 3 42 | y: 43 | .8byte -1 44 | .size y, 8 45 | 46 | .type z___hsc2hs_sign___,@object 47 | .globl z___hsc2hs_sign___ 48 | .p2align 3 49 | z___hsc2hs_sign___: 50 | .8byte 1 51 | .size z___hsc2hs_sign___, 8 52 | 53 | .type z,@object 54 | .globl z 55 | .p2align 3 56 | z: 57 | .8byte -1 58 | .size z, 8 59 | 60 | .type .L.str,@object 61 | .section .rodata.str1.1,"aMS",@progbits,1 62 | .L.str: 63 | .asciz "Hello World\" 12345" 64 | .size .L.str, 19 65 | 66 | .type t,@object 67 | .data 68 | .globl t 69 | .p2align 3 70 | t: 71 | .8byte .L.str 72 | .size t, 8 73 | 74 | 75 | .ident "clang version 5.0.1 (tags/RELEASE_501/final)" 76 | .section ".note.GNU-stack","",@progbits 77 | .text 78 | -------------------------------------------------------------------------------- /test/asm/nios2-linux.s: -------------------------------------------------------------------------------- 1 | .file "tmp.c" 2 | .global ___hsc2hs_BOM___ 3 | .section .sdata,"aws",@progbits 4 | .align 2 5 | .type ___hsc2hs_BOM___, @object 6 | .size ___hsc2hs_BOM___, 8 7 | ___hsc2hs_BOM___: 8 | .long 0 9 | .long 1 10 | .global x___hsc2hs_sign___ 11 | .section .sbss,"aws",@nobits 12 | .align 2 13 | .type x___hsc2hs_sign___, @object 14 | .size x___hsc2hs_sign___, 8 15 | x___hsc2hs_sign___: 16 | .zero 8 17 | .global x 18 | .section .sdata 19 | .align 2 20 | .type x, @object 21 | .size x, 8 22 | x: 23 | .long 1 24 | .long 0 25 | .global y___hsc2hs_sign___ 26 | .section .sbss 27 | .align 2 28 | .type y___hsc2hs_sign___, @object 29 | .size y___hsc2hs_sign___, 8 30 | y___hsc2hs_sign___: 31 | .zero 8 32 | .global y 33 | .section .sdata 34 | .align 2 35 | .type y, @object 36 | .size y, 8 37 | y: 38 | .long -1 39 | .long -1 40 | .global z___hsc2hs_sign___ 41 | .align 2 42 | .type z___hsc2hs_sign___, @object 43 | .size z___hsc2hs_sign___, 8 44 | z___hsc2hs_sign___: 45 | .long 1 46 | .long 0 47 | .global z 48 | .align 2 49 | .type z, @object 50 | .size z, 8 51 | z: 52 | .long -1 53 | .long -1 54 | .global t 55 | .section .rodata 56 | .align 2 57 | .LC0: 58 | .string "Hello World\" 12345" 59 | .section .sdata 60 | .align 2 61 | .type t, @object 62 | .size t, 4 63 | t: 64 | .long .LC0 65 | .ident "GCC: (Gentoo 7.2.0-r1 p1.1) 7.2.0" 66 | -------------------------------------------------------------------------------- /test/asm/powerpc-linux.s: -------------------------------------------------------------------------------- 1 | .text 2 | .file "tmp.c" 3 | .type ___hsc2hs_BOM___,@object # @___hsc2hs_BOM___ 4 | .data 5 | .globl ___hsc2hs_BOM___ 6 | .p2align 3 7 | ___hsc2hs_BOM___: 8 | .long 1 # 0x100000000 9 | .long 0 10 | .size ___hsc2hs_BOM___, 8 11 | 12 | .type x___hsc2hs_sign___,@object # @x___hsc2hs_sign___ 13 | .section .bss,"aw",@nobits 14 | .globl x___hsc2hs_sign___ 15 | .p2align 3 16 | x___hsc2hs_sign___: 17 | .long 0 # 0x0 18 | .long 0 19 | .size x___hsc2hs_sign___, 8 20 | 21 | .type x,@object # @x 22 | .data 23 | .globl x 24 | .p2align 3 25 | x: 26 | .long 0 # 0x1 27 | .long 1 28 | .size x, 8 29 | 30 | .type y___hsc2hs_sign___,@object # @y___hsc2hs_sign___ 31 | .section .bss,"aw",@nobits 32 | .globl y___hsc2hs_sign___ 33 | .p2align 3 34 | y___hsc2hs_sign___: 35 | .long 0 # 0x0 36 | .long 0 37 | .size y___hsc2hs_sign___, 8 38 | 39 | .type y,@object # @y 40 | .data 41 | .globl y 42 | .p2align 3 43 | y: 44 | .long 0 # 0xffffffff 45 | .long 4294967295 46 | .size y, 8 47 | 48 | .type z___hsc2hs_sign___,@object # @z___hsc2hs_sign___ 49 | .globl z___hsc2hs_sign___ 50 | .p2align 3 51 | z___hsc2hs_sign___: 52 | .long 0 # 0x1 53 | .long 1 54 | .size z___hsc2hs_sign___, 8 55 | 56 | .type z,@object # @z 57 | .globl z 58 | .p2align 3 59 | z: 60 | .long 4294967295 # 0xffffffffffffffff 61 | .long 4294967295 62 | .size z, 8 63 | 64 | .type .L.str,@object # @.str 65 | .section .rodata.str1.1,"aMS",@progbits,1 66 | .L.str: 67 | .asciz "Hello World\" 12345" 68 | .size .L.str, 19 69 | 70 | .type t,@object # @t 71 | .data 72 | .globl t 73 | .p2align 2 74 | t: 75 | .long .L.str 76 | .size t, 4 77 | 78 | 79 | .ident "clang version 5.0.1 (tags/RELEASE_501/final)" 80 | .section ".note.GNU-stack","",@progbits 81 | -------------------------------------------------------------------------------- /test/asm/powerpc64-linux.s: -------------------------------------------------------------------------------- 1 | .text 2 | .file "tmp.c" 3 | .type ___hsc2hs_BOM___,@object # @___hsc2hs_BOM___ 4 | .data 5 | .globl ___hsc2hs_BOM___ 6 | .p2align 3 7 | ___hsc2hs_BOM___: 8 | .quad 4294967296 # 0x100000000 9 | .size ___hsc2hs_BOM___, 8 10 | 11 | .type x___hsc2hs_sign___,@object # @x___hsc2hs_sign___ 12 | .section .bss,"aw",@nobits 13 | .globl x___hsc2hs_sign___ 14 | .p2align 3 15 | x___hsc2hs_sign___: 16 | .quad 0 # 0x0 17 | .size x___hsc2hs_sign___, 8 18 | 19 | .type x,@object # @x 20 | .data 21 | .globl x 22 | .p2align 3 23 | x: 24 | .quad 1 # 0x1 25 | .size x, 8 26 | 27 | .type y___hsc2hs_sign___,@object # @y___hsc2hs_sign___ 28 | .section .bss,"aw",@nobits 29 | .globl y___hsc2hs_sign___ 30 | .p2align 3 31 | y___hsc2hs_sign___: 32 | .quad 0 # 0x0 33 | .size y___hsc2hs_sign___, 8 34 | 35 | .type y,@object # @y 36 | .data 37 | .globl y 38 | .p2align 3 39 | y: 40 | .quad -1 # 0xffffffffffffffff 41 | .size y, 8 42 | 43 | .type z___hsc2hs_sign___,@object # @z___hsc2hs_sign___ 44 | .globl z___hsc2hs_sign___ 45 | .p2align 3 46 | z___hsc2hs_sign___: 47 | .quad 1 # 0x1 48 | .size z___hsc2hs_sign___, 8 49 | 50 | .type z,@object # @z 51 | .globl z 52 | .p2align 3 53 | z: 54 | .quad -1 # 0xffffffffffffffff 55 | .size z, 8 56 | 57 | .type .L.str,@object # @.str 58 | .section .rodata.str1.1,"aMS",@progbits,1 59 | .L.str: 60 | .asciz "Hello World\" 12345" 61 | .size .L.str, 19 62 | 63 | .type t,@object # @t 64 | .data 65 | .globl t 66 | .p2align 3 67 | t: 68 | .quad .L.str 69 | .size t, 8 70 | 71 | 72 | .ident "clang version 5.0.1 (tags/RELEASE_501/final)" 73 | .section ".note.GNU-stack","",@progbits 74 | -------------------------------------------------------------------------------- /test/asm/powerpc64le-linux.s: -------------------------------------------------------------------------------- 1 | .text 2 | .abiversion 2 3 | .file "tmp.c" 4 | .type ___hsc2hs_BOM___,@object # @___hsc2hs_BOM___ 5 | .data 6 | .globl ___hsc2hs_BOM___ 7 | .p2align 3 8 | ___hsc2hs_BOM___: 9 | .quad 4294967296 # 0x100000000 10 | .size ___hsc2hs_BOM___, 8 11 | 12 | .type x___hsc2hs_sign___,@object # @x___hsc2hs_sign___ 13 | .section .bss,"aw",@nobits 14 | .globl x___hsc2hs_sign___ 15 | .p2align 3 16 | x___hsc2hs_sign___: 17 | .quad 0 # 0x0 18 | .size x___hsc2hs_sign___, 8 19 | 20 | .type x,@object # @x 21 | .data 22 | .globl x 23 | .p2align 3 24 | x: 25 | .quad 1 # 0x1 26 | .size x, 8 27 | 28 | .type y___hsc2hs_sign___,@object # @y___hsc2hs_sign___ 29 | .section .bss,"aw",@nobits 30 | .globl y___hsc2hs_sign___ 31 | .p2align 3 32 | y___hsc2hs_sign___: 33 | .quad 0 # 0x0 34 | .size y___hsc2hs_sign___, 8 35 | 36 | .type y,@object # @y 37 | .data 38 | .globl y 39 | .p2align 3 40 | y: 41 | .quad -1 # 0xffffffffffffffff 42 | .size y, 8 43 | 44 | .type z___hsc2hs_sign___,@object # @z___hsc2hs_sign___ 45 | .globl z___hsc2hs_sign___ 46 | .p2align 3 47 | z___hsc2hs_sign___: 48 | .quad 1 # 0x1 49 | .size z___hsc2hs_sign___, 8 50 | 51 | .type z,@object # @z 52 | .globl z 53 | .p2align 3 54 | z: 55 | .quad -1 # 0xffffffffffffffff 56 | .size z, 8 57 | 58 | .type .L.str,@object # @.str 59 | .section .rodata.str1.1,"aMS",@progbits,1 60 | .L.str: 61 | .asciz "Hello World\" 12345" 62 | .size .L.str, 19 63 | 64 | .type t,@object # @t 65 | .data 66 | .globl t 67 | .p2align 3 68 | t: 69 | .quad .L.str 70 | .size t, 8 71 | 72 | 73 | .ident "clang version 5.0.1 (tags/RELEASE_501/final)" 74 | .section ".note.GNU-stack","",@progbits 75 | -------------------------------------------------------------------------------- /test/asm/s390-linux.s: -------------------------------------------------------------------------------- 1 | .file "tmp.c" 2 | .machinemode esa 3 | .machine "z900" 4 | .globl ___hsc2hs_BOM___ 5 | .data 6 | .align 8 7 | .type ___hsc2hs_BOM___, @object 8 | .size ___hsc2hs_BOM___, 8 9 | ___hsc2hs_BOM___: 10 | .long 1 11 | .long 0 12 | .globl x___hsc2hs_sign___ 13 | .bss 14 | .align 8 15 | .type x___hsc2hs_sign___, @object 16 | .size x___hsc2hs_sign___, 8 17 | x___hsc2hs_sign___: 18 | .zero 8 19 | .globl x 20 | .data 21 | .align 8 22 | .type x, @object 23 | .size x, 8 24 | x: 25 | .long 0 26 | .long 1 27 | .globl y___hsc2hs_sign___ 28 | .bss 29 | .align 8 30 | .type y___hsc2hs_sign___, @object 31 | .size y___hsc2hs_sign___, 8 32 | y___hsc2hs_sign___: 33 | .zero 8 34 | .globl y 35 | .data 36 | .align 8 37 | .type y, @object 38 | .size y, 8 39 | y: 40 | .long -1 41 | .long -1 42 | .globl z___hsc2hs_sign___ 43 | .align 8 44 | .type z___hsc2hs_sign___, @object 45 | .size z___hsc2hs_sign___, 8 46 | z___hsc2hs_sign___: 47 | .long 0 48 | .long 1 49 | .globl z 50 | .align 8 51 | .type z, @object 52 | .size z, 8 53 | z: 54 | .long -1 55 | .long -1 56 | .globl t 57 | .section .rodata 58 | .align 2 59 | .LC0: 60 | .string "Hello World\" 12345" 61 | .section .data.rel.local,"aw",@progbits 62 | .align 4 63 | .type t, @object 64 | .size t, 4 65 | t: 66 | .long .LC0 67 | .ident "GCC: (Gentoo 7.2.0-r1 p1.1) 7.2.0" 68 | .section .note.GNU-stack,"",@progbits 69 | -------------------------------------------------------------------------------- /test/asm/s390x-linux.s: -------------------------------------------------------------------------------- 1 | .file "tmp.c" 2 | .machinemode zarch 3 | .machine "z900" 4 | .globl ___hsc2hs_BOM___ 5 | .data 6 | .align 8 7 | .type ___hsc2hs_BOM___, @object 8 | .size ___hsc2hs_BOM___, 8 9 | ___hsc2hs_BOM___: 10 | .quad 4294967296 11 | .globl x___hsc2hs_sign___ 12 | .bss 13 | .align 8 14 | .type x___hsc2hs_sign___, @object 15 | .size x___hsc2hs_sign___, 8 16 | x___hsc2hs_sign___: 17 | .zero 8 18 | .globl x 19 | .data 20 | .align 8 21 | .type x, @object 22 | .size x, 8 23 | x: 24 | .quad 1 25 | .globl y___hsc2hs_sign___ 26 | .bss 27 | .align 8 28 | .type y___hsc2hs_sign___, @object 29 | .size y___hsc2hs_sign___, 8 30 | y___hsc2hs_sign___: 31 | .zero 8 32 | .globl y 33 | .data 34 | .align 8 35 | .type y, @object 36 | .size y, 8 37 | y: 38 | .quad -1 39 | .globl z___hsc2hs_sign___ 40 | .align 8 41 | .type z___hsc2hs_sign___, @object 42 | .size z___hsc2hs_sign___, 8 43 | z___hsc2hs_sign___: 44 | .quad 1 45 | .globl z 46 | .align 8 47 | .type z, @object 48 | .size z, 8 49 | z: 50 | .quad -1 51 | .globl t 52 | .section .rodata 53 | .align 2 54 | .LC0: 55 | .string "Hello World\" 12345" 56 | .section .data.rel.local,"aw",@progbits 57 | .align 8 58 | .type t, @object 59 | .size t, 8 60 | t: 61 | .quad .LC0 62 | .ident "GCC: (Gentoo 7.2.0-r1 p1.1) 7.2.0" 63 | .section .note.GNU-stack,"",@progbits 64 | -------------------------------------------------------------------------------- /test/asm/sh4-linux.s: -------------------------------------------------------------------------------- 1 | .file "tmp.c" 2 | .text 3 | .little 4 | .global ___hsc2hs_BOM___ 5 | .data 6 | .align 2 7 | .type ___hsc2hs_BOM___, @object 8 | .size ___hsc2hs_BOM___, 8 9 | ___hsc2hs_BOM___: 10 | .long 0 11 | .long 1 12 | .global x___hsc2hs_sign___ 13 | .section .bss 14 | .align 2 15 | .type x___hsc2hs_sign___, @object 16 | .size x___hsc2hs_sign___, 8 17 | x___hsc2hs_sign___: 18 | .zero 8 19 | .global x 20 | .data 21 | .align 2 22 | .type x, @object 23 | .size x, 8 24 | x: 25 | .long 1 26 | .long 0 27 | .global y___hsc2hs_sign___ 28 | .section .bss 29 | .align 2 30 | .type y___hsc2hs_sign___, @object 31 | .size y___hsc2hs_sign___, 8 32 | y___hsc2hs_sign___: 33 | .zero 8 34 | .global y 35 | .data 36 | .align 2 37 | .type y, @object 38 | .size y, 8 39 | y: 40 | .long -1 41 | .long -1 42 | .global z___hsc2hs_sign___ 43 | .align 2 44 | .type z___hsc2hs_sign___, @object 45 | .size z___hsc2hs_sign___, 8 46 | z___hsc2hs_sign___: 47 | .long 1 48 | .long 0 49 | .global z 50 | .align 2 51 | .type z, @object 52 | .size z, 8 53 | z: 54 | .long -1 55 | .long -1 56 | .global t 57 | .section .rodata 58 | .align 2 59 | .LC0: 60 | .string "Hello World\" 12345" 61 | .section .data.rel.local,"aw",@progbits 62 | .align 2 63 | .type t, @object 64 | .size t, 4 65 | t: 66 | .long .LC0 67 | .ident "GCC: (Gentoo 7.2.0-r1 p1.1) 7.2.0" 68 | .section .note.GNU-stack,"",@progbits 69 | -------------------------------------------------------------------------------- /test/asm/sparc-linux.s: -------------------------------------------------------------------------------- 1 | .text 2 | .file "tmp.c" 3 | .type ___hsc2hs_BOM___,@object 4 | .data 5 | .globl ___hsc2hs_BOM___ 6 | .p2align 3 7 | ___hsc2hs_BOM___: 8 | .word 1 9 | .word 0 10 | .size ___hsc2hs_BOM___, 8 11 | 12 | .type x___hsc2hs_sign___,@object 13 | .section .bss,#alloc,#write 14 | .globl x___hsc2hs_sign___ 15 | .p2align 3 16 | x___hsc2hs_sign___: 17 | .word 0 18 | .word 0 19 | .size x___hsc2hs_sign___, 8 20 | 21 | .type x,@object 22 | .data 23 | .globl x 24 | .p2align 3 25 | x: 26 | .word 0 27 | .word 1 28 | .size x, 8 29 | 30 | .type y___hsc2hs_sign___,@object 31 | .section .bss,#alloc,#write 32 | .globl y___hsc2hs_sign___ 33 | .p2align 3 34 | y___hsc2hs_sign___: 35 | .word 0 36 | .word 0 37 | .size y___hsc2hs_sign___, 8 38 | 39 | .type y,@object 40 | .data 41 | .globl y 42 | .p2align 3 43 | y: 44 | .word 0 45 | .word 4294967295 46 | .size y, 8 47 | 48 | .type z___hsc2hs_sign___,@object 49 | .globl z___hsc2hs_sign___ 50 | .p2align 3 51 | z___hsc2hs_sign___: 52 | .word 0 53 | .word 1 54 | .size z___hsc2hs_sign___, 8 55 | 56 | .type z,@object 57 | .globl z 58 | .p2align 3 59 | z: 60 | .word 4294967295 61 | .word 4294967295 62 | .size z, 8 63 | 64 | .type .L.str,@object 65 | .section .rodata.str1.1,"aMS",@progbits,1 66 | .L.str: 67 | .asciz "Hello World\" 12345" 68 | .size .L.str, 19 69 | 70 | .type t,@object 71 | .data 72 | .globl t 73 | .p2align 2 74 | t: 75 | .word .L.str 76 | .size t, 4 77 | 78 | 79 | .ident "clang version 5.0.1 (tags/RELEASE_501/final)" 80 | .section ".note.GNU-stack" 81 | -------------------------------------------------------------------------------- /test/asm/sparc64-linux.s: -------------------------------------------------------------------------------- 1 | .text 2 | .file "tmp.c" 3 | .type ___hsc2hs_BOM___,@object 4 | .data 5 | .globl ___hsc2hs_BOM___ 6 | .p2align 3 7 | ___hsc2hs_BOM___: 8 | .xword 4294967296 9 | .size ___hsc2hs_BOM___, 8 10 | 11 | .type x___hsc2hs_sign___,@object 12 | .section .bss,#alloc,#write 13 | .globl x___hsc2hs_sign___ 14 | .p2align 3 15 | x___hsc2hs_sign___: 16 | .xword 0 17 | .size x___hsc2hs_sign___, 8 18 | 19 | .type x,@object 20 | .data 21 | .globl x 22 | .p2align 3 23 | x: 24 | .xword 1 25 | .size x, 8 26 | 27 | .type y___hsc2hs_sign___,@object 28 | .section .bss,#alloc,#write 29 | .globl y___hsc2hs_sign___ 30 | .p2align 3 31 | y___hsc2hs_sign___: 32 | .xword 0 33 | .size y___hsc2hs_sign___, 8 34 | 35 | .type y,@object 36 | .data 37 | .globl y 38 | .p2align 3 39 | y: 40 | .xword -1 41 | .size y, 8 42 | 43 | .type z___hsc2hs_sign___,@object 44 | .globl z___hsc2hs_sign___ 45 | .p2align 3 46 | z___hsc2hs_sign___: 47 | .xword 1 48 | .size z___hsc2hs_sign___, 8 49 | 50 | .type z,@object 51 | .globl z 52 | .p2align 3 53 | z: 54 | .xword -1 55 | .size z, 8 56 | 57 | .type .L.str,@object 58 | .section .rodata.str1.1,"aMS",@progbits,1 59 | .L.str: 60 | .asciz "Hello World\" 12345" 61 | .size .L.str, 19 62 | 63 | .type t,@object 64 | .data 65 | .globl t 66 | .p2align 3 67 | t: 68 | .xword .L.str 69 | .size t, 8 70 | 71 | 72 | .ident "clang version 5.0.1 (tags/RELEASE_501/final)" 73 | .section ".note.GNU-stack" 74 | -------------------------------------------------------------------------------- /test/asm/tmp.c: -------------------------------------------------------------------------------- 1 | struct S { int unused; }; 2 | 3 | #define X 1 4 | #define Y -1 5 | 6 | // if BOM is 1, we end up with two 32bit integers 7 | // where the upper 4 byte ended up in the lower 4. 8 | extern unsigned long long ___hsc2hs_BOM___; 9 | unsigned long long ___hsc2hs_BOM___ = 0x100000000; 10 | 11 | extern unsigned long long x___hsc2hs_sign___; 12 | extern unsigned long long x; 13 | unsigned long long x___hsc2hs_sign___ = ((struct S *)X) < 0; 14 | unsigned long long x = (unsigned long long)((struct S *)X); 15 | 16 | extern unsigned long long y___hsc2hs_sign___; 17 | extern unsigned long long y; 18 | unsigned long long y___hsc2hs_sign___ = ((struct S *)Y) < 0; 19 | unsigned long long y = (unsigned long long)((struct S *)Y); 20 | 21 | extern unsigned long long z___hsc2hs_sign___; 22 | extern unsigned long long z; 23 | unsigned long long z___hsc2hs_sign___ = Y < 0; 24 | unsigned long long z = (unsigned long long)Y; 25 | 26 | extern char * t; 27 | char * t = "Hello World\" 12345"; 28 | -------------------------------------------------------------------------------- /test/asm/x86-linux.s: -------------------------------------------------------------------------------- 1 | .text 2 | .file "tmp.c" 3 | .type ___hsc2hs_BOM___,@object # @___hsc2hs_BOM___ 4 | .data 5 | .globl ___hsc2hs_BOM___ 6 | .p2align 3 7 | ___hsc2hs_BOM___: 8 | .quad 4294967296 # 0x100000000 9 | .size ___hsc2hs_BOM___, 8 10 | 11 | .type x___hsc2hs_sign___,@object # @x___hsc2hs_sign___ 12 | .bss 13 | .globl x___hsc2hs_sign___ 14 | .p2align 3 15 | x___hsc2hs_sign___: 16 | .quad 0 # 0x0 17 | .size x___hsc2hs_sign___, 8 18 | 19 | .type x,@object # @x 20 | .data 21 | .globl x 22 | .p2align 3 23 | x: 24 | .quad 1 # 0x1 25 | .size x, 8 26 | 27 | .type y___hsc2hs_sign___,@object # @y___hsc2hs_sign___ 28 | .bss 29 | .globl y___hsc2hs_sign___ 30 | .p2align 3 31 | y___hsc2hs_sign___: 32 | .quad 0 # 0x0 33 | .size y___hsc2hs_sign___, 8 34 | 35 | .type y,@object # @y 36 | .data 37 | .globl y 38 | .p2align 3 39 | y: 40 | .quad 4294967295 # 0xffffffff 41 | .size y, 8 42 | 43 | .type z___hsc2hs_sign___,@object # @z___hsc2hs_sign___ 44 | .globl z___hsc2hs_sign___ 45 | .p2align 3 46 | z___hsc2hs_sign___: 47 | .quad 1 # 0x1 48 | .size z___hsc2hs_sign___, 8 49 | 50 | .type z,@object # @z 51 | .globl z 52 | .p2align 3 53 | z: 54 | .quad -1 # 0xffffffffffffffff 55 | .size z, 8 56 | 57 | .type .L.str,@object # @.str 58 | .section .rodata.str1.1,"aMS",@progbits,1 59 | .L.str: 60 | .asciz "Hello World\" 12345" 61 | .size .L.str, 19 62 | 63 | .type t,@object # @t 64 | .data 65 | .globl t 66 | .p2align 2 67 | t: 68 | .long .L.str 69 | .size t, 4 70 | 71 | 72 | .ident "clang version 5.0.1 (tags/RELEASE_501/final)" 73 | .section ".note.GNU-stack","",@progbits 74 | -------------------------------------------------------------------------------- /test/asm/x86_64-linux.s: -------------------------------------------------------------------------------- 1 | .text 2 | .file "tmp.c" 3 | .type ___hsc2hs_BOM___,@object # @___hsc2hs_BOM___ 4 | .data 5 | .globl ___hsc2hs_BOM___ 6 | .p2align 3 7 | ___hsc2hs_BOM___: 8 | .quad 4294967296 # 0x100000000 9 | .size ___hsc2hs_BOM___, 8 10 | 11 | .type x___hsc2hs_sign___,@object # @x___hsc2hs_sign___ 12 | .bss 13 | .globl x___hsc2hs_sign___ 14 | .p2align 3 15 | x___hsc2hs_sign___: 16 | .quad 0 # 0x0 17 | .size x___hsc2hs_sign___, 8 18 | 19 | .type x,@object # @x 20 | .data 21 | .globl x 22 | .p2align 3 23 | x: 24 | .quad 1 # 0x1 25 | .size x, 8 26 | 27 | .type y___hsc2hs_sign___,@object # @y___hsc2hs_sign___ 28 | .bss 29 | .globl y___hsc2hs_sign___ 30 | .p2align 3 31 | y___hsc2hs_sign___: 32 | .quad 0 # 0x0 33 | .size y___hsc2hs_sign___, 8 34 | 35 | .type y,@object # @y 36 | .data 37 | .globl y 38 | .p2align 3 39 | y: 40 | .quad -1 # 0xffffffffffffffff 41 | .size y, 8 42 | 43 | .type z___hsc2hs_sign___,@object # @z___hsc2hs_sign___ 44 | .globl z___hsc2hs_sign___ 45 | .p2align 3 46 | z___hsc2hs_sign___: 47 | .quad 1 # 0x1 48 | .size z___hsc2hs_sign___, 8 49 | 50 | .type z,@object # @z 51 | .globl z 52 | .p2align 3 53 | z: 54 | .quad -1 # 0xffffffffffffffff 55 | .size z, 8 56 | 57 | .type .L.str,@object # @.str 58 | .section .rodata.str1.1,"aMS",@progbits,1 59 | .L.str: 60 | .asciz "Hello World\" 12345" 61 | .size .L.str, 19 62 | 63 | .type t,@object # @t 64 | .data 65 | .globl t 66 | .p2align 3 67 | t: 68 | .quad .L.str 69 | .size t, 8 70 | 71 | 72 | .ident "clang version 5.0.1 (tags/RELEASE_501/final)" 73 | .section ".note.GNU-stack","",@progbits 74 | -------------------------------------------------------------------------------- /test/asm/x86_64-mac.s: -------------------------------------------------------------------------------- 1 | .section __TEXT,__text,regular,pure_instructions 2 | .macosx_version_min 10, 4 3 | .section __DATA,__data 4 | .globl ____hsc2hs_BOM___ ## @___hsc2hs_BOM___ 5 | .p2align 3 6 | ____hsc2hs_BOM___: 7 | .quad 4294967296 ## 0x100000000 8 | 9 | .globl _x___hsc2hs_sign___ ## @x___hsc2hs_sign___ 10 | .zerofill __DATA,__common,_x___hsc2hs_sign___,8,3 11 | .globl _x ## @x 12 | .p2align 3 13 | _x: 14 | .quad 1 ## 0x1 15 | 16 | .globl _y___hsc2hs_sign___ ## @y___hsc2hs_sign___ 17 | .zerofill __DATA,__common,_y___hsc2hs_sign___,8,3 18 | .globl _y ## @y 19 | .p2align 3 20 | _y: 21 | .quad -1 ## 0xffffffffffffffff 22 | 23 | .globl _z___hsc2hs_sign___ ## @z___hsc2hs_sign___ 24 | .p2align 3 25 | _z___hsc2hs_sign___: 26 | .quad 1 ## 0x1 27 | 28 | .globl _z ## @z 29 | .p2align 3 30 | _z: 31 | .quad -1 ## 0xffffffffffffffff 32 | 33 | .section __TEXT,__cstring,cstring_literals 34 | L_.str: ## @.str 35 | .asciz "Hello World\" 12345" 36 | 37 | .section __DATA,__data 38 | .globl _t ## @t 39 | .p2align 3 40 | _t: 41 | .quad L_.str 42 | 43 | 44 | .subsections_via_symbols 45 | -------------------------------------------------------------------------------- /test/asm/x86_64-mingw32.s: -------------------------------------------------------------------------------- 1 | .file "tmp.c" 2 | .text 3 | .globl ___hsc2hs_BOM___ 4 | .data 5 | .align 8 6 | ___hsc2hs_BOM___: 7 | .quad 4294967296 8 | .globl x___hsc2hs_sign___ 9 | .bss 10 | .align 8 11 | x___hsc2hs_sign___: 12 | .space 8 13 | .globl x 14 | .data 15 | .align 8 16 | x: 17 | .quad 1 18 | .globl y___hsc2hs_sign___ 19 | .bss 20 | .align 8 21 | y___hsc2hs_sign___: 22 | .space 8 23 | .globl y 24 | .data 25 | .align 8 26 | y: 27 | .quad -1 28 | .globl z___hsc2hs_sign___ 29 | .align 8 30 | z___hsc2hs_sign___: 31 | .quad 1 32 | .globl z 33 | .align 8 34 | z: 35 | .quad -1 36 | .globl t 37 | .section .rdata,"dr" 38 | .LC0: 39 | .ascii "Hello World\" 12345\0" 40 | .data 41 | .align 8 42 | t: 43 | .quad .LC0 44 | .ident "GCC: (GNU) 7.3.0" 45 | --------------------------------------------------------------------------------