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"