--- When I push one of these on the stack, how much does Sp move by?
-taggedSizeW :: PrimRep -> Int
-taggedSizeW pr
- | isFollowableRep pr = 1
- | otherwise = 1{-the tag-} + getPrimRepSize pr
-
-
--- The plain size of something, without tag.
-untaggedSizeW :: PrimRep -> Int
-untaggedSizeW pr
- | isFollowableRep pr = 1
- | otherwise = getPrimRepSize pr
-
-
-taggedIdSizeW, untaggedIdSizeW :: Id -> Int
-taggedIdSizeW = taggedSizeW . typePrimRep . idType
-untaggedIdSizeW = untaggedSizeW . typePrimRep . idType
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{The bytecode generator's monad}
-%* *
-%************************************************************************
-
-\begin{code}
-data BcM_State
- = BcM_State { bcos :: [ProtoBCO Name], -- accumulates completed BCOs
- nextlabel :: Int } -- for generating local labels
-
-type BcM result = BcM_State -> (result, BcM_State)
-
-runBc :: BcM_State -> BcM () -> BcM_State
-runBc init_st m = case m init_st of { (r,st) -> st }
-
-thenBc :: BcM a -> (a -> BcM b) -> BcM b
-thenBc expr cont st
- = case expr st of { (result, st') -> cont result st' }
-
-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)
- in
- do -- pass 2: generate the instruction, ptr and nonptr bits
- insns <- return emptySS :: IO (SizedSeq Word16)
- lits <- return emptySS :: IO (SizedSeq Word)
- ptrs <- return emptySS :: IO (SizedSeq Name)
- itbls <- return emptySS :: IO (SizedSeq Name)
- let init_asm_state = (insns,lits,ptrs,itbls)
- (final_insns, final_lits, final_ptrs, final_itbls)
- <- mkBits findLabel init_asm_state instrs
-
- return (UnlinkedBCO nm final_insns final_lits final_ptrs final_itbls)
-
--- instrs nonptrs ptrs itbls
-type AsmState = (SizedSeq Word16, SizedSeq Word, SizedSeq Name, SizedSeq Name)
-
-data SizedSeq a = SizedSeq !Int [a]
-emptySS = SizedSeq 0 []
-addToSS (SizedSeq n r_xs) x = return (SizedSeq (n+1) (x:r_xs))
-addListToSS (SizedSeq n r_xs) xs
- = return (SizedSeq (n + length xs) (reverse xs ++ r_xs))
-sizeSS (SizedSeq n r_xs) = n
-listFromSS (SizedSeq n r_xs) = return (reverse r_xs)
-
-
--- 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 nws -> do (np, st2) <- literal st lit
- instr3 st2 i_PUSH_UBX np nws
- 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 <- addToSS 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 <- addToSS st_i0 (i2s i1)
- st_i2 <- addToSS 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 <- addToSS st_i0 (i2s i1)
- st_i2 <- addToSS st_i1 (i2s i2)
- st_i3 <- addToSS 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 <- addToSS st_i0 (i2s i1)
- st_i2 <- addToSS st_i1 (i2s i2)
- st_i3 <- addToSS st_i2 (i2s i3)
- st_i4 <- addToSS 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 ws = mkLitF f
- st_l1 <- addListToSS st_l0 ws
- return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
-
- double (st_i0,st_l0,st_p0,st_I0) d
- = do let ws = mkLitD d
- st_l1 <- addListToSS st_l0 ws
- return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
-
- int (st_i0,st_l0,st_p0,st_I0) i
- = do let ws = mkLitI i
- st_l1 <- addListToSS st_l0 ws
- return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
-
- addr (st_i0,st_l0,st_p0,st_I0) a
- = do let ws = mkLitA a
- st_l1 <- addListToSS st_l0 ws
- return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
-
- ptr (st_i0,st_l0,st_p0,st_I0) p
- = do st_p1 <- addToSS st_p0 p
- return (sizeSS st_p0, (st_i0,st_l0,st_p1,st_I0))
-
- itbl (st_i0,st_l0,st_p0,st_I0) dcon
- = do st_I1 <- addToSS st_I0 (getName dcon)
- return (sizeSS 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
- PUSH_AS _ _ -> 6
- PUSH_UBX _ _ -> 6
- PUSH_TAG _ -> 4
- SLIDE _ _ -> 6
- ALLOC _ -> 4
- MKAP _ _ -> 6
- UNPACK _ -> 4
- UPK_TAG _ _ _ -> 8
- 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
-
-
--- Make lists of host-sized 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 -> [Word]
-mkLitF :: Float -> [Word]
-mkLitD :: Double -> [Word]
-mkLitA :: Addr -> [Word]
-
-mkLitF f
- = runST (do
- arr <- newFloatArray ((0::Int),0)
- writeFloatArray arr 0 f
- f_arr <- castSTUArray arr
- w0 <- readWordArray f_arr 0
- return [w0]
- )
-
-mkLitD d
- | wORD_SIZE == 4
- = runST (do
- arr <- newDoubleArray ((0::Int),0)
- writeDoubleArray arr 0 d
- d_arr <- castSTUArray arr
- w0 <- readWordArray d_arr 0
- w1 <- readWordArray d_arr 1
- return [w0,w1]
- )
- | wORD_SIZE == 8
- = runST (do
- arr <- newDoubleArray ((0::Int),0)
- writeDoubleArray arr 0 d
- d_arr <- castSTUArray arr
- w0 <- readWordArray d_arr 0
- return [w0]
- )
-
-mkLitI i
- = runST (do
- arr <- newIntArray ((0::Int),0)
- writeIntArray arr 0 i
- i_arr <- castSTUArray arr
- w0 <- readWordArray i_arr 0
- return [w0]
- )
-
-mkLitA a
- = runST (do
- arr <- newAddrArray ((0::Int),0)
- writeAddrArray arr 0 a
- a_arr <- castSTUArray arr
- w0 <- readWordArray a_arr 0
- return [w0]
- )
-
-\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#
--}
-
-GLOBAL_VAR(v_cafTable, [], [HValue])
-
---addCAF :: HValue -> IO ()
---addCAF x = do xs <- readIORef v_cafTable; writeIORef v_cafTable (x:xs)
-
---bcosToHValue :: ItblEnv -> ClosureEnv -> UnlinkedBCOExpr -> IO HValue
---bcosToHValue ie ce (root_bco, other_bcos)
--- = do linked_expr <- linkIExpr ie ce (root_bco, other_bcos)
--- return linked_expr
-
-
-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)
-
-
-linkIExpr :: ItblEnv -> ClosureEnv -> UnlinkedBCOExpr
- -> IO HValue -- IO BCO# really
-linkIExpr ie ce (root_ul_bco, aux_ul_bcos)
- = do let aux_ul_binders = map nameOfUnlinkedBCO aux_ul_bcos
- (aux_bcos, aux_ce)
- <- fixIO
- (\ ~(aux_bcos, new_ce)
- -> do new_bcos <- linkBCOs ie new_ce aux_ul_bcos
- let new_ce = addListToFM ce (zip aux_ul_binders new_bcos)
- return (new_bcos, new_ce)
- )
- [root_bco]
- <- linkBCOs ie aux_ce [root_ul_bco]
- return root_bco
-
-
-linkBCOs :: ItblEnv -> ClosureEnv -> [UnlinkedBCO]
- -> IO [HValue] -- IO [BCO#] really
-linkBCOs ie ce binds = mapM (linkBCO ie ce) binds