Section.hsc

-- This file is part of Bindings-bfd.
--
-- Copyright (C) 2010,2011 Mick Nelso
--
-- 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
   , SectionName
   -- * Functions
   -- ** Creating
   , Bindings.Bfd.Section.mk
   , Bindings.Bfd.Section.getContents
   -- * Flags
   , Bindings.Bfd.Section.getFlags
   -- * SectionName
   , Bindings.Bfd.Section.setName
   , Bindings.Bfd.Section.getName
   , getNext
   -- * Section Size
   , Bindings.Bfd.Section.getSize
   , getRawsize
   , getLimit
   , Bindings.Bfd.Section.getOutputSection
   , setOutputSection
   , getRelocatedContents
   , getRelocations
   , Bindings.Bfd.Section.getSymbol
   -- * Addressing
   , setVma
   , getVma
   , getLma
   , setAlignment
   , getAlignment
   -- ** Testing
   , isAbsolute
   , isCommon
   , isExterns
   , externsName
   , isUndefined
   -- * Internal
   , Section'
) 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, lma) =
         (#poke struct bfd_section, lma) 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


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

-- -----------------------------------------------------------------------------

-- | Returns a list of the 'Section's 'Flags'.
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'

-- -----------------------------------------------------------------------------

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

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

-- -----------------------------------------------------------------------------

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

-- -----------------------------------------------------------------------------

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

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

-- | If the raw size (see 'getRawSize') is not zero then return the raw size.
-- Otherwise return the division of the size (see 'getSize') by the octets per 
-- byte (see 'getOctetsPerByte').
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

-- -----------------------------------------------------------------------------

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 (ptr bfd) sect
      let
         ptrs = fromIntegral bound `quot` (#const sizeof(arelent *))

      ppr <- mallocArray ptrs
      count <- c_bfd_canonicalize_reloc (ptr 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 p = 
         do
            let
               li  = nullPtr
               isR = fromBool False
            lo <- LinkOrder.mk sect
            setOutputSection sect sect
            buf <- c_bfd_get_relocated_section_contents (ptr bfd) li lo p isR $ tablePtr syms
            case buf == nullPtr of
               True  -> error "bfd_get_relocated_section_contents failed"
               False -> peekCAStringLen (buf, count)

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

-- -----------------------------------------------------------------------------

-- | Sets both the VMA and LMA of the 'Section' to the given 'Vma' and sets the
-- 'Section's /user_set_vma/ flag to 'True'.
setVma
   :: Section
   -> Vma
   -> IO ()
setVma sect vma = 
   do
      pokeByteOff sect (#offset struct bfd_section, vma) (Vma vma)
      pokeByteOff sect (#offset struct bfd_section, lma) (Vma vma)
      c__section_poke_user_set_vma sect 1

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

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

-- | Sets the alignment power of the 'Section'.
setAlignment
   :: Section
   -> Int
   -> IO ()
setAlignment sect align = pokeByteOff sect (#offset struct bfd_section, alignment_power) (AlignmentPower align)

-- | Returns the alignment power of the 'Section'.
getAlignment
   :: Section
   -> IO Int
getAlignment sect =
   do
      ap <- peekByteOff sect (#offset struct bfd_section, alignment_power)
      return $ unSection'AlignmentPower ap

-- -----------------------------------------------------------------------------

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

-- | Return 'True' if 'IsCommon' is found in the 'Section's 'Flags'.
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 == externsName

externsName
   :: String
externsName = "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
   :: Ptr Bfd'
   -> Section
   -> Contents'
   -> FilePtr'
   -> Size'
   -> IO Bool

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

foreign import ccall unsafe "bfd.h bfd_canonicalize_reloc" c_bfd_canonicalize_reloc
   :: Ptr 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
   :: Ptr 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

foreign import ccall unsafe "section.h _section_poke_user_set_vma" c__section_poke_user_set_vma
   :: Section
   -> CInt
   -> IO ()