Ticket #3867: 0003-Bytecode-assembler-refactoring.patch

File 0003-Bytecode-assembler-refactoring.patch, 30.4 KB (added by pcapriotti, 3 years ago)
  • compiler/ghci/ByteCodeAsm.lhs

    From adb3e1ec0f1f53f88b48f2cc4708ea909ace3d6d Mon Sep 17 00:00:00 2001
    From: Paolo Capriotti <[email protected]>
    Date: Thu, 5 Apr 2012 18:09:40 +0100
    Subject: [PATCH 3/4] Bytecode assembler refactoring.
    
    Use a free monad to specify the assembling procedure, so that it can be
    run multiple times without producing side effects.
    
    This paves the way for a more general implementation of variable-sized
    instructions, since we need to dry-run the bytecode assembler to
    determine the size of the operands for some instructions.
    ---
     compiler/ghci/ByteCodeAsm.lhs   |  607 ++++++++++++++++++---------------------
     compiler/ghci/ByteCodeItbls.lhs |    2 +-
     2 files changed, 278 insertions(+), 331 deletions(-)
    
    diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs
    index 360dffe..3119447 100644
    a b import DynFlags 
    3535import Outputable
    3636import Platform
    3737
    38 import Control.Monad    ( foldM )
     38import Control.Monad
    3939import Control.Monad.ST ( runST )
    4040
    4141import Data.Array.MArray
    import Foreign 
    4747import Data.Char        ( ord )
    4848import Data.List
    4949import Data.Map (Map)
     50import Data.Maybe (fromMaybe)
    5051import qualified Data.Map as Map
    5152
    5253import GHC.Base         ( ByteArray#, MutableByteArray#, RealWorld )
    assembleBCOs dflags proto_bcos tycons 
    124125        return (ByteCode bcos itblenv)
    125126
    126127assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO
    127 assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced)
    128    = let
    129          -- pass 1: collect up the offsets of the local labels.
    130          -- Remember that the first insn starts at offset
    131          --     sizeOf Word / sizeOf Word16
    132          -- since offset 0 (eventually) will hold the total # of insns.
    133          lableInitialOffset
    134           | wORD_SIZE_IN_BITS == 64 = 4
    135           | wORD_SIZE_IN_BITS == 32 = 2
    136           | otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?"
    137          label_env = mkLabelEnv Map.empty lableInitialOffset instrs
    138 
    139          -- Jump instructions are variable-sized, there are long and
    140          -- short variants depending on the magnitude of the offset.
    141          -- However, we can't tell what size instructions we will need
    142          -- until we have calculated the offsets of the labels, which
    143          -- depends on the size of the instructions...  We could
    144          -- repeat the calculation and hope to reach a fixpoint, but
    145          -- instead we just calculate the worst-case size and use that
    146          -- to decide whether *all* the jumps in this BCO will be long
    147          -- or short.
    148 
    149          -- True => all our jumps will be long
    150          large_bco = isLarge max_w16s
    151             where max_w16s = fromIntegral (length instrs) * maxInstr16s :: Word
    152 
    153          mkLabelEnv :: Map Word16 Word -> Word -> [BCInstr]
    154                     -> Map Word16 Word
    155          mkLabelEnv env _ [] = env
    156          mkLabelEnv env i_offset (i:is)
    157             = let new_env
    158                      = case i of LABEL n -> Map.insert n i_offset env ; _ -> env
    159               in  mkLabelEnv new_env (i_offset + instrSize16s i large_bco) is
    160 
    161          findLabel :: Word16 -> Word
    162          findLabel lab
    163             = case Map.lookup lab label_env of
    164                  Just bco_offset -> bco_offset
    165                  Nothing -> pprPanic "assembleBCO.findLabel" (ppr lab)
    166      in
    167      do  -- pass 2: generate the instruction, ptr and nonptr bits
    168          insns <- return emptySS :: IO (SizedSeq Word16)
    169          lits  <- return emptySS :: IO (SizedSeq BCONPtr)
    170          ptrs  <- return emptySS :: IO (SizedSeq BCOPtr)
    171          let init_asm_state = (insns,lits,ptrs)
    172          (final_insns, final_lits, final_ptrs)
    173             <- mkBits dflags large_bco findLabel init_asm_state instrs
    174 
    175          let asm_insns = ssElts final_insns
    176              n_insns   = sizeSS final_insns
    177 
    178              insns_arr = mkInstrArray lableInitialOffset n_insns asm_insns
    179              !insns_barr = case insns_arr of UArray _lo _hi _n barr -> barr
    180 
    181              bitmap_arr = mkBitmapArray bsize bitmap
    182              !bitmap_barr = case bitmap_arr of UArray _lo _hi _n barr -> barr
    183 
    184          let ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits final_ptrs
    185 
    186          -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
    187          -- objects, since they might get run too early.  Disable this until
    188          -- we figure out what to do.
    189          -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced))
    190 
    191          return ul_bco
    192      -- where
    193      --     zonk ptr = do -- putStrLn ("freeing malloc'd block at " ++ show (A# a#))
    194      --                      free ptr
     128assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = do
     129  -- pass 1: collect up the offsets of the local labels.
     130  let asm = mapM_ (assembleI dflags) instrs
     131
     132      -- Remember that the first insn starts at offset
     133      --     sizeOf Word / sizeOf Word16
     134      -- since offset 0 (eventually) will hold the total # of insns.
     135      initial_offset = largeArg16s
     136
     137      -- Jump instructions are variable-sized, there are long and short variants
     138      -- depending on the magnitude of the offset.  However, we can't tell what
     139      -- size instructions we will need until we have calculated the offsets of
     140      -- the labels, which depends on the size of the instructions...  So we
     141      -- first create the label environment assuming that all jumps are short,
     142      -- and if the final size is indeed small enough for short jumps, we are
     143      -- done.  Otherwise, we repeat the calculation, and we force all jumps in
     144      -- this BCO to be long.
     145      (n_insns0, lbl_map0) = inspectAsm False initial_offset asm
     146      ((n_insns, lbl_map), long_jumps)
     147        | isLarge n_insns0 = (inspectAsm True initial_offset asm, True)
     148        | otherwise = ((n_insns0, lbl_map0), False)
     149
     150      findLabel :: Word16 -> Word
     151      findLabel lbl = fromMaybe
     152        (pprPanic "assembleBCO.findLabel" (ppr lbl))
     153        (Map.lookup lbl lbl_map)
     154
     155      env :: Word16 -> Operand
     156      env
     157        | long_jumps = LargeOp . findLabel
     158        | otherwise  = SmallOp . fromIntegral . findLabel
     159
     160  -- pass 2: run assembler and generate instructions, literals and pointers
     161  let initial_insns = addListToSS emptySS $ largeArg n_insns
     162  let initial_state = (initial_insns, emptySS, emptySS)
     163  (final_insns, final_lits, final_ptrs) <- execState initial_state $ runAsm env asm
     164
     165  -- precomputed size should be equal to final size
     166  ASSERT (n_insns == sizeSS final_insns) return ()
     167
     168  let asm_insns = ssElts final_insns
     169      barr a = case a of UArray _lo _hi _n b -> b
     170
     171      insns_arr = listArray (0, n_insns - 1) asm_insns
     172      !insns_barr = barr insns_arr
     173
     174      bitmap_arr = mkBitmapArray bsize bitmap
     175      !bitmap_barr = barr bitmap_arr
     176
     177      ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits final_ptrs
     178
     179  -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
     180  -- objects, since they might get run too early.  Disable this until
     181  -- we figure out what to do.
     182  -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced))
     183
     184  return ul_bco
    195185
    196186mkBitmapArray :: Word16 -> [StgWord] -> UArray Int StgWord
    197187mkBitmapArray bsize bitmap
    198188  = listArray (0, length bitmap) (fromIntegral bsize : bitmap)
    199189
    200 mkInstrArray :: Word -> Word -> [Word16] -> UArray Word Word16
    201 mkInstrArray lableInitialOffset n_insns asm_insns
    202   = let size = lableInitialOffset + n_insns
    203     in listArray (0, size - 1) (largeArg size ++ asm_insns)
    204 
    205190-- instrs nonptrs ptrs
    206191type AsmState = (SizedSeq Word16,
    207192                 SizedSeq BCONPtr,
    data SizedSeq a = SizedSeq !Word [a] 
    211196emptySS :: SizedSeq a
    212197emptySS = SizedSeq 0 []
    213198
    214 -- Why are these two monadic???
    215 addToSS :: SizedSeq a -> a -> IO (SizedSeq a)
    216 addToSS (SizedSeq n r_xs) x = return (SizedSeq (n+1) (x:r_xs))
    217 addListToSS :: SizedSeq a -> [a] -> IO (SizedSeq a)
     199addToSS :: SizedSeq a -> a -> SizedSeq a
     200addToSS (SizedSeq n r_xs) x = SizedSeq (n+1) (x:r_xs)
     201
     202addListToSS :: SizedSeq a -> [a] -> SizedSeq a
    218203addListToSS (SizedSeq n r_xs) xs
    219    = return (SizedSeq (n + genericLength xs) (reverse xs ++ r_xs))
     204  = SizedSeq (n + genericLength xs) (reverse xs ++ r_xs)
    220205
    221206ssElts :: SizedSeq a -> [a]
    222207ssElts (SizedSeq _ r_xs) = reverse r_xs
    ssElts (SizedSeq _ r_xs) = reverse r_xs 
    224209sizeSS :: SizedSeq a -> Word
    225210sizeSS (SizedSeq n _) = n
    226211
    227 sizeSS16 :: SizedSeq a -> Word16
    228 sizeSS16 (SizedSeq n _) = fromIntegral n
     212data Operand
     213  = Op Word
     214  | SmallOp Word16
     215  | LargeOp Word
     216  | LabelOp Word16
     217
     218data Assembler a
     219  = AllocPtr (IO BCOPtr) (Word16 -> Assembler a)
     220  | AllocLit [BCONPtr] (Word16 -> Assembler a)
     221  | AllocLabel Word16 (Assembler a)
     222  | Emit Word16 [Operand] (Assembler a)
     223  | NullAsm a
     224
     225instance Monad Assembler where
     226  return = NullAsm
     227  NullAsm x >>= f = f x
     228  AllocPtr p k >>= f = AllocPtr p (k >=> f)
     229  AllocLit l k >>= f = AllocLit l (k >=> f)
     230  AllocLabel lbl k >>= f = AllocLabel lbl (k >>= f)
     231  Emit w ops k >>= f = Emit w ops (k >>= f)
     232
     233ioptr :: IO BCOPtr -> Assembler Word16
     234ioptr p = AllocPtr p return
     235
     236ptr :: BCOPtr -> Assembler Word16
     237ptr = ioptr . return
     238
     239lit :: [BCONPtr] -> Assembler Word16
     240lit l = AllocLit l return
     241
     242label :: Word16 -> Assembler ()
     243label w = AllocLabel w (return ())
     244
     245emit :: Word16 -> [Operand] -> Assembler ()
     246emit w ops = Emit w ops (return ())
     247
     248type LabelEnv = Word16 -> Operand
     249
     250runAsm :: LabelEnv -> Assembler a -> State AsmState IO a
     251runAsm _ (NullAsm x) = return x
     252runAsm e (AllocPtr p_io k) = do
     253  p <- lift p_io
     254  w <- State $ \(st_i0,st_l0,st_p0) -> do
     255    let st_p1 = addToSS st_p0 p
     256    return ((st_i0,st_l0,st_p1), sizeSS16 st_p0)
     257  runAsm e $ k w
     258runAsm e (AllocLit lits k) = do
     259  w <- State $ \(st_i0,st_l0,st_p0) -> do
     260    let st_l1 = addListToSS st_l0 lits
     261    return ((st_i0,st_l1,st_p0), sizeSS16 st_l0)
     262  runAsm e $ k w
     263runAsm e (AllocLabel _ k) = runAsm e k
     264runAsm e (Emit w ops k) = do
     265  let (large, words) = expand False ops []
     266      opcode
     267        | large     = largeArgInstr w
     268        | otherwise = w
     269      expand l [] r_ws = (l, reverse r_ws)
     270      expand l (op : ops) r_ws = case op of
     271        SmallOp w -> expand l ops (w : r_ws)
     272        LargeOp w -> expand True ops (reverse (largeArg w) ++ r_ws)
     273        LabelOp lbl -> expand l (e lbl : ops) r_ws
     274        Op w
     275          | l || isLarge w -> expand l (LargeOp w : ops) r_ws
     276          | otherwise      -> expand l (SmallOp (fromIntegral w) : ops) r_ws
     277  State $ \(st_i0,st_l0,st_p0) -> do
     278    let st_i1 = addListToSS st_i0 (opcode : words)
     279    return ((st_i1,st_l0,st_p0), ())
     280  runAsm e k
     281
     282type LabelEnvMap = Map Word16 Word
     283
     284data InspectState = InspectState
     285  { instrCount :: !Word
     286  , ptrCount :: !Word
     287  , litCount :: !Word
     288  , lblEnv :: LabelEnvMap
     289  }
     290
     291inspectAsm :: Bool -> Word -> Assembler a -> (Word, LabelEnvMap)
     292inspectAsm long_jumps initial_offset
     293  = go (InspectState initial_offset 0 0 Map.empty)
     294  where
     295    go s (NullAsm _) = (instrCount s, lblEnv s)
     296    go s (AllocPtr _ k) = go (s { ptrCount = n + 1 }) (k n)
     297      where n = ptrCount s
     298    go s (AllocLit ls k) = go (s { litCount = n + genericLength ls }) (k n)
     299      where n = litCount s
     300    go s (AllocLabel lbl k) = go s' k
     301      where s' = s { lblEnv = Map.insert lbl (instrCount s) (lblEnv s) }
     302    go s (Emit _ ops k) = go s' k
     303      where
     304        s' = s { instrCount = instrCount s + size }
     305        size = count False ops 0 + 1
     306        count _ [] n = n
     307        count l (op : ops) n
     308          | is_large  = count True ops (n + largeArg16s)
     309          | otherwise = count l ops (n + 1)
     310          where
     311            is_large = case op of
     312              SmallOp _          -> False
     313              LabelOp _
     314                | long_jumps     -> True
     315                | otherwise      -> False
     316              LargeOp _          -> True
     317              Op n
     318                | l || isLarge n -> True
     319                | otherwise      -> False
     320
    229321
    230322-- Bring in all the bci_ bytecode constants.
    231323#include "rts/Bytecodes.h"
    largeArg16s :: Word 
    249341largeArg16s | wORD_SIZE_IN_BITS == 64  = 4
    250342            | otherwise                = 2
    251343
    252 -- This is where all the action is (pass 2 of the assembler)
    253 mkBits :: DynFlags
    254        -> Bool                          -- jumps are long
    255        -> (Word16 -> Word)              -- label finder
    256        -> AsmState
    257        -> [BCInstr]                     -- instructions (in)
    258        -> IO AsmState
    259 
    260 mkBits dflags long_jumps findLabel st proto_insns
    261   = foldM doInstr st proto_insns
    262     where
    263        doInstr :: AsmState -> BCInstr -> IO AsmState
    264        doInstr st i
    265           = case i of
    266                STKCHECK  n
    267                   | isLarge n  -> instrn st (largeArgInstr bci_STKCHECK : largeArg n)
    268                   | otherwise  -> instr2 st bci_STKCHECK (fromIntegral n)
    269 
    270                PUSH_L    o1       -> instr2 st bci_PUSH_L o1
    271                PUSH_LL   o1 o2    -> instr3 st bci_PUSH_LL o1 o2
    272                PUSH_LLL  o1 o2 o3 -> instr4 st bci_PUSH_LLL o1 o2 o3
    273                PUSH_G    nm       -> do (p, st2) <- ptr st (BCOPtrName nm)
    274                                         instr2 st2 bci_PUSH_G p
    275                PUSH_PRIMOP op     -> do (p, st2) <- ptr st (BCOPtrPrimOp op)
    276                                         instr2 st2 bci_PUSH_G p
    277                PUSH_BCO proto     -> do ul_bco <- assembleBCO dflags proto
    278                                         (p, st2) <- ptr st (BCOPtrBCO ul_bco)
    279                                         instr2 st2 bci_PUSH_G p
    280                PUSH_ALTS proto    -> do ul_bco <- assembleBCO dflags proto
    281                                         (p, st2) <- ptr st (BCOPtrBCO ul_bco)
    282                                         instr2 st2 bci_PUSH_ALTS p
    283                PUSH_ALTS_UNLIFTED proto pk -> do
    284                                         ul_bco <- assembleBCO dflags proto
    285                                         (p, st2) <- ptr st (BCOPtrBCO ul_bco)
    286                                         instr2 st2 (push_alts pk) p
    287                PUSH_UBX  (Left lit) nws
    288                                   -> do (np, st2) <- literal st lit
    289                                         instr3 st2 bci_PUSH_UBX np nws
    290                PUSH_UBX  (Right aa) nws
    291                                   -> do (np, st2) <- addr st aa
    292                                         instr3 st2 bci_PUSH_UBX np nws
    293 
    294                PUSH_APPLY_N         -> do instr1 st bci_PUSH_APPLY_N
    295                PUSH_APPLY_V         -> do instr1 st bci_PUSH_APPLY_V
    296                PUSH_APPLY_F         -> do instr1 st bci_PUSH_APPLY_F
    297                PUSH_APPLY_D         -> do instr1 st bci_PUSH_APPLY_D
    298                PUSH_APPLY_L         -> do instr1 st bci_PUSH_APPLY_L
    299                PUSH_APPLY_P         -> do instr1 st bci_PUSH_APPLY_P
    300                PUSH_APPLY_PP        -> do instr1 st bci_PUSH_APPLY_PP
    301                PUSH_APPLY_PPP       -> do instr1 st bci_PUSH_APPLY_PPP
    302                PUSH_APPLY_PPPP      -> do instr1 st bci_PUSH_APPLY_PPPP
    303                PUSH_APPLY_PPPPP     -> do instr1 st bci_PUSH_APPLY_PPPPP
    304                PUSH_APPLY_PPPPPP    -> do instr1 st bci_PUSH_APPLY_PPPPPP
    305 
    306                SLIDE     n by     -> instr3 st bci_SLIDE n by
    307                ALLOC_AP  n        -> instr2 st bci_ALLOC_AP n
    308                ALLOC_AP_NOUPD n   -> instr2 st bci_ALLOC_AP_NOUPD n
    309                ALLOC_PAP arity n  -> instr3 st bci_ALLOC_PAP arity n
    310                MKAP      off sz   -> instr3 st bci_MKAP off sz
    311                MKPAP     off sz   -> instr3 st bci_MKPAP off sz
    312                UNPACK    n        -> instr2 st bci_UNPACK n
    313                PACK      dcon sz  -> do (itbl_no,st2) <- itbl st dcon
    314                                         instr3 st2 bci_PACK itbl_no sz
    315                LABEL     _        -> return st
    316                TESTLT_I  i l      -> do (np, st2) <- int st i
    317                                         jumpInstr2 st2 bci_TESTLT_I np (findLabel l)
    318                TESTEQ_I  i l      -> do (np, st2) <- int st i
    319                                         jumpInstr2 st2 bci_TESTEQ_I np (findLabel l)
    320                TESTLT_W  w l      -> do (np, st2) <- word st w
    321                                         jumpInstr2 st2 bci_TESTLT_W np (findLabel l)
    322                TESTEQ_W  w l      -> do (np, st2) <- word st w
    323                                         jumpInstr2 st2 bci_TESTEQ_W np (findLabel l)
    324                TESTLT_F  f l      -> do (np, st2) <- float st f
    325                                         jumpInstr2 st2 bci_TESTLT_F np (findLabel l)
    326                TESTEQ_F  f l      -> do (np, st2) <- float st f
    327                                         jumpInstr2 st2 bci_TESTEQ_F np (findLabel l)
    328                TESTLT_D  d l      -> do (np, st2) <- double st d
    329                                         jumpInstr2 st2 bci_TESTLT_D np (findLabel l)
    330                TESTEQ_D  d l      -> do (np, st2) <- double st d
    331                                         jumpInstr2 st2 bci_TESTEQ_D np (findLabel l)
    332                TESTLT_P  i l      -> jumpInstr2 st bci_TESTLT_P i (findLabel l)
    333                TESTEQ_P  i l      -> jumpInstr2 st bci_TESTEQ_P i (findLabel l)
    334                CASEFAIL           -> instr1 st bci_CASEFAIL
    335                SWIZZLE   stkoff n -> instr3 st bci_SWIZZLE stkoff n
    336                JMP       l        -> jumpInstr1 st bci_JMP (findLabel l)
    337                ENTER              -> instr1 st bci_ENTER
    338                RETURN             -> instr1 st bci_RETURN
    339                RETURN_UBX rep     -> instr1 st (return_ubx rep)
    340                CCALL off m_addr int -> do (np, st2) <- addr st m_addr
    341                                           instr4 st2 bci_CCALL off np int
    342                BRK_FUN array index info -> do
    343                   (p1, st2) <- ptr st  (BCOPtrArray array)
    344                   (p2, st3) <- ptr st2 (BCOPtrBreakInfo info)
    345                   instr4 st3 bci_BRK_FUN p1 index p2
    346 
    347        instrn :: AsmState -> [Word16] -> IO AsmState
    348        instrn st [] = return st
    349        instrn (st_i, st_l, st_p) (i:is)
    350           = do st_i' <- addToSS st_i i
    351                instrn (st_i', st_l, st_p) is
    352 
    353        jumpInstr1 st i1 i2
    354             | long_jumps = instrn st (largeArgInstr i1 : largeArg i2)
    355             | otherwise  = instr2 st i1 (fromIntegral i2)
    356 
    357        jumpInstr2 st i1 i2 i3
    358            | long_jumps = instrn st (largeArgInstr i1 : i2 : largeArg i3)
    359            | otherwise  = instr3 st i1 i2 (fromIntegral i3)
    360 
    361        instr1 (st_i0,st_l0,st_p0) i1
    362           = do st_i1 <- addToSS st_i0 i1
    363                return (st_i1,st_l0,st_p0)
    364 
    365        instr2 (st_i0,st_l0,st_p0) w1 w2
    366           = do st_i1 <- addToSS st_i0 w1
    367                st_i2 <- addToSS st_i1 w2
    368                return (st_i2,st_l0,st_p0)
    369 
    370        instr3 (st_i0,st_l0,st_p0) w1 w2 w3
    371           = do st_i1 <- addToSS st_i0 w1
    372                st_i2 <- addToSS st_i1 w2
    373                st_i3 <- addToSS st_i2 w3
    374                return (st_i3,st_l0,st_p0)
    375 
    376        instr4 (st_i0,st_l0,st_p0) w1 w2 w3 w4
    377           = do st_i1 <- addToSS st_i0 w1
    378                st_i2 <- addToSS st_i1 w2
    379                st_i3 <- addToSS st_i2 w3
    380                st_i4 <- addToSS st_i3 w4
    381                return (st_i4,st_l0,st_p0)
    382 
    383        float (st_i0,st_l0,st_p0) f
    384           = do let ws = mkLitF f
    385                st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
    386                return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
    387 
    388        double (st_i0,st_l0,st_p0) d
    389           = do let ws = mkLitD d
    390                st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
    391                return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
    392 
    393        int (st_i0,st_l0,st_p0) i
    394           = do let ws = mkLitI i
    395                st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
    396                return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
    397 
    398        word (st_i0,st_l0,st_p0) w
    399           = do let ws = [w]
    400                st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
    401                return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
    402 
    403        int64 (st_i0,st_l0,st_p0) i
    404           = do let ws = mkLitI64 i
    405                st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
    406                return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
    407 
    408        addr (st_i0,st_l0,st_p0) a
    409           = do let ws = mkLitPtr a
    410                st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
    411                return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
    412 
    413        litlabel (st_i0,st_l0,st_p0) fs
    414           = do st_l1 <- addListToSS st_l0 [BCONPtrLbl fs]
    415                return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
    416 
    417        ptr (st_i0,st_l0,st_p0) p
    418           = do st_p1 <- addToSS st_p0 p
    419                return (sizeSS16 st_p0, (st_i0,st_l0,st_p1))
    420 
    421        itbl (st_i0,st_l0,st_p0) dcon
    422           = do st_l1 <- addToSS st_l0 (BCONPtrItbl (getName dcon))
    423                return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
    424 
    425        literal st (MachLabel fs (Just sz) _)
    426         | platformOS (targetPlatform dflags) == OSMinGW32
    427             = litlabel st (appendFS fs (mkFastString ('@':show sz)))
    428         -- On Windows, stdcall labels have a suffix indicating the no. of
    429         -- arg words, e.g. foo@8.  testcase: ffi012(ghci)
    430        literal st (MachLabel fs _ _) = litlabel st fs
    431        literal st (MachWord w)     = int st (fromIntegral w)
    432        literal st (MachInt j)      = int st (fromIntegral j)
    433        literal st MachNullAddr     = int st 0
    434        literal st (MachFloat r)    = float st (fromRational r)
    435        literal st (MachDouble r)   = double st (fromRational r)
    436        literal st (MachChar c)     = int st (ord c)
    437        literal st (MachInt64 ii)   = int64 st (fromIntegral ii)
    438        literal st (MachWord64 ii)  = int64 st (fromIntegral ii)
    439        literal _  other            = pprPanic "ByteCodeAsm.literal" (ppr other)
     344assembleI :: DynFlags
     345          -> BCInstr
     346          -> Assembler ()
     347assembleI dflags i = case i of
     348  STKCHECK n               -> emit bci_STKCHECK [Op n]
     349  PUSH_L o1                -> emit bci_PUSH_L [SmallOp o1]
     350  PUSH_LL o1 o2            -> emit bci_PUSH_LL [SmallOp o1, SmallOp o2]
     351  PUSH_LLL o1 o2 o3        -> emit bci_PUSH_LLL [SmallOp o1, SmallOp o2, SmallOp o3]
     352  PUSH_G nm                -> do p <- ptr (BCOPtrName nm)
     353                                 emit bci_PUSH_G [SmallOp p]
     354  PUSH_PRIMOP op           -> do p <- ptr (BCOPtrPrimOp op)
     355                                 emit bci_PUSH_G [SmallOp p]
     356  PUSH_BCO proto           -> do let ul_bco = assembleBCO dflags proto
     357                                 p <- ioptr (liftM BCOPtrBCO ul_bco)
     358                                 emit bci_PUSH_G [SmallOp p]
     359  PUSH_ALTS proto          -> do let ul_bco = assembleBCO dflags proto
     360                                 p <- ioptr (liftM BCOPtrBCO ul_bco)
     361                                 emit bci_PUSH_ALTS [SmallOp p]
     362  PUSH_ALTS_UNLIFTED proto pk
     363                           -> do let ul_bco = assembleBCO dflags proto
     364                                 p <- ioptr (liftM BCOPtrBCO ul_bco)
     365                                 emit (push_alts pk) [SmallOp p]
     366  PUSH_UBX (Left lit) nws  -> do np <- literal lit
     367                                 emit bci_PUSH_UBX [SmallOp np, SmallOp nws]
     368  PUSH_UBX (Right aa) nws  -> do np <- addr aa
     369                                 emit bci_PUSH_UBX [SmallOp np, SmallOp nws]
     370
     371  PUSH_APPLY_N             -> emit bci_PUSH_APPLY_N []
     372  PUSH_APPLY_V             -> emit bci_PUSH_APPLY_V []
     373  PUSH_APPLY_F             -> emit bci_PUSH_APPLY_F []
     374  PUSH_APPLY_D             -> emit bci_PUSH_APPLY_D []
     375  PUSH_APPLY_L             -> emit bci_PUSH_APPLY_L []
     376  PUSH_APPLY_P             -> emit bci_PUSH_APPLY_P []
     377  PUSH_APPLY_PP            -> emit bci_PUSH_APPLY_PP []
     378  PUSH_APPLY_PPP           -> emit bci_PUSH_APPLY_PPP []
     379  PUSH_APPLY_PPPP          -> emit bci_PUSH_APPLY_PPPP []
     380  PUSH_APPLY_PPPPP         -> emit bci_PUSH_APPLY_PPPPP []
     381  PUSH_APPLY_PPPPPP        -> emit bci_PUSH_APPLY_PPPPPP []
     382
     383  SLIDE     n by           -> emit bci_SLIDE [SmallOp n, SmallOp by]
     384  ALLOC_AP  n              -> emit bci_ALLOC_AP [SmallOp n]
     385  ALLOC_AP_NOUPD n         -> emit bci_ALLOC_AP_NOUPD [SmallOp n]
     386  ALLOC_PAP arity n        -> emit bci_ALLOC_PAP [SmallOp arity, SmallOp n]
     387  MKAP      off sz         -> emit bci_MKAP [SmallOp off, SmallOp sz]
     388  MKPAP     off sz         -> emit bci_MKPAP [SmallOp off, SmallOp sz]
     389  UNPACK    n              -> emit bci_UNPACK [SmallOp n]
     390  PACK      dcon sz        -> do itbl_no <- lit [BCONPtrItbl (getName dcon)]
     391                                 emit bci_PACK [SmallOp itbl_no, SmallOp sz]
     392  LABEL     lbl            -> label lbl
     393  TESTLT_I  i l            -> do np <- int i
     394                                 emit bci_TESTLT_I [SmallOp np, LabelOp l]
     395  TESTEQ_I  i l            -> do np <- int i
     396                                 emit bci_TESTEQ_I [SmallOp np, LabelOp l]
     397  TESTLT_W  w l            -> do np <- word w
     398                                 emit bci_TESTLT_W [SmallOp np, LabelOp l]
     399  TESTEQ_W  w l            -> do np <- word w
     400                                 emit bci_TESTEQ_W [SmallOp np, LabelOp l]
     401  TESTLT_F  f l            -> do np <- float f
     402                                 emit bci_TESTLT_F [SmallOp np, LabelOp l]
     403  TESTEQ_F  f l            -> do np <- float f
     404                                 emit bci_TESTEQ_F [SmallOp np, LabelOp l]
     405  TESTLT_D  d l            -> do np <- double d
     406                                 emit bci_TESTLT_D [SmallOp np, LabelOp l]
     407  TESTEQ_D  d l            -> do np <- double d
     408                                 emit bci_TESTEQ_D [SmallOp np, LabelOp l]
     409  TESTLT_P  i l            -> emit bci_TESTLT_P [SmallOp i, LabelOp l]
     410  TESTEQ_P  i l            -> emit bci_TESTEQ_P [SmallOp i, LabelOp l]
     411  CASEFAIL                 -> emit bci_CASEFAIL []
     412  SWIZZLE   stkoff n       -> emit bci_SWIZZLE [SmallOp stkoff, SmallOp n]
     413  JMP       l              -> emit bci_JMP [LabelOp l]
     414  ENTER                    -> emit bci_ENTER []
     415  RETURN                   -> emit bci_RETURN []
     416  RETURN_UBX rep           -> emit (return_ubx rep) []
     417  CCALL off m_addr i       -> do np <- addr m_addr
     418                                 emit bci_CCALL [SmallOp off, SmallOp np, SmallOp i]
     419  BRK_FUN array index info -> do p1 <- ptr (BCOPtrArray array)
     420                                 p2 <- ptr (BCOPtrBreakInfo info)
     421                                 emit bci_BRK_FUN [SmallOp p1, SmallOp index, SmallOp p2]
     422
     423  where
     424    literal (MachLabel fs (Just sz) _)
     425     | platformOS (targetPlatform dflags) == OSMinGW32
     426         = litlabel (appendFS fs (mkFastString ('@':show sz)))
     427     -- On Windows, stdcall labels have a suffix indicating the no. of
     428     -- arg words, e.g. foo@8.  testcase: ffi012(ghci)
     429    literal (MachLabel fs _ _) = litlabel fs
     430    literal (MachWord w)       = int (fromIntegral w)
     431    literal (MachInt j)        = int (fromIntegral j)
     432    literal MachNullAddr       = int 0
     433    literal (MachFloat r)      = float (fromRational r)
     434    literal (MachDouble r)     = double (fromRational r)
     435    literal (MachChar c)       = int (ord c)
     436    literal (MachInt64 ii)     = int64 (fromIntegral ii)
     437    literal (MachWord64 ii)    = int64 (fromIntegral ii)
     438    literal other              = pprPanic "ByteCodeAsm.literal" (ppr other)
     439
     440    litlabel fs = lit [BCONPtrLbl fs]
     441    addr = words . mkLitPtr
     442    float = words . mkLitF
     443    double = words . mkLitD
     444    int = words . mkLitI
     445    int64 = words . mkLitI64
     446    words ws = lit (map BCONPtrWord ws)
     447    word w = words [w]
    440448
    441449isLarge :: Word -> Bool
    442450isLarge n = n > 65535
    return_ubx VoidArg = bci_RETURN_V 
    457465return_ubx LongArg   = bci_RETURN_L
    458466return_ubx PtrArg    = bci_RETURN_P
    459467
    460 
    461 -- The size in 16-bit entities of an instruction.
    462 instrSize16s :: BCInstr -> Bool -> Word
    463 instrSize16s instr long_jumps
    464    = case instr of
    465         STKCHECK n              -> if isLarge n then 1 + largeArg16s else 2
    466         PUSH_L{}                -> 2
    467         PUSH_LL{}               -> 3
    468         PUSH_LLL{}              -> 4
    469         PUSH_G{}                -> 2
    470         PUSH_PRIMOP{}           -> 2
    471         PUSH_BCO{}              -> 2
    472         PUSH_ALTS{}             -> 2
    473         PUSH_ALTS_UNLIFTED{}    -> 2
    474         PUSH_UBX{}              -> 3
    475         PUSH_APPLY_N{}          -> 1
    476         PUSH_APPLY_V{}          -> 1
    477         PUSH_APPLY_F{}          -> 1
    478         PUSH_APPLY_D{}          -> 1
    479         PUSH_APPLY_L{}          -> 1
    480         PUSH_APPLY_P{}          -> 1
    481         PUSH_APPLY_PP{}         -> 1
    482         PUSH_APPLY_PPP{}        -> 1
    483         PUSH_APPLY_PPPP{}       -> 1
    484         PUSH_APPLY_PPPPP{}      -> 1
    485         PUSH_APPLY_PPPPPP{}     -> 1
    486         SLIDE{}                 -> 3
    487         ALLOC_AP{}              -> 2
    488         ALLOC_AP_NOUPD{}        -> 2
    489         ALLOC_PAP{}             -> 3
    490         MKAP{}                  -> 3
    491         MKPAP{}                 -> 3
    492         UNPACK{}                -> 2
    493         PACK{}                  -> 3
    494         LABEL{}                 -> 0    -- !!
    495         TESTLT_I{}              -> 2 + jump
    496         TESTEQ_I{}              -> 2 + jump
    497         TESTLT_W{}              -> 2 + jump
    498         TESTEQ_W{}              -> 2 + jump
    499         TESTLT_F{}              -> 2 + jump
    500         TESTEQ_F{}              -> 2 + jump
    501         TESTLT_D{}              -> 2 + jump
    502         TESTEQ_D{}              -> 2 + jump
    503         TESTLT_P{}              -> 2 + jump
    504         TESTEQ_P{}              -> 2 + jump
    505         JMP{}                   -> 1 + jump
    506         CASEFAIL{}              -> 1
    507         ENTER{}                 -> 1
    508         RETURN{}                -> 1
    509         RETURN_UBX{}            -> 1
    510         CCALL{}                 -> 4
    511         SWIZZLE{}               -> 3
    512         BRK_FUN{}               -> 4
    513   where
    514     jump | long_jumps = largeArg16s
    515          | otherwise  = 1
    516 
    517 -- The biggest instruction in Word16s
    518 maxInstr16s :: Word
    519 maxInstr16s = 2 + largeArg16s -- LARGE TESTLT_I = 2 + largeArg16s
    520 
    521468-- Make lists of host-sized words for literals, so that when the
    522469-- words are placed in memory at increasing addresses, the
    523470-- bit pattern is correct for the host's word size and endianness.
  • compiler/ghci/ByteCodeItbls.lhs

    diff --git a/compiler/ghci/ByteCodeItbls.lhs b/compiler/ghci/ByteCodeItbls.lhs
    index bbf68bf..e6da640 100644
    a b ByteCodeItbls: Generate infotables for interpreter-made bytecodes 
    1515
    1616module ByteCodeItbls ( ItblEnv, ItblPtr(..), itblCode, mkITbls
    1717                     , StgInfoTable(..)
    18                      , State(..), runState, evalState, execState, MonadT
     18                     , State(..), runState, evalState, execState, MonadT(..)
    1919                     ) where
    2020
    2121#include "HsVersions.h"