Section.hsc

-- This file is part of Bindings-bfd.
--
-- Copyright (C) 2010 Michael Nelson
--
-- Bindings-bfd is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Lesser General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- Bindings-bfd is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU Lesser General Public License for more details.

-- You should have received a copy of the GNU Lesser General Public License
-- along with Bindings-bfd.  If not, see <http://www.gnu.org/licenses/>.

module Bindings.Bfd.Section (
   -- * Types
     Section
   , Section'
   , SectionName
   -- * Functions
   -- ** Creating
   , Bindings.Bfd.Section.mk
   -- ** Reading\/Writing
   , getAlignment
   , setAlignment
   , Bindings.Bfd.Section.getContents
   , Bindings.Bfd.Section.getFlags
   , getLimit
   , getLma
   , Bindings.Bfd.Section.getName
   , Bindings.Bfd.Section.setName
   , getNext
   , getRawsize
   , Bindings.Bfd.Section.getOutputSection
   , setOutputSection
   , getRelocatedContents
   , getRelocations
   , Bindings.Bfd.Section.getSize
   , Bindings.Bfd.Section.getSymbol
   , getVma
   , setVma
   -- ** Testing
   , isAbsolute
   , isCommon
   , isExterns
   , isUndefined
) where

import Data.Bits

import Foreign.C
import Foreign.Marshal
import Foreign.Ptr
import Foreign.Storable

import {-# SOURCE #-} Bindings.Bfd
import                Bindings.Bfd.LinkInfo      as LinkInfo
import                Bindings.Bfd.LinkOrder     as LinkOrder
import                Bindings.Bfd.Misc
import                Bindings.Bfd.Relocation
import                Bindings.Bfd.Section.Flags
import                Bindings.Bfd.Symbol
import                Bindings.Bfd.SymbolTable

#include <bfd.h>


type SectionName = String

type Contents  = String
type Contents' = Ptr CChar

type Section = Ptr Section'

data Section' = Name           SectionName
              | Next           Section
              | Flags          Int
              | Vma            Vma
              | Lma            Vma
              | Size           Size
              | Rawsize        Int
              | OutputSection  Section
              | AlignmentPower Int
              | Symbol         Symbol
     deriving (Show)

instance Storable Section' where
   sizeOf _ = #size struct bfd_section
   alignment = sizeOf
   peekByteOff buf off
      | off == (#offset struct bfd_section, name) =
         do
            name <- (#peek struct bfd_section, name) buf
            name' <- peekCString name
            return $ Bindings.Bfd.Section.Name name'
      | off == (#offset struct bfd_section, next) =
         do
            next <- (#peek struct bfd_section, next) buf
            return $ Next next
      | off == (#offset struct bfd_section, flags) =
         do
            flags <- (#peek struct bfd_section, flags) buf :: IO CUInt
            return $ Bindings.Bfd.Section.Flags $ fromIntegral flags
      | off == (#offset struct bfd_section, vma) =
         do
            vma <- (#peek struct bfd_section, vma) buf :: IO Vma'
            return $ Vma $ fromIntegral vma
      | off == (#offset struct bfd_section, lma) =
         do
            lma <- (#peek struct bfd_section, lma) buf :: IO Vma'
            return $ Lma $ fromIntegral lma
      | off == (#offset struct bfd_section, size) =
         do
            size <- (#peek struct bfd_section, size) buf :: IO Size'
            return $ Size $ fromIntegral size 
      | off == (#offset struct bfd_section, rawsize) =
         do
            rawsize <- (#peek struct bfd_section, rawsize) buf :: IO Size'
            return $ Rawsize $ fromIntegral rawsize     
      | off == (#offset struct bfd_section, alignment_power) =
         do
            ap <- (#peek struct bfd_section, alignment_power) buf
            return $ AlignmentPower ap
      | off == (#offset struct bfd_section, symbol) =
         do
            sym <- (#peek struct bfd_section, symbol) buf
            return $ Bindings.Bfd.Section.Symbol sym
      | otherwise = error $ "internal error: Bfd.Section'.peekByteOff " ++ show off
   pokeByteOff buf off val
      | off == (#offset struct bfd_section, name) =
         do
            cs <- newCString $ unSection'Name val
            (#poke struct bfd_section, name) buf cs
      | off == (#offset struct bfd_section, vma) =
         (#poke struct bfd_section, vma) buf (unSection'Vma val)
      | off == (#offset struct bfd_section, alignment_power) =
         (#poke struct bfd_section, alignment_power) buf (unSection'AlignmentPower val)
      | off == (#offset struct bfd_section, output_section) =
         (#poke struct bfd_section, output_section) buf (unSection'OutputSection val)
      | otherwise = error $ "internal error: Bfd.Section'.peekByteOff " ++ show off
   

mk 
   :: SectionName
   -> Int
   -> IO Section
mk name align =
   do
      sect <- malloc :: IO Section
      Bindings.Bfd.Section.setName sect name
      setAlignment sect align
      setVma sect 0
      return sect


getAlignment
   :: Section
   -> IO Int
getAlignment sect =
   do
      ap <- peekByteOff sect (#offset struct bfd_section, alignment_power)
      return $ unSection'AlignmentPower ap

setAlignment
   :: Section
   -> Int
   -> IO ()
setAlignment sect align = pokeByteOff sect (#offset struct bfd_section, alignment_power) (AlignmentPower align)

getContents
   :: Section
   -> Bfd
   -> FilePtr
   -> Size
   -> IO Contents
getContents sect bfd offset count = allocaArray count f
   where
      f ptr =
         do
            let
               offset' = fromIntegral offset
               count'  = fromIntegral count
            _ <- c_bfd_get_section_contents bfd sect ptr offset' count' -- FIXME: if not ok, throw exception
            peekCAStringLen (ptr, count)

getFlags
   :: Section
   -> IO [Flags]
getFlags sect =
   do
      flags <- peekByteOff sect (#offset struct bfd_section, flags)
      let
         flags' = filter f $ enumFrom Alloc
            where
               f e = unSection'Flags flags .&. (bit $ fromEnum e) /= 0
      return flags'

getLimit
   :: Section
   -> Bfd
   -> IO Int
getLimit sect bfd =
   do
      rs <- getRawsize sect
      case rs == 0 of
         True  ->
            do
               sz <- Bindings.Bfd.Section.getSize sect
               opb <- getOctetsPerByte bfd
               return $ sz `quot` opb
         False -> return rs

getLma
   :: Section
   -> IO Vma
getLma sect =
   do
      lma <- peekByteOff sect (#offset struct bfd_section, lma)
      return $ unSection'Lma lma

getName
   :: Section
   -> IO SectionName
getName sect =
   do
      n <- peekByteOff sect (#offset struct bfd_section, name)
      return $ unSection'Name n

setName
   :: Section
   -> SectionName
   -> IO ()
setName sect name = pokeByteOff sect (#offset struct bfd_section, name) (Bindings.Bfd.Section.Name name)

getNext
   :: Section
   -> IO Section
getNext sect =
   do
      s <- peekByteOff sect (#offset struct bfd_section, next)
      return $ unSection'Next s

getRawsize
   :: Section
   -> IO Size
getRawsize sect =
   do
      rs <- peekByteOff sect (#offset struct bfd_section, rawsize)
      return $ unSection'Rawsize rs

getOutputSection
   :: Section
   -> IO Section
getOutputSection sect =
   do
      os <- peekByteOff sect (#offset struct bfd_section, output_section)
      return $ unSection'OutputSection os

setOutputSection
   :: Section
   -> Section
   -> IO ()
setOutputSection sect1 sect2 = pokeByteOff sect1 (#offset struct bfd_section, output_section) (OutputSection sect2)

getRelocations
   :: Section
   -> Bfd
   -> SymbolTable
   -> IO [Relocation]
getRelocations sect bfd st =
   do
      bound <- c_bfd_get_reloc_upper_bound bfd sect
      let
         ptrs = fromIntegral bound `quot` (#const sizeof(arelent *))

      ppr <- mallocArray ptrs
      count <- c_bfd_canonicalize_reloc bfd sect ppr $ tablePtr st
      prs <- peekArray (fromIntegral count) ppr
      mapM peek prs

getRelocatedContents
   :: Section
   -> Bfd
   -> SymbolTable
   -> IO Contents
getRelocatedContents sect bfd syms =
   do
      count <- Bindings.Bfd.Section.getSize sect
      allocaArray count (f count)
   where
      f count ptr = 
         do
            let
               li  = nullPtr
               isR = fromBool False
            lo <- LinkOrder.mk sect
            setOutputSection sect sect
            buf <- c_bfd_get_relocated_section_contents bfd li lo ptr isR $ tablePtr syms
            case buf == nullPtr of
               True  -> error "bfd_get_relocated_section_contents failed"
               False -> peekCAStringLen (buf, count)

getSize
   :: Section
   -> IO Size
getSize sect = 
   do
      s <- peekByteOff sect (#offset struct bfd_section, size)
      return $ unSection'Size s

getSymbol
   :: Section
   -> IO Symbol
getSymbol sect =
   do
      sym <- peekByteOff sect (#offset struct bfd_section, symbol)
      return $ unSection'Symbol sym

getVma
   :: Section
   -> IO Vma
getVma sect =
   do
      s <- peekByteOff sect (#offset struct bfd_section, vma)
      return $ unSection'Vma s

setVma
   :: Section
   -> Vma
   -> IO ()
setVma sect vma = pokeByteOff sect (#offset struct bfd_section, vma) (Vma vma)


isAbsolute
   :: Section
   -> Bool
isAbsolute sect = sect == c_bfd_abs_section

isCommon
   :: Section
   -> IO Bool
isCommon sect =
   do
      flags <- Bindings.Bfd.Section.getFlags sect
      return $ IsCommon `elem` flags

isExterns
   :: Section
   -> IO Bool
isExterns sect =
   do
      n <- Bindings.Bfd.Section.getName sect
      return $ n == "externs"

isUndefined 
   :: Section
   -> Bool
isUndefined sect = sect == c_bfd_und_section

-- Given a section

createSection
   :: Section
   -> Vma
   -> IO (Vma, (Section, Vma))
createSection sect vma =
   do
      origVma <- getVma sect
      size    <- Bindings.Bfd.Section.getSize sect
      case origVma of
         0  -> 
            do
               align <- getAlignment sect
               let
                  vma' = alignToPower vma align
               setVma sect vma'
               return (vma' + size, (sect, vma'))
         _  -> return (origVma + size, (sect, origVma))


unSection'Name
   :: Section'
   -> SectionName
unSection'Name (Bindings.Bfd.Section.Name n) = n
unSection'Name x        = error $ "internal error: unSection'Name " ++ show x

unSection'Next
   :: Section'
   -> Section
unSection'Next (Next n) = n
unSection'Next x        = error $ "internal error: unSection'Next " ++ show x

unSection'Flags
   :: Section'
   -> Int
unSection'Flags (Bindings.Bfd.Section.Flags f) = f
unSection'Flags x         = error $ "internal error: unSection'Flags " ++ show x

unSection'Vma
   :: Section'
   -> Vma
unSection'Vma (Vma v) = v
unSection'Vma x       = error $ "internal error: unSection'Vma " ++ show x

unSection'Lma
   :: Section'
   -> Vma
unSection'Lma (Lma l) = l
unSection'Lma _       = error "unSection'Lma"

unSection'Size
   :: Section'
   -> Size
unSection'Size (Size s) = s
unSection'Size x        = error $ "internal error: unSection'Size " ++ show x

unSection'Rawsize
   :: Section'
   -> Size
unSection'Rawsize (Rawsize rs) = rs
unSection'Rawsize _            = error "unSection'Rawsize"

unSection'OutputSection
   :: Section'
   -> Section
unSection'OutputSection (OutputSection s) = s
unSection'OutputSection x                 = error $ "internal error: unSection'OutputSection " ++ show x

unSection'AlignmentPower
   :: Section'
   -> Int
unSection'AlignmentPower (AlignmentPower ap) = ap
unSection'AlignmentPower x                   = error $ "internal error: unSection'AlignmentPower " ++ show x

unSection'Symbol
   :: Section'
   -> Symbol
unSection'Symbol (Bindings.Bfd.Section.Symbol s) = s
unSection'Symbol x          = error $ "internal error: unSection'Symbol " ++ show x


foreign import ccall unsafe "bfd.h bfd_get_section_contents" c_bfd_get_section_contents
   :: Bfd
   -> Section
   -> Contents'
   -> FilePtr'
   -> Size'
   -> IO Bool

foreign import ccall unsafe "bfd.h bfd_get_reloc_upper_bound" c_bfd_get_reloc_upper_bound
   :: Bfd
   -> Section
   -> IO CLong

foreign import ccall unsafe "bfd.h bfd_canonicalize_reloc" c_bfd_canonicalize_reloc
   :: Bfd
   -> Section
   -> Ptr (Ptr Relocation)
   -> Ptr Symbol
   -> IO CLong

foreign import ccall unsafe "bfd.h bfd_get_relocated_section_contents" c_bfd_get_relocated_section_contents
   :: Bfd
   -> LinkInfo
   -> LinkOrder
   -> Contents'
   -> Bool'
   -> Ptr Symbol
   -> IO Contents'

foreign import ccall unsafe "bfd.h &bfd_und_section" c_bfd_und_section
   :: Section

foreign import ccall unsafe "bfd.h &bfd_abs_section" c_bfd_abs_section
   :: Section