Commit 14aa7ae9 authored by sewardj's avatar sewardj

[project @ 2001-01-03 16:45:04 by sewardj]

Updates to track bug fixes in the bytecode interpreter.
parent 8f417a2d
......@@ -53,10 +53,12 @@ import MArray ( castSTUArray,
newAddrArray, writeAddrArray )
import Foreign ( Storable(..), Word8, Word16, Word32, Ptr(..),
malloc, castPtr, plusPtr )
import Addr ( Word, Addr, addrToInt, nullAddr )
import Addr ( Word, addrToInt, nullAddr )
import Bits ( Bits(..), shiftR )
import PrelGHC ( BCO#, newBCO#, unsafeCoerce#, ByteArray#, Array# )
import PrelAddr ( Addr(..) )
import PrelGHC ( BCO#, newBCO#, unsafeCoerce#,
ByteArray#, Array#, addrToHValue# )
import IOExts ( IORef, fixIO )
import ArrayBase
import PrelArr ( Array(..) )
......@@ -132,36 +134,37 @@ 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)
linkIModules gie gce mods
= do let (bcoss, ies) = unzip mods
bcos = concat bcoss
final_gie = foldr plusFM gie ies
(final_gce, linked_bcos) <- linkSomeBCOs final_gie gce bcos
return (linked_bcos, final_gie, final_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]
= do (aux_ce, _) <- linkSomeBCOs ie ce aux_ul_bcos
(_, [root_bco]) <- linkSomeBCOs ie aux_ce [root_ul_bco]
return root_bco
-- Link a bunch of BCOs and return them + updated closure env.
linkSomeBCOs :: ItblEnv -> ClosureEnv -> [UnlinkedBCO]
-> IO (ClosureEnv, [HValue])
linkSomeBCOs ie ce_in ul_bcos
= do let nms = map nameOfUnlinkedBCO ul_bcos
hvals <- fixIO
( \ hvs -> let ce_out = addListToFM ce_in (zipLazily nms hvs)
in mapM (linkBCO ie ce_out) ul_bcos )
let ce_out = addListToFM ce_in (zip nms hvals)
return (ce_out, hvals)
where
-- A lazier zip, in which no demand is propagated to the second
-- list unless some demand is propagated to the snd of one of the
-- result list elems.
zipLazily [] ys = []
zipLazily (x:xs) ys = (x, head ys) : zipLazily xs (tail ys)
data UnlinkedBCO
......@@ -270,7 +273,8 @@ instance Outputable BCInstr where
ppr (PUSH_TAG n) = text "PUSH_TAG" <+> int n
ppr (SLIDE n d) = text "SLIDE " <+> int n <+> int d
ppr (ALLOC sz) = text "ALLOC " <+> int sz
ppr (MKAP offset sz) = text "MKAP " <+> int offset <+> int sz
ppr (MKAP offset sz) = text "MKAP " <+> int sz <+> text "words,"
<+> int offset <+> text "stkoff"
ppr (UNPACK sz) = text "UNPACK " <+> int sz
ppr (UPK_TAG n m k) = text "UPK_TAG " <+> int n <> text "words"
<+> int m <> text "conoff"
......@@ -328,7 +332,7 @@ type BCEnv = FiniteMap Id Int -- To find vars on the stack
-- Create a BCO and do a spot of peephole optimisation on the insns
-- at the same time.
mkProtoBCO nm instrs_ordlist origin
= ProtoBCO nm (peep (fromOL instrs_ordlist)) origin
= ProtoBCO nm (id {-peep-} (fromOL instrs_ordlist)) origin
where
peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest)
= PUSH_LLL off1 (off2-1) (off3-2) : peep rest
......@@ -345,7 +349,19 @@ mkProtoBCO nm instrs_ordlist origin
-- variable to which this value was bound, so as to give the
-- resulting BCO a name.
schemeR :: (Id, AnnExpr Id VarSet) -> BcM ()
schemeR (nm, rhs) = schemeR_wrk rhs nm (collect [] rhs)
schemeR (nm, rhs)
{-
| trace (showSDoc (
(char ' '
$$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs
$$ pprCoreExpr (deAnnotate rhs)
$$ char ' '
))) False
= undefined
-}
| otherwise
= schemeR_wrk rhs nm (collect [] rhs)
collect xs (_, AnnLam x e)
= collect (if isTyVar x then xs else (x:xs)) e
......@@ -358,7 +374,7 @@ schemeR_wrk original_body nm (args, body)
szsw_args = map taggedIdSizeW all_args
szw_args = sum szsw_args
p_init = listToFM (zip all_args (mkStackOffsets 0 szsw_args))
argcheck = if null args then nilOL else unitOL (ARGCHECK szw_args)
argcheck = {-if null args then nilOL else-} unitOL (ARGCHECK szw_args)
in
schemeE szw_args 0 p_init body `thenBc` \ body_code ->
emitBc (mkProtoBCO (getName nm) (appOL argcheck body_code) (Right original_body))
......@@ -401,6 +417,8 @@ schemeE d s p (fvs, AnnLet binds b)
AnnRec xs_n_rhss -> unzip xs_n_rhss
n = length xs
fvss = map (filter (not.isTyVar).varSetElems.fst) rhss
-- Sizes of tagged free vars, + 1 for the fn
sizes = map (\rhs_fvs -> 1 + sum (map taggedIdSizeW rhs_fvs)) fvss
-- This p', d' defn is safe because all the items being pushed
......@@ -627,6 +645,7 @@ pushAtom False d p (AnnLit lit)
MachInt i -> code IntRep
MachFloat r -> code FloatRep
MachDouble r -> code DoubleRep
MachChar c -> code CharRep
where
code rep
= let size_host_words = untaggedSizeW rep
......@@ -1014,6 +1033,7 @@ mkBits findLabel st proto_insns
literal st (MachInt j) = int st (fromIntegral j)
literal st (MachFloat r) = float st (fromRational r)
literal st (MachDouble r) = double st (fromRational r)
literal st (MachChar c) = int st c
ctoi_itbl st pk
= addr st ret_itbl_addr
......@@ -1155,18 +1175,13 @@ GLOBAL_VAR(v_cafTable, [], [HValue])
-- = do linked_expr <- linkIExpr ie ce (root_bco, other_bcos)
-- return linked_expr
linkBCOs :: ItblEnv -> ClosureEnv -> [UnlinkedBCO]
-> IO [HValue] -- IO [BCO#] really
linkBCOs ie ce binds = mapM (linkBCO ie ce) binds
linkBCO ie ce (UnlinkedBCO nm insnsSS literalsSS ptrsSS itblsSS)
= do insns <- listFromSS insnsSS
literals <- listFromSS literalsSS
ptrs <- listFromSS ptrsSS
itbls <- listFromSS itblsSS
let linked_ptrs = map (lookupCE ce) ptrs
linked_ptrs <- mapM (lookupCE ce) ptrs
linked_itbls <- mapM (lookupIE ie) itbls
let n_insns = sizeSS insnsSS
......@@ -1209,11 +1224,16 @@ newBCO a b c d
= IO (\s -> case newBCO# a b c d s of (# s1, bco #) -> (# s1, BCO bco #))
lookupCE :: ClosureEnv -> Name -> HValue
lookupCE :: ClosureEnv -> Name -> IO HValue
lookupCE ce nm
= case lookupFM ce nm of
Just aa -> unsafeCoerce# aa
Nothing -> pprPanic "ByteCodeGen.lookupCE" (ppr nm)
Just aa -> return aa
Nothing
-> do m <- lookupSymbol (nameToCLabel nm "closure")
case m of
Just (A# addr) -> case addrToHValue# addr of
(# hval #) -> return hval
Nothing -> pprPanic "ByteCodeGen.lookupCE" (ppr nm)
lookupIE :: ItblEnv -> Name -> IO Addr
lookupIE ie con_nm
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment