Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
10
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
5615397b
Commit
5615397b
authored
Aug 01, 2009
by
Ian Lynagh
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Allow more than 64k instructions in a BCO; fixes
#789
parent
723f9afa
Changes
2
Hide whitespace changes
Inline
Side-by-side
Showing
2 changed files
with
51 additions
and
37 deletions
+51
-37
compiler/ghci/ByteCodeAsm.lhs
compiler/ghci/ByteCodeAsm.lhs
+37
-26
rts/Interpreter.c
rts/Interpreter.c
+14
-11
No files found.
compiler/ghci/ByteCodeAsm.lhs
View file @
5615397b
...
...
@@ -121,17 +121,24 @@ assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO
assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced)
= let
-- pass 1: collect up the offsets of the local labels.
-- Remember that the first insn starts at offset 1 since offset 0
-- (eventually) will hold the total # of insns.
label_env = mkLabelEnv emptyFM 1 instrs
-- Remember that the first insn starts at offset
-- sizeOf Word / sizeOf Word16
-- since offset 0 (eventually) will hold the total # of insns.
lableInitialOffset
| wORD_SIZE_IN_BITS == 64 = 4
| wORD_SIZE_IN_BITS == 32 = 2
| otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?"
label_env = mkLabelEnv emptyFM lableInitialOffset instrs
mkLabelEnv :: FiniteMap Word16 Word -> Word -> [BCInstr]
-> FiniteMap Word16 Word
mkLabelEnv env _ [] = env
mkLabelEnv env i_offset (i:is)
= let new_env
= case i of LABEL n -> addToFM env n i_offset ; _ -> env
in mkLabelEnv new_env (i_offset + instrSize16s i) is
findLabel :: Word16 -> Word
16
findLabel :: Word16 -> Word
findLabel lab
= case lookupFM label_env lab of
Just bco_offset -> bco_offset
...
...
@@ -148,9 +155,7 @@ assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced)
let asm_insns = ssElts final_insns
n_insns = sizeSS final_insns
insns_arr
| n_insns > 65535 = panic "linkBCO: >= 64k insns in BCO"
| otherwise = mkInstrArray (fromIntegral n_insns) asm_insns
insns_arr = mkInstrArray lableInitialOffset n_insns asm_insns
!insns_barr = case insns_arr of UArray _lo _hi _n barr -> barr
bitmap_arr = mkBitmapArray bsize bitmap
...
...
@@ -172,9 +177,10 @@ mkBitmapArray :: Word16 -> [StgWord] -> UArray Int StgWord
mkBitmapArray bsize bitmap
= listArray (0, length bitmap) (fromIntegral bsize : bitmap)
mkInstrArray :: Word16 -> [Word16] -> UArray Word16 Word16
mkInstrArray n_insns asm_insns
= listArray (0, n_insns) (n_insns : asm_insns)
mkInstrArray :: Word -> Word -> [Word16] -> UArray Word Word16
mkInstrArray lableInitialOffset n_insns asm_insns
= let size = lableInitialOffset + n_insns
in listArray (0, size - 1) (largeArg size ++ asm_insns)
-- instrs nonptrs ptrs
type AsmState = (SizedSeq Word16,
...
...
@@ -220,7 +226,7 @@ largeArg w
| otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?"
-- This is where all the action is (pass 2 of the assembler)
mkBits :: (Word16 -> Word
16)
-- label finder
mkBits :: (Word16 -> Word
)
-- label finder
-> AsmState
-> [BCInstr] -- instructions (in)
-> IO AsmState
...
...
@@ -231,10 +237,7 @@ mkBits findLabel st proto_insns
doInstr :: AsmState -> BCInstr -> IO AsmState
doInstr st i
= case i of
STKCHECK n
| n > 65535 ->
instrn st (largeArgInstr bci_STKCHECK : largeArg n)
| otherwise -> instr2 st bci_STKCHECK (fromIntegral n)
STKCHECK n -> instr1Large st bci_STKCHECK n
PUSH_L o1 -> instr2 st bci_PUSH_L o1
PUSH_LL o1 o2 -> instr3 st bci_PUSH_LL o1 o2
PUSH_LLL o1 o2 o3 -> instr4 st bci_PUSH_LLL o1 o2 o3
...
...
@@ -282,22 +285,22 @@ mkBits findLabel st proto_insns
instr3 st2 bci_PACK itbl_no sz
LABEL _ -> return st
TESTLT_I i l -> do (np, st2) <- int st i
instr
3
st2 bci_TESTLT_I np (findLabel l)
instr
2Large
st2 bci_TESTLT_I np (findLabel l)
TESTEQ_I i l -> do (np, st2) <- int st i
instr
3
st2 bci_TESTEQ_I np (findLabel l)
instr
2Large
st2 bci_TESTEQ_I np (findLabel l)
TESTLT_F f l -> do (np, st2) <- float st f
instr
3
st2 bci_TESTLT_F np (findLabel l)
instr
2Large
st2 bci_TESTLT_F np (findLabel l)
TESTEQ_F f l -> do (np, st2) <- float st f
instr
3
st2 bci_TESTEQ_F np (findLabel l)
instr
2Large
st2 bci_TESTEQ_F np (findLabel l)
TESTLT_D d l -> do (np, st2) <- double st d
instr
3
st2 bci_TESTLT_D np (findLabel l)
instr
2Large
st2 bci_TESTLT_D np (findLabel l)
TESTEQ_D d l -> do (np, st2) <- double st d
instr
3
st2 bci_TESTEQ_D np (findLabel l)
TESTLT_P i l -> instr
3
st bci_TESTLT_P i (findLabel l)
TESTEQ_P i l -> instr
3
st bci_TESTEQ_P i (findLabel l)
instr
2Large
st2 bci_TESTEQ_D np (findLabel l)
TESTLT_P i l -> instr
2Large
st bci_TESTLT_P i (findLabel l)
TESTEQ_P i l -> instr
2Large
st bci_TESTEQ_P i (findLabel l)
CASEFAIL -> instr1 st bci_CASEFAIL
SWIZZLE stkoff n -> instr3 st bci_SWIZZLE stkoff n
JMP l -> instr
2
st bci_JMP (findLabel l)
JMP l -> instr
1Large
st bci_JMP (findLabel l)
ENTER -> instr1 st bci_ENTER
RETURN -> instr1 st bci_RETURN
RETURN_UBX rep -> instr1 st (return_ubx rep)
...
...
@@ -314,6 +317,14 @@ mkBits findLabel st proto_insns
= do st_i' <- addToSS st_i i
instrn (st_i', st_l, st_p) is
instr1Large st i1 large
| large > 65535 = instrn st (largeArgInstr i1 : largeArg large)
| otherwise = instr2 st i1 (fromIntegral large)
instr2Large st i1 i2 large
| large > 65535 = instrn st (largeArgInstr i1 : i2 : largeArg large)
| otherwise = instr3 st i1 i2 (fromIntegral large)
instr1 (st_i0,st_l0,st_p0) i1
= do st_i1 <- addToSS st_i0 i1
return (st_i1,st_l0,st_p0)
...
...
@@ -409,7 +420,7 @@ return_ubx PtrArg = bci_RETURN_P
-- The size in 16-bit entities of an instruction.
instrSize16s :: BCInstr -> Word
16
instrSize16s :: BCInstr -> Word
instrSize16s instr
= case instr of
STKCHECK{} -> 2
...
...
rts/Interpreter.c
View file @
5615397b
...
...
@@ -763,19 +763,22 @@ run_BCO_fun:
run_BCO:
INTERP_TICK
(
it_BCO_entries
);
{
register
int
bciPtr
=
1
;
/* instruction pointer */
register
int
bciPtr
=
0
;
/* instruction pointer */
register
StgWord16
bci
;
register
StgBCO
*
bco
=
(
StgBCO
*
)
obj
;
register
StgWord16
*
instrs
=
(
StgWord16
*
)(
bco
->
instrs
->
payload
);
register
StgWord
*
literals
=
(
StgWord
*
)(
&
bco
->
literals
->
payload
[
0
]);
register
StgPtr
*
ptrs
=
(
StgPtr
*
)(
&
bco
->
ptrs
->
payload
[
0
]);
int
bcoSize
;
bcoSize
=
BCO_NEXT_WORD
;
IF_DEBUG
(
interpreter
,
debugBelch
(
"bcoSize = %d
\n
"
,
bcoSize
));
#ifdef INTERP_STATS
it_lastopc
=
0
;
/* no opcode */
#endif
nextInsn:
ASSERT
(
bciPtr
<
=
instrs
[
0
]
);
ASSERT
(
bciPtr
<
bcoSize
);
IF_DEBUG
(
interpreter
,
//if (do_print_stack) {
//debugBelch("\n-- BEGIN stack\n");
...
...
@@ -1186,7 +1189,7 @@ run_BCO:
case
bci_TESTLT_P
:
{
unsigned
int
discr
=
BCO_NEXT
;
int
failto
=
BCO_
NEXT
;
int
failto
=
BCO_
GET_LARGE_ARG
;
StgClosure
*
con
=
(
StgClosure
*
)
Sp
[
0
];
if
(
GET_TAG
(
con
)
>=
discr
)
{
bciPtr
=
failto
;
...
...
@@ -1196,7 +1199,7 @@ run_BCO:
case
bci_TESTEQ_P
:
{
unsigned
int
discr
=
BCO_NEXT
;
int
failto
=
BCO_
NEXT
;
int
failto
=
BCO_
GET_LARGE_ARG
;
StgClosure
*
con
=
(
StgClosure
*
)
Sp
[
0
];
if
(
GET_TAG
(
con
)
!=
discr
)
{
bciPtr
=
failto
;
...
...
@@ -1207,7 +1210,7 @@ run_BCO:
case
bci_TESTLT_I
:
{
// There should be an Int at Sp[1], and an info table at Sp[0].
int
discr
=
BCO_NEXT
;
int
failto
=
BCO_
NEXT
;
int
failto
=
BCO_
GET_LARGE_ARG
;
I_
stackInt
=
(
I_
)
Sp
[
1
];
if
(
stackInt
>=
(
I_
)
BCO_LIT
(
discr
))
bciPtr
=
failto
;
...
...
@@ -1217,7 +1220,7 @@ run_BCO:
case
bci_TESTEQ_I
:
{
// There should be an Int at Sp[1], and an info table at Sp[0].
int
discr
=
BCO_NEXT
;
int
failto
=
BCO_
NEXT
;
int
failto
=
BCO_
GET_LARGE_ARG
;
I_
stackInt
=
(
I_
)
Sp
[
1
];
if
(
stackInt
!=
(
I_
)
BCO_LIT
(
discr
))
{
bciPtr
=
failto
;
...
...
@@ -1228,7 +1231,7 @@ run_BCO:
case
bci_TESTLT_D
:
{
// There should be a Double at Sp[1], and an info table at Sp[0].
int
discr
=
BCO_NEXT
;
int
failto
=
BCO_
NEXT
;
int
failto
=
BCO_
GET_LARGE_ARG
;
StgDouble
stackDbl
,
discrDbl
;
stackDbl
=
PK_DBL
(
&
Sp
[
1
]
);
discrDbl
=
PK_DBL
(
&
BCO_LIT
(
discr
)
);
...
...
@@ -1241,7 +1244,7 @@ run_BCO:
case
bci_TESTEQ_D
:
{
// There should be a Double at Sp[1], and an info table at Sp[0].
int
discr
=
BCO_NEXT
;
int
failto
=
BCO_
NEXT
;
int
failto
=
BCO_
GET_LARGE_ARG
;
StgDouble
stackDbl
,
discrDbl
;
stackDbl
=
PK_DBL
(
&
Sp
[
1
]
);
discrDbl
=
PK_DBL
(
&
BCO_LIT
(
discr
)
);
...
...
@@ -1254,7 +1257,7 @@ run_BCO:
case
bci_TESTLT_F
:
{
// There should be a Float at Sp[1], and an info table at Sp[0].
int
discr
=
BCO_NEXT
;
int
failto
=
BCO_
NEXT
;
int
failto
=
BCO_
GET_LARGE_ARG
;
StgFloat
stackFlt
,
discrFlt
;
stackFlt
=
PK_FLT
(
&
Sp
[
1
]
);
discrFlt
=
PK_FLT
(
&
BCO_LIT
(
discr
)
);
...
...
@@ -1267,7 +1270,7 @@ run_BCO:
case
bci_TESTEQ_F
:
{
// There should be a Float at Sp[1], and an info table at Sp[0].
int
discr
=
BCO_NEXT
;
int
failto
=
BCO_
NEXT
;
int
failto
=
BCO_
GET_LARGE_ARG
;
StgFloat
stackFlt
,
discrFlt
;
stackFlt
=
PK_FLT
(
&
Sp
[
1
]
);
discrFlt
=
PK_FLT
(
&
BCO_LIT
(
discr
)
);
...
...
@@ -1451,7 +1454,7 @@ run_BCO:
case
bci_JMP
:
{
/* BCO_NEXT modifies bciPtr, so be conservative. */
int
nextpc
=
BCO_
NEXT
;
int
nextpc
=
BCO_
GET_LARGE_ARG
;
bciPtr
=
nextpc
;
goto
nextInsn
;
}
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment