Commit 91925e64 authored by sewardj's avatar sewardj

[project @ 2000-12-06 11:20:14 by sewardj]

Handle tagging correctly (we hope :) -- don't tag up stuff to go into
constructors.

Also rearrange order of code for readability.
parent f7a5edd3
...@@ -27,13 +27,14 @@ import Type ( typePrimRep ) ...@@ -27,13 +27,14 @@ import Type ( typePrimRep )
import DataCon ( DataCon, dataConTag, fIRST_TAG ) import DataCon ( DataCon, dataConTag, fIRST_TAG )
import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe ) import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe )
import VarSet ( VarSet, varSetElems ) import VarSet ( VarSet, varSetElems )
import PrimRep ( getPrimRepSize, isFollowableRep )
--import FastTypes --import FastTypes
\end{code} \end{code}
Entry point. Entry point.
\begin{code} \begin{code}
byteCodeGen :: [CoreBind] -> [BCO Name] byteCodeGen :: [CoreBind] -> [ProtoBCO Name]
byteCodeGen binds byteCodeGen binds
= let flatBinds = concatMap getBind binds = let flatBinds = concatMap getBind binds
getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)] getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)]
...@@ -43,7 +44,6 @@ byteCodeGen binds ...@@ -43,7 +44,6 @@ byteCodeGen binds
in in
case final_state of case final_state of
BcM_State bcos final_ctr -> bcos BcM_State bcos final_ctr -> bcos
\end{code} \end{code}
The real machinery. The real machinery.
...@@ -53,35 +53,60 @@ type LocalLabel = Int ...@@ -53,35 +53,60 @@ type LocalLabel = Int
data BCInstr data BCInstr
-- Messing with the stack -- Messing with the stack
= ARGCHECK Int = ARGCHECK Int
| PUSH_L Int{-size-} Int{-offset-} | PUSH_L Int{-size-} Int{-offset-}
| PUSH_G Name | PUSH_G Name
| PUSH_I Integer | PUSHT_I Int
| SLIDE Int{-this many-} Int{-down by this much-} | PUSHT_F Float
| PUSHT_D Double
| PUSHU_I Int
| PUSHU_F Float
| PUSHU_D Double
| SLIDE Int{-this many-} Int{-down by this much-}
-- To do with the heap -- To do with the heap
| ALLOC Int | ALLOC Int
| MKAP Int{-place ptr to heap this far down stack-} Int{-# words-} | MKAP Int{-place ptr to heap this far down stack-} Int{-# words-}
| UNPACK Int | UNPACK Int
| PACK DataCon Int | PACK DataCon Int
-- For doing case trees -- For doing case trees
| LABEL LocalLabel | LABEL LocalLabel
| TESTLT_I Int LocalLabel | TESTLT_I Int LocalLabel
| TESTEQ_I Int LocalLabel | TESTEQ_I Int LocalLabel
| TESTLT_F Float LocalLabel | TESTLT_F Float LocalLabel
| TESTEQ_F Float LocalLabel | TESTEQ_F Float LocalLabel
| TESTLT_D Double LocalLabel | TESTLT_D Double LocalLabel
| TESTEQ_D Double LocalLabel | TESTEQ_D Double LocalLabel
| TESTLT_P Int LocalLabel | TESTLT_P Int LocalLabel
| TESTEQ_P Int LocalLabel | TESTEQ_P Int LocalLabel
| CASEFAIL | CASEFAIL
-- To Infinity And Beyond -- To Infinity And Beyond
| ENTER | ENTER
\end{code}
The object format for this 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}
--data BCO a = BCO [Word16] -- instructions
-- [Word8] -- literal pool
-- [a] -- Names or HValues
--assembleBCO :: ProtoBCO -> BCO
--assembleBCO (ProtoBCO nm instrs)
-- = -- pass 1: collect up the offsets of the local labels,
-- -- and also the literals and
instance Outputable BCInstr where instance Outputable BCInstr where
ppr (ARGCHECK n) = text "ARGCHECK" <+> int n ppr (ARGCHECK n) = text "ARGCHECK" <+> int n
ppr (PUSH_L sz offset) = text "PUSH_L " <+> int sz <+> int offset ppr (PUSH_L sz offset) = text "PUSH_L " <+> int sz <+> int offset
ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm
ppr (PUSH_I i) = text "PUSH_I " <+> integer i ppr (PUSHT_I i) = text "PUSHT_I " <+> int i
ppr (SLIDE n d) = text "SLIDE " <+> int n <+> int d ppr (SLIDE n d) = text "SLIDE " <+> int n <+> int d
ppr (ALLOC sz) = text "ALLOC " <+> int sz ppr (ALLOC sz) = text "ALLOC " <+> int sz
ppr (MKAP offset sz) = text "MKAP " <+> int offset <+> int sz ppr (MKAP offset sz) = text "MKAP " <+> int offset <+> int sz
...@@ -96,11 +121,11 @@ pprAltCode discrs_n_codes ...@@ -96,11 +121,11 @@ pprAltCode discrs_n_codes
type BCInstrList = OrdList BCInstr type BCInstrList = OrdList BCInstr
data BCO a = BCO a BCInstrList data ProtoBCO a = ProtoBCO a BCInstrList
instance Outputable a => Outputable (BCO a) where instance Outputable a => Outputable (ProtoBCO a) where
ppr (BCO name instrs) ppr (ProtoBCO name instrs)
= (text "BCO" <+> ppr name <> colon) = (text "ProtoBCO" <+> ppr name <> colon)
$$ nest 6 (vcat (map ppr (fromOL instrs))) $$ nest 6 (vcat (map ppr (fromOL instrs)))
...@@ -139,17 +164,22 @@ instance Outputable Discr where ...@@ -139,17 +164,22 @@ instance Outputable Discr where
ppr NoDiscr = text "DEF" ppr NoDiscr = text "DEF"
-- Hmm. This isn't really right (ie on Alpha, idSizeW Double -> 2)
-- There must be an Officially Approved way to do this somewhere.
idSizeW :: Id -> Int
idSizeW nm
= let pr = typePrimRep (idType nm)
in case pr of IntRep -> 2
FloatRep -> 2
DoubleRep -> 3
PtrRep -> 1
other -> pprPanic "ByteCodeGen.idSizeW" (ppr pr)
-- 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
-- Compile code for the right hand side of a let binding. -- Compile code for the right hand side of a let binding.
...@@ -165,13 +195,13 @@ collect xs not_lambda = (reverse xs, not_lambda) ...@@ -165,13 +195,13 @@ collect xs not_lambda = (reverse xs, not_lambda)
schemeR_wrk nm (args, body) schemeR_wrk nm (args, body)
= let fvs = fst body = let fvs = fst body
all_args = varSetElems fvs ++ args all_args = varSetElems fvs ++ args
szsw_args = map idSizeW all_args szsw_args = map taggedIdSizeW all_args
szw_args = sum szsw_args szw_args = sum szsw_args
p_init = listToFM (zip all_args (scanl (+) 0 szsw_args)) p_init = listToFM (zip all_args (scanl (+) 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 in
schemeE szw_args 0 p_init body `thenBc` \ body_code -> schemeE szw_args 0 p_init body `thenBc` \ body_code ->
emitBc (BCO (getName nm) (appOL argcheck body_code)) emitBc (ProtoBCO (getName nm) (appOL argcheck body_code))
-- Compile code to apply the given expression to the remaining args -- Compile code to apply the given expression to the remaining args
...@@ -179,8 +209,10 @@ schemeR_wrk nm (args, body) ...@@ -179,8 +209,10 @@ schemeR_wrk nm (args, body)
schemeE :: Int -> Sequel -> BCEnv -> AnnExpr Id VarSet -> BcM BCInstrList schemeE :: Int -> Sequel -> BCEnv -> AnnExpr Id VarSet -> BcM BCInstrList
-- Delegate tail-calls to schemeT. -- Delegate tail-calls to schemeT.
schemeE d s p (fvs, AnnApp f a) = returnBc (schemeT d s 0 p (fvs, AnnApp f a)) schemeE d s p e@(fvs, AnnApp f a)
schemeE d s p (fvs, AnnVar v) = returnBc (schemeT d s 0 p (fvs, AnnVar v)) = returnBc (schemeT (should_args_be_tagged e) d s 0 p (fvs, AnnApp f a))
schemeE d s p e@(fvs, AnnVar v)
= returnBc (schemeT (should_args_be_tagged e) d s 0 p (fvs, AnnVar v))
schemeE d s p (fvs, AnnLet binds b) schemeE d s p (fvs, AnnLet binds b)
= let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs]) = let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs])
...@@ -189,7 +221,7 @@ schemeE d s p (fvs, AnnLet binds b) ...@@ -189,7 +221,7 @@ schemeE d s p (fvs, AnnLet binds b)
mapBc schemeR (zip xs rhss) `thenBc_` mapBc schemeR (zip xs rhss) `thenBc_`
let n = length xs let n = length xs
fvss = map (varSetElems.fst) rhss fvss = map (varSetElems.fst) rhss
sizes = map (\rhs_fvs -> 1 + sum (map idSizeW rhs_fvs)) fvss sizes = map (\rhs_fvs -> 1 + sum (map taggedIdSizeW rhs_fvs)) fvss
p' = addListToFM p (zipE xs [d .. d+n-1]) p' = addListToFM p (zipE xs [d .. d+n-1])
d' = d + n d' = d + n
infos = zipE4 fvss sizes xs [n, n-1 .. 1] infos = zipE4 fvss sizes xs [n, n-1 .. 1]
...@@ -198,7 +230,7 @@ schemeE d s p (fvs, AnnLet binds b) ...@@ -198,7 +230,7 @@ schemeE d s p (fvs, AnnLet binds b)
-- ToDo: don't build thunks for things with no free variables -- ToDo: don't build thunks for things with no free variables
buildThunk (fvs, size, id, off) buildThunk (fvs, size, id, off)
= case unzip (map (pushAtom d' p . AnnVar) (reverse fvs)) of = case unzip (map (pushAtom True d' p . AnnVar) (reverse fvs)) of
(push_codes, pushed_szsw) (push_codes, pushed_szsw)
-> ASSERT(sum pushed_szsw == size - 1) -> ASSERT(sum pushed_szsw == size - 1)
(toOL push_codes `snocOL` PUSH_G (getName id) (toOL push_codes `snocOL` PUSH_G (getName id)
...@@ -222,7 +254,7 @@ schemeE d s p (fvs, AnnCase scrut bndr alts) ...@@ -222,7 +254,7 @@ schemeE d s p (fvs, AnnCase scrut bndr alts)
-- Env and depth in which to compile the alts, not including -- Env and depth in which to compile the alts, not including
-- any vars bound by the alts themselves -- any vars bound by the alts themselves
d' = d + ret_frame_sizeW + idSizeW bndr d' = d + ret_frame_sizeW + taggedIdSizeW bndr
p' = addToFM p bndr d' p' = addToFM p bndr d'
isAlgCase isAlgCase
...@@ -234,7 +266,7 @@ schemeE d s p (fvs, AnnCase scrut bndr alts) ...@@ -234,7 +266,7 @@ schemeE d s p (fvs, AnnCase scrut bndr alts)
-- given an alt, return a discr and code for it. -- given an alt, return a discr and code for it.
codeAlt alt@(discr, binds, rhs) codeAlt alt@(discr, binds, rhs)
| isAlgCase | isAlgCase
= let binds_szsw = map idSizeW binds = let binds_szsw = map untaggedIdSizeW binds
binds_szw = sum binds_szsw binds_szw = sum binds_szsw
p'' = addListToFM p' (zip binds (scanl (+) d' binds_szsw)) p'' = addListToFM p' (zip binds (scanl (+) d' binds_szsw))
d'' = d' + binds_szw d'' = d' + binds_szw
...@@ -257,7 +289,7 @@ schemeE d s p (fvs, AnnCase scrut bndr alts) ...@@ -257,7 +289,7 @@ schemeE d s p (fvs, AnnCase scrut bndr alts)
mkMultiBranch alt_stuff `thenBc` \ alt_final -> mkMultiBranch alt_stuff `thenBc` \ alt_final ->
let let
alt_bco_name = getName bndr alt_bco_name = getName bndr
alt_bco = BCO alt_bco_name alt_final alt_bco = ProtoBCO alt_bco_name alt_final
in in
schemeE (d + ret_frame_sizeW) schemeE (d + ret_frame_sizeW)
(d + ret_frame_sizeW) p scrut `thenBc` \ scrut_code -> (d + ret_frame_sizeW) p scrut `thenBc` \ scrut_code ->
...@@ -266,6 +298,83 @@ schemeE d s p (fvs, AnnCase scrut bndr alts) ...@@ -266,6 +298,83 @@ schemeE d s p (fvs, AnnCase scrut bndr alts)
returnBc (PUSH_G alt_bco_name `consOL` scrut_code) returnBc (PUSH_G alt_bco_name `consOL` scrut_code)
-- Compile code to do a tail call. Doesn't need to be monadic.
schemeT :: Bool -- do tagging?
-> Int -- Stack depth
-> Sequel -- Sequel depth
-> Int -- # arg words so far
-> BCEnv -- stack env
-> AnnExpr Id VarSet -> BCInstrList
schemeT enTag d s narg_words p (_, AnnApp f a)
= let (push, arg_words) = pushAtom enTag d p (snd a)
in push
`consOL` schemeT enTag (d+arg_words) s (narg_words+arg_words) p f
schemeT enTag d s narg_words p (_, AnnVar f)
| Just con <- isDataConId_maybe f
= ASSERT(enTag == False)
PACK con narg_words `consOL` SLIDE 1 (d-s-1) `consOL` unitOL ENTER
| otherwise
= ASSERT(enTag == True)
let (push, arg_words) = pushAtom True d p (AnnVar f)
in push
`consOL` SLIDE (narg_words+arg_words) (d - s - narg_words)
`consOL` unitOL ENTER
should_args_be_tagged (_, AnnVar v)
= case isDataConId_maybe v of
Just dcon -> False; Nothing -> True
should_args_be_tagged (_, AnnApp f a)
= should_args_be_tagged f
should_args_be_tagged (_, other)
= panic "should_args_be_tagged: tail call to non-con, non-var"
-- Push an atom onto the stack, returning suitable code & number of
-- stack words used. Pushes it either tagged or untagged, since
-- pushAtom is used to set up the stack prior to copying into the
-- heap for both APs (requiring tags) and constructors (which don't).
--
-- NB this means NO GC between pushing atoms for a constructor and
-- copying them into the heap. It probably also means that
-- tail calls MUST be of the form atom{atom ... atom} since if the
-- expression head was allowed to be arbitrary, there could be GC
-- in between pushing the arg atoms and completing the head.
-- (not sure; perhaps the allocate/doYouWantToGC interface means this
-- isn't a problem; but only if arbitrary graph construction for the
-- head doesn't leave this BCO, since GC might happen at the start of
-- each BCO (we consult doYouWantToGC there).
--
-- Blargh. JRS 001206
--
pushAtom True{-tagged-} d p (AnnVar v)
= case lookupBCEnv_maybe p v of
Just offset -> (PUSH_L sz offset, sz)
Nothing -> ASSERT(sz == 1) (PUSH_G nm, sz)
where
nm = getName v
sz = taggedIdSizeW v
pushAtom False{-not tagged-} d p (AnnVar v)
= case lookupBCEnv_maybe p v of
Just offset -> (PUSH_L sz (offset+1), sz-1)
Nothing -> ASSERT(sz == 1) (PUSH_G nm, sz)
where
nm = getName v
sz = untaggedIdSizeW v
pushAtom True d p (AnnLit lit)
= case lit of
MachInt i -> (PUSHT_I (fromInteger i), taggedSizeW IntRep)
MachFloat r -> (PUSHT_F (fromRational r), taggedSizeW FloatRep)
MachDouble r -> (PUSHT_D (fromRational r), taggedSizeW DoubleRep)
pushAtom False d p (AnnLit lit)
= case lit of
MachInt i -> (PUSHU_I (fromInteger i), untaggedSizeW IntRep)
MachFloat r -> (PUSHU_F (fromRational r), untaggedSizeW FloatRep)
MachDouble r -> (PUSHU_D (fromRational r), untaggedSizeW DoubleRep)
-- Given a bunch of alts code and their discrs, do the donkey work -- Given a bunch of alts code and their discrs, do the donkey work
-- of making a multiway branch using a switch tree. -- of making a multiway branch using a switch tree.
-- What a load of hassle! -- What a load of hassle!
...@@ -362,51 +471,18 @@ mkMultiBranch raw_ways ...@@ -362,51 +471,18 @@ mkMultiBranch raw_ways
maxD = 1.0e308 maxD = 1.0e308
in in
mkTree notd_ways init_lo init_hi mkTree notd_ways init_lo init_hi
-- Compile code to do a tail call. Doesn't need to be monadic.
schemeT :: Int -> Sequel -> Int -> BCEnv -> AnnExpr Id VarSet -> BCInstrList
schemeT d s narg_words p (_, AnnApp f a)
= let (push, arg_words) = pushAtom d p (snd a)
in push
`consOL` schemeT (d+arg_words) s (narg_words+arg_words) p f
schemeT d s narg_words p (_, AnnVar f)
| Just con <- isDataConId_maybe f
= PACK con narg_words `consOL` SLIDE 1 (d-s-1) `consOL` unitOL ENTER
| otherwise
= let (push, arg_words) = pushAtom d p (AnnVar f)
in push
`consOL` SLIDE (narg_words+arg_words) (d - s - narg_words)
`consOL` unitOL ENTER
-- Push an atom onto the stack, returning suitable code & number of
-- stack words used.
pushAtom d p (AnnVar v)
= case lookupBCEnv_maybe p v of
Just offset -> (PUSH_L sz offset, sz)
Nothing -> ASSERT(sz == 1) (PUSH_G nm, 1)
where
nm = getName v
sz = idSizeW v
pushAtom d p (AnnLit lit)
= case lit of
MachInt i -> (PUSH_I i, 2)
\end{code} \end{code}
The bytecode generator's monad. The bytecode generator's monad.
\begin{code} \begin{code}
data BcM_State data BcM_State
= BcM_State { bcos :: [BCO Name], -- accumulates completed BCOs = BcM_State { bcos :: [ProtoBCO Name], -- accumulates completed BCOs
nextlabel :: Int } -- for generating local labels nextlabel :: Int } -- for generating local labels
type BcM result = BcM_State -> (result, BcM_State) type BcM result = BcM_State -> (result, BcM_State)
mkBcM_State :: [BCO Name] -> Int -> BcM_State mkBcM_State :: [ProtoBCO Name] -> Int -> BcM_State
mkBcM_State = BcM_State mkBcM_State = BcM_State
runBc :: BcM_State -> BcM () -> BcM_State runBc :: BcM_State -> BcM () -> BcM_State
...@@ -430,7 +506,7 @@ mapBc f (x:xs) ...@@ -430,7 +506,7 @@ mapBc f (x:xs)
mapBc f xs `thenBc` \ rs -> mapBc f xs `thenBc` \ rs ->
returnBc (r:rs) returnBc (r:rs)
emitBc :: BCO Name -> BcM () emitBc :: ProtoBCO Name -> BcM ()
emitBc bco st emitBc bco st
= ((), st{bcos = bco : bcos st}) = ((), st{bcos = bco : bcos st})
......
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