melf 1.1.0 → 1.2.0
raw patch · 12 files changed
+478/−425 lines, 12 filesdep +lensdep −containersdep ~optparse-applicativedep ~singletonsdep ~template-haskell
Dependencies added: lens
Dependencies removed: containers
Dependency ranges changed: optparse-applicative, singletons, template-haskell
Files
- ChangeLog.md +9/−0
- README.md +86/−70
- examples/AsmAArch64.hs +9/−9
- examples/DummyLd.hs +26/−18
- examples/ForwardLabel.hs +1/−2
- melf.cabal +24/−18
- src/Data/Elf.hs +3/−1
- src/Data/Elf/Constants/TH.hs +5/−1
- src/Data/Elf/Headers.hs +2/−4
- src/Data/Elf/PrettyPrint.hs +25/−19
- src/Data/Internal/Elf.hs +287/−282
- src/Data/Interval.hs +1/−1
ChangeLog.md view
@@ -1,3 +1,12 @@+1.2.0+=====++- Test with GHC 8.8.4, 8.10.7, 9.0.2, 9.2.4, 9.2.5, 9.4.4+- Add a fantom parameter type to `ElfXX` to differentiate+ between nodes on the type level.+- Revise warning options+- Use monad optics for ELF write builder+ 1.1.0 =====
README.md view
@@ -7,12 +7,12 @@ ## Parsing the header and table entries Module-[`Data.Elf.Headers`](https://hackage.haskell.org/package/melf-1.0.1/docs/Data-Elf-Headers.html)+[`Data.Elf.Headers`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf-Headers.html) implements parsing and serialization of the ELF file header and the entries of section and segment tables. ELF files come in two flavors: 64-bit and 32-bit. To differentiate between them type-[`ElfClass`](https://hackage.haskell.org/package/melf-1.0.1/docs/Data-Elf-Headers.html#t:ElfClass)+[`ElfClass`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf-Headers.html#t:ElfClass) is defined: ``` Haskell@@ -24,7 +24,7 @@ Some fields of the header and table entries have different bitwidth for 64-bit and 32-bit files. So the type-[`WordXX a`](https://hackage.haskell.org/package/melf-1.0.1/docs/Data-Elf-Headers.html#t:WordXX)+[`WordXX a`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf-Headers.html#t:WordXX) was borrowed from the `data-elf` package: ``` Haskell@@ -59,7 +59,7 @@ ``` The header of the ELF file is represented with the type-[`HeaderXX a`](https://hackage.haskell.org/package/melf-1.0.1/docs/Data-Elf-Headers.html#t:HeaderXX):+[`HeaderXX a`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf-Headers.html#t:HeaderXX): ``` Haskell -- | Parsed ELF header@@ -84,7 +84,7 @@ So we have two types `HeaderXX 'ELFCLASS64` and `HeaderXX 'ELFCLASS32`. To be able to work with headers uniformly the type-[`Header`](https://hackage.haskell.org/package/melf-1.0.1/docs/Data-Elf-Headers.html#t:Header)+[`Header`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf-Headers.html#t:Header) was introduced: ``` Haskell@@ -124,7 +124,7 @@ is defined in the package [`binary`](https://hackage.haskell.org/package/binary). The function-[`withElfClass`](https://hackage.haskell.org/package/melf-1.0.1/docs/Data-Elf-Headers.html#v:withElfClass)+[`withElfClass`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf-Headers.html#v:withElfClass) creates a context with an implicit word width available and looks like [`withSingI`](https://hackage.haskell.org/package/singletons-3.0.1/docs/Data-Singletons.html#v:withSingI): @@ -138,42 +138,52 @@ ``` The module `Data.Elf.Headers` also defines the types-[`SectionXX`](https://hackage.haskell.org/package/melf-1.0.1/docs/Data-Elf-Headers.html#t:SectionXX),-[`SegmentXX`](https://hackage.haskell.org/package/melf-1.0.1/docs/Data-Elf-Headers.html#t:SegmentXX) and-[`SymbolXX`](https://hackage.haskell.org/package/melf-1.0.1/docs/Data-Elf-Headers.html#t:SymbolXX)+[`SectionXX`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf-Headers.html#t:SectionXX),+[`SegmentXX`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf-Headers.html#t:SegmentXX) and+[`SymbolXX`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf-Headers.html#t:SymbolXX) for the elements of section, segment and symbol tables. ## Parsing the whole ELF file The module-[`Data.Elf`](https://hackage.haskell.org/package/melf-1.0.1/docs/Data-Elf.html)+[`Data.Elf`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf.html) implements parsing and serialization of the whole ELF files. To parse ELF file it reads ELF header, section table and segment table and uses that data to create-a list of elements of the type-[`ElfXX`](https://hackage.haskell.org/package/melf-1.0.1/docs/Data-Elf.html#t:ElfXX)+a list of type+[`ElfListXX`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf.html#t:ElfListXX)+of elements of the type+[`ElfXX`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf.html#t:ElfXX) representing the recursive structure of the ELF file. It also restores section names from the the string table indexes. That results in creating an object of type-[`Elf`](https://hackage.haskell.org/package/melf-1.0.1/docs/Data-Elf.html#t:Elf):+[`Elf`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf.html#t:Elf): ``` Haskell -- | `Elf` is a forrest of trees of type `ElfXX`. -- Trees are composed of `ElfXX` nodes, `ElfSegment` can contain subtrees-newtype ElfList c = ElfList [ElfXX c]+data ElfNodeType = Header | SectionTable | SegmentTable | Section | Segment | RawData | RawAlign+data ElfListXX c where+ ElfListCons :: ElfXX t c -> ElfListXX c -> ElfListXX c+ ElfListNull :: ElfListXX c -- | Elf is a sigma type where `ElfClass` defines the type of `ElfList`-type Elf = Sigma ElfClass (TyCon1 ElfList)+type Elf = Sigma ElfClass (TyCon1 ElfListXX) -- | Section data may contain a string table. -- If a section contains a string table with section names, the data -- for such a section is generated and `esData` should contain `ElfSectionDataStringTable`-data ElfSectionData- = ElfSectionData BSL.ByteString -- ^ Regular section data+data ElfSectionData c+ = ElfSectionData -- ^ Regular section data+ { esdData :: BSL.ByteString -- ^ The content of the section+ } | ElfSectionDataStringTable -- ^ Section data will be generated from section names+ | ElfSectionDataNoBits -- ^ SHT_NOBITS uninitialized section data: section has size but no content+ { esdSize :: WordXX c -- ^ Size of the section+ } -- | The type of node that defines Elf structure.-data ElfXX (c :: ElfClass)- = ElfHeader+data ElfXX t c where+ ElfHeader :: { ehData :: ElfData -- ^ Data encoding (big- or little-endian) , ehOSABI :: ElfOSABI -- ^ OS/ABI identification , ehABIVersion :: Word8 -- ^ ABI version@@ -181,10 +191,10 @@ , ehMachine :: ElfMachine -- ^ Machine type , ehEntry :: WordXX c -- ^ Entry point address , ehFlags :: Word32 -- ^ Processor-specific flags- }- | ElfSectionTable- | ElfSegmentTable- | ElfSection+ } -> ElfXX 'Header c+ ElfSectionTable :: ElfXX 'SectionTable c+ ElfSegmentTable :: ElfXX 'SegmentTable c+ ElfSection :: { esName :: String -- ^ Section name (NB: string, not offset in the string table) , esType :: ElfSectionType -- ^ Section type , esFlags :: ElfSectionFlag -- ^ Section attributes@@ -194,9 +204,9 @@ , esN :: ElfSectionIndex -- ^ Section number , esInfo :: Word32 -- ^ Miscellaneous information , esLink :: Word32 -- ^ Link to other section- , esData :: ElfSectionData -- ^ The content of the section- }- | ElfSegment+ , esData :: ElfSectionData c -- ^ The content of the section+ } -> ElfXX 'Section c+ ElfSegment :: { epType :: ElfSegmentType -- ^ Type of segment , epFlags :: ElfSegmentFlag -- ^ Segment attributes , epVirtAddr :: WordXX c -- ^ Virtual address in memory@@ -204,20 +214,24 @@ , epAddMemSize :: WordXX c -- ^ Add this amount of memory after the section when the section is loaded to memory by execution system. -- Or, in other words this is how much `pMemSize` is bigger than `pFileSize` , epAlign :: WordXX c -- ^ Alignment of segment- , epData :: [ElfXX c] -- ^ Content of the segment- }- | ElfRawData -- ^ Some ELF files (some executables) don't bother to define- -- sections for linking and have just raw data in segments.+ , epData :: ElfListXX c -- ^ Content of the segment+ } -> ElfXX 'Segment c+ -- | Some ELF files (some executables) don't bother to define+ -- sections for linking and have just raw data in segments.+ ElfRawData :: { edData :: BSL.ByteString -- ^ Raw data in ELF file- }- | ElfRawAlign -- ^ Align the next data in the ELF file.- -- The offset of the next data in the ELF file- -- will be the minimal @x@ such that- -- @x mod eaAlign == eaOffset mod eaAlign @+ } -> ElfXX 'RawData c+ -- | Align the next data in the ELF file.+ -- The offset of the next data in the ELF file+ -- will be the minimal @x@ such that+ -- @x mod eaAlign == eaOffset mod eaAlign @+ ElfRawAlign :: { eaOffset :: WordXX c -- ^ Align value , eaAlign :: WordXX c -- ^ Align module- }+ } -> ElfXX 'RawAlign c +(~:) :: ElfXX t a -> ElfListXX a -> ElfListXX a+(~:) = ElfListCons ``` Not each object of that type can be serialized.@@ -238,9 +252,9 @@ node `ElfSegmentTable`. Correctly composed ELF object can be serialized with the function-[`serializeElf`](https://hackage.haskell.org/package/melf-1.0.1/docs/Data-Elf.html#v:serializeElf)+[`serializeElf`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf.html#v:serializeElf) and parsed with the function-[`parseElf`](https://hackage.haskell.org/package/melf-1.0.1/docs/Data-Elf.html#v:parseElf):+[`parseElf`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf.html#v:parseElf): ``` Haskell serializeElf :: MonadThrow m => Elf -> m ByteString@@ -255,7 +269,7 @@ To create machine code that is used in the examples a pair of modules were created. The module-[`AsmAArch64`](https://github.com/aleksey-makarov/melf/blob/v1.0.2/examples/AsmAArch64.hs)+[`AsmAArch64`](https://github.com/aleksey-makarov/melf/blob/v1.2.0/examples/AsmAArch64.hs) provides a DSL embedded in Haskell. This DSL is a kind of assembler language for the AArch64 platform. It exports some primitives to generate machine instructions and organize machine code.@@ -270,10 +284,10 @@ ["Monads to Machine Code"](https://www.stephendiehl.com/posts/monads_machine_code.html) by Stephen Diehl. Detailed description of this module is available in russian:-[README_ru.md](https://github.com/aleksey-makarov/melf/blob/v1.0.2/examples/README_ru.md).+[README_ru.md](https://github.com/aleksey-makarov/melf/blob/v1.2.0/examples/README_ru.md) (outdated). The module-[`HelloWorld`](https://github.com/aleksey-makarov/melf/blob/v1.0.2/examples/HelloWorld.hs)+[`HelloWorld`](https://github.com/aleksey-makarov/melf/blob/v1.2.0/examples/HelloWorld.hs) uses primitives from `AsmAArch64` to compose relocatable executable code that uses system calls to output a "Hello World!" message into standard output and exit: @@ -284,8 +298,8 @@ Function `assemble` uses the `melf` library to generate an object file: ``` Haskell- return $ SELFCLASS64 :&: ElfList- [ ElfHeader+ return $ SELFCLASS64 :&:+ ElfHeader { ehData = ELFDATA2LSB , ehOSABI = ELFOSABI_SYSV , ehABIVersion = 0@@ -294,7 +308,7 @@ , ehEntry = 0 , ehFlags = 0 }- , ElfSection+ ~: ElfSection { esName = ".text" , esType = SHT_PROGBITS , esFlags = SHF_EXECINSTR .|. SHF_ALLOC@@ -306,7 +320,7 @@ , esInfo = 0 , esData = ElfSectionData txt }- , ElfSection+ ~: ElfSection { esName = ".shstrtab" , esType = SHT_STRTAB , esFlags = 0@@ -318,7 +332,7 @@ , esInfo = 0 , esData = ElfSectionDataStringTable }- , ElfSection+ ~: ElfSection { esName = ".symtab" , esType = SHT_SYMTAB , esFlags = 0@@ -330,7 +344,7 @@ , esInfo = 1 , esData = ElfSectionData symbolTableData }- , ElfSection+ ~: ElfSection { esName = ".strtab" , esType = SHT_STRTAB , esFlags = 0@@ -342,8 +356,8 @@ , esInfo = 0 , esData = ElfSectionData stringTableData }- , ElfSectionTable- ]+ ~: ElfSectionTable+ ~: ElfListNull ``` It runs the `State` monad that was passed as an argument.@@ -396,22 +410,22 @@ ## Generation of executable files The module-[`DummyLd`](https://github.com/aleksey-makarov/melf/blob/v1.0.2/examples/DummyLd.hs)+[`DummyLd`](https://github.com/aleksey-makarov/melf/blob/v1.2.0/examples/DummyLd.hs) uses the section `.text` of object file to create an executable file. Code relocation and symbol resolution is not implemented so that procedure works only for position-independent code that does not refer to external translation units, for example, it works with the code described above. Function `dummyLd` consumes an object of the type `Elf` and finds a section `.text`-(using [`elfFindSectionByName`](https://hackage.haskell.org/package/melf-1.0.1/docs/Data-Elf.html#v:elfFindSectionByName))+(using [`elfFindSectionByName`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf.html#v:elfFindSectionByName)) and header-(using [`elfFindHeader`](https://hackage.haskell.org/package/melf-1.0.1/docs/Data-Elf.html#v:elfFindHeader))+(using [`elfFindHeader`](https://hackage.haskell.org/package/melf-1.2.0/docs/Data-Elf.html#v:elfFindHeader)) in it. Then the header type is changed to `ET_EXEC`, the address of the first executable instruction is specified and a loadable segment containing the header and the content of `.text` is formed: ``` Haskell-data MachineConfig (a :: ElfClass)+data MachineConfig a = MachineConfig { mcAddress :: WordXX a -- ^ Virtual address of the executable segment , mcAlign :: WordXX a -- ^ Required alignment of the executable segment@@ -423,20 +437,23 @@ getMachineConfig EM_X86_64 = return $ MachineConfig 0x400000 0x1000 getMachineConfig _ = $chainedError "could not find machine config for this arch" -dummyLd' :: forall a m . (MonadThrow m, IsElfClass a) => ElfList a -> m (ElfList a)-dummyLd' (ElfList es) = do+dummyLd' :: forall a m . (MonadThrow m, IsElfClass a) => ElfListXX a -> m (ElfListXX a)+dummyLd' es = do - txtSection <- elfFindSectionByName es ".text"- txtSectionData <- case txtSection of- ElfSection { esData = ElfSectionData textData } -> return textData+ section' <- elfFindSectionByName es ".text"++ txtSectionData <- case esData section' of+ ElfSectionData textData -> return textData _ -> $chainedError "could not find correct \".text\" section" - header <- elfFindHeader es- case header of- ElfHeader { .. } -> do- MachineConfig { .. } <- getMachineConfig ehMachine- return $ ElfList- [ ElfSegment+ header' <- elfFindHeader es++ MachineConfig { .. } <- getMachineConfig (ehMachine header')++ return $+ case header' of+ ElfHeader { .. } ->+ ElfSegment { epType = PT_LOAD , epFlags = PF_X .|. PF_R , epVirtAddr = mcAddress@@ -444,19 +461,18 @@ , epAddMemSize = 0 , epAlign = mcAlign , epData =- [ ElfHeader+ ElfHeader { ehType = ET_EXEC , ehEntry = mcAddress + headerSize (fromSing $ sing @a) , .. }- , ElfRawData+ ~: ElfRawData { edData = txtSectionData }- ]+ ~: ElfListNull }- , ElfSegmentTable- ]- _ -> $chainedError "could not find ELF header"+ ~: ElfSegmentTable+ ~: ElfListNull -- | @dummyLd@ places the content of ".text" section of the input ELF -- into the loadable segment of the resulting ELF.
examples/AsmAArch64.hs view
@@ -261,7 +261,7 @@ steType = STT_NoType steShNdx = textSecN steValue = fromIntegral $ findOffset poolOffset r- steSize = 0+ steSize = 0 :: Word64 in ElfSymbolXX{..} @@ -269,8 +269,8 @@ (symbolTableData, stringTableData) <- serializeSymbolTable ELFDATA2LSB (zeroIndexStringItem : symbolTable) - return $ SELFCLASS64 :&: ElfList- [ ElfHeader+ return $ SELFCLASS64 :&:+ ElfHeader { ehData = ELFDATA2LSB , ehOSABI = ELFOSABI_SYSV , ehABIVersion = 0@@ -279,7 +279,7 @@ , ehEntry = 0 , ehFlags = 0 }- , ElfSection+ ~: ElfSection { esName = ".text" , esType = SHT_PROGBITS , esFlags = SHF_EXECINSTR .|. SHF_ALLOC@@ -291,7 +291,7 @@ , esInfo = 0 , esData = ElfSectionData txt }- , ElfSection+ ~: ElfSection { esName = ".shstrtab" , esType = SHT_STRTAB , esFlags = 0@@ -303,7 +303,7 @@ , esInfo = 0 , esData = ElfSectionDataStringTable }- , ElfSection+ ~: ElfSection { esName = ".symtab" , esType = SHT_SYMTAB , esFlags = 0@@ -315,7 +315,7 @@ , esInfo = 1 , esData = ElfSectionData symbolTableData }- , ElfSection+ ~: ElfSection { esName = ".strtab" , esType = SHT_STRTAB , esFlags = 0@@ -327,5 +327,5 @@ , esInfo = 0 , esData = ElfSectionData stringTableData }- , ElfSectionTable- ]+ ~: ElfSectionTable+ ~: ElfListNull
examples/DummyLd.hs view
@@ -18,7 +18,7 @@ import Data.Elf.Headers import Control.Exception.ChainedException -data MachineConfig (a :: ElfClass)+data MachineConfig a = MachineConfig { mcAddress :: WordXX a -- ^ Virtual address of the executable segment , mcAlign :: WordXX a -- ^ Required alignment of the executable segment@@ -30,20 +30,29 @@ getMachineConfig EM_X86_64 = return $ MachineConfig 0x400000 0x1000 getMachineConfig _ = $chainedError "could not find machine config for this arch" -dummyLd' :: forall a m . (MonadThrow m, IsElfClass a) => ElfList a -> m (ElfList a)-dummyLd' (ElfList es) = do+dummyLd' :: forall a m . (MonadThrow m, IsElfClass a) => ElfListXX a -> m (ElfListXX a)+dummyLd' es = do - txtSection <- elfFindSectionByName es ".text"- txtSectionData <- case txtSection of- ElfSection { esData = ElfSectionData textData } -> return textData+ section' <- elfFindSectionByName es ".text"++ txtSectionData <- case esData section' of+ ElfSectionData textData -> return textData _ -> $chainedError "could not find correct \".text\" section" - header <- elfFindHeader es- case header of- ElfHeader { .. } -> do- MachineConfig { .. } <- getMachineConfig ehMachine- return $ ElfList- [ ElfSegment+ -- FIXME: it's better to match constructor here, but there is a bug that prevents to conclude that+ -- the match is irrefutable:+ -- https://stackoverflow.com/questions/72803815/phantom-type-makes-pattern-matching-irrefutable-but-that-seemingly-does-not-wor+ -- https://gitlab.haskell.org/ghc/ghc/-/issues/15681#note_165436+ -- But if I use lazy pattern match, then some other bug comes up that prevents type inference+ -- on GHC 9.0.2+ header' <- elfFindHeader es++ MachineConfig { .. } <- getMachineConfig (ehMachine header')++ return $+ case header' of+ ElfHeader { .. } ->+ ElfSegment { epType = PT_LOAD , epFlags = PF_X .|. PF_R , epVirtAddr = mcAddress@@ -51,19 +60,18 @@ , epAddMemSize = 0 , epAlign = mcAlign , epData =- [ ElfHeader+ ElfHeader { ehType = ET_EXEC , ehEntry = mcAddress + headerSize (fromSing $ sing @a) , .. }- , ElfRawData+ ~: ElfRawData { edData = txtSectionData }- ]+ ~: ElfListNull }- , ElfSegmentTable- ]- _ -> $chainedError "could not find ELF header"+ ~: ElfSegmentTable+ ~: ElfListNull -- | @dummyLd@ places the content of ".text" section of the input ELF -- into the loadable segment of the resulting ELF.
examples/ForwardLabel.hs view
@@ -5,7 +5,6 @@ import Prelude as P -import Control.Monad.Catch import Control.Monad.Fix import Control.Monad.State import Data.Word@@ -23,7 +22,7 @@ sysWrite = 64 sysExit = 93 -forwardLabel :: (MonadCatch m, MonadFix m) => StateT CodeState m ()+forwardLabel :: MonadFix m => StateT CodeState m () forwardLabel = mdo label >>= exportSymbol "_start"
melf.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.18 --- This file has been generated from package.yaml by hpack version 0.34.5.+-- This file has been generated from package.yaml by hpack version 0.35.1. -- -- see: https://github.com/sol/hpack name: melf-version: 1.1.0+version: 1.2.0 synopsis: An Elf parser description: Parser for ELF object format category: Data@@ -18,7 +18,7 @@ license-file: LICENSE build-type: Simple tested-with:- GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.1, GHC == 9.2.1+ GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.4, GHC == 9.2.5, GHC == 9.4.4 extra-doc-files: ChangeLog.md README.md@@ -69,21 +69,25 @@ Data.BList hs-source-dirs: src- ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wno-redundant-constraints+ ghc-options: -Wall -Wcompat build-depends: base >=4.13 && <5.0 , binary >=0.8.7 && <0.9 , bytestring >=0.10.10 && <0.12 , exceptions >=0.10.4 && <0.11+ , lens >=5.0.1 && <5.3 , mtl >=2.2.2 && <2.3 , prettyprinter >=1.7.0 && <1.8- , singletons >=2.6 && <3.2- , template-haskell >=2.15 && <2.19+ , template-haskell >=2.15 && <2.20+ default-language: Haskell2010 if impl(ghc >= 9.0) build-depends:- singletons-base >=3.0 && <3.2+ singletons ==3.0.*+ , singletons-base >=3.0 && <3.2 , singletons-th >=3.0 && <3.2- default-language: Haskell2010+ else+ build-depends:+ singletons >=2.6 && <2.8 executable hobjdump main-is: hObjDump.hs@@ -91,13 +95,13 @@ Paths_melf hs-source-dirs: app- ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wno-redundant-constraints -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N+ ghc-options: -Wall -Wcompat -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.13 && <5.0 , binary , bytestring , melf- , optparse-applicative >=0.16.1 && <0.17+ , optparse-applicative >=0.16.1 && <0.18 , prettyprinter default-language: Haskell2010 @@ -107,7 +111,7 @@ Paths_melf hs-source-dirs: app- ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wno-redundant-constraints -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N+ ghc-options: -Wall -Wcompat -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.13 && <5.0 , binary@@ -128,24 +132,26 @@ Paths_melf hs-source-dirs: examples- ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wno-redundant-constraints+ ghc-options: -Wall -Wcompat build-depends: base >=4.13 && <5.0 , bytestring- , containers >=0.6.2.1 && <0.7 , exceptions , filepath , melf , mtl- , singletons , tasty , tasty-golden , tasty-hunit , unix >=2.7.2.2 && <2.8+ default-language: Haskell2010 if impl(ghc >= 9.0) build-depends:- singletons-th- default-language: Haskell2010+ singletons+ , singletons-th+ else+ build-depends:+ singletons test-suite exceptions type: exitcode-stdio-1.0@@ -154,7 +160,7 @@ Paths_melf hs-source-dirs: tests/exceptions- ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wno-redundant-constraints+ ghc-options: -Wall -Wcompat build-depends: base >=4.13 && <5.0 , exceptions@@ -170,7 +176,7 @@ Paths_melf hs-source-dirs: tests- ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wno-redundant-constraints+ ghc-options: -Wall -Wcompat build-depends: base >=4.13 && <5.0 , binary
src/Data/Elf.hs view
@@ -11,10 +11,12 @@ module Data.Elf ( -- * Elf- ElfList (..)+ ElfNodeType (..)+ , ElfListXX (..) , Elf , ElfSectionData (..) , ElfXX (..)+ , (~:) , parseElf , serializeElf
src/Data/Elf/Constants/TH.hs view
@@ -22,6 +22,7 @@ let patternName s = mkName (patternPrefixString ++ s) let defaultPatternName = mkName defaultPatternNameString let+ baseTypeT :: Q Type baseTypeT = case baseType of BaseWord8 -> conT $ mkName "Word8"@@ -55,7 +56,9 @@ (normalB [| patternPrefixString ++ s |]) [] - let showClauses = map mkShowClause enums+ let+ showClauses :: [Q Clause]+ showClauses = map mkShowClause enums (nP, nE) <- newNamePE "n" let@@ -149,6 +152,7 @@ localName3 <- newName "n" let+ defaultPatternDef :: Q Dec defaultPatternDef = patSynD defaultPatternName
src/Data/Elf/Headers.hs view
@@ -104,13 +104,11 @@ import Data.Singletons.TH import Data.Typeable (Typeable) -#if defined(MIN_VERSION_GLASGOW_HASKELL)-#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)+#if MIN_VERSION_singletons(3,0,0) import Data.Eq.Singletons import Text.Show.Singletons import Data.Bool.Singletons #endif-#endif import Control.Exception.ChainedException import Data.BList@@ -598,7 +596,7 @@ relaSym32 v = v `shiftR` 8 relaType32 :: Word32 -> Word32-relaType32 v = fromIntegral $ v .&. 0xff+relaType32 v = v .&. 0xff relaSym64 :: Word64 -> Word32 relaSym64 v = fromIntegral $ v `shiftR` 32
src/Data/Elf/PrettyPrint.hs view
@@ -242,6 +242,7 @@ let xs = concatMap printRBuilder' rbpData l = longest xs+ appendSectionBar :: [(a1, String, c1)] -> [(a1, String, c1)] appendSectionBar = fmap (mapL ('│' : )) xsf = appendSectionBar $ equalize l xs b = '┌' : replicate l '─'@@ -252,6 +253,7 @@ [(if empty i then o else o + s - 1, e, [] )] f RBuilderRawData{} = let+ doc :: [Doc ()] doc = [ "R" ] in [(o, "╓", doc)@@ -347,7 +349,7 @@ <+> "value:" <+> printWordXX steValue <+> "size:" <+> printWordXX steSize) -printRelocationTableA_AARCH64 :: MonadThrow m => Bool -> Word32 -> [ElfXX 'ELFCLASS64] -> BSL.ByteString -> m (Doc ())+printRelocationTableA_AARCH64 :: MonadThrow m => Bool -> Word32 -> ElfListXX 'ELFCLASS64 -> BSL.ByteString -> m (Doc ()) printRelocationTableA_AARCH64 full sLink elfs bs = do symTableSection <- elfFindSection elfs sLink symTable <- parseSymbolTable ELFDATA2LSB symTableSection elfs@@ -383,21 +385,25 @@ -- | Print ELF. If first argument is False, don't dump all the data, print just the first two and the last lines. printElf_ :: MonadThrow m => Bool -> Elf -> m (Doc ())-printElf_ full (classS :&: ElfList elfs) = withElfClass classS do+printElf_ full (classS :&: elfs) = withElfClass classS $ printElf_' full elfs - (hData, hMachine) <- do- header <- elfFindHeader elfs- case header of- ElfHeader{..} -> return (ehData, ehMachine)- _ -> $chainedError "not a header" -- FIXME+printElf_' :: forall a m . (MonadThrow m, IsElfClass a) => Bool -> ElfListXX a -> m (Doc ())+printElf_' full elfs = do + -- FIXME: lazy matching here is a workaround for some GHC bug, see+ -- https://stackoverflow.com/questions/72803815/phantom-type-makes-pattern-matching-irrefutable-but-that-seemingly-does-not-wor+ -- https://gitlab.haskell.org/ghc/ghc/-/issues/15681#note_165436+ ~(ElfHeader { .. }) <- elfFindHeader elfs+ let - printElf' elfs' = align . vsep <$> mapM printElf'' elfs'+ printElf' :: ElfListXX a -> m (Doc ())+ printElf' elfs' = align . vsep <$> mapMElfList printElf'' elfs' - printElf'' ElfHeader{..} =+ printElf'' :: ElfXX t' a -> m (Doc ())+ printElf'' ElfHeader {} = return $ formatPairsBlock "header"- [ ("Class", viaShow $ fromSing classS )+ [ ("Class", viaShow $ fromSing $ sing @a) , ("Data", viaShow ehData ) -- ElfData , ("OSABI", viaShow ehOSABI ) -- ElfOSABI , ("ABIVersion", viaShow ehABIVersion ) -- Word8@@ -427,21 +433,21 @@ ElfSectionData bs -> if sectionIsSymbolTable esType then do- stes <- parseSymbolTable hData s elfs+ stes <- parseSymbolTable ehData s elfs return $ printSection' "symbol table section" $ if null stes then "" else line <> indent 4 (printElfSymbolTable full stes)- else if hMachine == EM_AARCH64- && hData == ELFDATA2LSB- && esType == SHT_RELA- && esEntSize == withElfClass classS relocationTableAEntrySize then- case classS of+ else if ehMachine == EM_AARCH64+ && ehData == ELFDATA2LSB+ && esType == SHT_RELA+ && esEntSize == relocationTableAEntrySize then+ case sing @a of SELFCLASS64 -> printSection' "section" <$> printRelocationTableA_AARCH64 full esLink elfs bs SELFCLASS32 -> $chainedError "invalid ELF: EM_AARCH64 and ELFCLASS32" else return $ printSection' "section" $ printData full bs printElf'' ElfSegment{..} = do- dataDoc <- if null epData- then return ""- else do+ dataDoc <- case epData of+ ElfListNull -> return ""+ _ -> do dataDoc' <- printElf' epData return $ line <> indent 4 dataDoc' return $ formatPairsBlock "segment"
src/Data/Internal/Elf.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTSyntax #-} {-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -25,6 +26,8 @@ import Data.Elf.Headers import Data.Interval as I +import Control.Lens.Combinators hiding (contains)+import Control.Lens.Operators import Control.Monad import Control.Monad.Catch import Control.Monad.State as MS@@ -40,23 +43,6 @@ import Data.Singletons import Data.Singletons.Sigma --- import System.IO.Unsafe--headerInterval :: forall a . IsElfClass a => HeaderXX a -> Interval (WordXX a)-headerInterval _ = I 0 $ headerSize $ fromSing $ sing @a--sectionTableInterval :: IsElfClass a => HeaderXX a -> Interval (WordXX a)-sectionTableInterval HeaderXX{..} = I hShOff $ fromIntegral $ hShEntSize * hShNum--segmentTableInterval :: IsElfClass a => HeaderXX a -> Interval (WordXX a)-segmentTableInterval HeaderXX{..} = I hPhOff $ fromIntegral $ hPhEntSize * hPhNum--sectionInterval :: IsElfClass a => SectionXX a -> Interval (WordXX a)-sectionInterval SectionXX{..} = I sOffset if sType == SHT_NOBITS then 0 else sSize--segmentInterval :: IsElfClass a => SegmentXX a -> Interval (WordXX a)-segmentInterval SegmentXX{..} = I pOffset pFileSize- -- | @RBuilder@ is an intermediate internal data type that is used by parser. -- It contains information about layout of the ELF file that can be used -- by `Data.Elf.PrettyPrint.printLayout`@@ -88,6 +74,138 @@ , rbraAlign :: WordXX c } +data LZip a = LZip [a] (Maybe a) [a]++instance Foldable LZip where+ foldMap f (LZip l (Just c) r) = foldMap f $ LZip l Nothing (c : r)+ foldMap f (LZip l Nothing r) = foldMap f $ L.reverse l ++ r++-- FIXME: Use validity (https://hackage.haskell.org/package/validity)+-- for constraints on the Elf type (???)++-- | `Elf` is a forrest of trees of type `ElfXX`.+-- Trees are composed of `ElfXX` nodes, `ElfSegment` can contain subtrees+data ElfNodeType = Header | SectionTable | SegmentTable | Section | Segment | RawData | RawAlign+data ElfListXX c where+ ElfListCons :: ElfXX t c -> ElfListXX c -> ElfListXX c+ ElfListNull :: ElfListXX c++-- | Elf is a sigma type where `ElfClass` defines the type of `ElfList`+type Elf = Sigma ElfClass (TyCon1 ElfListXX)++-- | Section data may contain a string table.+-- If a section contains a string table with section names, the data+-- for such a section is generated and `esData` should contain `ElfSectionDataStringTable`+data ElfSectionData c+ = ElfSectionData -- ^ Regular section data+ { esdData :: BSL.ByteString -- ^ The content of the section+ }+ | ElfSectionDataStringTable -- ^ Section data will be generated from section names+ | ElfSectionDataNoBits -- ^ SHT_NOBITS uninitialized section data: section has size but no content+ { esdSize :: WordXX c -- ^ Size of the section+ }++-- | The type of node that defines Elf structure.+data ElfXX t c where+ ElfHeader ::+ { ehData :: ElfData -- ^ Data encoding (big- or little-endian)+ , ehOSABI :: ElfOSABI -- ^ OS/ABI identification+ , ehABIVersion :: Word8 -- ^ ABI version+ , ehType :: ElfType -- ^ Object file type+ , ehMachine :: ElfMachine -- ^ Machine type+ , ehEntry :: WordXX c -- ^ Entry point address+ , ehFlags :: Word32 -- ^ Processor-specific flags+ } -> ElfXX 'Header c+ ElfSectionTable :: ElfXX 'SectionTable c+ ElfSegmentTable :: ElfXX 'SegmentTable c+ ElfSection ::+ { esName :: String -- ^ Section name (NB: string, not offset in the string table)+ , esType :: ElfSectionType -- ^ Section type+ , esFlags :: ElfSectionFlag -- ^ Section attributes+ , esAddr :: WordXX c -- ^ Virtual address in memory+ , esAddrAlign :: WordXX c -- ^ Address alignment boundary+ , esEntSize :: WordXX c -- ^ Size of entries, if section has table+ , esN :: ElfSectionIndex -- ^ Section number+ , esInfo :: Word32 -- ^ Miscellaneous information+ , esLink :: Word32 -- ^ Link to other section+ , esData :: ElfSectionData c -- ^ The content of the section+ } -> ElfXX 'Section c+ ElfSegment ::+ { epType :: ElfSegmentType -- ^ Type of segment+ , epFlags :: ElfSegmentFlag -- ^ Segment attributes+ , epVirtAddr :: WordXX c -- ^ Virtual address in memory+ , epPhysAddr :: WordXX c -- ^ Physical address+ , epAddMemSize :: WordXX c -- ^ Add this amount of memory after the section when the section is loaded to memory by execution system.+ -- Or, in other words this is how much `pMemSize` is bigger than `pFileSize`+ , epAlign :: WordXX c -- ^ Alignment of segment+ , epData :: ElfListXX c -- ^ Content of the segment+ } -> ElfXX 'Segment c+ -- | Some ELF files (some executables) don't bother to define+ -- sections for linking and have just raw data in segments.+ ElfRawData ::+ { edData :: BSL.ByteString -- ^ Raw data in ELF file+ } -> ElfXX 'RawData c+ -- | Align the next data in the ELF file.+ -- The offset of the next data in the ELF file+ -- will be the minimal @x@ such that+ -- @x mod eaAlign == eaOffset mod eaAlign @+ ElfRawAlign ::+ { eaOffset :: WordXX c -- ^ Align value+ , eaAlign :: WordXX c -- ^ Align module+ } -> ElfXX 'RawAlign c++data WBuilderData+ = WBuilderDataHeader+ | WBuilderDataByteStream { wbdData :: BSL.ByteString }+ | WBuilderDataSectionTable+ | WBuilderDataSegmentTable++data WBuilderState a =+ WBuilderState+ { _wbsSections :: [(ElfSectionIndex, SectionXX a)]+ , _wbsSegmentsReversed :: [SegmentXX a]+ , _wbsDataReversed :: [WBuilderData]+ , _wbsOffset :: WordXX a+ , _wbsPhOff :: WordXX a+ , _wbsShOff :: WordXX a+ , _wbsShStrNdx :: ElfSectionIndex+ , _wbsNameIndexes :: [Int64]+ }++makeLenses ''WBuilderState++infixr 9 ~:++(~:) :: ElfXX t a -> ElfListXX a -> ElfListXX a+(~:) = ElfListCons++foldMapElfList :: Monoid m => (forall t' . (ElfXX t' a -> m)) -> ElfListXX a -> m+foldMapElfList f (ElfListCons v@(ElfSegment { .. }) l) = f v <> foldMapElfList f epData <> foldMapElfList f l+foldMapElfList f (ElfListCons v l) = f v <> foldMapElfList f l+foldMapElfList _ ElfListNull = mempty++foldMapElfList' :: Monoid m => (forall t' . (ElfXX t' a -> m)) -> ElfListXX a -> m+foldMapElfList' f (ElfListCons v l) = f v <> foldMapElfList' f l+foldMapElfList' _ ElfListNull = mempty++mapMElfList :: Monad m => (forall t' . (ElfXX t' a -> m b)) -> ElfListXX a -> m [b]+mapMElfList f l = sequence $ foldMapElfList' ((: []) . f) l++headerInterval :: forall a . IsElfClass a => HeaderXX a -> Interval (WordXX a)+headerInterval _ = I 0 $ headerSize $ fromSing $ sing @a++sectionTableInterval :: IsElfClass a => HeaderXX a -> Interval (WordXX a)+sectionTableInterval HeaderXX{..} = I hShOff $ fromIntegral $ hShEntSize * hShNum++segmentTableInterval :: IsElfClass a => HeaderXX a -> Interval (WordXX a)+segmentTableInterval HeaderXX{..} = I hPhOff $ fromIntegral $ hPhEntSize * hPhNum++sectionInterval :: IsElfClass a => SectionXX a -> Interval (WordXX a)+sectionInterval SectionXX{..} = I sOffset if sType == SHT_NOBITS then 0 else sSize++segmentInterval :: IsElfClass a => SegmentXX a -> Interval (WordXX a)+segmentInterval SegmentXX{..} = I pOffset pFileSize+ rBuilderInterval :: IsElfClass a => RBuilder a -> Interval (WordXX a) rBuilderInterval RBuilderHeader{..} = headerInterval rbhHeader rBuilderInterval RBuilderSectionTable{..} = sectionTableInterval rbstHeader@@ -97,12 +215,6 @@ rBuilderInterval RBuilderRawData{..} = rbrdInterval rBuilderInterval RBuilderRawAlign{} = undefined -- FIXME -data LZip a = LZip [a] (Maybe a) [a]--instance Foldable LZip where- foldMap f (LZip l (Just c) r) = foldMap f $ LZip l Nothing (c : r)- foldMap f (LZip l Nothing r) = foldMap f $ L.reverse l ++ r- findInterval :: (Ord t, Num t) => (a -> Interval t) -> t -> [a] -> LZip a findInterval f e = findInterval' [] where@@ -140,8 +252,8 @@ addRBuilderEmpty t ts = -- (unsafePerformIO $ Prelude.putStrLn $ "Add Empty " ++ showRBuilder t ++ " to " ++ showERBList ts) `seq` let- to = offset $ rBuilderInterval t- (LZip l c' r) = findInterval rBuilderInterval to ts+ to' = offset $ rBuilderInterval t+ (LZip l c' r) = findInterval rBuilderInterval to' ts -- Let `(le, lo)` is the result of `allEmptyStarting a l`. -- Then `le` is the initial sublist of `l` each element of which is empty and starts at `a`,@@ -161,16 +273,16 @@ d <- $addContext' $ addRBuilderEmpty t rbpData return $ toList $ LZip l (Just RBuilderSegment{ rbpData = d, .. }) r Just c ->- if offset (rBuilderInterval c) /= to then+ if offset (rBuilderInterval c) /= to' then $chainedError $ intersectMessage t c else let- (ce, re) = allEmptyStartingAt to (c : r)+ (ce, re') = allEmptyStartingAt to' (c : r) in case t of RBuilderSegment{..} ->- return $ toList $ LZip l (Just RBuilderSegment{ rbpData = ce, .. }) re+ return $ toList $ LZip l (Just RBuilderSegment{ rbpData = ce, .. }) re' _ ->- return $ toList $ LZip l Nothing (ce ++ (t : re))+ return $ toList $ LZip l Nothing (ce ++ (t : re')) Nothing -> return $ toList $ LZip l (Just t) r addRBuilderNonEmpty :: (IsElfClass a, MonadCatch m) => RBuilder a -> [RBuilder a] -> m [RBuilder a]@@ -284,112 +396,40 @@ in addRBuilders' addRBuilderNonEmpty nonEmptyRBs [] >>= addRBuilders' addRBuilderEmpty emptyRBs --- FIXME: Use validity (https://hackage.haskell.org/package/validity) for constraints on the Elf type (???)---- | `Elf` is a forrest of trees of type `ElfXX`.--- Trees are composed of `ElfXX` nodes, `ElfSegment` can contain subtrees-newtype ElfList c = ElfList [ElfXX c]---- | Elf is a sigma type where `ElfClass` defines the type of `ElfList`-type Elf = Sigma ElfClass (TyCon1 ElfList)---- | Section data may contain a string table.--- If a section contains a string table with section names, the data--- for such a section is generated and `esData` should contain `ElfSectionDataStringTable`-data ElfSectionData c- = ElfSectionData -- ^ Regular section data- { esdData :: BSL.ByteString -- ^ The content of the section- }- | ElfSectionDataStringTable -- ^ Section data will be generated from section names- | ElfSectionDataNoBits -- ^ SHT_NOBITS uninitialized section data: section has size but no content- { esdSize :: WordXX c -- ^ Size of the section- }---- | The type of node that defines Elf structure.-data ElfXX c- = ElfHeader- { ehData :: ElfData -- ^ Data encoding (big- or little-endian)- , ehOSABI :: ElfOSABI -- ^ OS/ABI identification- , ehABIVersion :: Word8 -- ^ ABI version- , ehType :: ElfType -- ^ Object file type- , ehMachine :: ElfMachine -- ^ Machine type- , ehEntry :: WordXX c -- ^ Entry point address- , ehFlags :: Word32 -- ^ Processor-specific flags- }- | ElfSectionTable- | ElfSegmentTable- | ElfSection- { esName :: String -- ^ Section name (NB: string, not offset in the string table)- , esType :: ElfSectionType -- ^ Section type- , esFlags :: ElfSectionFlag -- ^ Section attributes- , esAddr :: WordXX c -- ^ Virtual address in memory- , esAddrAlign :: WordXX c -- ^ Address alignment boundary- , esEntSize :: WordXX c -- ^ Size of entries, if section has table- , esN :: ElfSectionIndex -- ^ Section number- , esInfo :: Word32 -- ^ Miscellaneous information- , esLink :: Word32 -- ^ Link to other section- , esData :: ElfSectionData c -- ^ The content of the section- }- | ElfSegment- { epType :: ElfSegmentType -- ^ Type of segment- , epFlags :: ElfSegmentFlag -- ^ Segment attributes- , epVirtAddr :: WordXX c -- ^ Virtual address in memory- , epPhysAddr :: WordXX c -- ^ Physical address- , epAddMemSize :: WordXX c -- ^ Add this amount of memory after the section when the section is loaded to memory by execution system.- -- Or, in other words this is how much `pMemSize` is bigger than `pFileSize`- , epAlign :: WordXX c -- ^ Alignment of segment- , epData :: [ElfXX c] -- ^ Content of the segment- }- | ElfRawData -- ^ Some ELF files (some executables) don't bother to define- -- sections for linking and have just raw data in segments.- { edData :: BSL.ByteString -- ^ Raw data in ELF file- }- | ElfRawAlign -- ^ Align the next data in the ELF file.- -- The offset of the next data in the ELF file- -- will be the minimal @x@ such that- -- @x mod eaAlign == eaOffset mod eaAlign @- { eaOffset :: WordXX c -- ^ Align value- , eaAlign :: WordXX c -- ^ Align module- }--foldMapElf :: Monoid m => (ElfXX a -> m) -> ElfXX a -> m-foldMapElf f e@ElfSegment{..} = f e <> foldMapElfList f epData-foldMapElf f e = f e--foldMapElfList :: Monoid m => (ElfXX a -> m) -> [ElfXX a] -> m-foldMapElfList f = foldMap (foldMapElf f)- -- | Find section with a given number elfFindSection :: forall a m b . (SingI a, MonadThrow m, Integral b, Show b)- => [ElfXX a] -- ^ Structured ELF data- -> b -- ^ Number of the section- -> m (ElfXX a) -- ^ The section in question+ => ElfListXX a -- ^ Structured ELF data+ -> b -- ^ Number of the section+ -> m (ElfXX 'Section a) -- ^ The section in question elfFindSection elfs n = if n == 0 then $chainedError "no section 0" else $maybeAddContext ("no section " ++ show n) maybeSection where maybeSection = getFirst $ foldMapElfList f elfs+ f :: ElfXX t a -> First (ElfXX 'Section a) f s@ElfSection{..} | esN == fromIntegral n = First $ Just s f _ = First Nothing -- | Find section with a given name elfFindSectionByName :: forall a m . (SingI a, MonadThrow m)- => [ElfXX a] -- ^ Structured ELF data- -> String -- ^ Section name- -> m (ElfXX a) -- ^ The section in question+ => ElfListXX a -- ^ Structured ELF data+ -> String -- ^ Section name+ -> m (ElfXX 'Section a) -- ^ The section in question elfFindSectionByName elfs n = $maybeAddContext ("no section \"" ++ show n ++ "\"") maybeSection where maybeSection = getFirst $ foldMapElfList f elfs+ f :: ElfXX t a -> First (ElfXX 'Section a) f s@ElfSection{..} | esName == n = First $ Just s f _ = First Nothing -- | Find ELF header elfFindHeader :: forall a m . (SingI a, MonadThrow m)- => [ElfXX a] -- ^ Structured ELF data- -> m (ElfXX a) -- ^ ELF header+ => ElfListXX a -- ^ Structured ELF data+ -> m (ElfXX 'Header a) -- ^ ELF header elfFindHeader elfs = $maybeAddContext "no header" maybeHeader where maybeHeader = getFirst $ foldMapElfList f elfs+ f :: ElfXX t a -> First (ElfXX 'Header a) f h@ElfHeader{} = First $ Just h f _ = First Nothing @@ -552,9 +592,9 @@ rbs <- parseRBuilder hdr ss ps bs let- rBuilderToElf :: RBuilder a -> m (ElfXX a)- rBuilderToElf RBuilderHeader{} =- return ElfHeader+ rBuilderToElf :: RBuilder a -> ElfListXX a -> m (ElfListXX a)+ rBuilderToElf RBuilderHeader{} l =+ return $ ElfListCons ElfHeader { ehData = hData , ehOSABI = hOSABI , ehABIVersion = hABIVersion@@ -562,13 +602,13 @@ , ehMachine = hMachine , ehEntry = hEntry , ehFlags = hFlags- }- rBuilderToElf RBuilderSectionTable{} =- return ElfSectionTable- rBuilderToElf RBuilderSegmentTable{} =- return ElfSegmentTable- rBuilderToElf RBuilderSection{ rbsHeader = s@SectionXX{..}, ..} =- return ElfSection+ } l+ rBuilderToElf RBuilderSectionTable{} l =+ return $ ElfListCons ElfSectionTable l+ rBuilderToElf RBuilderSegmentTable{} l =+ return $ ElfListCons ElfSegmentTable l+ rBuilderToElf RBuilderSection{ rbsHeader = s@SectionXX{..}, ..} l =+ return $ ElfListCons ElfSection { esName = rbsName , esType = sType , esFlags = fromIntegral sFlags@@ -584,13 +624,13 @@ else if sType == SHT_NOBITS then ElfSectionDataNoBits sSize else ElfSectionData $ getSectionData bs s- }- rBuilderToElf RBuilderSegment{ rbpHeader = SegmentXX{..}, ..} = do- d <- mapM rBuilderToElf rbpData+ } l+ rBuilderToElf RBuilderSegment{ rbpHeader = SegmentXX{..}, ..} l = do+ d <- foldrM rBuilderToElf ElfListNull rbpData addMemSize <- if pMemSize /= 0 && pFileSize /= 0 && pMemSize < pFileSize then $chainedError "memSize < fileSize" else return (pMemSize - pFileSize)- return ElfSegment+ return $ ElfListCons ElfSegment { epType = pType , epFlags = pFlags , epVirtAddr = pVirtAddr@@ -598,14 +638,14 @@ , epAddMemSize = addMemSize , epAlign = pAlign , epData = d- }- rBuilderToElf RBuilderRawData{ rbrdInterval = I o s } =- return $ ElfRawData $ cut bs (fromIntegral o) (fromIntegral s)- rBuilderToElf RBuilderRawAlign{..} =- return $ ElfRawAlign rbraOffset rbraAlign+ } l+ rBuilderToElf RBuilderRawData{ rbrdInterval = I o s } l =+ return $ ElfListCons (ElfRawData $ cut bs (fromIntegral o) (fromIntegral s)) l+ rBuilderToElf RBuilderRawAlign{..} l =+ return $ ElfListCons (ElfRawAlign rbraOffset rbraAlign) l - el <- mapM rBuilderToElf rbs- return $ sing :&: ElfList el+ el <- foldrM rBuilderToElf ElfListNull rbs -- mapM rBuilderToElf rbs+ return $ sing :&: el -- | Parse ELF file parseElf :: MonadCatch m => BSL.ByteString -> m Elf@@ -617,34 +657,16 @@ -- ------------------------------------------------------------------------------- -data WBuilderData- = WBuilderDataHeader- | WBuilderDataByteStream { wbdData :: BSL.ByteString }- | WBuilderDataSectionTable- | WBuilderDataSegmentTable--data WBuilderState a =- WBuilderState- { wbsSections :: [(ElfSectionIndex, SectionXX a)]- , wbsSegmentsReversed :: [SegmentXX a]- , wbsDataReversed :: [WBuilderData]- , wbsOffset :: WordXX a- , wbsPhOff :: WordXX a- , wbsShOff :: WordXX a- , wbsShStrNdx :: ElfSectionIndex- , wbsNameIndexes :: [Int64]- }- wbStateInit :: forall a . IsElfClass a => WBuilderState a wbStateInit = WBuilderState- { wbsSections = []- , wbsSegmentsReversed = []- , wbsDataReversed = []- , wbsOffset = 0- , wbsPhOff = 0- , wbsShOff = 0- , wbsShStrNdx = 0- , wbsNameIndexes = []+ { _wbsSections = []+ , _wbsSegmentsReversed = []+ , _wbsDataReversed = []+ , _wbsOffset = 0+ , _wbsPhOff = 0+ , _wbsShOff = 0+ , _wbsShStrNdx = 0+ , _wbsNameIndexes = [] } zeroSection :: forall a . IsElfClass a => SectionXX a@@ -701,15 +723,16 @@ ((i', o') : iosff, insff) else (iosff, (i', n') : insff) --- FIXME: rewrite serializeElf using lenses (???)-serializeElf' :: forall a m . (IsElfClass a, MonadThrow m) => [ElfXX a] -> m BSL.ByteString+serializeElf' :: forall a m . (IsElfClass a, MonadCatch m) => ElfListXX a -> m BSL.ByteString serializeElf' elfs = do - (header', hData') <- do- header <- elfFindHeader elfs- case header of- ElfHeader{..} -> return (header, ehData)- _ -> $chainedError "not a header" -- FIXME+ -- FIXME: it's better to match constructor here, but there is a bug that prevents to conclude that+ -- the match is irrefutable:+ -- https://stackoverflow.com/questions/72803815/phantom-type-makes-pattern-matching-irrefutable-but-that-seemingly-does-not-wor+ -- https://gitlab.haskell.org/ghc/ghc/-/issues/15681#note_165436+ -- But if I use lazy pattern match, then some other bug comes up that prevents type inference+ -- on GHC 9.0.2+ header' <- $addContext' $ elfFindHeader elfs let @@ -724,6 +747,7 @@ sectionNames :: [String] sectionNames = foldMapElfList f elfs where+ f :: ElfXX t a -> [String] f ElfSection{..} = [ esName ] f _ = [] @@ -741,22 +765,17 @@ f ElfSectionTable = Any True f _ = Any False - align :: MonadThrow n => WordXX a -> WordXX a -> WBuilderState a -> n (WBuilderState a)- align _ 0 x = return x- align _ 1 x = return x- align t m WBuilderState{..} | m .&. (m - 1) /= 0 = $chainedError $ "align module is not power of two " ++ show m- | otherwise =- let- wbsOffset' = nextOffset t m wbsOffset- d = WBuilderDataByteStream $ BSL.replicate (fromIntegral $ wbsOffset' - wbsOffset) 0- in- return WBuilderState- { wbsDataReversed = d : wbsDataReversed- , wbsOffset = wbsOffset'- , ..- }+ align :: (MonadThrow n, MonadState (WBuilderState a) n) => WordXX a -> WordXX a -> n ()+ align _ 0 = return ()+ align _ 1 = return ()+ align t m | m .&. (m - 1) /= 0 = $chainedError $ "align module is not power of two " ++ show m+ | otherwise = do+ offset <- use wbsOffset+ wbsOffset .= nextOffset t m offset+ offset' <- use wbsOffset+ wbsDataReversed %= (WBuilderDataByteStream (BSL.replicate (fromIntegral $ offset' - offset) 0) :) - alignWord :: MonadThrow n => WBuilderState a -> n (WBuilderState a)+ alignWord :: (MonadThrow n, MonadState (WBuilderState a) n) => n () alignWord = align 0 $ wordSize $ fromSing $ sing @a dataIsEmpty :: ElfSectionData c -> Bool@@ -764,106 +783,88 @@ dataIsEmpty ElfSectionDataStringTable = BSL.null stringTable dataIsEmpty (ElfSectionDataNoBits _) = True - lastSectionIsEmpty :: [ElfXX a] -> Bool- lastSectionIsEmpty [] = False- lastSectionIsEmpty l = case L.last l of- ElfSection{..} -> dataIsEmpty esData- _ -> False+ lastSection :: ElfListXX a -> (forall t' . (ElfXX t' a -> b)) -> b -> b+ lastSection ElfListNull _ b = b+ lastSection (ElfListCons v ElfListNull) f _ = f v+ lastSection (ElfListCons _ l) f b = lastSection l f b - elf2WBuilder' :: MonadThrow n => ElfXX a -> WBuilderState a -> n (WBuilderState a)- elf2WBuilder' ElfHeader{} WBuilderState{..} =- return WBuilderState- { wbsDataReversed = WBuilderDataHeader : wbsDataReversed- , wbsOffset = wbsOffset + headerSize elfClass- , ..- }- elf2WBuilder' ElfSectionTable s = do- WBuilderState{..} <- alignWord s- return WBuilderState- { wbsDataReversed = WBuilderDataSectionTable : wbsDataReversed- , wbsOffset = wbsOffset + (sectionN + 1) * sectionTableEntrySize elfClass- , wbsShOff = wbsOffset- , ..- }- elf2WBuilder' ElfSegmentTable s = do- WBuilderState{..} <- alignWord s- return WBuilderState- { wbsDataReversed = WBuilderDataSegmentTable : wbsDataReversed- , wbsOffset = wbsOffset + segmentN * segmentTableEntrySize elfClass- , wbsPhOff = wbsOffset- , ..- }- elf2WBuilder' ElfSection{esFlags = ElfSectionFlag f, ..} s = do- when (f .&. fromIntegral (complement (maxBound @(WordXX a))) /= 0)- ($chainedError $ "section flags at section " ++ show esN ++ "don't fit")- -- I don't see any sense in aligning NOBITS sections+ lastSectionIsEmpty :: ElfListXX a -> Bool+ lastSectionIsEmpty l = lastSection l f False+ where+ f ElfSection { .. } = dataIsEmpty esData+ f _ = False++ elf2WBuilder :: (MonadThrow n, MonadState (WBuilderState a) n) => ElfXX t a -> n ()+ elf2WBuilder ElfHeader{} = do+ -- FIXME: add push monad+ wbsDataReversed %= (WBuilderDataHeader :)+ wbsOffset += headerSize elfClass+ elf2WBuilder ElfSectionTable = do+ alignWord+ use wbsOffset >>= assign wbsShOff+ wbsDataReversed %= (WBuilderDataSectionTable :)+ wbsOffset += (sectionN + 1) * sectionTableEntrySize elfClass+ elf2WBuilder ElfSegmentTable = do+ alignWord+ use wbsOffset >>= assign wbsPhOff+ wbsDataReversed %= (WBuilderDataSegmentTable :)+ wbsOffset += segmentN * segmentTableEntrySize elfClass+ elf2WBuilder ElfSection{esFlags = ElfSectionFlag f, ..} = do+ when (f .&. fromIntegral (complement (maxBound @(WordXX a))) /= 0) do+ $chainedError $ "section flags at section " ++ show esN ++ "don't fit"+ -- I don't see any sense in aligning NOBITS section data -- still gcc does it for .o files- WBuilderState{..} <- if esType == SHT_NOBITS && (ehType header') /= ET_REL- then return s- else align 0 esAddrAlign s+ when (esType /= SHT_NOBITS || (ehType header') == ET_REL) do+ align 0 esAddrAlign+ (n, ns) <- uses wbsNameIndexes \case+ n' : ns' -> (n', ns')+ _ -> error "internal error: different number of sections in two iterations"+ shStrNdx' <- use wbsShStrNdx let (d, shStrNdx, sz) = case esData of- ElfSectionData { .. } -> (esdData, wbsShStrNdx, fromIntegral $ BSL.length esdData)+ ElfSectionData { .. } -> (esdData, shStrNdx', fromIntegral $ BSL.length esdData) ElfSectionDataStringTable -> (stringTable, esN, fromIntegral $ BSL.length stringTable)- ElfSectionDataNoBits { .. } -> (BSL.empty, wbsShStrNdx, esdSize)- (n, ns) = case wbsNameIndexes of- n' : ns' -> (n', ns')- _ -> error "internal error: different number of sections in two iterations"+ ElfSectionDataNoBits { .. } -> (BSL.empty, shStrNdx', esdSize) sName = fromIntegral n -- Word32 sType = esType -- ElfSectionType sFlags = fromIntegral f sAddr = esAddr -- WXX c- sOffset = wbsOffset -- WXX c sSize = sz -- WXX c sLink = esLink -- Word32 sInfo = esInfo -- Word32 sAddrAlign = esAddrAlign -- WXX c sEntSize = esEntSize -- WXX c- return WBuilderState- { wbsSections = (esN, SectionXX{..}) : wbsSections- , wbsDataReversed = WBuilderDataByteStream d : wbsDataReversed- , wbsOffset = wbsOffset + fromIntegral (BSL.length d)- , wbsShStrNdx = shStrNdx- , wbsNameIndexes = ns- , ..- }- elf2WBuilder' ElfSegment{..} s = do- s' <- align epVirtAddr epAlign s- let- offset = wbsOffset s'- WBuilderState{..} <- execStateT (mapM elf2WBuilder epData) s'+ sOffset <- use wbsOffset -- WXX c+ wbsSections %= ((esN, SectionXX { .. }) :)+ wbsDataReversed %= (WBuilderDataByteStream d :)+ wbsOffset += fromIntegral (BSL.length d)+ wbsShStrNdx .= shStrNdx+ wbsNameIndexes .= ns+ elf2WBuilder ElfSegment { .. } = do+ align epVirtAddr epAlign+ offset <- use wbsOffset+ void $ mapMElfList elf2WBuilder epData+ offset' <- use wbsOffset let -- allocate one more byte in the end of segment if there exists an empty section -- at the end so that that empty section will go to the current segment- add1 = lastSectionIsEmpty epData && offset /= wbsOffset+ add1 = lastSectionIsEmpty epData && offset /= offset' pType = epType pFlags = epFlags pOffset = offset pVirtAddr = epVirtAddr pPhysAddr = epPhysAddr- pFileSize = wbsOffset - offset + if add1 then 1 else 0+ pFileSize = offset' - offset + if add1 then 1 else 0 pMemSize = pFileSize + epAddMemSize pAlign = epAlign- return WBuilderState- { wbsSegmentsReversed = SegmentXX{..} : wbsSegmentsReversed- , wbsDataReversed = if add1- then WBuilderDataByteStream (BSL.singleton 0) : wbsDataReversed- else wbsDataReversed- , wbsOffset = if add1- then wbsOffset + 1- else wbsOffset- , ..- }- elf2WBuilder' ElfRawData{..} WBuilderState{..} =- return WBuilderState- { wbsDataReversed = WBuilderDataByteStream edData : wbsDataReversed- , wbsOffset = wbsOffset + fromIntegral (BSL.length edData)- , ..- }- elf2WBuilder' ElfRawAlign{..} s = align eaOffset eaAlign s-- elf2WBuilder :: (MonadThrow n, MonadState (WBuilderState a) n) => ElfXX a -> n ()- elf2WBuilder elf = MS.get >>= elf2WBuilder' elf >>= MS.put+ wbsSegmentsReversed %= (SegmentXX { .. } :)+ when add1 do+ wbsDataReversed %= (WBuilderDataByteStream (BSL.singleton 0) :)+ wbsOffset += 1+ elf2WBuilder ElfRawData { .. } = do+ wbsDataReversed %= (WBuilderDataByteStream edData :)+ wbsOffset += fromIntegral (BSL.length edData)+ elf2WBuilder ElfRawAlign { .. } = align eaOffset eaAlign fixSections :: [(ElfSectionIndex, SectionXX a)] -> m [SectionXX a] fixSections ss = do@@ -880,7 +881,7 @@ wbState2ByteString :: WBuilderState a -> m BSL.ByteString wbState2ByteString WBuilderState{..} = do - sections <- fixSections wbsSections+ sections <- fixSections _wbsSections let f WBuilderDataHeader =@@ -893,33 +894,32 @@ hType = ehType hMachine = ehMachine hEntry = ehEntry- hPhOff = wbsPhOff- hShOff = wbsShOff+ hPhOff = _wbsPhOff+ hShOff = _wbsShOff hFlags = ehFlags hPhEntSize = segmentTableEntrySize elfClass- hPhNum = segmentN+ hPhNum = segmentN :: Word16 hShEntSize = sectionTableEntrySize elfClass- hShNum = if sectionTable then sectionN + 1 else 0- hShStrNdx = wbsShStrNdx+ hShNum = (if sectionTable then sectionN + 1 else 0) :: Word16+ hShStrNdx = _wbsShStrNdx h :: Header h = sing @a :&: HeaderXX{..} in encode h- _ -> error "this should be ElfHeader" -- FIXME f WBuilderDataByteStream {..} = wbdData f WBuilderDataSectionTable =- serializeBList hData' $ zeroSection : sections+ serializeBList (ehData header') $ zeroSection : sections f WBuilderDataSegmentTable =- serializeBList hData' $ L.reverse wbsSegmentsReversed+ serializeBList (ehData header') $ L.reverse _wbsSegmentsReversed - return $ foldMap f $ L.reverse wbsDataReversed+ return $ foldMap f $ L.reverse _wbsDataReversed - execStateT (mapM elf2WBuilder elfs) wbStateInit{ wbsNameIndexes = nameIndexes } >>= wbState2ByteString+ execStateT (mapMElfList elf2WBuilder elfs) wbStateInit{ _wbsNameIndexes = nameIndexes } >>= wbState2ByteString -- | Serialze ELF file-serializeElf :: MonadThrow m => Elf -> m BSL.ByteString-serializeElf (classS :&: ElfList ls) = withElfClass classS serializeElf' ls+serializeElf :: MonadCatch m => Elf -> m BSL.ByteString+serializeElf (classS :&: ls) = withElfClass classS serializeElf' ls ------------------------------------------------------------------------------- --@@ -956,19 +956,24 @@ -- | Parse symbol table parseSymbolTable :: (MonadThrow m, SingI a) => ElfData -- ^ Endianness of the ELF file- -> ElfXX a -- ^ Parsed section such that @`sectionIsSymbolTable` . `sType`@ is true.- -> [ElfXX a] -- ^ Structured ELF data+ -> ElfXX 'Section a -- ^ Parsed section such that @`sectionIsSymbolTable` . `sType`@ is true.+ -> ElfListXX a -- ^ Structured ELF data -> m [ElfSymbolXX a] -- ^ Symbol table-parseSymbolTable d ElfSection{ esData = ElfSectionData symbolTable, ..} elfs = do+parseSymbolTable d symbolTableSection@(ElfSection { .. }) elfs = do++ symbolTable <- case symbolTableSection of+ ElfSection{ esData = ElfSectionData st } -> return st+ _ -> $chainedError "wrong symbol table section data"+ section <- elfFindSection elfs esLink- case section of- ElfSection{ esData = ElfSectionData stringTable } -> do- st <- parseBList d symbolTable- return (mkElfSymbolTableEntry stringTable <$> st)- _ -> $chainedError "not a section" -- FIXME-parseSymbolTable _ _ _ = $chainedError "incorrect args to parseSymbolTable" -- FIXME+ stringTable <- case section of+ ElfSection{ esData = ElfSectionData st } -> return st+ _ -> $chainedError "wrong string table section data" -mkSymbolTableEntry :: SingI a => Word32 -> ElfSymbolXX a -> SymbolXX a+ st <- parseBList d symbolTable+ return (mkElfSymbolTableEntry stringTable <$> st)++mkSymbolTableEntry :: Word32 -> ElfSymbolXX a -> SymbolXX a mkSymbolTableEntry nameIndex ElfSymbolXX{..} = let ElfSymbolBinding b = steBind@@ -976,7 +981,7 @@ stName = nameIndex stInfo = b `shift` 4 .|. t- stOther = 0+ stOther = 0 :: Word8 stShNdx = steShNdx stValue = steValue stSize = steSize@@ -994,7 +999,7 @@ (stringTable, stringIndexes) = mkStringTable $ fmap steName ss ssWithNameIndexes = L.zip ss stringIndexes - f :: SingI a => (ElfSymbolXX a, Int64) -> SymbolXX a+ f :: (ElfSymbolXX a, Int64) -> SymbolXX a f (s, n) = mkSymbolTableEntry (fromIntegral n) s symbolTable = serializeBList d $ fmap f ssWithNameIndexes
src/Data/Interval.hs view
@@ -9,7 +9,7 @@ data Interval a = I { offset :: !a, size :: !a } -instance (Ord a, Eq a, Num a) => Eq (Interval a) where+instance (Ord a, Num a) => Eq (Interval a) where (==) (I o1 s1) (I o2 s2) | s1 > 0 && s2 > 0 = o1 == o2 && s1 == s2 | s1 <= 0 && s2 <= 0 = o1 == o2 | otherwise = False