Target.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/>.

-- | The "Target" represents a particular back-end used to interpret the Binary
-- File Descriptor (BFD).  A 'Bfd' handle will be associated with exactly one
-- 'Target' as set in the 'open' function.
module Bindings.Bfd.Target (
   -- * Types
     Target
   , TargetName
   -- * Platform
   , listSupported
   , find
   , setDefault
   -- * Attributes
   , getFlavour
   , getName
   -- ** Byte Order
   , getByteorder
   , getHeaderByteorder
   -- ** Flags
   , getObjectFlags
   , getSectionFlags
   -- * Testing
   , isCoffFamily
   -- ** Byte Order
   , isBigEndian
   , isLittleEndian
   , isHeaderBigEndian
   , isHeaderLittleEndian
   -- * Internal
   , Target'
   , unTarget'CanonicalizeDynamicReloc
   , unTarget'CanonicalizeDynamicSymtab
   , unTarget'CanonicalizeSymtab
   , unTarget'GetDynamicRelocUpperBound
   , unTarget'GetDynamicSymtabUpperBound
   , unTarget'GetSymtabUpperBound
   , unTarget'GetSyntheticSymtab
   , unTarget'PrintSymbol
) where

import Data.Bits ( (.&.), bit )
import Data.Word ( Word )

import Foreign.C        ( CInt, CLong, CString, CUInt, newCString, peekCString
                        , withCString )
import Foreign.Marshal  ( free, peekArray0, toBool )
import Foreign.Ptr      ( FunPtr, Ptr, castPtrToFunPtr, nullPtr, wordPtrToPtr )
import Foreign.Storable ( Storable, alignment, peekByteOff, sizeOf )

import {-# SOURCE #-} Bindings.Bfd                               ( Bfd, Bfd'
                                                                 , ptr )
import                Bindings.Bfd.Endian                        ( Endian(..) )
import                Bindings.Bfd.Exception                     ( throwExceptionIfFalse)
import                Bindings.Bfd.Flags         as BfdFlags     ( Flags(HasReloc) )
import                Bindings.Bfd.Flavour                       ( Flavour(Coff, Xcoff) )
import                Bindings.Bfd.Misc                          ( File )
import {-# SOURCE #-} Bindings.Bfd.Relocation                    ( Relocation )
import                Bindings.Bfd.Section.Flags as SectionFlags ( Flags(Alloc) ) 
import {-# SOURCE #-} Bindings.Bfd.Symbol        as Symbol       ( Symbol )

#include <bfd.h>


-- ### PUBLIC ##################################################################

-- === Types ===================================================================

type Target = Ptr Target'

type TargetName = String


-- --- Platform and Bfd ========================================================

-- | Returns the /Platform Target List/; that is, the target names that are 
-- supported by the platform that /libbfd/ was compiled for.
listSupported
   :: IO [TargetName]
listSupported = 
   do
      let
         pts = c_bfd_target_list
      ps <- peekArray0 nullPtr pts
      res <- mapM peekCString ps
      free pts                       -- FIXME is this dodgy?
      return res

-- | Returns a handle to the target named 'TargetName'.  If /target/ is 
-- 'Nothing', choose the one in the environment variable /GNUTARGET/; if that is
-- null or not defined, then choose the first entry in the /Platform Target List/
-- (see 'listSupported').
-- 
-- Passing the 'String' \"default\" as /target/ or setting the environment
-- variable to \"default\" will cause the /Default Target/ to be returned (see 
-- 'setDefault'), and the fact that the target is defaulted will be set in the
-- BFD if /bfd/ isn't 'Nothing'.  This will cause 'checkFormat' to loop over all
-- the targets to find the one that matches the file being read.
find
   :: Maybe TargetName -- ^ target
   -> Maybe Bfd        -- ^ bfd
   -> IO Target
find mbTarg mbBfd =
   do
      targ <- maybe (return nullPtr) (\t -> newCString t) mbTarg
      let
         bfd = maybe nullPtr (\b -> ptr b) mbBfd
      r <- c_bfd_find_target targ bfd
      free targ
      return r

-- | Set the /Default Target/ for use when 'TargetName' is equal to \"default\"
-- or 'Nothing' in the 'find' and 'open' functions.
--
-- /Possible exceptions:/ 'InvalidTarget'
setDefault
   :: TargetName
   -> IO ()
setDefault tn =
   do
      r <- withCString tn (\s -> c_bfd_set_default_target s)
      _ <- throwExceptionIfFalse "setDefault" tn (return $ toBool r)
      return ()


-- === Attributes ==============================================================

getFlavour
   :: Target
   -> IO Flavour
getFlavour targ =
   do
      flav <- peekByteOff targ (#offset struct bfd_target, flavour)
      return $ unTarget'Flavour flav

getName
   :: Target
   -> IO TargetName
getName targ =
   do
      tn <- peekByteOff targ (#offset struct bfd_target, name)
      let
         tn' = unTarget'Name tn
      return tn'

-- Byte Order ------------------------------------------------------------------

getByteorder
   :: Target
   -> IO Endian
getByteorder targ =
   do
      bo <- peekByteOff targ (#offset struct bfd_target, byteorder)
      return $ unTarget'Byteorder bo

getHeaderByteorder
   :: Target
   -> IO Endian
getHeaderByteorder targ =
   do
      bo <- peekByteOff targ (#offset struct bfd_target, header_byteorder)
      return $ unTarget'HeaderByteorder bo

-- Flags -----------------------------------------------------------------------

getObjectFlags
   :: Target
   -> IO [BfdFlags.Flags]
getObjectFlags targ =
   do
      f <- peekByteOff targ (#offset struct bfd_target, object_flags)
      return $ unTarget'ObjectFlags f

getSectionFlags
   :: Target
   -> IO [SectionFlags.Flags]
getSectionFlags targ =
   do
      f <- peekByteOff targ (#offset struct bfd_target, section_flags)
      return $ unTarget'SectionFlags f

-- Testing =====================================================================

-- | Returns 'True' if the 'Flavour' of the 'Target' is either 'Coff' or 'Xcoff'.
--  Otherwise 'False'.
isCoffFamily
   :: Target
   -> IO Bool
isCoffFamily targ =
   do
      flav <- getFlavour targ
      return $ flav == Coff || flav == Xcoff

-- Byte Order ------------------------------------------------------------------

-- | Returns 'True' if the 'Target's byte order (see 'getByteorder') is 'Big'.
-- Otherwise 'False'.
isBigEndian
   :: Target
   -> IO Bool
isBigEndian targ =
   do
      bo <- getByteorder targ
      return $ bo == Big

-- | Returns 'True' if the 'Target's byte order (see 'getByteorder') is 'Little'.
-- Otherwise 'False'.
isLittleEndian
   :: Target
   -> IO Bool
isLittleEndian targ =
   do
      bo <- getByteorder targ
      return $ bo == Little

-- | Returns 'True' if the 'Target's header byte order (see 'getHeaderByteOrder')
-- is 'Big'.  Otherwise 'False'.
isHeaderBigEndian
   :: Target
   -> IO Bool
isHeaderBigEndian targ =
   do
      bo <- getHeaderByteorder targ
      return $ bo == Big

-- | Returns 'True' if the 'Target's header byte order (see 'getHeaderByteOrder')
-- is 'Little'.  Otherwise 'False'.
isHeaderLittleEndian
   :: Target
   -> IO Bool
isHeaderLittleEndian targ =
   do
      bo <- getHeaderByteorder targ
      return $ bo == Little

-- Internal ====================================================================

data Target' = Name                       TargetName
             | Flavour                    Flavour
             | Byteorder                  Endian
             | HeaderByteorder            Endian
             | ObjectFlags                [BfdFlags.Flags]
             | SectionFlags               [SectionFlags.Flags]
             | GetSymtabUpperBound        (FunPtr (Ptr Bfd' -> IO CLong))
             | CanonicalizeSymtab         (FunPtr (Ptr Bfd' -> Ptr Symbol -> IO CLong))
             | PrintSymbol                (FunPtr (Ptr Bfd' -> File -> Symbol -> CUInt -> IO ()))
             | GetDynamicSymtabUpperBound (FunPtr (Ptr Bfd' -> IO CLong))
             | CanonicalizeDynamicSymtab  (FunPtr (Ptr Bfd' -> Ptr Symbol -> IO CLong))
             | GetSyntheticSymtab         (FunPtr (Ptr Bfd' -> CLong -> Ptr Symbol -> CLong -> Ptr Symbol -> Ptr Symbol -> IO CLong))
             | GetDynamicRelocUpperBound  (FunPtr (Ptr Bfd' -> IO CLong))
             | CanonicalizeDynamicReloc   (FunPtr (Ptr Bfd' -> Ptr (Ptr Relocation) -> Ptr Symbol -> IO CLong))
     deriving (Show)

instance Storable Target' where
   sizeOf _ = #size struct bfd_target
   alignment = sizeOf
   peekByteOff buf off
      | off == (#offset struct bfd_target, name) =
         do
            val <- (#peek struct bfd_target, name) buf
            s   <- peekCString val
            return $ Bindings.Bfd.Target.Name s
      | off == (#offset struct bfd_target, flavour) =
         do
            val <- (#peek struct bfd_target, flavour) buf :: IO CUInt
            return $ Flavour $ toEnum $ fromIntegral val
      | off == (#offset struct bfd_target, byteorder) =
         do
            val <- (#peek struct bfd_target, byteorder) buf :: IO CUInt
            return $ Byteorder $ toEnum $ fromIntegral val
      | off == (#offset struct bfd_target, header_byteorder) =
         do
            val <- (#peek struct bfd_target, header_byteorder) buf :: IO CUInt
            return $ HeaderByteorder $ toEnum $ fromIntegral val
      | off == (#offset struct bfd_target, object_flags) =
         do
            val <- (#peek struct bfd_target, object_flags) buf :: IO CUInt
            let
               flags = filter f $ enumFrom HasReloc
                  where
                     f e = val .&. (bit $ fromEnum e) /= 0
            return $ ObjectFlags flags
      | off == (#offset struct bfd_target, section_flags) =
         do
            val <- (#peek struct bfd_target, section_flags) buf :: IO CUInt
            let
               flags = filter f $ enumFrom Alloc
                  where
                     f e = val .&. (bit $ fromEnum e) /= 0
            return $ SectionFlags flags
      | off == (#offset struct bfd_target, _bfd_get_symtab_upper_bound) =
         do
            val <- (#peek struct bfd_target, _bfd_get_symtab_upper_bound) buf :: IO Word
            return $ GetSymtabUpperBound $ castPtrToFunPtr $ wordPtrToPtr $ fromIntegral val
      | off == (#offset struct bfd_target, _bfd_canonicalize_symtab) =
         do
            val <- (#peek struct bfd_target, _bfd_canonicalize_symtab) buf :: IO Word
            return $ CanonicalizeSymtab $ castPtrToFunPtr $ wordPtrToPtr $ fromIntegral val
      | off == (#offset struct bfd_target, _bfd_print_symbol) =
         do
            val <- (#peek struct bfd_target, _bfd_print_symbol) buf :: IO Word
            return $ PrintSymbol $ castPtrToFunPtr $ wordPtrToPtr $ fromIntegral val
      | off == (#offset struct bfd_target, _bfd_get_dynamic_symtab_upper_bound) =
         do
            val <- (#peek struct bfd_target, _bfd_get_dynamic_symtab_upper_bound) buf :: IO Word
            return $ GetDynamicSymtabUpperBound $ castPtrToFunPtr $ wordPtrToPtr $ fromIntegral val
      | off == (#offset struct bfd_target, _bfd_canonicalize_dynamic_symtab) =
         do
            val <- (#peek struct bfd_target, _bfd_canonicalize_dynamic_symtab) buf :: IO Word
            return $ CanonicalizeDynamicSymtab $ castPtrToFunPtr $ wordPtrToPtr $ fromIntegral val
      | off == (#offset struct bfd_target, _bfd_get_synthetic_symtab) =
         do
            val <- (#peek struct bfd_target, _bfd_get_synthetic_symtab) buf :: IO Word
            return $ GetSyntheticSymtab $ castPtrToFunPtr $ wordPtrToPtr $ fromIntegral val
      | off == (#offset struct bfd_target, _bfd_get_dynamic_reloc_upper_bound) =
         do
            val <- (#peek struct bfd_target, _bfd_get_dynamic_reloc_upper_bound) buf :: IO Word
            return $ GetDynamicRelocUpperBound $ castPtrToFunPtr $ wordPtrToPtr $ fromIntegral val
      | off == (#offset struct bfd_target, _bfd_canonicalize_dynamic_reloc) =
         do
            val <- (#peek struct bfd_target, _bfd_canonicalize_dynamic_reloc) buf :: IO Word
            return $ CanonicalizeDynamicReloc $ castPtrToFunPtr $ wordPtrToPtr $ fromIntegral val
      | otherwise = error $ "internal error: Bfd.Target.peekByteOff " ++ show off

unTarget'CanonicalizeDynamicReloc
   :: Target'
   -> FunPtr (Ptr Bfd' -> Ptr (Ptr Relocation) -> Ptr Symbol -> IO CLong)
unTarget'CanonicalizeDynamicReloc (CanonicalizeDynamicReloc fn) = fn
unTarget'CanonicalizeDynamicReloc _                             = error "unTarget'CanonicalizeDynamicReloc"

unTarget'CanonicalizeDynamicSymtab
   :: Target'
   -> FunPtr (Ptr Bfd' -> Ptr Symbol -> IO CLong)
unTarget'CanonicalizeDynamicSymtab (CanonicalizeDynamicSymtab fn) = fn
unTarget'CanonicalizeDynamicSymtab _                              = error "unTarget'CanonicalizeDynamicSymtab"

unTarget'CanonicalizeSymtab
   :: Target'
   -> FunPtr (Ptr Bfd' -> Ptr Symbol -> IO CLong)
unTarget'CanonicalizeSymtab (CanonicalizeSymtab fn) = fn
unTarget'CanonicalizeSymtab _                       = error "unTarget'CanonicalizeSymtab"

unTarget'GetDynamicRelocUpperBound
   :: Target'
   -> FunPtr (Ptr Bfd' -> IO CLong)
unTarget'GetDynamicRelocUpperBound (GetDynamicRelocUpperBound fn) = fn
unTarget'GetDynamicRelocUpperBound _                              = error "unTarget'GetDynamicRelocUpperBound"

unTarget'GetDynamicSymtabUpperBound
   :: Target'
   -> FunPtr (Ptr Bfd' -> IO CLong)
unTarget'GetDynamicSymtabUpperBound (GetDynamicSymtabUpperBound fn) = fn
unTarget'GetDynamicSymtabUpperBound _                               = error "unTarget'GetDynamicSymtabUpperBound"

unTarget'GetSymtabUpperBound
   :: Target'
   -> FunPtr (Ptr Bfd' -> IO CLong)
unTarget'GetSymtabUpperBound (GetSymtabUpperBound fn) = fn
unTarget'GetSymtabUpperBound _                        = error "unTarget'GetSymtabUpperBound"

unTarget'GetSyntheticSymtab
   :: Target'
   -> FunPtr (Ptr Bfd' -> CLong -> Ptr Symbol -> CLong -> Ptr Symbol -> Ptr Symbol -> IO CLong)
unTarget'GetSyntheticSymtab (GetSyntheticSymtab fn) = fn
unTarget'GetSyntheticSymtab _                       = error "unTarget'GetSyntheticSymtab"

unTarget'PrintSymbol
   :: Target'
   -> FunPtr (Ptr Bfd' -> File -> Symbol -> CUInt -> IO ())
unTarget'PrintSymbol (PrintSymbol fn) = fn
unTarget'PrintSymbol x                = error $ "internal error: unXVec2 " ++ show x

-- PRIVATE #####################################################################

unTarget'Name
   :: Target'
   -> TargetName
unTarget'Name (Bindings.Bfd.Target.Name s) = s
unTarget'Name _                            = error "unTarget'Name"

unTarget'Flavour
   :: Target'
   -> Flavour
unTarget'Flavour (Flavour f) = f
unTarget'Flavour _           = error "unTarget'Flavour"

unTarget'Byteorder
   :: Target'
   -> Endian
unTarget'Byteorder (Byteorder b) = b
unTarget'Byteorder _             = error "unTarget'Byteorder"

unTarget'HeaderByteorder
   :: Target'
   -> Endian
unTarget'HeaderByteorder (HeaderByteorder b) = b
unTarget'HeaderByteorder _                   = error "unTarget'HeaderByteorder"

unTarget'ObjectFlags
   :: Target'
   -> [BfdFlags.Flags]
unTarget'ObjectFlags (ObjectFlags b) = b
unTarget'ObjectFlags _               = error "unTarget'ObjectFlags"

unTarget'SectionFlags
   :: Target'
   -> [SectionFlags.Flags]
unTarget'SectionFlags (SectionFlags b) = b
unTarget'SectionFlags _                = error "unTarget'SectionFlags"

-- Foreign ---------------------------------------------------------------------

foreign import ccall unsafe "bfd.h bfd_target_list" c_bfd_target_list
   :: Ptr CString

foreign import ccall unsafe "bfd.h bfd_find_target" c_bfd_find_target
   :: CString
   -> Ptr Bfd'
   -> IO Target

foreign import ccall unsafe "bfd.h bfd_set_default_target" c_bfd_set_default_target
   :: CString
   -> IO CInt