Commit 4bb1b965 authored by sewardj's avatar sewardj
Browse files

[project @ 2001-08-08 12:06:28 by sewardj]

Remove the last use of unsavouryPerformIO in this module.  What a lot
of hassle.  Gimme a Von Neumann machine any day.
parent 5a9bbffa
...@@ -25,9 +25,8 @@ import PprCore ( pprCoreExpr ) ...@@ -25,9 +25,8 @@ import PprCore ( pprCoreExpr )
import Literal ( Literal(..), literalPrimRep ) import Literal ( Literal(..), literalPrimRep )
import PrimRep ( PrimRep(..) ) import PrimRep ( PrimRep(..) )
import PrimOp ( PrimOp(..) ) import PrimOp ( PrimOp(..) )
import CStrings ( CLabelString )
import CoreFVs ( freeVars ) import CoreFVs ( freeVars )
import Type ( typePrimRep, splitTyConApp_maybe, isTyVarTy, splitForAllTys ) import Type ( typePrimRep, splitTyConApp_maybe, isTyVarTy )
import DataCon ( dataConTag, fIRST_TAG, dataConTyCon, import DataCon ( dataConTag, fIRST_TAG, dataConTyCon,
dataConWrapId, isUnboxedTupleCon ) dataConWrapId, isUnboxedTupleCon )
import TyCon ( TyCon(..), tyConFamilySize, isDataTyCon, tyConDataCons, import TyCon ( TyCon(..), tyConFamilySize, isDataTyCon, tyConDataCons,
...@@ -37,13 +36,12 @@ import Type ( Type, repType, splitRepFunTys ) ...@@ -37,13 +36,12 @@ import Type ( Type, repType, splitRepFunTys )
import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem ) import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem )
import Var ( isTyVar ) import Var ( isTyVar )
import VarSet ( VarSet, varSetElems ) import VarSet ( VarSet, varSetElems )
import PrimRep ( getPrimRepSize, isFollowableRep ) import PrimRep ( isFollowableRep )
import CmdLineOpts ( DynFlags, DynFlag(..) ) import CmdLineOpts ( DynFlags, DynFlag(..) )
import ErrUtils ( showPass, dumpIfSet_dyn ) import ErrUtils ( showPass, dumpIfSet_dyn )
import Unique ( mkPseudoUnique3 ) import Unique ( mkPseudoUnique3 )
import FastString ( FastString(..) ) import FastString ( FastString(..) )
import Panic ( GhcException(..) ) import Panic ( GhcException(..) )
import SMRep ( fixedHdrSize )
import PprType ( pprType ) import PprType ( pprType )
import ByteCodeInstr ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO, bciStackUse ) import ByteCodeInstr ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO, bciStackUse )
import ByteCodeItbls ( ItblEnv, mkITbls ) import ByteCodeItbls ( ItblEnv, mkITbls )
...@@ -55,13 +53,12 @@ import Linker ( lookupSymbol ) ...@@ -55,13 +53,12 @@ import Linker ( lookupSymbol )
import List ( intersperse, sortBy, zip4 ) import List ( intersperse, sortBy, zip4 )
import Foreign ( Ptr(..), mallocBytes ) import Foreign ( Ptr(..), mallocBytes )
import Addr ( Addr(..), nullAddr, addrToInt, writeCharOffAddr ) import Addr ( Addr(..), writeCharOffAddr )
import CTypes ( CInt ) import CTypes ( CInt )
import Exception ( throwDyn ) import Exception ( throwDyn )
import PrelBase ( Int(..) ) import PrelBase ( Int(..) )
import PrelGHC ( ByteArray# ) import PrelGHC ( ByteArray# )
import IOExts ( unsafePerformIO )
import PrelIOBase ( IO(..) ) import PrelIOBase ( IO(..) )
\end{code} \end{code}
...@@ -278,16 +275,16 @@ schemeE d s p e@(fvs, AnnVar v) ...@@ -278,16 +275,16 @@ schemeE d s p e@(fvs, AnnVar v)
| otherwise | otherwise
= -- returning an unboxed value. Heave it on the stack, SLIDE, and RETURN. = -- returning an unboxed value. Heave it on the stack, SLIDE, and RETURN.
let (push, szw) = pushAtom True d p (AnnVar v) pushAtom True d p (AnnVar v) `thenBc` \ (push, szw) ->
in returnBc (push -- value onto stack returnBc (push -- value onto stack
`appOL` mkSLIDE szw (d-s) -- clear to sequel `appOL` mkSLIDE szw (d-s) -- clear to sequel
`snocOL` RETURN v_rep) -- go `snocOL` RETURN v_rep) -- go
where where
v_rep = typePrimRep (idType v) v_rep = typePrimRep (idType v)
schemeE d s p (fvs, AnnLit literal) schemeE d s p (fvs, AnnLit literal)
= let (push, szw) = pushAtom True d p (AnnLit literal) = pushAtom True d p (AnnLit literal) `thenBc` \ (push, szw) ->
l_rep = literalPrimRep literal let l_rep = literalPrimRep literal
in returnBc (push -- value onto stack in returnBc (push -- value onto stack
`appOL` mkSLIDE szw (d-s) -- clear to sequel `appOL` mkSLIDE szw (d-s) -- clear to sequel
`snocOL` RETURN l_rep) -- go `snocOL` RETURN l_rep) -- go
...@@ -314,19 +311,23 @@ schemeE d s p (fvs, AnnLet binds b) ...@@ -314,19 +311,23 @@ 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 dd ([], size, id, off) buildThunk dd ([], size, id, off)
= PUSH_G (Left (getName id)) = returnBc (PUSH_G (Left (getName id))
`consOL` unitOL (MKAP (off+size-1) size) `consOL` unitOL (MKAP (off+size-1) size))
buildThunk dd ((fv:fvs), size, id, off) buildThunk dd ((fv:fvs), size, id, off)
= case pushAtom True dd p' (AnnVar fv) of = pushAtom True dd p' (AnnVar fv)
(push_code, pushed_szw) `thenBc` \ (push_code, pushed_szw) ->
-> push_code `appOL` buildThunk (dd+pushed_szw) (fvs, size, id, off)
buildThunk (dd+pushed_szw) (fvs, size, id, off) `thenBc` \ more_push_code ->
returnBc (push_code `appOL` more_push_code)
genThunkCode = mapBc (buildThunk d') infos `thenBc` \ tcodes ->
returnBc (concatOL tcodes)
thunkCode = concatOL (map (buildThunk d') infos)
allocCode = toOL (map ALLOC sizes) allocCode = toOL (map ALLOC sizes)
in in
schemeE d' s p' b `thenBc` \ bodyCode -> schemeE d' s p' b `thenBc` \ bodyCode ->
mapBc (schemeR False) (zip xs rhss) `thenBc_` mapBc (schemeR False) (zip xs rhss) `thenBc_`
genThunkCode `thenBc` \ thunkCode ->
returnBc (allocCode `appOL` thunkCode `appOL` bodyCode) returnBc (allocCode `appOL` thunkCode `appOL` bodyCode)
...@@ -359,7 +360,6 @@ schemeE d s p (fvs_case, AnnCase (fvs_scrut, scrut) bndr ...@@ -359,7 +360,6 @@ schemeE d s p (fvs_case, AnnCase (fvs_scrut, scrut) bndr
in trace ("WARNING: ignoring polymorphic case in interpreted mode.\n" ++ in trace ("WARNING: ignoring polymorphic case in interpreted mode.\n" ++
" Possibly due to strict polymorphic/functional constructor args.\n" ++ " Possibly due to strict polymorphic/functional constructor args.\n" ++
" Your program may leak space unexpectedly.\n") " Your program may leak space unexpectedly.\n")
-- ++ showSDoc (char ' ' $$ pprCoreExpr (deAnnotate new_expr) $$ char ' '))
(schemeE d s p new_expr) (schemeE d s p new_expr)
...@@ -506,7 +506,7 @@ schemeT d s p app ...@@ -506,7 +506,7 @@ schemeT d s p app
-- Handle case 0 -- Handle case 0
| Just (arg, constr_names) <- maybe_is_tagToEnum_call | Just (arg, constr_names) <- maybe_is_tagToEnum_call
= pushAtom True d p arg `bind` \ (push, arg_words) -> = pushAtom True d p arg `thenBc` \ (push, arg_words) ->
implement_tagToId constr_names `thenBc` \ tagToId_sequence -> implement_tagToId constr_names `thenBc` \ tagToId_sequence ->
returnBc (push `appOL` tagToId_sequence returnBc (push `appOL` tagToId_sequence
`appOL` mkSLIDE 1 (d+arg_words-s) `appOL` mkSLIDE 1 (d+arg_words-s)
...@@ -538,8 +538,8 @@ schemeT d s p app ...@@ -538,8 +538,8 @@ schemeT d s p app
-- Cases 3 and 4 -- Cases 3 and 4
| otherwise | otherwise
= if is_con_call && isUnboxedTupleCon con = if is_con_call && isUnboxedTupleCon con
then returnBc unboxedTupleException then unboxedTupleException
else code `seq` returnBc code else do_pushery d (map snd args_final_r_to_l)
where where
-- Detect and extract relevant info for the tagToEnum kludge. -- Detect and extract relevant info for the tagToEnum kludge.
...@@ -548,7 +548,7 @@ schemeT d s p app ...@@ -548,7 +548,7 @@ schemeT d s p app
= case splitTyConApp_maybe (repType ty) of = case splitTyConApp_maybe (repType ty) of
(Just (tyc, [])) | isDataTyCon tyc (Just (tyc, [])) | isDataTyCon tyc
-> map getName (tyConDataCons tyc) -> map getName (tyConDataCons tyc)
other -> panic "maybe_is_tagToEnum_call.extract_constr_Ids" other -> panic "maybe_is_tagToEnum_call.extract_constr_Ids"
in in
case app of case app of
(_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg) (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg)
...@@ -585,28 +585,30 @@ schemeT d s p app ...@@ -585,28 +585,30 @@ schemeT d s p app
where isPtr = isFollowableRep . atomRep where isPtr = isFollowableRep . atomRep
-- make code to push the args and then do the SLIDE-ENTER thing -- make code to push the args and then do the SLIDE-ENTER thing
code = do_pushery d (map snd args_final_r_to_l)
tag_when_push = not is_con_call tag_when_push = not is_con_call
narg_words = sum (map (get_arg_szw . atomRep . snd) args_r_to_l) narg_words = sum (map (get_arg_szw . atomRep . snd) args_r_to_l)
get_arg_szw = if tag_when_push then taggedSizeW else untaggedSizeW get_arg_szw = if tag_when_push then taggedSizeW else untaggedSizeW
do_pushery d (arg:args) do_pushery d (arg:args)
= let (push, arg_words) = pushAtom tag_when_push d p arg = pushAtom tag_when_push d p arg `thenBc` \ (push, arg_words) ->
in push `appOL` do_pushery (d+arg_words) args do_pushery (d+arg_words) args `thenBc` \ more_push_code ->
returnBc (push `appOL` more_push_code)
do_pushery d [] do_pushery d []
| Just (CCall ccall_spec) <- isFCallId_maybe fn | Just (CCall ccall_spec) <- isFCallId_maybe fn
= panic "schemeT.do_pushery: unexpected ccall" = panic "schemeT.do_pushery: unexpected ccall"
| otherwise | otherwise
= case maybe_dcon of = case maybe_dcon of
Just con -> PACK con narg_words `consOL` ( Just con -> returnBc (
mkSLIDE 1 (d - narg_words - s) `snocOL` ENTER) (PACK con narg_words `consOL`
mkSLIDE 1 (d - narg_words - s)) `snocOL`
ENTER
)
Nothing Nothing
-> let (push, arg_words) = pushAtom True d p (AnnVar fn) -> pushAtom True d p (AnnVar fn)
in push `thenBc` \ (push, arg_words) ->
`appOL` mkSLIDE (narg_words+arg_words) returnBc (push `appOL` mkSLIDE (narg_words+arg_words)
(d - s - narg_words) (d - s - narg_words)
`snocOL` ENTER `snocOL` ENTER)
...@@ -634,27 +636,32 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l ...@@ -634,27 +636,32 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l
-- depth to the first word of the bits for that arg, and the -- depth to the first word of the bits for that arg, and the
-- PrimRep of what was actually pushed. -- PrimRep of what was actually pushed.
f d [] = [] pargs d [] = returnBc []
f d ((_,a):az) pargs d ((_,a):az)
= let rep_arg = atomRep a = let rep_arg = atomRep a
in case rep_arg of in case rep_arg of
-- Don't push the FO; instead push the Addr# it -- Don't push the FO; instead push the Addr# it
-- contains. -- contains.
ForeignObjRep ForeignObjRep
-> let foro_szW = taggedSizeW ForeignObjRep -> pushAtom False{-irrelevant-} d p a
push_fo = fst (pushAtom False{-irrelevant-} d p a) `thenBc` \ (push_fo, _) ->
let foro_szW = taggedSizeW ForeignObjRep
d_now = d + addr_tsizeW d_now = d + addr_tsizeW
code = push_fo `appOL` toOL [ code = push_fo `appOL` toOL [
UPK_TAG addr_usizeW 0 0, UPK_TAG addr_usizeW 0 0,
SLIDE addr_tsizeW foro_szW SLIDE addr_tsizeW foro_szW
] ]
in (code, AddrRep) : f d_now az in pargs d_now az `thenBc` \ rest ->
returnBc ((code, AddrRep) : rest)
-- Default case: push taggedly, but otherwise intact. -- Default case: push taggedly, but otherwise intact.
other other
-> let (code_a, sz_a) = pushAtom True d p a -> pushAtom True d p a `thenBc` \ (code_a, sz_a) ->
in (code_a, rep_arg) : f (d+sz_a) az pargs (d+sz_a) az `thenBc` \ rest ->
returnBc ((code_a, rep_arg) : rest)
(pushs_arg, a_reps_pushed_r_to_l) = unzip (f d0 args_r_to_l) in
pargs d0 args_r_to_l `thenBc` \ code_n_reps ->
let
(pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps
push_args = concatOL pushs_arg push_args = concatOL pushs_arg
d_after_args = d0 + sum (map taggedSizeW a_reps_pushed_r_to_l) d_after_args = d0 + sum (map taggedSizeW a_reps_pushed_r_to_l)
...@@ -960,18 +967,18 @@ mkUnpackCode vars d p ...@@ -960,18 +967,18 @@ mkUnpackCode vars d p
-- 5 and not to 4. Stack locations are numbered from zero, so a depth -- 5 and not to 4. Stack locations are numbered from zero, so a depth
-- 6 stack has valid words 0 .. 5. -- 6 stack has valid words 0 .. 5.
pushAtom :: Bool -> Int -> BCEnv -> AnnExpr' Id VarSet -> (BCInstrList, Int) pushAtom :: Bool -> Int -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Int)
pushAtom tagged d p (AnnVar v) pushAtom tagged d p (AnnVar v)
| idPrimRep v == VoidRep | idPrimRep v == VoidRep
= if tagged then (unitOL (PUSH_TAG 0), 1) = if tagged then returnBc (unitOL (PUSH_TAG 0), 1)
else panic "ByteCodeGen.pushAtom(VoidRep,untaggedly)" else panic "ByteCodeGen.pushAtom(VoidRep,untaggedly)"
| isFCallId v | isFCallId v
= pprPanic "pushAtom: shouldn't get an FCallId here" (ppr v) = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr v)
| Just primop <- isPrimOpId_maybe v | Just primop <- isPrimOpId_maybe v
= (unitOL (PUSH_G (Right primop)), 1) = returnBc (unitOL (PUSH_G (Right primop)), 1)
| otherwise | otherwise
= let {- = let {-
...@@ -998,11 +1005,11 @@ pushAtom tagged d p (AnnVar v) ...@@ -998,11 +1005,11 @@ pushAtom tagged d p (AnnVar v)
sz_u = untaggedIdSizeW v sz_u = untaggedIdSizeW v
nwords = if tagged then sz_t else sz_u nwords = if tagged then sz_t else sz_u
in in
result returnBc result
pushAtom True d p (AnnLit lit) pushAtom True d p (AnnLit lit)
= let (ubx_code, ubx_size) = pushAtom False d p (AnnLit lit) = pushAtom False d p (AnnLit lit) `thenBc` \ (ubx_code, ubx_size) ->
in (ubx_code `snocOL` PUSH_TAG ubx_size, 1 + ubx_size) returnBc (ubx_code `snocOL` PUSH_TAG ubx_size, 1 + ubx_size)
pushAtom False d p (AnnLit lit) pushAtom False d p (AnnLit lit)
= case lit of = case lit of
...@@ -1015,12 +1022,13 @@ pushAtom False d p (AnnLit lit) ...@@ -1015,12 +1022,13 @@ pushAtom False d p (AnnLit lit)
where where
code rep code rep
= let size_host_words = untaggedSizeW rep = let size_host_words = untaggedSizeW rep
in (unitOL (PUSH_UBX (Left lit) size_host_words), size_host_words) in returnBc (unitOL (PUSH_UBX (Left lit) size_host_words),
size_host_words)
pushStr s pushStr s
= let mallocvilleAddr = let getMallocvilleAddr
= case s of = case s of
CharStr s i -> A# s CharStr s i -> returnBc (A# s)
FastString _ l ba -> FastString _ l ba ->
-- sigh, a string in the heap is no good to us. -- sigh, a string in the heap is no good to us.
...@@ -1030,16 +1038,17 @@ pushAtom False d p (AnnLit lit) ...@@ -1030,16 +1038,17 @@ pushAtom False d p (AnnLit lit)
-- at the same time. -- at the same time.
let n = I# l let n = I# l
-- CAREFUL! Chars are 32 bits in ghc 4.09+ -- CAREFUL! Chars are 32 bits in ghc 4.09+
in unsafePerformIO ( in ioToBc (
do (Ptr a#) <- mallocBytes (n+1) do (Ptr a#) <- mallocBytes (n+1)
strncpy (Ptr a#) ba (fromIntegral n) strncpy (Ptr a#) ba (fromIntegral n)
writeCharOffAddr (A# a#) n '\0' writeCharOffAddr (A# a#) n '\0'
return (A# a#) return (A# a#)
) )
_ -> panic "StgInterp.lit2expr: unhandled string constant type" other -> panic "ByteCodeGen.pushAtom.pushStr"
in in
getMallocvilleAddr `thenBc` \ addr ->
-- Get the addr on the stack, untaggedly -- Get the addr on the stack, untaggedly
(unitOL (PUSH_UBX (Right mallocvilleAddr) 1), 1) returnBc (unitOL (PUSH_UBX (Right addr) 1), 1)
......
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