From 423d477bfecd490de1449c59325c8776f91d7aac Mon Sep 17 00:00:00 2001 From: simonmar Date: Fri, 13 Aug 2004 13:11:23 +0000 Subject: [project @ 2004-08-13 13:04:50 by simonmar] Merge backend-hacking-branch onto HEAD. Yay! --- ghc/compiler/ghci/ByteCodeAsm.lhs | 37 ++++---- ghc/compiler/ghci/ByteCodeFFI.lhs | 59 ++++++------- ghc/compiler/ghci/ByteCodeGen.lhs | 162 +++++++++++++++++------------------- ghc/compiler/ghci/ByteCodeInstr.lhs | 7 +- ghc/compiler/ghci/ByteCodeItbls.lhs | 10 ++- ghc/compiler/ghci/InteractiveUI.hs | 4 +- ghc/compiler/ghci/Linker.lhs | 2 +- 7 files changed, 130 insertions(+), 151 deletions(-) (limited to 'ghc/compiler/ghci') diff --git a/ghc/compiler/ghci/ByteCodeAsm.lhs b/ghc/compiler/ghci/ByteCodeAsm.lhs index 53340e78cd..3958753b69 100644 --- a/ghc/compiler/ghci/ByteCodeAsm.lhs +++ b/ghc/compiler/ghci/ByteCodeAsm.lhs @@ -26,10 +26,9 @@ import FiniteMap ( addToFM, lookupFM, emptyFM ) import Literal ( Literal(..) ) import TyCon ( TyCon ) import PrimOp ( PrimOp ) -import PrimRep ( PrimRep(..), isFollowableRep, is64BitRep ) import Constants ( wORD_SIZE ) import FastString ( FastString(..) ) -import SMRep ( StgWord ) +import SMRep ( CgRep(..), StgWord ) import FiniteMap import Outputable @@ -356,27 +355,19 @@ mkBits findLabel st proto_insns literal st other = pprPanic "ByteCodeLink.literal" (ppr other) -push_alts WordRep = bci_PUSH_ALTS_N -push_alts IntRep = bci_PUSH_ALTS_N -push_alts AddrRep = bci_PUSH_ALTS_N -push_alts CharRep = bci_PUSH_ALTS_N -push_alts FloatRep = bci_PUSH_ALTS_F -push_alts DoubleRep = bci_PUSH_ALTS_D -push_alts VoidRep = bci_PUSH_ALTS_V -push_alts pk - | is64BitRep pk = bci_PUSH_ALTS_L - | isFollowableRep pk = bci_PUSH_ALTS_P - -return_ubx WordRep = bci_RETURN_N -return_ubx IntRep = bci_RETURN_N -return_ubx AddrRep = bci_RETURN_N -return_ubx CharRep = bci_RETURN_N -return_ubx FloatRep = bci_RETURN_F -return_ubx DoubleRep = bci_RETURN_D -return_ubx VoidRep = bci_RETURN_V -return_ubx pk - | is64BitRep pk = bci_RETURN_L - | isFollowableRep pk = bci_RETURN_P +push_alts NonPtrArg = bci_PUSH_ALTS_N +push_alts FloatArg = bci_PUSH_ALTS_F +push_alts DoubleArg = bci_PUSH_ALTS_D +push_alts VoidArg = bci_PUSH_ALTS_V +push_alts LongArg = bci_PUSH_ALTS_L +push_alts PtrArg = bci_PUSH_ALTS_P + +return_ubx NonPtrArg = bci_RETURN_N +return_ubx FloatArg = bci_RETURN_F +return_ubx DoubleArg = bci_RETURN_D +return_ubx VoidArg = bci_RETURN_V +return_ubx LongArg = bci_RETURN_L +return_ubx PtrArg = bci_RETURN_P -- The size in 16-bit entities of an instruction. diff --git a/ghc/compiler/ghci/ByteCodeFFI.lhs b/ghc/compiler/ghci/ByteCodeFFI.lhs index 78cfa610b2..fe258dd7cf 100644 --- a/ghc/compiler/ghci/ByteCodeFFI.lhs +++ b/ghc/compiler/ghci/ByteCodeFFI.lhs @@ -9,7 +9,7 @@ module ByteCodeFFI ( mkMarshalCode, moan64 ) where #include "HsVersions.h" import Outputable -import PrimRep ( PrimRep(..), getPrimRepSize ) +import SMRep ( CgRep(..), cgRepSizeW ) import ForeignCall ( CCallConv(..) ) -- DON'T remove apparently unused imports here .. @@ -66,7 +66,7 @@ itself expects only to be called using the ccall convention -- that is, we don't clear our own (single) arg off the C stack. -} mkMarshalCode :: CCallConv - -> (Int, PrimRep) -> Int -> [(Int, PrimRep)] + -> (Int, CgRep) -> Int -> [(Int, CgRep)] -> IO (Ptr Word8) mkMarshalCode cconv (r_offW, r_rep) addr_offW arg_offs_n_reps = let bytes = mkMarshalCode_wrk cconv (r_offW, r_rep) @@ -77,7 +77,7 @@ mkMarshalCode cconv (r_offW, r_rep) addr_offW arg_offs_n_reps mkMarshalCode_wrk :: CCallConv - -> (Int, PrimRep) -> Int -> [(Int, PrimRep)] + -> (Int, CgRep) -> Int -> [(Int, CgRep)] -> [Word8] mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps @@ -90,7 +90,7 @@ mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps offsets_to_pushW = concat [ -- reversed because x86 is little-endian - reverse [a_offW .. a_offW + getPrimRepSize a_rep - 1] + reverse [a_offW .. a_offW + cgRepSizeW a_rep - 1] -- reversed because args are pushed L -> R onto C stack | (a_offW, a_rep) <- reverse arg_offs_n_reps @@ -187,7 +187,7 @@ mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps ++ movl_offespmem_esi 32 {- For each arg in args_offs_n_reps, examine the associated - PrimRep to determine how many words there are. This gives a + CgRep to determine how many words there are. This gives a bunch of offsets on the H stack to copy to the C stack: movl off1(%esi), %ecx @@ -235,15 +235,11 @@ mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps f64 = fstpl_offesimem 0 in case r_rep of - CharRep -> i32 - IntRep -> i32 - WordRep -> i32 - AddrRep -> i32 - DoubleRep -> f64 - FloatRep -> f32 - -- Word64Rep -> i64 - -- Int64Rep -> i64 - VoidRep -> [] + NonPtrArg -> i32 + DoubleArg -> f64 + FloatArg -> f32 + -- LongArg -> i64 + VoidArg -> [] other -> moan64 "ByteCodeFFI.mkMarshalCode_wrk(x86)" (ppr r_rep) @@ -278,7 +274,7 @@ mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps offsets_to_pushW = concat - [ [a_offW .. a_offW + getPrimRepSize a_rep - 1] + [ [a_offW .. a_offW + cgRepSizeW a_rep - 1] | (a_offW, a_rep) <- arg_offs_n_reps ] @@ -385,7 +381,7 @@ mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps [mkSAVE sp (- ({-92-}112 + 4*argWs_on_stack_ROUNDED_UP)) sp] {- For each arg in args_offs_n_reps, examine the associated - PrimRep to determine how many words there are. This gives a + CgRep to determine how many words there are. This gives a bunch of offsets on the H stack. Move the first 6 words into %o0 .. %o5 and the rest on the stack, starting at [%sp+92]. Use %g1 as a temp. @@ -429,13 +425,10 @@ mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps f64 = [mkSTF f0 i0 0, mkSTF f1 i0 4] in case r_rep of - CharRep -> i32 - IntRep -> i32 - WordRep -> i32 - AddrRep -> i32 - DoubleRep -> f64 - FloatRep -> f32 - VoidRep -> [] + NonPtrArg -> i32 + DoubleArg -> f64 + FloatArg -> f32 + VoidArg -> [] other -> moan64 "ByteCodeFFI.mkMarshalCode_wrk(sparc)" (ppr r_rep) @@ -460,7 +453,7 @@ mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps result_off = r_offW * bytes_per_word linkageArea = 24 - parameterArea = sum [ getPrimRepSize a_rep * bytes_per_word + parameterArea = sum [ cgRepSizeW a_rep * bytes_per_word | (_, a_rep) <- arg_offs_n_reps ] savedRegisterArea = 4 frameSize = padTo16 (linkageArea + max parameterArea 32 + savedRegisterArea) @@ -472,7 +465,7 @@ mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps pass_parameters ((a_offW, a_rep):args) nextFPR offsetW = let haskellArgOffset = a_offW * bytes_per_word - offsetW' = offsetW + getPrimRepSize a_rep + offsetW' = offsetW + cgRepSizeW a_rep pass_word w | offsetW + w < 8 = @@ -489,34 +482,34 @@ mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps dst = linkageArea + (offsetW+w) * bytes_per_word in case a_rep of - FloatRep | nextFPR < 14 -> + FloatArg | nextFPR < 14 -> (0xc01f0000 -- lfs fX, haskellArgOffset(r31) .|. (fromIntegral haskellArgOffset .&. 0xFFFF) .|. (fromIntegral nextFPR `shiftL` 21)) : pass_parameters args (nextFPR+1) offsetW' - DoubleRep | nextFPR < 14 -> + DoubleArg | nextFPR < 14 -> (0xc81f0000 -- lfd fX, haskellArgOffset(r31) .|. (fromIntegral haskellArgOffset .&. 0xFFFF) .|. (fromIntegral nextFPR `shiftL` 21)) : pass_parameters args (nextFPR+1) offsetW' _ -> - concatMap pass_word [0 .. getPrimRepSize a_rep - 1] + concatMap pass_word [0 .. cgRepSizeW a_rep - 1] ++ pass_parameters args nextFPR offsetW' gather_result = case r_rep of - VoidRep -> [] - FloatRep -> + VoidArg -> [] + FloatArg -> [0xd03f0000 .|. (fromIntegral result_off .&. 0xFFFF)] -- stfs f1, result_off(r31) - DoubleRep -> + DoubleArg -> [0xd83f0000 .|. (fromIntegral result_off .&. 0xFFFF)] -- stfs f1, result_off(r31) - _ | getPrimRepSize r_rep == 2 -> + _ | cgRepSizeW r_rep == 2 -> [0x907f0000 .|. (fromIntegral result_off .&. 0xFFFF), 0x909f0000 .|. (fromIntegral (result_off+4) .&. 0xFFFF)] -- stw r3, result_off(r31) -- stw r4, result_off+4(r31) - _ | getPrimRepSize r_rep == 1 -> + _ | cgRepSizeW r_rep == 1 -> [0x907f0000 .|. (fromIntegral result_off .&. 0xFFFF)] -- stw r3, result_off(r31) in diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index d7a477bfdc..f7256f3f77 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -23,11 +23,10 @@ import HscTypes ( TypeEnv, typeEnvTyCons, typeEnvClasses ) import CoreUtils ( exprType ) import CoreSyn import PprCore ( pprCoreExpr ) -import Literal ( Literal(..), literalPrimRep ) -import PrimRep +import Literal ( Literal(..), literalType ) import PrimOp ( PrimOp(..) ) import CoreFVs ( freeVars ) -import Type ( typePrimRep, isUnLiftedType, splitTyConApp_maybe ) +import Type ( isUnLiftedType, splitTyConApp_maybe ) import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon, isUnboxedTupleCon, isNullaryDataCon, dataConWorkId, dataConRepArity ) @@ -42,13 +41,13 @@ import VarSet ( VarSet, varSetElems ) import TysPrim ( arrayPrimTyCon, mutableArrayPrimTyCon, byteArrayPrimTyCon, mutableByteArrayPrimTyCon ) -import PrimRep ( isFollowableRep ) import CmdLineOpts ( DynFlags, DynFlag(..) ) import ErrUtils ( showPass, dumpIfSet_dyn ) -import Unique ( mkPseudoUnique3 ) +import Unique ( mkPseudoUniqueE ) import FastString ( FastString(..), unpackFS ) import Panic ( GhcException(..) ) -import SMRep ( arrWordsHdrSize, arrPtrsHdrSize, StgWord ) +import SMRep ( typeCgRep, arrWordsHdrSize, arrPtrsHdrSize, StgWord, + CgRep(..), cgRepSizeW, isFollowableArg, idCgRep ) import Bitmap ( intsToReverseBitmap, mkBitmap ) import OrdList import Constants ( wORD_SIZE ) @@ -103,7 +102,7 @@ coreExprToBCOs dflags expr -- create a totally bogus name for the top-level BCO; this -- should be harmless, since it's never used for anything - let invented_name = mkSystemName (mkPseudoUnique3 0) FSLIT("ExprTopLevel") + let invented_name = mkSystemName (mkPseudoUniqueE 0) FSLIT("ExprTopLevel") invented_id = mkLocalId invented_name (panic "invented_id's type") (BcM_State final_ctr mallocd, proto_bco) @@ -134,7 +133,7 @@ ppBCEnv p $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (fmToList p)))) $$ text "end-env" where - pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (idPrimRep var) + pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (idCgRep var) cmp_snd x y = compare (snd x) (snd y) -- Create a BCO and do a spot of peephole optimisation on the insns @@ -195,11 +194,11 @@ mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap peep [] = [] -argBits :: [PrimRep] -> [Bool] +argBits :: [CgRep] -> [Bool] argBits [] = [] argBits (rep : args) - | isFollowableRep rep = False : argBits args - | otherwise = take (getPrimRepSize rep) (repeat True) ++ argBits args + | isFollowableArg rep = False : argBits args + | otherwise = take (cgRepSizeW rep) (repeat True) ++ argBits args -- ----------------------------------------------------------------------------- -- schemeTopBind @@ -272,7 +271,7 @@ schemeR_wrk fvs nm original_body (args, body) p_init = listToFM (zip all_args (mkStackOffsets 0 szsw_args)) -- make the arg bitmap - bits = argBits (reverse (map idPrimRep all_args)) + bits = argBits (reverse (map idCgRep all_args)) bitmap_size = length bits bitmap = mkBitmap bits in @@ -319,11 +318,11 @@ schemeE d s p e@(AnnVar v) `snocOL` RETURN_UBX v_rep) -- go where v_type = idType v - v_rep = typePrimRep v_type + v_rep = typeCgRep v_type schemeE d s p (AnnLit literal) = pushAtom d p (AnnLit literal) `thenBc` \ (push, szw) -> - let l_rep = literalPrimRep literal + let l_rep = typeCgRep (literalType literal) in returnBc (push -- value onto stack `appOL` mkSLIDE szw (d-s) -- clear to sequel `snocOL` RETURN_UBX l_rep) -- go @@ -393,9 +392,9 @@ schemeE d s p (AnnLet binds (_,body)) schemeE d s p (AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)]) - | isUnboxedTupleCon dc && VoidRep == typePrimRep (idType bind1) + | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1) -- Convert - -- case .... of x { (# VoidRep'd-thing, a #) -> ... } + -- case .... of x { (# VoidArg'd-thing, a #) -> ... } -- to -- case .... of a { DEFAULT -> ... } -- becuse the return convention for both are identical. @@ -403,11 +402,11 @@ schemeE d s p (AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)]) -- Note that it does not matter losing the void-rep thing from the -- envt (it won't be bound now) because we never look such things up. - = --trace "automagic mashing of case alts (# VoidRep, a #)" $ + = --trace "automagic mashing of case alts (# VoidArg, a #)" $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-} - | isUnboxedTupleCon dc && VoidRep == typePrimRep (idType bind2) - = --trace "automagic mashing of case alts (# a, VoidRep #)" $ + | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind2) + = --trace "automagic mashing of case alts (# a, VoidArg #)" $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} schemeE d s p (AnnCase scrut bndr [(DataAlt dc, [bind1], rhs)]) @@ -441,9 +440,9 @@ schemeE d s p other -- -- 1. The fn denotes a ccall. Defer to generateCCall. -- --- 2. (Another nasty hack). Spot (# a::VoidRep, b #) and treat +-- 2. (Another nasty hack). Spot (# a::VoidArg, b #) and treat -- it simply as b -- since the representations are identical --- (the VoidRep takes up zero stack space). Also, spot +-- (the VoidArg takes up zero stack space). Also, spot -- (# b #) and treat it as b. -- -- 3. Application of a constructor, by defn saturated. @@ -483,9 +482,9 @@ schemeT d s p app | Just con <- maybe_saturated_dcon, isUnboxedTupleCon con = case args_r_to_l of - [arg1,arg2] | isVoidRepAtom arg1 -> + [arg1,arg2] | isVoidArgAtom arg1 -> unboxedTupleReturn d s p arg2 - [arg1,arg2] | isVoidRepAtom arg2 -> + [arg1,arg2] | isVoidArgAtom arg2 -> unboxedTupleReturn d s p arg1 _other -> unboxedTupleException @@ -589,7 +588,7 @@ doTailCall -> Id -> [AnnExpr' Id VarSet] -> BcM BCInstrList doTailCall init_d s p fn args - = do_pushes init_d args (map (primRepToArgRep.atomRep) args) + = do_pushes init_d args (map atomRep args) where do_pushes d [] reps = do ASSERTM( null reps ) @@ -613,29 +612,29 @@ doTailCall init_d s p fn args return (final_d, push_code `appOL` more_push_code) -- v. similar to CgStackery.findMatch, ToDo: merge -findPushSeq (RepP: RepP: RepP: RepP: RepP: RepP: RepP: rest) +findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest) = (PUSH_APPLY_PPPPPPP, 7, rest) -findPushSeq (RepP: RepP: RepP: RepP: RepP: RepP: rest) +findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest) = (PUSH_APPLY_PPPPPP, 6, rest) -findPushSeq (RepP: RepP: RepP: RepP: RepP: rest) +findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest) = (PUSH_APPLY_PPPPP, 5, rest) -findPushSeq (RepP: RepP: RepP: RepP: rest) +findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: rest) = (PUSH_APPLY_PPPP, 4, rest) -findPushSeq (RepP: RepP: RepP: rest) +findPushSeq (PtrArg: PtrArg: PtrArg: rest) = (PUSH_APPLY_PPP, 3, rest) -findPushSeq (RepP: RepP: rest) +findPushSeq (PtrArg: PtrArg: rest) = (PUSH_APPLY_PP, 2, rest) -findPushSeq (RepP: rest) +findPushSeq (PtrArg: rest) = (PUSH_APPLY_P, 1, rest) -findPushSeq (RepV: rest) +findPushSeq (VoidArg: rest) = (PUSH_APPLY_V, 1, rest) -findPushSeq (RepN: rest) +findPushSeq (NonPtrArg: rest) = (PUSH_APPLY_N, 1, rest) -findPushSeq (RepF: rest) +findPushSeq (FloatArg: rest) = (PUSH_APPLY_F, 1, rest) -findPushSeq (RepD: rest) +findPushSeq (DoubleArg: rest) = (PUSH_APPLY_D, 1, rest) -findPushSeq (RepL: rest) +findPushSeq (LongArg: rest) = (PUSH_APPLY_L, 1, rest) findPushSeq _ = panic "ByteCodeGen.findPushSeq" @@ -688,7 +687,7 @@ doCase d s p (_,scrut) -- algebraic alt with some binders | ASSERT(isAlgCase) otherwise = let - (ptrs,nptrs) = partition (isFollowableRep.idPrimRep) real_bndrs + (ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs ptr_sizes = map idSizeW ptrs nptrs_sizes = map idSizeW nptrs bind_sizes = ptr_sizes ++ nptrs_sizes @@ -736,7 +735,7 @@ doCase d s p (_,scrut) binds = fmToList p rel_slots = concat (map spread binds) spread (id, offset) - | isFollowableRep (idPrimRep id) = [ rel_offset ] + | isFollowableArg (idCgRep id) = [ rel_offset ] | otherwise = [] where rel_offset = d - offset - 1 @@ -754,7 +753,7 @@ doCase d s p (_,scrut) alt_bco' <- emitBc alt_bco let push_alts | isAlgCase = PUSH_ALTS alt_bco' - | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typePrimRep bndr_ty) + | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeCgRep bndr_ty) returnBc (push_alts `consOL` scrut_code) @@ -777,12 +776,12 @@ generateCCall :: Int -> Sequel -- stack and sequel depths generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l = let -- useful constants - addr_sizeW = getPrimRepSize AddrRep + addr_sizeW = cgRepSizeW NonPtrArg -- Get the args on the stack, with tags and suitably -- dereferenced for the CCall. For each arg, return the -- depth to the first word of the bits for that arg, and the - -- PrimRep of what was actually pushed. + -- CgRep of what was actually pushed. pargs d [] = returnBc [] pargs d (a:az) @@ -796,13 +795,13 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l -> pargs (d + addr_sizeW) az `thenBc` \ rest -> parg_ArrayishRep arrPtrsHdrSize d p a `thenBc` \ code -> - returnBc ((code,AddrRep):rest) + returnBc ((code,NonPtrArg):rest) | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon -> pargs (d + addr_sizeW) az `thenBc` \ rest -> parg_ArrayishRep arrWordsHdrSize d p a `thenBc` \ code -> - returnBc ((code,AddrRep):rest) + returnBc ((code,NonPtrArg):rest) -- Default case: push taggedly, but otherwise intact. other @@ -813,13 +812,11 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l -- Do magic for Ptr/Byte arrays. Push a ptr to the array on -- the stack but then advance it over the headers, so as to -- point to the payload. - parg_ArrayishRep hdrSizeW d p a + parg_ArrayishRep hdrSize d p a = pushAtom d p a `thenBc` \ (push_fo, _) -> -- The ptr points at the header. Advance it over the -- header and then pretend this is an Addr#. - returnBc (push_fo `snocOL` - SWIZZLE 0 (hdrSizeW * getPrimRepSize WordRep - * wORD_SIZE)) + returnBc (push_fo `snocOL` SWIZZLE 0 hdrSize) in pargs d0 args_r_to_l `thenBc` \ code_n_reps -> @@ -827,9 +824,9 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps push_args = concatOL pushs_arg - d_after_args = d0 + sum (map getPrimRepSize a_reps_pushed_r_to_l) + d_after_args = d0 + sum (map cgRepSizeW a_reps_pushed_r_to_l) a_reps_pushed_RAW - | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidRep + | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidArg = panic "ByteCodeGen.generateCCall: missing or invalid World token?" | otherwise = reverse (tail a_reps_pushed_r_to_l) @@ -841,7 +838,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l -- Get the result rep. (returns_void, r_rep) = case maybe_getCCallReturnRep (idType fn) of - Nothing -> (True, VoidRep) + Nothing -> (True, VoidArg) Just rr -> (False, rr) {- Because the Haskell stack grows down, the a_reps refer to @@ -906,8 +903,8 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l = (nilOL, d_after_args) -- Push the return placeholder. For a call returning nothing, - -- this is a VoidRep (tag). - r_sizeW = getPrimRepSize r_rep + -- this is a VoidArg (tag). + r_sizeW = cgRepSizeW r_rep d_after_r = d_after_Addr + r_sizeW r_lit = mkDummyLiteral r_rep push_r = (if returns_void @@ -919,7 +916,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l addr_offW = r_sizeW arg1_offW = r_sizeW + addr_sizeW args_offW = map (arg1_offW +) - (init (scanl (+) 0 (map getPrimRepSize a_reps))) + (init (scanl (+) 0 (map cgRepSizeW a_reps))) in ioToBc (mkMarshalCode cconv (r_offW, r_rep) addr_offW @@ -938,7 +935,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l wrapup = mkSLIDE r_sizeW (d_after_r - r_sizeW - s) `snocOL` RETURN_UBX r_rep in - --trace (show (arg1_offW, args_offW , (map getPrimRepSize a_reps) )) $ + --trace (show (arg1_offW, args_offW , (map cgRepSizeW a_reps) )) $ returnBc ( push_args `appOL` push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup @@ -947,15 +944,12 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l -- Make a dummy literal, to be used as a placeholder for FFI return -- values on the stack. -mkDummyLiteral :: PrimRep -> Literal +mkDummyLiteral :: CgRep -> Literal mkDummyLiteral pr = case pr of - CharRep -> MachChar (chr 0) - IntRep -> MachInt 0 - WordRep -> MachWord 0 - DoubleRep -> MachDouble 0 - FloatRep -> MachFloat 0 - AddrRep | getPrimRepSize AddrRep == getPrimRepSize WordRep -> MachWord 0 + NonPtrArg -> MachWord 0 + DoubleArg -> MachDouble 0 + FloatArg -> MachFloat 0 _ -> moan64 "mkDummyLiteral" (ppr pr) @@ -964,7 +958,7 @@ mkDummyLiteral pr -- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #) -- -- to Just IntRep --- and check that an unboxed pair is returned wherein the first arg is VoidRep'd. +-- and check that an unboxed pair is returned wherein the first arg is VoidArg'd. -- -- Alternatively, for call-targets returning nothing, convert -- @@ -973,21 +967,21 @@ mkDummyLiteral pr -- -- to Nothing -maybe_getCCallReturnRep :: Type -> Maybe PrimRep +maybe_getCCallReturnRep :: Type -> Maybe CgRep maybe_getCCallReturnRep fn_ty = let (a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) maybe_r_rep_to_go = if isSingleton r_reps then Nothing else Just (r_reps !! 1) (r_tycon, r_reps) = case splitTyConApp_maybe (repType r_ty) of - (Just (tyc, tys)) -> (tyc, map typePrimRep tys) + (Just (tyc, tys)) -> (tyc, map typeCgRep tys) Nothing -> blargh - ok = ( ( r_reps `lengthIs` 2 && VoidRep == head r_reps) - || r_reps == [VoidRep] ) + ok = ( ( r_reps `lengthIs` 2 && VoidArg == head r_reps) + || r_reps == [VoidArg] ) && isUnboxedTupleTyCon r_tycon && case maybe_r_rep_to_go of Nothing -> True - Just r_rep -> r_rep /= PtrRep + Just r_rep -> r_rep /= PtrArg -- if it was, it would be impossible -- to create a valid return value -- placeholder on the stack @@ -1047,7 +1041,7 @@ pushAtom d p (AnnLam x e) pushAtom d p (AnnVar v) - | idPrimRep v == VoidRep + | idCgRep v == VoidArg = returnBc (nilOL, 0) | isFCallId v @@ -1079,16 +1073,16 @@ pushAtom d p (AnnVar v) pushAtom d p (AnnLit lit) = case lit of - MachLabel fs _ -> code CodePtrRep - MachWord w -> code WordRep - MachInt i -> code IntRep - MachFloat r -> code FloatRep - MachDouble r -> code DoubleRep - MachChar c -> code CharRep + MachLabel fs _ -> code NonPtrArg + MachWord w -> code NonPtrArg + MachInt i -> code PtrArg + MachFloat r -> code FloatArg + MachDouble r -> code DoubleArg + MachChar c -> code NonPtrArg MachStr s -> pushStr s where code rep - = let size_host_words = getPrimRepSize rep + = let size_host_words = cgRepSizeW rep in returnBc (unitOL (PUSH_UBX (Left lit) size_host_words), size_host_words) @@ -1256,7 +1250,7 @@ lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int lookupBCEnv_maybe = lookupFM idSizeW :: Id -> Int -idSizeW id = getPrimRepSize (typePrimRep (idType id)) +idSizeW id = cgRepSizeW (typeCgRep (idType id)) unboxedTupleException :: a unboxedTupleException @@ -1284,21 +1278,21 @@ isTypeAtom :: AnnExpr' id ann -> Bool isTypeAtom (AnnType _) = True isTypeAtom _ = False -isVoidRepAtom :: AnnExpr' id ann -> Bool -isVoidRepAtom (AnnVar v) = typePrimRep (idType v) == VoidRep -isVoidRepAtom (AnnNote n (_,e)) = isVoidRepAtom e -isVoidRepAtom _ = False +isVoidArgAtom :: AnnExpr' id ann -> Bool +isVoidArgAtom (AnnVar v) = typeCgRep (idType v) == VoidArg +isVoidArgAtom (AnnNote n (_,e)) = isVoidArgAtom e +isVoidArgAtom _ = False -atomRep :: AnnExpr' Id ann -> PrimRep -atomRep (AnnVar v) = typePrimRep (idType v) -atomRep (AnnLit l) = literalPrimRep l +atomRep :: AnnExpr' Id ann -> CgRep +atomRep (AnnVar v) = typeCgRep (idType v) +atomRep (AnnLit l) = typeCgRep (literalType l) atomRep (AnnNote n b) = atomRep (snd b) atomRep (AnnApp f (_, AnnType _)) = atomRep (snd f) atomRep (AnnLam x e) | isTyVar x = atomRep (snd e) atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other))) isPtrAtom :: AnnExpr' Id ann -> Bool -isPtrAtom e = isFollowableRep (atomRep e) +isPtrAtom e = atomRep e == PtrArg -- Let szsw be the sizes in words of some items pushed onto the stack, -- which has initial depth d'. Return the values which the stack environment diff --git a/ghc/compiler/ghci/ByteCodeInstr.lhs b/ghc/compiler/ghci/ByteCodeInstr.lhs index 05c4fe4734..43c551549f 100644 --- a/ghc/compiler/ghci/ByteCodeInstr.lhs +++ b/ghc/compiler/ghci/ByteCodeInstr.lhs @@ -17,11 +17,10 @@ import Id ( Id ) import CoreSyn import PprCore ( pprCoreExpr, pprCoreAlt ) import Literal ( Literal ) -import PrimRep ( PrimRep ) import DataCon ( DataCon ) import VarSet ( VarSet ) import PrimOp ( PrimOp ) -import SMRep ( StgWord ) +import SMRep ( StgWord, CgRep ) import GHC.Ptr -- ---------------------------------------------------------------------------- @@ -59,7 +58,7 @@ data BCInstr -- Push an alt continuation | PUSH_ALTS (ProtoBCO Name) - | PUSH_ALTS_UNLIFTED (ProtoBCO Name) PrimRep + | PUSH_ALTS_UNLIFTED (ProtoBCO Name) CgRep -- Pushing literals | PUSH_UBX (Either Literal (Ptr ())) Int @@ -125,7 +124,7 @@ data BCInstr -- To Infinity And Beyond | ENTER | RETURN -- return a lifted value - | RETURN_UBX PrimRep -- return an unlifted value, here's its rep + | RETURN_UBX CgRep -- return an unlifted value, here's its rep -- ----------------------------------------------------------------------------- -- Printing bytecode instructions diff --git a/ghc/compiler/ghci/ByteCodeItbls.lhs b/ghc/compiler/ghci/ByteCodeItbls.lhs index 5325f8f29e..c44e562bc0 100644 --- a/ghc/compiler/ghci/ByteCodeItbls.lhs +++ b/ghc/compiler/ghci/ByteCodeItbls.lhs @@ -13,11 +13,11 @@ module ByteCodeItbls ( ItblEnv, ItblPtr, mkITbls ) where import Name ( Name, getName ) import NameEnv -import Type ( typePrimRep ) +import SMRep ( typeCgRep ) import DataCon ( DataCon, dataConRepArgTys ) import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) import Constants ( mIN_SIZE_NonUpdHeapObject ) -import ClosureInfo ( mkVirtHeapOffsets ) +import CgHeapery ( mkVirtHeapOffsets ) import FastString ( FastString(..) ) import Util ( lengthIs, listLengthCmp ) @@ -87,8 +87,10 @@ make_constr_itbls cons mk_itbl :: DataCon -> Int -> Ptr () -> IO (Name,ItblPtr) mk_itbl dcon conNo entry_addr - = let (tot_wds, ptr_wds, _) - = mkVirtHeapOffsets typePrimRep (dataConRepArgTys dcon) + = let rep_args = [ (typeCgRep arg,arg) + | arg <- dataConRepArgTys dcon ] + (tot_wds, ptr_wds, _) = mkVirtHeapOffsets rep_args + ptrs = ptr_wds nptrs = tot_wds - ptr_wds nptrs_really diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index c4b5aeb934..38b24854cf 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,6 +1,6 @@ {-# OPTIONS -#include "Linker.h" #-} ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.172 2004/08/12 13:10:35 simonmar Exp $ +-- $Id: InteractiveUI.hs,v 1.173 2004/08/13 13:06:42 simonmar Exp $ -- -- GHC Interactive User Interface -- @@ -12,7 +12,7 @@ module InteractiveUI ( ghciWelcomeMsg ) where -#include "../includes/config.h" +#include "../includes/ghcconfig.h" #include "HsVersions.h" import CompManager diff --git a/ghc/compiler/ghci/Linker.lhs b/ghc/compiler/ghci/Linker.lhs index 0879aa3a79..0849859bae 100644 --- a/ghc/compiler/ghci/Linker.lhs +++ b/ghc/compiler/ghci/Linker.lhs @@ -20,7 +20,7 @@ module Linker ( HValue, showLinkerState, linkPackages, ) where -#include "../includes/config.h" +#include "../includes/ghcconfig.h" #include "HsVersions.h" import ObjLink ( loadDLL, loadObj, unloadObj, resolveObjs, initObjLinker ) -- cgit v1.2.1