{-# LANGUAGE BangPatterns #-}
{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}

{-# OPTIONS -w #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details

module ByteCodeLink ( 
	HValue, 
	ClosureEnv, emptyClosureEnv, extendClosureEnv,
	linkBCO, lookupStaticPtr, lookupName
       ,lookupIE
  ) where

#include "HsVersions.h"

import ByteCodeItbls
import ByteCodeAsm
import ObjLink

import Name
import NameEnv
import OccName
import PrimOp
import Module
import PackageConfig
import FastString
import Panic
import Outputable

-- Standard libraries

import Data.Array.Base

import Control.Monad	( zipWithM )
import Control.Monad.ST ( stToIO )

import GHC.Arr          ( Array(..), STArray(..) )
import GHC.Base		( writeArray#, RealWorld, Int(..), Word# )  
import GHC.IOBase	( IO(..) )
import GHC.Exts
import GHC.Ptr		( Ptr(..), castPtr )
import GHC.Word		( Word(..) )

import Data.Word

type ClosureEnv = NameEnv (Name, HValue)
newtype HValue = HValue Any

emptyClosureEnv = emptyNameEnv

extendClosureEnv :: ClosureEnv -> [(Name,HValue)] -> ClosureEnv
extendClosureEnv cl_env pairs
  = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs]

{- 
data BCO# = BCO# ByteArray# 		-- instrs   :: Array Word16#
                 ByteArray# 		-- literals :: Array Word32#
                 PtrArray# 		-- ptrs     :: Array HValue
                 ByteArray#		-- itbls    :: Array Addr#
-}

linkBCO :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO HValue
linkBCO ie ce ul_bco
   = do BCO bco# <- linkBCO' ie ce ul_bco
	-- SDM: Why do we need mkApUpd0 here?  I *think* it's because
	-- otherwise top-level interpreted CAFs don't get updated 
 	-- after evaluation.   A top-level BCO will evaluate itself and
	-- return its value when entered, but it won't update itself.
	-- Wrapping the BCO in an AP_UPD thunk will take care of the
	-- update for us.
	--
	-- Update: the above is true, but now we also have extra invariants:
	--   (a) An AP thunk *must* point directly to a BCO
	--   (b) A zero-arity BCO *must* be wrapped in an AP thunk
	--   (c) An AP is always fully saturated, so we *can't* wrap
	--       non-zero arity BCOs in an AP thunk.
	-- 
	if (unlinkedBCOArity ul_bco > 0) 
	   then return (unsafeCoerce# bco#)
	   else case mkApUpd0# bco# of { (# final_bco #) -> return final_bco }


linkBCO' :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO BCO
linkBCO' ie ce (UnlinkedBCO nm arity insns_barr bitmap literalsSS ptrsSS)
   -- Raises an IO exception on failure
   = do let literals = ssElts literalsSS
	    ptrs     = ssElts ptrsSS

        linked_literals <- mapM (lookupLiteral ie) literals

        let n_literals = sizeSS literalsSS
            n_ptrs     = sizeSS ptrsSS

        ptrs_arr <- if n_ptrs > 65535
                    then panic "linkBCO: >= 64k ptrs"
                    else mkPtrsArray ie ce (fromIntegral n_ptrs) ptrs

        let 
            !ptrs_parr = case ptrs_arr of Array _lo _hi _n parr -> parr

            litRange
             | n_literals > 65535 = panic "linkBCO: >= 64k literals"
             | n_literals > 0     = (0, fromIntegral n_literals - 1)
             | otherwise          = (1, 0)
            literals_arr :: UArray Word16 Word
            literals_arr = listArray litRange linked_literals
            !literals_barr = case literals_arr of UArray _lo _hi _n barr -> barr

	    !(I# arity#)  = arity

        newBCO insns_barr literals_barr ptrs_parr arity# bitmap


-- we recursively link any sub-BCOs while making the ptrs array
mkPtrsArray :: ItblEnv -> ClosureEnv -> Word16 -> [BCOPtr] -> IO (Array Word16 HValue)
mkPtrsArray ie ce n_ptrs ptrs = do
  let ptrRange = if n_ptrs > 0 then (0, n_ptrs-1) else (1, 0)
  marr <- newArray_ ptrRange
  let 
    fill (BCOPtrName n)     i = do
	ptr <- lookupName ce n
	unsafeWrite marr i ptr
    fill (BCOPtrPrimOp op)  i = do
 	ptr <- lookupPrimOp op
	unsafeWrite marr i ptr
    fill (BCOPtrBCO ul_bco) i = do
	BCO bco# <- linkBCO' ie ce ul_bco
	writeArrayBCO marr i bco#
    fill (BCOPtrBreakInfo brkInfo) i =                    
        unsafeWrite marr i (unsafeCoerce# brkInfo)
    fill (BCOPtrArray brkArray) i =                    
        unsafeWrite marr i (unsafeCoerce# brkArray)
  zipWithM fill ptrs [0..]
  unsafeFreeze marr

newtype IOArray i e = IOArray (STArray RealWorld i e)

instance MArray IOArray e IO where
    getBounds (IOArray marr) = stToIO $ getBounds marr
    getNumElements (IOArray marr) = stToIO $ getNumElements marr
    newArray lu init = stToIO $ do
        marr <- newArray lu init; return (IOArray marr)
    newArray_ lu = stToIO $ do
        marr <- newArray_ lu; return (IOArray marr)
    unsafeRead (IOArray marr) i = stToIO (unsafeRead marr i)
    unsafeWrite (IOArray marr) i e = stToIO (unsafeWrite marr i e)

-- XXX HACK: we should really have a new writeArray# primop that takes a BCO#.
writeArrayBCO :: IOArray Word16 a -> Int -> BCO# -> IO ()
writeArrayBCO (IOArray (STArray _ _ _ marr#)) (I# i#) bco# = IO $ \s# ->
  case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# ->
  (# s#, () #) }

{-
writeArrayMBA :: IOArray Int a -> Int -> MutableByteArray# a -> IO ()
writeArrayMBA (IOArray (STArray _ _ marr#)) (I# i#) mba# = IO $ \s# ->
  case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# ->
  (# s#, () #) }
-}

data BCO = BCO BCO#

newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO
newBCO instrs lits ptrs arity bitmap
   = IO $ \s -> case newBCO# instrs lits ptrs arity bitmap s of 
		  (# s1, bco #) -> (# s1, BCO bco #)


lookupLiteral :: ItblEnv -> BCONPtr -> IO Word
lookupLiteral ie (BCONPtrWord lit) = return lit
lookupLiteral ie (BCONPtrLbl  sym) = do Ptr a# <- lookupStaticPtr sym
			                return (W# (int2Word# (addr2Int# a#)))
lookupLiteral ie (BCONPtrItbl nm)  = do Ptr a# <- lookupIE ie nm
			                return (W# (int2Word# (addr2Int# a#)))

lookupStaticPtr :: FastString -> IO (Ptr ())
lookupStaticPtr addr_of_label_string 
   = do let label_to_find = unpackFS addr_of_label_string
        m <- lookupSymbol label_to_find 
        case m of
           Just ptr -> return ptr
           Nothing  -> linkFail "ByteCodeLink: can't find label" 
                                label_to_find

lookupPrimOp :: PrimOp -> IO HValue
lookupPrimOp primop
   = do let sym_to_find = primopToCLabel primop "closure"
        m <- lookupSymbol sym_to_find
        case m of
           Just (Ptr addr) -> case addrToHValue# addr of
                                 (# hval #) -> return hval
           Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find

lookupName :: ClosureEnv -> Name -> IO HValue
lookupName ce nm
   = case lookupNameEnv ce nm of
        Just (_,aa) -> return aa
        Nothing 
           -> ASSERT2(isExternalName nm, ppr nm)
	      do let sym_to_find = nameToCLabel nm "closure"
                 m <- lookupSymbol sym_to_find
                 case m of
                    Just (Ptr addr) -> case addrToHValue# addr of
                                          (# hval #) -> return hval
                    Nothing         -> linkFail "ByteCodeLink.lookupCE" sym_to_find

lookupIE :: ItblEnv -> Name -> IO (Ptr a)
lookupIE ie con_nm 
   = case lookupNameEnv ie con_nm of
        Just (_, a) -> return (castPtr (itblCode a))
        Nothing
           -> do -- try looking up in the object files.
                 let sym_to_find1 = nameToCLabel con_nm "con_info"
                 m <- lookupSymbol sym_to_find1
                 case m of
                    Just addr -> return addr
                    Nothing 
                       -> do -- perhaps a nullary constructor?
                             let sym_to_find2 = nameToCLabel con_nm "static_info"
                             n <- lookupSymbol sym_to_find2
                             case n of
                                Just addr -> return addr
                                Nothing   -> linkFail "ByteCodeLink.lookupIE" 
                                                (sym_to_find1 ++ " or " ++ sym_to_find2)

linkFail :: String -> String -> IO a
linkFail who what
   = ghcError (ProgramError $
        unlines [ ""
	        , "During interactive linking, GHCi couldn't find the following symbol:"
		, ' ' : ' ' : what 
		, "This may be due to you not asking GHCi to load extra object files,"
		, "archives or DLLs needed by your current session.  Restart GHCi, specifying"
		, "the missing library using the -L/path/to/object/dir and -lmissinglibname"
		, "flags, or simply by naming the relevant files on the GHCi command line."
		, "Alternatively, this link failure might indicate a bug in GHCi."
		, "If you suspect the latter, please send a bug report to:"
		, "  glasgow-haskell-bugs@haskell.org"
		])

-- HACKS!!!  ToDo: cleaner
nameToCLabel :: Name -> String{-suffix-} -> String
nameToCLabel n suffix
   = if pkgid /= mainPackageId
        then package_part ++ '_': qual_name
        else qual_name
  where
        pkgid = modulePackageId mod
        mod = ASSERT( isExternalName n ) nameModule n
        package_part = unpackFS (zEncodeFS (packageIdFS (modulePackageId mod)))
        module_part  = unpackFS (zEncodeFS (moduleNameFS (moduleName mod)))
        occ_part     = unpackFS (zEncodeFS (occNameFS (nameOccName n)))
        qual_name = module_part ++ '_':occ_part ++ '_':suffix


primopToCLabel :: PrimOp -> String{-suffix-} -> String
primopToCLabel primop suffix
   = let str = "ghczmprim_GHCziPrimopWrappers_" ++ unpackFS (zEncodeFS (occNameFS (primOpOcc primop))) ++ '_':suffix
     in --trace ("primopToCLabel: " ++ str)
        str