projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
fix haddock submodule pointer
[ghc-hetmet.git]
/
compiler
/
ghci
/
ByteCodeAsm.lhs
diff --git
a/compiler/ghci/ByteCodeAsm.lhs
b/compiler/ghci/ByteCodeAsm.lhs
index
e842bf7
..
af9fbe9
100644
(file)
--- a/
compiler/ghci/ByteCodeAsm.lhs
+++ b/
compiler/ghci/ByteCodeAsm.lhs
@@
-6,6
+6,7
@@
ByteCodeLink: Bytecode assembler and linker
\begin{code}
{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
\begin{code}
{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
+{-# LANGUAGE BangPatterns #-}
module ByteCodeAsm (
assembleBCOs, assembleBCO,
module ByteCodeAsm (
assembleBCOs, assembleBCO,
@@
-23,14
+24,15
@@
import ByteCodeItbls
import Name
import NameSet
import Name
import NameSet
-import FiniteMap
import Literal
import TyCon
import PrimOp
import Constants
import FastString
import SMRep
import Literal
import TyCon
import PrimOp
import Constants
import FastString
import SMRep
+import DynFlags
import Outputable
import Outputable
+import Platform
import Control.Monad ( foldM )
import Control.Monad.ST ( runST )
import Control.Monad ( foldM )
import Control.Monad.ST ( runST )
@@
-42,6
+44,8
@@
import Data.Array.ST ( castSTUArray )
import Foreign
import Data.Char ( ord )
import Data.List
import Foreign
import Data.Char ( ord )
import Data.List
+import Data.Map (Map)
+import qualified Data.Map as Map
import GHC.Base ( ByteArray#, MutableByteArray#, RealWorld )
import GHC.Base ( ByteArray#, MutableByteArray#, RealWorld )
@@
-111,14
+115,14
@@
instance Outputable UnlinkedBCO where
-- bytecode address in this BCO.
-- Top level assembler fn.
-- bytecode address in this BCO.
-- Top level assembler fn.
-assembleBCOs :: [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode
-assembleBCOs proto_bcos tycons
+assembleBCOs :: DynFlags -> [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode
+assembleBCOs dflags proto_bcos tycons
= do itblenv <- mkITbls tycons
= do itblenv <- mkITbls tycons
- bcos <- mapM assembleBCO proto_bcos
+ bcos <- mapM (assembleBCO dflags) proto_bcos
return (ByteCode bcos itblenv)
return (ByteCode bcos itblenv)
-assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO
-assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced)
+assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO
+assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced)
= let
-- pass 1: collect up the offsets of the local labels.
-- Remember that the first insn starts at offset
= let
-- pass 1: collect up the offsets of the local labels.
-- Remember that the first insn starts at offset
@@
-128,19
+132,19
@@
assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced)
| wORD_SIZE_IN_BITS == 64 = 4
| wORD_SIZE_IN_BITS == 32 = 2
| otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?"
| wORD_SIZE_IN_BITS == 64 = 4
| wORD_SIZE_IN_BITS == 32 = 2
| otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?"
- label_env = mkLabelEnv emptyFM lableInitialOffset instrs
+ label_env = mkLabelEnv Map.empty lableInitialOffset instrs
- mkLabelEnv :: FiniteMap Word16 Word -> Word -> [BCInstr]
- -> FiniteMap Word16 Word
+ mkLabelEnv :: Map Word16 Word -> Word -> [BCInstr]
+ -> Map Word16 Word
mkLabelEnv env _ [] = env
mkLabelEnv env i_offset (i:is)
= let new_env
mkLabelEnv env _ [] = env
mkLabelEnv env i_offset (i:is)
= let new_env
- = case i of LABEL n -> addToFM env n i_offset ; _ -> env
+ = case i of LABEL n -> Map.insert n i_offset env ; _ -> env
in mkLabelEnv new_env (i_offset + instrSize16s i) is
findLabel :: Word16 -> Word
findLabel lab
in mkLabelEnv new_env (i_offset + instrSize16s i) is
findLabel :: Word16 -> Word
findLabel lab
- = case lookupFM label_env lab of
+ = case Map.lookup lab label_env of
Just bco_offset -> bco_offset
Nothing -> pprPanic "assembleBCO.findLabel" (ppr lab)
in
Just bco_offset -> bco_offset
Nothing -> pprPanic "assembleBCO.findLabel" (ppr lab)
in
@@
-150,7
+154,7
@@
assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced)
ptrs <- return emptySS :: IO (SizedSeq BCOPtr)
let init_asm_state = (insns,lits,ptrs)
(final_insns, final_lits, final_ptrs)
ptrs <- return emptySS :: IO (SizedSeq BCOPtr)
let init_asm_state = (insns,lits,ptrs)
(final_insns, final_lits, final_ptrs)
- <- mkBits findLabel init_asm_state instrs
+ <- mkBits dflags findLabel init_asm_state instrs
let asm_insns = ssElts final_insns
n_insns = sizeSS final_insns
let asm_insns = ssElts final_insns
n_insns = sizeSS final_insns
@@
-208,7
+212,7
@@
sizeSS16 :: SizedSeq a -> Word16
sizeSS16 (SizedSeq n _) = fromIntegral n
-- Bring in all the bci_ bytecode constants.
sizeSS16 (SizedSeq n _) = fromIntegral n
-- Bring in all the bci_ bytecode constants.
-#include "Bytecodes.h"
+#include "rts/Bytecodes.h"
largeArgInstr :: Word16 -> Word16
largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci
largeArgInstr :: Word16 -> Word16
largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci
@@
-226,12
+230,13
@@
largeArg w
| otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?"
-- This is where all the action is (pass 2 of the assembler)
| otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?"
-- This is where all the action is (pass 2 of the assembler)
-mkBits :: (Word16 -> Word) -- label finder
+mkBits :: DynFlags
+ -> (Word16 -> Word) -- label finder
-> AsmState
-> [BCInstr] -- instructions (in)
-> IO AsmState
-> AsmState
-> [BCInstr] -- instructions (in)
-> IO AsmState
-mkBits findLabel st proto_insns
+mkBits dflags findLabel st proto_insns
= foldM doInstr st proto_insns
where
doInstr :: AsmState -> BCInstr -> IO AsmState
= foldM doInstr st proto_insns
where
doInstr :: AsmState -> BCInstr -> IO AsmState
@@
-245,14
+250,14
@@
mkBits findLabel st proto_insns
instr2 st2 bci_PUSH_G p
PUSH_PRIMOP op -> do (p, st2) <- ptr st (BCOPtrPrimOp op)
instr2 st2 bci_PUSH_G p
instr2 st2 bci_PUSH_G p
PUSH_PRIMOP op -> do (p, st2) <- ptr st (BCOPtrPrimOp op)
instr2 st2 bci_PUSH_G p
- PUSH_BCO proto -> do ul_bco <- assembleBCO proto
+ PUSH_BCO proto -> do ul_bco <- assembleBCO dflags proto
(p, st2) <- ptr st (BCOPtrBCO ul_bco)
instr2 st2 bci_PUSH_G p
(p, st2) <- ptr st (BCOPtrBCO ul_bco)
instr2 st2 bci_PUSH_G p
- PUSH_ALTS proto -> do ul_bco <- assembleBCO proto
+ PUSH_ALTS proto -> do ul_bco <- assembleBCO dflags proto
(p, st2) <- ptr st (BCOPtrBCO ul_bco)
instr2 st2 bci_PUSH_ALTS p
PUSH_ALTS_UNLIFTED proto pk -> do
(p, st2) <- ptr st (BCOPtrBCO ul_bco)
instr2 st2 bci_PUSH_ALTS p
PUSH_ALTS_UNLIFTED proto pk -> do
- ul_bco <- assembleBCO proto
+ ul_bco <- assembleBCO dflags proto
(p, st2) <- ptr st (BCOPtrBCO ul_bco)
instr2 st2 (push_alts pk) p
PUSH_UBX (Left lit) nws
(p, st2) <- ptr st (BCOPtrBCO ul_bco)
instr2 st2 (push_alts pk) p
PUSH_UBX (Left lit) nws
@@
-288,6
+293,10
@@
mkBits findLabel st proto_insns
instr2Large st2 bci_TESTLT_I np (findLabel l)
TESTEQ_I i l -> do (np, st2) <- int st i
instr2Large st2 bci_TESTEQ_I np (findLabel l)
instr2Large st2 bci_TESTLT_I np (findLabel l)
TESTEQ_I i l -> do (np, st2) <- int st i
instr2Large st2 bci_TESTEQ_I np (findLabel l)
+ TESTLT_W w l -> do (np, st2) <- word st w
+ instr2Large st2 bci_TESTLT_W np (findLabel l)
+ TESTEQ_W w l -> do (np, st2) <- word st w
+ instr2Large st2 bci_TESTEQ_W np (findLabel l)
TESTLT_F f l -> do (np, st2) <- float st f
instr2Large st2 bci_TESTLT_F np (findLabel l)
TESTEQ_F f l -> do (np, st2) <- float st f
TESTLT_F f l -> do (np, st2) <- float st f
instr2Large st2 bci_TESTLT_F np (findLabel l)
TESTEQ_F f l -> do (np, st2) <- float st f
@@
-304,8
+313,8
@@
mkBits findLabel st proto_insns
ENTER -> instr1 st bci_ENTER
RETURN -> instr1 st bci_RETURN
RETURN_UBX rep -> instr1 st (return_ubx rep)
ENTER -> instr1 st bci_ENTER
RETURN -> instr1 st bci_RETURN
RETURN_UBX rep -> instr1 st (return_ubx rep)
- CCALL off m_addr -> do (np, st2) <- addr st m_addr
- instr3 st2 bci_CCALL off np
+ CCALL off m_addr int -> do (np, st2) <- addr st m_addr
+ instr4 st2 bci_CCALL off np int
BRK_FUN array index info -> do
(p1, st2) <- ptr st (BCOPtrArray array)
(p2, st3) <- ptr st2 (BCOPtrBreakInfo info)
BRK_FUN array index info -> do
(p1, st2) <- ptr st (BCOPtrArray array)
(p2, st3) <- ptr st2 (BCOPtrBreakInfo info)
@@
-362,6
+371,11
@@
mkBits findLabel st proto_insns
st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
+ word (st_i0,st_l0,st_p0) w
+ = do let ws = [w]
+ st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
+ return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
+
int64 (st_i0,st_l0,st_p0) i
= do let ws = mkLitI64 i
st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
int64 (st_i0,st_l0,st_p0) i
= do let ws = mkLitI64 i
st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
@@
-384,12
+398,11
@@
mkBits findLabel st proto_insns
= do st_l1 <- addToSS st_l0 (BCONPtrItbl (getName dcon))
return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
= do st_l1 <- addToSS st_l0 (BCONPtrItbl (getName dcon))
return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
-#ifdef mingw32_TARGET_OS
literal st (MachLabel fs (Just sz) _)
literal st (MachLabel fs (Just sz) _)
+ | platformOS (targetPlatform dflags) == OSMinGW32
= litlabel st (appendFS fs (mkFastString ('@':show sz)))
-- On Windows, stdcall labels have a suffix indicating the no. of
-- arg words, e.g. foo@8. testcase: ffi012(ghci)
= litlabel st (appendFS fs (mkFastString ('@':show sz)))
-- On Windows, stdcall labels have a suffix indicating the no. of
-- arg words, e.g. foo@8. testcase: ffi012(ghci)
-#endif
literal st (MachLabel fs _ _) = litlabel st fs
literal st (MachWord w) = int st (fromIntegral w)
literal st (MachInt j) = int st (fromIntegral j)
literal st (MachLabel fs _ _) = litlabel st fs
literal st (MachWord w) = int st (fromIntegral w)
literal st (MachInt j) = int st (fromIntegral j)
@@
-455,6
+468,8
@@
instrSize16s instr
LABEL{} -> 0 -- !!
TESTLT_I{} -> 3
TESTEQ_I{} -> 3
LABEL{} -> 0 -- !!
TESTLT_I{} -> 3
TESTEQ_I{} -> 3
+ TESTLT_W{} -> 3
+ TESTEQ_W{} -> 3
TESTLT_F{} -> 3
TESTEQ_F{} -> 3
TESTLT_D{} -> 3
TESTLT_F{} -> 3
TESTEQ_F{} -> 3
TESTLT_D{} -> 3
@@
-466,7
+481,7
@@
instrSize16s instr
ENTER{} -> 1
RETURN{} -> 1
RETURN_UBX{} -> 1
ENTER{} -> 1
RETURN{} -> 1
RETURN_UBX{} -> 1
- CCALL{} -> 3
+ CCALL{} -> 4
SWIZZLE{} -> 3
BRK_FUN{} -> 4
SWIZZLE{} -> 3
BRK_FUN{} -> 4