From daf8e15b8dcad8808ad068c3b93ee5fe99ece5bf Mon Sep 17 00:00:00 2001 From: sewardj Date: Fri, 3 Aug 2001 15:11:10 +0000 Subject: [PATCH] [project @ 2001-08-03 15:11:10 by sewardj] Fix enough bugs/incompletenesses so that foreign import (static) works fairly well on x86. Still ToDo: * f-i dynamic * save/restore GC/thread context around calls * stdcall support * pass/return of 64-bit integral quantities on x86 * sparc implementation --- ghc/compiler/ghci/ByteCodeFFI.lhs | 28 ++++++++++++++---- ghc/compiler/ghci/ByteCodeGen.lhs | 57 +++++++++++++++++++++--------------- ghc/compiler/ghci/ByteCodeLink.lhs | 40 +++++++++++++------------ 3 files changed, 78 insertions(+), 47 deletions(-) diff --git a/ghc/compiler/ghci/ByteCodeFFI.lhs b/ghc/compiler/ghci/ByteCodeFFI.lhs index 8e65548..8703c84 100644 --- a/ghc/compiler/ghci/ByteCodeFFI.lhs +++ b/ghc/compiler/ghci/ByteCodeFFI.lhs @@ -8,6 +8,7 @@ module ByteCodeFFI ( taggedSizeW, untaggedSizeW, mkMarshalCode ) where #include "HsVersions.h" +import Outputable import PrimRep ( PrimRep(..), getPrimRepSize, isFollowableRep ) import Bits ( Bits(..), shiftR ) import Word ( Word8, Word32 ) @@ -96,6 +97,7 @@ mkMarshalCode_wrk (r_offW, r_rep) addr_offW arg_offs_n_reps [ let -- where this arg's bits start a_bits_offW = a_offW + sizeOfTagW a_rep in + reverse [a_bits_offW .. a_bits_offW + untaggedSizeW a_rep - 1] | (a_offW, a_rep) <- reverse arg_offs_n_reps @@ -120,7 +122,10 @@ mkMarshalCode_wrk (r_offW, r_rep) addr_offW arg_offs_n_reps = [0x89, 0x86] ++ lit32 offB ret -- ret = [0xC3] - + fstl_offesimem offB -- fstl offB(%esi) + = [0xDD, 0x96] ++ lit32 offB + fsts_offesimem offB -- fsts offB(%esi) + = [0xD9, 0x96] ++ lit32 offB lit32 :: Int -> [Word8] lit32 i = let w32 = (fromIntegral i) :: Word32 in map (fromIntegral . ( .&. 0xFF)) @@ -147,6 +152,14 @@ mkMarshalCode_wrk (r_offW, r_rep) addr_offW arg_offs_n_reps 15 3412 16 002a 89967856 movl %edx, 0x12345678(%esi) 16 3412 + 17 + 18 0030 DD967856 fstl 0x12345678(%esi) + 18 3412 + 19 0036 DD9E7856 fstpl 0x12345678(%esi) + 19 3412 + 20 003c D9967856 fsts 0x12345678(%esi) + 20 3412 + 21 0042 D99E7856 fstps 0x12345678(%esi) 18 19 0030 C3 ret 20 @@ -154,7 +167,7 @@ mkMarshalCode_wrk (r_offW, r_rep) addr_offW arg_offs_n_reps -} in - trace (show (map fst arg_offs_n_reps)) + --trace (show (map fst arg_offs_n_reps)) ( {- On entry, top of C stack 0(%esp) is the RA and 4(%esp) is arg passed from the interpreter. @@ -216,12 +229,17 @@ mkMarshalCode_wrk (r_offW, r_rep) addr_offW arg_offs_n_reps movl %edx, 4(%esi) movl %eax, 8(%esi) or - fstpl 4(%esi) + fstl 4(%esi) or - fstps 4(%esi) + fsts 4(%esi) -} ++ case r_rep of - IntRep -> movl_eax_offesimem 4 + IntRep -> movl_eax_offesimem 4 + WordRep -> movl_eax_offesimem 4 + AddrRep -> movl_eax_offesimem 4 + DoubleRep -> fstl_offesimem 4 + FloatRep -> fsts_offesimem 4 + other -> pprPanic "ByteCodeFFI.mkMarshalCode_wrk(x86)" (ppr r_rep) {- Restore all the pushed regs and go home. diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index 41021a4..59170d5 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -360,16 +360,20 @@ schemeE d s p (fvs_case, AnnCase (fvs_scrut, scrut) bndr (schemeE d s p new_expr) -schemeE d s p (fvs, AnnCase scrut bndr alts0) - = let - alts = case alts0 of - [(DataAlt dc, [bind1, bind2], rhs)] - | isUnboxedTupleCon dc - && VoidRep == typePrimRep (idType bind1) - -> [(DEFAULT, [bind2], rhs)] - other - -> alts0 +{- Convert case .... of (# VoidRep'd-thing, a #) -> ... + as + case .... of a -> ... + Use a as the name of the binder too. +-} +schemeE d s p (fvs, AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)]) + | isUnboxedTupleCon dc && VoidRep == typePrimRep (idType bind1) + = trace "automagic mashing of case alts (# VoidRep, a #)" ( + schemeE d s p (fvs, AnnCase scrut bind2 [(DEFAULT, [bind2], rhs)]) + ) + +schemeE d s p (fvs, AnnCase scrut bndr alts) + = let -- Top of stack is the return itbl, as usual. -- underneath it is the pointer to the alt_code BCO. -- When an alt is entered, it assumes the returned value is @@ -383,12 +387,15 @@ schemeE d s p (fvs, AnnCase scrut bndr alts0) scrut_primrep = typePrimRep (idType bndr) isAlgCase - = case scrut_primrep of - CharRep -> False ; AddrRep -> False ; WordRep -> False - IntRep -> False ; FloatRep -> False ; DoubleRep -> False - VoidRep -> False ; - PtrRep -> True - other -> pprPanic "ByteCodeGen.schemeE" (ppr other) + | scrut_primrep == PtrRep + = True + | scrut_primrep `elem` + [CharRep, AddrRep, WordRep, IntRep, FloatRep, DoubleRep, + VoidRep, Int8Rep, Int16Rep, Int32Rep, Int64Rep, + Word8Rep, Word16Rep, Word32Rep, Word64Rep] + = False + | otherwise + = pprPanic "ByteCodeGen.schemeE" (ppr scrut_primrep) -- given an alt, return a discr and code for it. codeAlt alt@(discr, binds_f, rhs) @@ -648,11 +655,11 @@ schemeT d s p app = mkMarshalCode (r_offW, r_rep) addr_offW (zip args_offW a_reps) in - trace (show (arg1_offW, args_offW , (map taggedSizeW a_reps) )) ( + --trace (show (arg1_offW, args_offW , (map taggedSizeW a_reps) )) ( target_addr `seq` (push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup) - ) + --) | otherwise = case maybe_dcon of @@ -674,8 +681,11 @@ bind x f mkDummyLiteral :: PrimRep -> Literal mkDummyLiteral pr = case pr of - IntRep -> MachInt 0 - _ -> pprPanic "mkDummyLiteral" (ppr pr) + IntRep -> MachInt 0 + DoubleRep -> MachDouble 0 + FloatRep -> MachFloat 0 + AddrRep | taggedSizeW AddrRep == taggedSizeW WordRep -> MachWord 0 + _ -> pprPanic "mkDummyLiteral" (ppr pr) -- Convert (eg) @@ -801,11 +811,10 @@ mkUnpackCode vars d p code_np = do_nptrs vreps_env_uszw ptrs_szw (reverse (map snd vreps_np)) do_nptrs off_h off_s [] = nilOL do_nptrs off_h off_s (npr:nprs) - = case npr of - IntRep -> approved ; FloatRep -> approved - DoubleRep -> approved ; AddrRep -> approved - CharRep -> approved - _ -> pprPanic "ByteCodeGen.mkUnpackCode" (ppr npr) + | npr `elem` [IntRep, FloatRep, DoubleRep, CharRep, AddrRep] + = approved + | otherwise + = pprPanic "ByteCodeGen.mkUnpackCode" (ppr npr) where approved = UPK_TAG usizeW (off_h-usizeW) off_s `consOL` theRest theRest = do_nptrs (off_h-usizeW) (off_s + tsizeW) nprs diff --git a/ghc/compiler/ghci/ByteCodeLink.lhs b/ghc/compiler/ghci/ByteCodeLink.lhs index 8aecbe2..50d0125 100644 --- a/ghc/compiler/ghci/ByteCodeLink.lhs +++ b/ghc/compiler/ghci/ByteCodeLink.lhs @@ -322,32 +322,36 @@ mkBits findLabel st proto_insns literal st (MachFloat r) = float st (fromRational r) literal st (MachDouble r) = double st (fromRational r) literal st (MachChar c) = int st c - literal st other = pprPanic "ByteCodeLink.mkBits" (ppr other) + literal st other = pprPanic "ByteCodeLink.literal" (ppr other) ctoi_itbl st pk = addr st ret_itbl_addr where - ret_itbl_addr = case pk of - PtrRep -> stg_ctoi_ret_R1p_info - WordRep -> stg_ctoi_ret_R1n_info - IntRep -> stg_ctoi_ret_R1n_info - AddrRep -> stg_ctoi_ret_R1n_info - CharRep -> stg_ctoi_ret_R1n_info - FloatRep -> stg_ctoi_ret_F1_info - DoubleRep -> stg_ctoi_ret_D1_info - VoidRep -> stg_ctoi_ret_V_info - _ -> pprPanic "mkBits.ctoi_itbl" (ppr pk) + ret_itbl_addr + = case pk of + PtrRep -> stg_ctoi_ret_R1p_info + WordRep -> stg_ctoi_ret_R1n_info + IntRep -> stg_ctoi_ret_R1n_info + AddrRep -> stg_ctoi_ret_R1n_info + CharRep -> stg_ctoi_ret_R1n_info + FloatRep -> stg_ctoi_ret_F1_info + DoubleRep -> stg_ctoi_ret_D1_info + VoidRep -> stg_ctoi_ret_V_info + other -> pprPanic "ByteCodeLink.ctoi_itbl" (ppr pk) itoc_itbl st pk = addr st ret_itbl_addr where - ret_itbl_addr = case pk of - CharRep -> stg_gc_unbx_r1_ret_info - IntRep -> stg_gc_unbx_r1_ret_info - FloatRep -> stg_gc_f1_ret_info - DoubleRep -> stg_gc_d1_ret_info - VoidRep -> nullAddr - -- Interpreter.c spots this special case + ret_itbl_addr + = case pk of + CharRep -> stg_gc_unbx_r1_ret_info + IntRep -> stg_gc_unbx_r1_ret_info + AddrRep -> stg_gc_unbx_r1_ret_info + FloatRep -> stg_gc_f1_ret_info + DoubleRep -> stg_gc_d1_ret_info + VoidRep -> nullAddr + -- Interpreter.c spots this special case + other -> pprPanic "ByteCodeLink.itoc_itbl" (ppr pk) foreign label "stg_ctoi_ret_R1p_info" stg_ctoi_ret_R1p_info :: Addr foreign label "stg_ctoi_ret_R1n_info" stg_ctoi_ret_R1n_info :: Addr -- 1.7.10.4