Skip to content

GitLab

GHC
GHC
Commit daf8e15b authored by sewardj's avatar sewardj
Browse files
Options

[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
parent 593c27ba
Hide whitespace changes
Inline Side-by-side
Showing with 78 additions and 47 deletions
ghc/compiler/ghci/ByteCodeFFI.lhs
View file @ daf8e15b
......@@ -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.
......
ghc/compiler/ghci/ByteCodeGen.lhs
View file @ daf8e15b
......@@ -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
......
ghc/compiler/ghci/ByteCodeLink.lhs
View file @ daf8e15b
......@@ -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
......
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