-thenBc_ :: BcM a -> BcM b -> BcM b
-thenBc_ expr cont st
- = case expr st of { (result, st') -> cont st' }
-
-returnBc :: a -> BcM a
-returnBc result st = (result, st)
-
-mapBc :: (a -> BcM b) -> [a] -> BcM [b]
-mapBc f [] = returnBc []
-mapBc f (x:xs)
- = f x `thenBc` \ r ->
- mapBc f xs `thenBc` \ rs ->
- returnBc (r:rs)
-
-emitBc :: ProtoBCO Name -> BcM ()
-emitBc bco st
- = ((), st{bcos = bco : bcos st})
-
-getLabelBc :: BcM Int
-getLabelBc st
- = (nextlabel st, st{nextlabel = 1 + nextlabel st})
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{The bytecode assembler}
-%* *
-%************************************************************************
-
-The object format for bytecodes is: 16 bits for the opcode, and 16 for
-each field -- so the code can be considered a sequence of 16-bit ints.
-Each field denotes either a stack offset or number of items on the
-stack (eg SLIDE), and index into the pointer table (eg PUSH_G), an
-index into the literal table (eg PUSH_I/D/L), or a bytecode address in
-this BCO.
-
-\begin{code}
--- Top level assembler fn.
-assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO
-
-assembleBCO (ProtoBCO nm instrs origin)
- = let
- -- pass 1: collect up the offsets of the local labels
- label_env = mkLabelEnv emptyFM 0 instrs
-
- mkLabelEnv env i_offset [] = env
- mkLabelEnv env i_offset (i:is)
- = let new_env
- = case i of LABEL n -> addToFM env n i_offset ; _ -> env
- in mkLabelEnv new_env (i_offset + instrSizeB i) is
-
- findLabel lab
- = case lookupFM label_env lab of
- Just bco_offset -> bco_offset
- Nothing -> pprPanic "assembleBCO.findLabel" (int lab)
-
- init_n_insns = 10
- init_n_lits = 4
- init_n_ptrs = 4
- init_n_itbls = 4
- in
- do insns <- newXIOUArray init_n_insns :: IO (XIOUArray Word16)
- lits <- newXIOUArray init_n_lits :: IO (XIOUArray Word32)
- ptrs <- newXIOArray init_n_ptrs -- :: IO (XIOArray Name)
- itbls <- newXIOArray init_n_itbls -- :: IO (XIOArray Name)
-
- -- pass 2: generate the instruction, ptr and nonptr bits
- let init_asm_state = (insns,lits,ptrs,itbls)
- final_asm_state <- mkBits findLabel init_asm_state instrs
-
- -- unwrap the expandable arrays
- let final_insns = stuffXIOU insns
- final_lits = stuffXIOU lits
- final_ptrs = stuffXIO ptrs
- final_itbls = stuffXIO itbls
-
- return (UnlinkedBCO nm
- (usedXIOU insns) final_insns
- (usedXIOU lits) final_lits
- (usedXIO ptrs) final_ptrs
- (usedXIO itbls) final_itbls)
-
-
--- instrs nonptrs ptrs itbls
-type AsmState = (XIOUArray Word16, XIOUArray Word32, XIOArray Name, XIOArray Name)
-
-
--- This is where all the action is (pass 2 of the assembler)
-mkBits :: (Int -> Int) -- label finder
- -> AsmState
- -> [BCInstr] -- instructions (in)
- -> IO AsmState
-
-mkBits findLabel st proto_insns
- = foldM doInstr st proto_insns
- where
- doInstr :: AsmState -> BCInstr -> IO AsmState
- doInstr st i
- = case i of
- ARGCHECK n -> instr2 st i_ARGCHECK n
- PUSH_L o1 -> instr2 st i_PUSH_L o1
- PUSH_LL o1 o2 -> instr3 st i_PUSH_LL o1 o2
- PUSH_LLL o1 o2 o3 -> instr4 st i_PUSH_LLL o1 o2 o3
- PUSH_G nm -> do (p, st2) <- ptr st nm
- instr2 st2 i_PUSH_G p
- PUSH_AS nm pk -> do (p, st2) <- ptr st nm
- (np, st3) <- ret_itbl st2 pk
- instr3 st3 i_PUSH_AS p np
- PUSH_UBX lit nw32s -> do (np, st2) <- literal st lit
- instr3 st2 i_PUSH_UBX np nw32s
- PUSH_TAG tag -> instr2 st i_PUSH_TAG tag
- SLIDE n by -> instr3 st i_SLIDE n by
- ALLOC n -> instr2 st i_ALLOC n
- MKAP off sz -> instr3 st i_MKAP off sz
- UNPACK n -> instr2 st i_UNPACK n
- UPK_TAG n m k -> instr4 st i_UPK_TAG n m k
- PACK dcon sz -> do (itbl_no,st2) <- itbl st dcon
- instr3 st2 i_PACK itbl_no sz
- LABEL lab -> return st
- TESTLT_I i l -> do (np, st2) <- int st i
- instr3 st2 i_TESTLT_I np (findLabel l)
- TESTEQ_I i l -> do (np, st2) <- int st i
- instr3 st2 i_TESTEQ_I np (findLabel l)
- TESTLT_F f l -> do (np, st2) <- float st f
- instr3 st2 i_TESTLT_F np (findLabel l)
- TESTEQ_F f l -> do (np, st2) <- float st f
- instr3 st2 i_TESTEQ_F np (findLabel l)
- TESTLT_D d l -> do (np, st2) <- double st d
- instr3 st2 i_TESTLT_D np (findLabel l)
- TESTEQ_D d l -> do (np, st2) <- double st d
- instr3 st2 i_TESTEQ_D np (findLabel l)
- TESTLT_P i l -> do (np, st2) <- int st i
- instr3 st2 i_TESTLT_P np (findLabel l)
- TESTEQ_P i l -> do (np, st2) <- int st i
- instr3 st2 i_TESTEQ_P np (findLabel l)
- CASEFAIL -> instr1 st i_CASEFAIL
- ENTER -> instr1 st i_ENTER
- RETURN -> instr1 st i_RETURN
-
- i2s :: Int -> Word16
- i2s = fromIntegral
-
- instr1 (st_i0,st_l0,st_p0,st_I0) i1
- = do st_i1 <- addToXIOUArray st_i0 (i2s i1)
- return (st_i1,st_l0,st_p0,st_I0)
-
- instr2 (st_i0,st_l0,st_p0,st_I0) i1 i2
- = do st_i1 <- addToXIOUArray st_i0 (i2s i1)
- st_i2 <- addToXIOUArray st_i1 (i2s i2)
- return (st_i2,st_l0,st_p0,st_I0)
-
- instr3 (st_i0,st_l0,st_p0,st_I0) i1 i2 i3
- = do st_i1 <- addToXIOUArray st_i0 (i2s i1)
- st_i2 <- addToXIOUArray st_i1 (i2s i2)
- st_i3 <- addToXIOUArray st_i2 (i2s i3)
- return (st_i3,st_l0,st_p0,st_I0)
-
- instr4 (st_i0,st_l0,st_p0,st_I0) i1 i2 i3 i4
- = do st_i1 <- addToXIOUArray st_i0 (i2s i1)
- st_i2 <- addToXIOUArray st_i1 (i2s i2)
- st_i3 <- addToXIOUArray st_i2 (i2s i3)
- st_i4 <- addToXIOUArray st_i3 (i2s i4)
- return (st_i4,st_l0,st_p0,st_I0)
-
- float (st_i0,st_l0,st_p0,st_I0) f
- = do let w32s = mkLitF f
- st_l1 <- addListToXIOUArray st_l0 w32s
- return (usedXIOU st_l0, (st_i0,st_l1,st_p0,st_I0))
-
- double (st_i0,st_l0,st_p0,st_I0) d
- = do let w32s = mkLitD d
- st_l1 <- addListToXIOUArray st_l0 w32s
- return (usedXIOU st_l0, (st_i0,st_l1,st_p0,st_I0))
-
- int (st_i0,st_l0,st_p0,st_I0) i
- = do let w32s = mkLitI i
- st_l1 <- addListToXIOUArray st_l0 w32s
- return (usedXIOU st_l0, (st_i0,st_l1,st_p0,st_I0))
-
- addr (st_i0,st_l0,st_p0,st_I0) a
- = do let w32s = mkLitA a
- st_l1 <- addListToXIOUArray st_l0 w32s
- return (usedXIOU st_l0, (st_i0,st_l1,st_p0,st_I0))
-
- ptr (st_i0,st_l0,st_p0,st_I0) p
- = do st_p1 <- addToXIOArray st_p0 p
- return (usedXIO st_p0, (st_i0,st_l0,st_p1,st_I0))
-
- itbl (st_i0,st_l0,st_p0,st_I0) dcon
- = do st_I1 <- addToXIOArray st_I0 (getName dcon)
- return (usedXIO st_I0, (st_i0,st_l0,st_p0,st_I1))
-
- literal st (MachInt j) = int st (fromIntegral j)
- literal st (MachFloat r) = float st (fromRational r)
- literal st (MachDouble r) = double st (fromRational r)
-
- ret_itbl st pk
- = addr st ret_itbl_addr
- where
- ret_itbl_addr
- = case pk of
- IntRep -> stg_ctoi_ret_R1_info
- FloatRep -> stg_ctoi_ret_F1_info
- DoubleRep -> stg_ctoi_ret_D1_info
- where -- TEMP HACK
- stg_ctoi_ret_F1_info = nullAddr
- stg_ctoi_ret_D1_info = nullAddr
-
-foreign label "stg_ctoi_ret_R1_info" stg_ctoi_ret_R1_info :: Addr
---foreign label "stg_ctoi_ret_F1_info" stg_ctoi_ret_F1_info :: Addr
---foreign label "stg_ctoi_ret_D1_info" stg_ctoi_ret_D1_info :: Addr
-
--- The size in bytes of an instruction.
-instrSizeB :: BCInstr -> Int
-instrSizeB instr
- = case instr of
- ARGCHECK _ -> 4
- PUSH_L _ -> 4
- PUSH_LL _ _ -> 6
- PUSH_LLL _ _ _ -> 8
- PUSH_G _ -> 4
- SLIDE _ _ -> 6
- ALLOC _ -> 4
- MKAP _ _ -> 6
- UNPACK _ -> 4
- PACK _ _ -> 6
- LABEL _ -> 4
- TESTLT_I _ _ -> 6
- TESTEQ_I _ _ -> 6
- TESTLT_F _ _ -> 6
- TESTEQ_F _ _ -> 6
- TESTLT_D _ _ -> 6
- TESTEQ_D _ _ -> 6
- TESTLT_P _ _ -> 6
- TESTEQ_P _ _ -> 6
- CASEFAIL -> 2
- ENTER -> 2
- RETURN -> 2
-
-
--- Sizes of Int, Float and Double literals, in units of 32-bitses
-intLitSz32s, floatLitSz32s, doubleLitSz32s, addrLitSz32s :: Int
-intLitSz32s = wORD_SIZE `div` 4
-floatLitSz32s = 1 -- Assume IEEE floats
-doubleLitSz32s = 2
-addrLitSz32s = intLitSz32s
-
--- Make lists of 32-bit words for literals, so that when the
--- words are placed in memory at increasing addresses, the
--- bit pattern is correct for the host's word size and endianness.
-mkLitI :: Int -> [Word32]
-mkLitF :: Float -> [Word32]
-mkLitD :: Double -> [Word32]
-mkLitA :: Addr -> [Word32]
-
-mkLitF f
- = runST (do
- arr <- newFloatArray ((0::Int),0)
- writeFloatArray arr 0 f
- f_arr <- castSTUArray arr
- w0 <- readWord32Array f_arr 0
- return [w0]
- )
-
-mkLitD d
- = runST (do
- arr <- newDoubleArray ((0::Int),0)
- writeDoubleArray arr 0 d
- d_arr <- castSTUArray arr
- w0 <- readWord32Array d_arr 0
- w1 <- readWord32Array d_arr 1
- return [w0,w1]
- )
-
-mkLitI i
- | wORD_SIZE == 4
- = runST (do
- arr <- newIntArray ((0::Int),0)
- writeIntArray arr 0 i
- i_arr <- castSTUArray arr
- w0 <- readWord32Array i_arr 0
- return [w0]
- )
- | wORD_SIZE == 8
- = runST (do
- arr <- newIntArray ((0::Int),0)
- writeIntArray arr 0 i
- i_arr <- castSTUArray arr
- w0 <- readWord32Array i_arr 0
- w1 <- readWord32Array i_arr 1
- return [w0,w1]
- )
-
-mkLitA a
- | wORD_SIZE == 4
- = runST (do
- arr <- newAddrArray ((0::Int),0)
- writeAddrArray arr 0 a
- a_arr <- castSTUArray arr
- w0 <- readWord32Array a_arr 0
- return [w0]
- )
- | wORD_SIZE == 8
- = runST (do
- arr <- newAddrArray ((0::Int),0)
- writeAddrArray arr 0 a
- a_arr <- castSTUArray arr
- w0 <- readWord32Array a_arr 0
- w1 <- readWord32Array a_arr 1
- return [w0,w1]
- )
-
-
-
--- Zero-based expandable arrays
-data XIOUArray ele
- = XIOUArray { usedXIOU :: Int, stuffXIOU :: (IOUArray Int ele) }
-data XIOArray ele
- = XIOArray { usedXIO :: Int , stuffXIO :: (IOArray Int ele) }
-
-newXIOUArray size
- = do arr <- newArray (0, size-1)
- return (XIOUArray 0 arr)
-
-addListToXIOUArray xarr []
- = return xarr
-addListToXIOUArray xarr (x:xs)
- = addToXIOUArray xarr x >>= \ xarr' -> addListToXIOUArray xarr' xs
-
-
-addToXIOUArray :: MArray IOUArray a IO
- => XIOUArray a -> a -> IO (XIOUArray a)
-addToXIOUArray (XIOUArray n_arr arr) x
- = case bounds arr of
- (lo, hi) -> ASSERT(lo == 0)
- if n_arr > hi
- then do new_arr <- newArray (0, 2*hi-1)
- copy hi arr new_arr
- addToXIOUArray (XIOUArray n_arr new_arr) x
- else do writeArray arr n_arr x
- return (XIOUArray (n_arr+1) arr)
- where
- copy :: MArray IOUArray a IO
- => Int -> IOUArray Int a -> IOUArray Int a -> IO ()
- copy n src dst
- | n < 0 = return ()
- | otherwise = do nx <- readArray src n
- writeArray dst n nx
- copy (n-1) src dst
-
-
-
-newXIOArray size
- = do arr <- newArray (0, size-1)
- return (XIOArray 0 arr)
-
-addToXIOArray :: XIOArray a -> a -> IO (XIOArray a)
-addToXIOArray (XIOArray n_arr arr) x
- = case bounds arr of
- (lo, hi) -> ASSERT(lo == 0)
- if n_arr > hi
- then do new_arr <- newArray (0, 2*hi-1)
- copy hi arr new_arr
- addToXIOArray (XIOArray n_arr new_arr) x
- else do writeArray arr n_arr x
- return (XIOArray (n_arr+1) arr)
- where
- copy :: Int -> IOArray Int a -> IOArray Int a -> IO ()
- copy n src dst
- | n < 0 = return ()
- | otherwise = do nx <- readArray src n
- writeArray dst n nx
- copy (n-1) src dst
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Linking interpretables into something we can run}
-%* *
-%************************************************************************
-
-\begin{code}
-
-{-
-data UnlinkedBCO
- = UnlinkedBCO Int (IOUArray Int Word16) -- #insns insns
- Int (IOUArray Int Word32) -- #literals literals
- Int (IOArray Int Name) -- #ptrs ptrs
- Int (IOArray Int Name) -- #itblrefs itblrefs
-
-data BCO# = BCO# ByteArray# -- instrs :: array Word16#
- ByteArray# -- literals :: array Word32#
- PtrArray# -- ptrs :: Array HValue
- ByteArray# -- itbls :: Array Addr#
--}
-
-data LinkedBCO = LinkedBCO BCO#
-
-
-
-GLOBAL_VAR(v_cafTable, [], [HValue])
-
-addCAF :: HValue -> IO ()
-addCAF x = do xs <- readIORef v_cafTable; writeIORef v_cafTable (x:xs)
-
-linkIModules :: ItblEnv -- incoming global itbl env; returned updated
- -> ClosureEnv -- incoming global closure env; returned updated
- -> [([UnlinkedBCO], ItblEnv)]
- -> IO ([HValue], ItblEnv, ClosureEnv)
-linkIModules gie gce mods = do
- let (bcoss, ies) = unzip mods
- bcos = concat bcoss
- top_level_binders = map nameOfUnlinkedBCO bcos
- final_gie = foldr plusFM gie ies
-
- (new_bcos, new_gce) <-
- fixIO (\ ~(new_bcos, new_gce) -> do
-
- new_bcos <- linkBCOs final_gie new_gce bcos
-
- let new_gce = addListToFM gce (zip top_level_binders new_bcos)
-
- return (new_bcos, new_gce))
-
- return (new_bcos, final_gie, new_gce)
-
-
-
-linkBCOs :: ItblEnv -> ClosureEnv -> [UnlinkedBCO]
- -> IO [HValue] -- IO [BCO#] really
-linkBCOs ie ce binds = mapM (linkBCO ie ce) binds
-
-linkBCO ie ce (UnlinkedBCO nm
- n_insns insns n_literals literals
- n_ptrs ptrs n_itbls itbls)
- = do linked_ptrs <- mapArray (lookupCE ce) ptrs
- linked_itbls <- mapArray (lookupIE ie) itbls
-
- ptrs_froz <- freeze linked_ptrs
- let ptrs_parr = case ptrs_froz of Array lo hi parr -> parr
-
- insns_froz <- freeze insns
- let insns_barr = case insns_froz of UArray lo hi barr -> barr
-
- literals_froz <- freeze literals
- let literals_barr = case literals_froz of UArray lo hi barr -> barr
-
- itbls_froz <- freeze linked_itbls
- let itbls_barr = case itbls_froz of UArray lo hi barr -> barr
-
- BCO bco# <- newBCO insns_barr literals_barr ptrs_parr itbls_barr
-
- return (unsafeCoerce# bco#)
-
-data BCO = BCO BCO#
-
-newBCO :: ByteArray# -> ByteArray# -> Array# a -> ByteArray# -> IO BCO
-newBCO a b c d = IO (\s -> case newBCO# a b c d s of (# s1, bco #) -> (# s1, BCO bco #))