Commit 6d7e8b17 authored by sewardj's avatar sewardj
Browse files

[project @ 2001-08-08 11:11:06 by sewardj]

"Greetings, earthlings.  Take us to your mutable variables."
^A^K^K
Build the bytecode generator's monad on top of IO, and as a result get
rid of various unsafePerformIOs.
parent 52c07834
......@@ -15,7 +15,7 @@ import Bits ( Bits(..), shiftR )
import Word ( Word8, Word32 )
import Addr ( Addr(..), writeWord8OffAddr )
import Foreign ( Ptr(..), mallocBytes )
import IOExts ( unsafePerformIO, trace )
import IOExts ( trace )
\end{code}
......@@ -83,11 +83,11 @@ we don't clear our own (single) arg off the C stack.
-}
mkMarshalCode :: CCallConv
-> (Int, PrimRep) -> Int -> [(Int, PrimRep)]
-> Addr
-> IO Addr
mkMarshalCode cconv (r_offW, r_rep) addr_offW arg_offs_n_reps
= let bytes = mkMarshalCode_wrk cconv (r_offW, r_rep)
addr_offW arg_offs_n_reps
in unsafePerformIO (sendBytesToMallocville bytes)
in sendBytesToMallocville bytes
......
......@@ -86,10 +86,10 @@ byteCodeGen dflags binds local_tycons local_classes
let flatBinds = concatMap getBind binds
getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)]
getBind (Rec binds) = [(bndr, freeVars rhs) | (bndr,rhs) <- binds]
final_state = runBc (BcM_State [] 0)
(mapBc (schemeR True) flatBinds
`thenBc_` returnBc ())
(BcM_State proto_bcos final_ctr) = final_state
(BcM_State proto_bcos final_ctr, ())
<- runBc (BcM_State [] 0)
(mapBc (schemeR True) flatBinds `thenBc_` returnBc ())
dumpIfSet_dyn dflags Opt_D_dump_BCOs
"Proto-bcos" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
......@@ -113,9 +113,10 @@ coreExprToBCOs dflags expr
(panic "invented_id's type")
let invented_name = idName invented_id
let (BcM_State all_proto_bcos final_ctr)
= runBc (BcM_State [] 0)
(schemeR True (invented_id, freeVars expr))
(BcM_State all_proto_bcos final_ctr, ())
<- runBc (BcM_State [] 0)
(schemeR True (invented_id, freeVars expr))
dumpIfSet_dyn dflags Opt_D_dump_BCOs
"Proto-bcos" (vcat (intersperse (char ' ') (map ppr all_proto_bcos)))
......@@ -709,21 +710,24 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l
void marshall_code ( StgWord* ptr_to_top_of_stack )
-}
-- resolve static address
(is_static, static_target_addr)
get_target_info
= case target of
DynamicTarget
-> (False, panic "ByteCodeGen.generateCCall(dyn)")
-> returnBc (False, panic "ByteCodeGen.generateCCall(dyn)")
StaticTarget target
-> let unpacked = _UNPK_ target
in case unsafePerformIO (lookupSymbol unpacked) of
Just aa -> case aa of Ptr a# -> (True, A# a#)
Nothing -> invalid
-> ioToBc (lookupSymbol (_UNPK_ target)) `thenBc` \res ->
case res of
Just aa -> case aa of Ptr a# -> returnBc (True, A# a#)
Nothing -> returnBc invalid
CasmTarget _
-> invalid
-> returnBc invalid
where
invalid = pprPanic ("ByteCodeGen.generateCCall: unfindable "
++ "symbol or otherwise invalid target")
(ppr ccall_spec)
in
get_target_info `thenBc` \ (is_static, static_target_addr) ->
let
-- Get the arg reps, zapping the leading Addr# in the dynamic case
a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"
......@@ -753,22 +757,22 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l
`appOL`
unitOL (PUSH_TAG r_usizeW)
-- do the call
do_call = unitOL (CCALL addr_of_marshaller)
-- slide and return
wrapup = mkSLIDE r_tsizeW (d_after_r - r_tsizeW - s)
`snocOL` RETURN r_rep
-- generate the marshalling code we're going to call
r_offW = 0
addr_offW = r_tsizeW
arg1_offW = r_tsizeW + addr_tsizeW
args_offW = map (arg1_offW +)
(init (scanl (+) 0 (map taggedSizeW a_reps)))
addr_of_marshaller
= mkMarshalCode cconv
(r_offW, r_rep) addr_offW
(zip args_offW a_reps)
in
ioToBc (mkMarshalCode cconv
(r_offW, r_rep) addr_offW
(zip args_offW a_reps)) `thenBc` \ addr_of_marshaller ->
let
-- do the call
do_call = unitOL (CCALL addr_of_marshaller)
-- slide and return
wrapup = mkSLIDE r_tsizeW (d_after_r - r_tsizeW - s)
`snocOL` RETURN r_rep
in
--trace (show (arg1_offW, args_offW , (map taggedSizeW a_reps) )) (
returnBc (
......@@ -791,18 +795,18 @@ mkDummyLiteral pr
-- Convert (eg)
-- PrelGHC.Int# -> PrelGHC.State# PrelGHC.RealWorld
-- -> (# PrelGHC.State# PrelGHC.RealWorld, PrelGHC.Int# #)
-- PrelGHC.Char# -> PrelGHC.State# PrelGHC.RealWorld
-- -> (# PrelGHC.State# PrelGHC.RealWorld, PrelGHC.Int# #)
--
-- to Just IntRep
-- and check that an unboxed pair isreturned wherein the first arg is VoidRep'd.
-- to Just IntRep
-- and check that an unboxed pair is returned wherein the first arg is VoidRep'd.
--
-- Alternatively, for call-targets returning nothing, convert
--
-- PrelGHC.Int# -> PrelGHC.State# PrelGHC.RealWorld
-- -> (# PrelGHC.State# PrelGHC.RealWorld, PrelGHC.Int# #)
-- PrelGHC.Char# -> PrelGHC.State# PrelGHC.RealWorld
-- -> (# PrelGHC.State# PrelGHC.RealWorld #)
--
-- to Nothing
-- to Nothing
maybe_getCCallReturnRep :: Type -> Maybe PrimRep
maybe_getCCallReturnRep fn_ty
......@@ -1232,21 +1236,31 @@ 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)
type BcM r = BcM_State -> IO (BcM_State, r)
runBc :: BcM_State -> BcM () -> BcM_State
runBc init_st m = case m init_st of { (r,st) -> st }
ioToBc :: IO a -> BcM a
ioToBc io st = do x <- io
return (st, x)
runBc :: BcM_State -> BcM r -> IO (BcM_State, r)
runBc st0 m = do (st1, res) <- m st0
return (st1, res)
thenBc :: BcM a -> (a -> BcM b) -> BcM b
thenBc expr cont st
= case expr st of { (result, st') -> cont result st' }
thenBc expr cont st0
= do (st1, q) <- expr st0
(st2, r) <- cont q st1
return (st2, r)
thenBc_ :: BcM a -> BcM b -> BcM b
thenBc_ expr cont st
= case expr st of { (result, st') -> cont st' }
thenBc_ expr cont st0
= do (st1, q) <- expr st0
(st2, r) <- cont st1
return (st2, r)
returnBc :: a -> BcM a
returnBc result st = (result, st)
returnBc result st = return (st, result)
mapBc :: (a -> BcM b) -> [a] -> BcM [b]
mapBc f [] = returnBc []
......@@ -1257,15 +1271,15 @@ mapBc f (x:xs)
emitBc :: ProtoBCO Name -> BcM ()
emitBc bco st
= ((), st{bcos = bco : bcos st})
= return (st{bcos = bco : bcos st}, ())
getLabelBc :: BcM Int
getLabelBc st
= (nextlabel st, st{nextlabel = 1 + nextlabel st})
= return (st{nextlabel = 1 + nextlabel st}, nextlabel st)
getLabelsBc :: Int -> BcM [Int]
getLabelsBc n st
= let ctr = nextlabel st
in ([ctr .. ctr+n-1], st{nextlabel = ctr+n})
in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
\end{code}
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