Commit 2f78eff3 authored by sewardj's avatar sewardj

[project @ 2001-01-12 10:18:14 by sewardj]

Split ByteCodeGen up into more manageable-sized pieces.
parent 61558409
This diff is collapsed.
%
% (c) The University of Glasgow 2000
%
\section[ByteCodeInstrs]{Bytecode instruction definitions}
\begin{code}
module ByteCodeInstr ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO ) where
#include "HsVersions.h"
import Outputable
import Name ( Name )
import Id ( Id )
import CoreSyn
import PprCore ( pprCoreExpr, pprCoreAlt )
import Literal ( Literal )
import PrimRep ( PrimRep )
import DataCon ( DataCon )
import VarSet ( VarSet )
\end{code}
%************************************************************************
%* *
\subsection{Bytecodes, and Outputery.}
%* *
%************************************************************************
\begin{code}
data ProtoBCO a
= ProtoBCO a -- name, in some sense
[BCInstr] -- instrs
-- what the BCO came from
(Either [AnnAlt Id VarSet]
(AnnExpr Id VarSet))
nameOfProtoBCO (ProtoBCO nm insns origin) = nm
type LocalLabel = Int
data BCInstr
-- Messing with the stack
= ARGCHECK Int
-- Push locals (existing bits of the stack)
| PUSH_L Int{-offset-}
| PUSH_LL Int Int{-2 offsets-}
| PUSH_LLL Int Int Int{-3 offsets-}
-- Push a ptr
| PUSH_G Name
-- Push an alt continuation
| PUSH_AS Name PrimRep -- push alts and BCO_ptr_ret_info
-- PrimRep so we know which itbl
-- Pushing literals
| PUSH_UBX Literal Int
-- push this int/float/double, NO TAG, on the stack
-- Int is # of words to copy from literal pool
| PUSH_TAG Int -- push this tag on the stack
| SLIDE Int{-this many-} Int{-down by this much-}
-- To do with the heap
| ALLOC Int -- make an AP_UPD with this many payload words, zeroed
| MKAP Int{-ptr to AP_UPD is this far down stack-} Int{-# words-}
| UNPACK Int -- unpack N ptr words from t.o.s Constr
| UPK_TAG Int Int Int
-- unpack N non-ptr words from offset M in constructor
-- K words down the stack
| PACK DataCon Int
-- after assembly, the DataCon is an index into the
-- itbl array
-- For doing case trees
| LABEL LocalLabel
| TESTLT_I Int LocalLabel
| TESTEQ_I Int LocalLabel
| TESTLT_F Float LocalLabel
| TESTEQ_F Float LocalLabel
| TESTLT_D Double LocalLabel
| TESTEQ_D Double LocalLabel
-- The Int value is a constructor number and therefore
-- stored in the insn stream rather than as an offset into
-- the literal pool.
| TESTLT_P Int LocalLabel
| TESTEQ_P Int LocalLabel
| CASEFAIL
-- To Infinity And Beyond
| ENTER
| RETURN PrimRep
-- unboxed value on TOS. Use tag to find underlying ret itbl
-- and return as per that.
instance Outputable BCInstr where
ppr (ARGCHECK n) = text "ARGCHECK" <+> int n
ppr (PUSH_L offset) = text "PUSH_L " <+> int offset
ppr (PUSH_LL o1 o2) = text "PUSH_LL " <+> int o1 <+> int o2
ppr (PUSH_LLL o1 o2 o3) = text "PUSH_LLL" <+> int o1 <+> int o2 <+> int o3
ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm
ppr (PUSH_AS nm pk) = text "PUSH_AS " <+> ppr nm <+> ppr pk
ppr (PUSH_UBX lit nw) = text "PUSH_UBX" <+> parens (int nw) <+> ppr lit
ppr (PUSH_TAG n) = text "PUSH_TAG" <+> int n
ppr (SLIDE n d) = text "SLIDE " <+> int n <+> int d
ppr (ALLOC sz) = text "ALLOC " <+> int sz
ppr (MKAP offset sz) = text "MKAP " <+> int sz <+> text "words,"
<+> int offset <+> text "stkoff"
ppr (UNPACK sz) = text "UNPACK " <+> int sz
ppr (UPK_TAG n m k) = text "UPK_TAG " <+> int n <> text "words"
<+> int m <> text "conoff"
<+> int k <> text "stkoff"
ppr (PACK dcon sz) = text "PACK " <+> ppr dcon <+> ppr sz
ppr (LABEL lab) = text "__" <> int lab <> colon
ppr (TESTLT_I i lab) = text "TESTLT_I" <+> int i <+> text "__" <> int lab
ppr (TESTEQ_I i lab) = text "TESTEQ_I" <+> int i <+> text "__" <> int lab
ppr (TESTLT_F f lab) = text "TESTLT_F" <+> float f <+> text "__" <> int lab
ppr (TESTEQ_F f lab) = text "TESTEQ_F" <+> float f <+> text "__" <> int lab
ppr (TESTLT_D d lab) = text "TESTLT_D" <+> double d <+> text "__" <> int lab
ppr (TESTEQ_D d lab) = text "TESTEQ_D" <+> double d <+> text "__" <> int lab
ppr (TESTLT_P i lab) = text "TESTLT_P" <+> int i <+> text "__" <> int lab
ppr (TESTEQ_P i lab) = text "TESTEQ_P" <+> int i <+> text "__" <> int lab
ppr CASEFAIL = text "CASEFAIL"
ppr ENTER = text "ENTER"
ppr (RETURN pk) = text "RETURN " <+> ppr pk
instance Outputable a => Outputable (ProtoBCO a) where
ppr (ProtoBCO name instrs origin)
= (text "ProtoBCO" <+> ppr name <> colon)
$$ nest 6 (vcat (map ppr instrs))
$$ case origin of
Left alts -> vcat (map (pprCoreAlt.deAnnAlt) alts)
Right rhs -> pprCoreExpr (deAnnotate rhs)
\end{code}
%
% (c) The University of Glasgow 2000
%
\section[ByteCodeItbls]{Generate infotables for interpreter-made bytecodes}
\begin{code}
module ByteCodeItbls ( ItblEnv, mkITbls ) where
#include "HsVersions.h"
import Name ( Name, getName )
import FiniteMap ( FiniteMap, listToFM, emptyFM, plusFM )
import Type ( typePrimRep )
import DataCon ( DataCon, dataConRepArgTys )
import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
import Constants ( mIN_SIZE_NonUpdHeapObject )
import ClosureInfo ( mkVirtHeapOffsets )
import FastString ( FastString(..) )
import Foreign ( Storable(..), Word8, Word16, Word32, Ptr(..),
malloc, castPtr, plusPtr )
import Addr ( addrToInt )
import Bits ( Bits(..), shiftR )
import PrelBase ( Int(..) )
import PrelAddr ( Addr(..) )
import PrelIOBase ( IO(..) )
\end{code}
%************************************************************************
%* *
\subsection{Manufacturing of info tables for DataCons}
%* *
%************************************************************************
\begin{code}
type ItblEnv = FiniteMap Name (Ptr StgInfoTable)
#if __GLASGOW_HASKELL__ <= 408
type ItblPtr = Addr
#else
type ItblPtr = Ptr StgInfoTable
#endif
-- Make info tables for the data decls in this module
mkITbls :: [TyCon] -> IO ItblEnv
mkITbls [] = return emptyFM
mkITbls (tc:tcs) = do itbls <- mkITbl tc
itbls2 <- mkITbls tcs
return (itbls `plusFM` itbls2)
mkITbl :: TyCon -> IO ItblEnv
mkITbl tc
| not (isDataTyCon tc)
= return emptyFM
| n == length dcs -- paranoia; this is an assertion.
= make_constr_itbls dcs
where
dcs = tyConDataCons tc
n = tyConFamilySize tc
cONSTR :: Int
cONSTR = 1 -- as defined in ghc/includes/ClosureTypes.h
-- Assumes constructors are numbered from zero, not one
make_constr_itbls :: [DataCon] -> IO ItblEnv
make_constr_itbls cons
| length cons <= 8
= do is <- mapM mk_vecret_itbl (zip cons [0..])
return (listToFM is)
| otherwise
= do is <- mapM mk_dirret_itbl (zip cons [0..])
return (listToFM is)
where
mk_vecret_itbl (dcon, conNo)
= mk_itbl dcon conNo (vecret_entry conNo)
mk_dirret_itbl (dcon, conNo)
= mk_itbl dcon conNo stg_interp_constr_entry
mk_itbl :: DataCon -> Int -> Addr -> IO (Name,ItblPtr)
mk_itbl dcon conNo entry_addr
= let (tot_wds, ptr_wds, _)
= mkVirtHeapOffsets typePrimRep (dataConRepArgTys dcon)
ptrs = ptr_wds
nptrs = tot_wds - ptr_wds
nptrs_really
| ptrs + nptrs >= mIN_SIZE_NonUpdHeapObject = nptrs
| otherwise = mIN_SIZE_NonUpdHeapObject - ptrs
itbl = StgInfoTable {
ptrs = fromIntegral ptrs,
nptrs = fromIntegral nptrs_really,
tipe = fromIntegral cONSTR,
srtlen = fromIntegral conNo,
code0 = fromIntegral code0, code1 = fromIntegral code1,
code2 = fromIntegral code2, code3 = fromIntegral code3,
code4 = fromIntegral code4, code5 = fromIntegral code5,
code6 = fromIntegral code6, code7 = fromIntegral code7
}
-- Make a piece of code to jump to "entry_label".
-- This is the only arch-dependent bit.
-- On x86, if entry_label has an address 0xWWXXYYZZ,
-- emit movl $0xWWXXYYZZ,%eax ; jmp *%eax
-- which is
-- B8 ZZ YY XX WW FF E0
(code0,code1,code2,code3,code4,code5,code6,code7)
= (0xB8, byte 0 entry_addr_w, byte 1 entry_addr_w,
byte 2 entry_addr_w, byte 3 entry_addr_w,
0xFF, 0xE0,
0x90 {-nop-})
entry_addr_w :: Word32
entry_addr_w = fromIntegral (addrToInt entry_addr)
in
do addr <- malloc
--putStrLn ("SIZE of itbl is " ++ show (sizeOf itbl))
--putStrLn ("# ptrs of itbl is " ++ show ptrs)
--putStrLn ("# nptrs of itbl is " ++ show nptrs_really)
poke addr itbl
return (getName dcon, addr `plusPtr` 8)
byte :: Int -> Word32 -> Word32
byte 0 w = w .&. 0xFF
byte 1 w = (w `shiftR` 8) .&. 0xFF
byte 2 w = (w `shiftR` 16) .&. 0xFF
byte 3 w = (w `shiftR` 24) .&. 0xFF
vecret_entry 0 = stg_interp_constr1_entry
vecret_entry 1 = stg_interp_constr2_entry
vecret_entry 2 = stg_interp_constr3_entry
vecret_entry 3 = stg_interp_constr4_entry
vecret_entry 4 = stg_interp_constr5_entry
vecret_entry 5 = stg_interp_constr6_entry
vecret_entry 6 = stg_interp_constr7_entry
vecret_entry 7 = stg_interp_constr8_entry
-- entry point for direct returns for created constr itbls
foreign label "stg_interp_constr_entry" stg_interp_constr_entry :: Addr
-- and the 8 vectored ones
foreign label "stg_interp_constr1_entry" stg_interp_constr1_entry :: Addr
foreign label "stg_interp_constr2_entry" stg_interp_constr2_entry :: Addr
foreign label "stg_interp_constr3_entry" stg_interp_constr3_entry :: Addr
foreign label "stg_interp_constr4_entry" stg_interp_constr4_entry :: Addr
foreign label "stg_interp_constr5_entry" stg_interp_constr5_entry :: Addr
foreign label "stg_interp_constr6_entry" stg_interp_constr6_entry :: Addr
foreign label "stg_interp_constr7_entry" stg_interp_constr7_entry :: Addr
foreign label "stg_interp_constr8_entry" stg_interp_constr8_entry :: Addr
-- Ultra-minimalist version specially for constructors
data StgInfoTable = StgInfoTable {
ptrs :: Word16,
nptrs :: Word16,
srtlen :: Word16,
tipe :: Word16,
code0, code1, code2, code3, code4, code5, code6, code7 :: Word8
}
instance Storable StgInfoTable where
sizeOf itbl
= (sum . map (\f -> f itbl))
[fieldSz ptrs, fieldSz nptrs, fieldSz srtlen, fieldSz tipe,
fieldSz code0, fieldSz code1, fieldSz code2, fieldSz code3,
fieldSz code4, fieldSz code5, fieldSz code6, fieldSz code7]
alignment itbl
= (sum . map (\f -> f itbl))
[fieldAl ptrs, fieldAl nptrs, fieldAl srtlen, fieldAl tipe,
fieldAl code0, fieldAl code1, fieldAl code2, fieldAl code3,
fieldAl code4, fieldAl code5, fieldAl code6, fieldAl code7]
poke a0 itbl
= do a1 <- store (ptrs itbl) (castPtr a0)
a2 <- store (nptrs itbl) a1
a3 <- store (tipe itbl) a2
a4 <- store (srtlen itbl) a3
a5 <- store (code0 itbl) a4
a6 <- store (code1 itbl) a5
a7 <- store (code2 itbl) a6
a8 <- store (code3 itbl) a7
a9 <- store (code4 itbl) a8
aA <- store (code5 itbl) a9
aB <- store (code6 itbl) aA
aC <- store (code7 itbl) aB
return ()
peek a0
= do (a1,ptrs) <- load (castPtr a0)
(a2,nptrs) <- load a1
(a3,tipe) <- load a2
(a4,srtlen) <- load a3
(a5,code0) <- load a4
(a6,code1) <- load a5
(a7,code2) <- load a6
(a8,code3) <- load a7
(a9,code4) <- load a8
(aA,code5) <- load a9
(aB,code6) <- load aA
(aC,code7) <- load aB
return StgInfoTable { ptrs = ptrs, nptrs = nptrs,
srtlen = srtlen, tipe = tipe,
code0 = code0, code1 = code1, code2 = code2,
code3 = code3, code4 = code4, code5 = code5,
code6 = code6, code7 = code7 }
fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
fieldSz sel x = sizeOf (sel x)
fieldAl :: (Storable a, Storable b) => (a -> b) -> a -> Int
fieldAl sel x = alignment (sel x)
store :: Storable a => a -> Ptr a -> IO (Ptr b)
store x addr = do poke addr x
return (castPtr (addr `plusPtr` sizeOf x))
load :: Storable a => Ptr a -> IO (Ptr b, a)
load addr = do x <- peek addr
return (castPtr (addr `plusPtr` sizeOf x), x)
\end{code}
%
% (c) The University of Glasgow 2000
%
\section[ByteCodeLink]{Bytecode assembler and linker}
\begin{code}
module ByteCodeLink ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO,
ClosureEnv, HValue, linkSomeBCOs, filterNameMap
) where
#include "HsVersions.h"
import Outputable
import Name ( Name, getName, nameModule, toRdrName )
import RdrName ( rdrNameOcc, rdrNameModule )
import OccName ( occNameString )
import FiniteMap ( FiniteMap, addListToFM, filterFM,
addToFM, lookupFM, emptyFM )
import CoreSyn
import Literal ( Literal(..) )
import PrimRep ( PrimRep(..) )
import Util ( global )
import Constants ( wORD_SIZE )
import Module ( ModuleName, moduleName, moduleNameFS )
import Linker ( lookupSymbol )
import FastString ( FastString(..) )
import ByteCodeInstr ( BCInstr(..), ProtoBCO(..) )
import ByteCodeItbls ( ItblEnv )
import Monad ( foldM )
import ST ( runST )
import MArray ( castSTUArray,
newFloatArray, writeFloatArray,
newDoubleArray, writeDoubleArray,
newIntArray, writeIntArray,
newAddrArray, writeAddrArray )
import Foreign ( Word16, Ptr(..) )
import Addr ( Word )
import PrelBase ( Int(..) )
import PrelAddr ( Addr(..) )
import PrelGHC ( BCO#, newBCO#, unsafeCoerce#,
ByteArray#, Array#, addrToHValue# )
import IOExts ( IORef, fixIO, readIORef, writeIORef )
import ArrayBase
import PrelArr ( Array(..) )
import PrelIOBase ( IO(..) )
\end{code}
%************************************************************************
%* *
\subsection{Top-level stuff}
%* *
%************************************************************************
\begin{code}
-- Link a bunch of BCOs and return them + updated closure env.
linkSomeBCOs :: ItblEnv -> ClosureEnv -> [UnlinkedBCO]
-> IO (ClosureEnv, [HValue])
linkSomeBCOs ie ce_in ul_bcos
= do let nms = map nameOfUnlinkedBCO ul_bcos
hvals <- fixIO
( \ hvs -> let ce_out = addListToFM ce_in (zipLazily nms hvs)
in mapM (linkBCO ie ce_out) ul_bcos )
let ce_out = addListToFM ce_in (zip nms hvals)
return (ce_out, hvals)
where
-- A lazier zip, in which no demand is propagated to the second
-- list unless some demand is propagated to the snd of one of the
-- result list elems.
zipLazily [] ys = []
zipLazily (x:xs) ys = (x, head ys) : zipLazily xs (tail ys)
data UnlinkedBCO
= UnlinkedBCO Name
(SizedSeq Word16) -- insns
(SizedSeq Word) -- literals
(SizedSeq Name) -- ptrs
(SizedSeq Name) -- itbl refs
nameOfUnlinkedBCO (UnlinkedBCO nm _ _ _ _) = nm
-- When translating expressions, we need to distinguish the root
-- BCO for the expression
type UnlinkedBCOExpr = (UnlinkedBCO, [UnlinkedBCO])
instance Outputable UnlinkedBCO where
ppr (UnlinkedBCO nm insns lits ptrs itbls)
= sep [text "BCO", ppr nm, text "with",
int (sizeSS insns), text "insns",
int (sizeSS lits), text "lits",
int (sizeSS ptrs), text "ptrs",
int (sizeSS itbls), text "itbls"]
-- these need a proper home
type ClosureEnv = FiniteMap Name HValue
data HValue = HValue -- dummy type, actually a pointer to some Real Code.
-- remove all entries for a given set of modules from the environment
filterNameMap :: [ModuleName] -> FiniteMap Name a -> FiniteMap Name a
filterNameMap mods env
= filterFM (\n _ -> moduleName (nameModule n) `notElem` mods) env
\end{code}
%************************************************************************
%* *
\subsection{The bytecode assembler}
%* *
%************************************************************************
The object format for bytecodes is: 16 bits for the opcode, and 16 for
each field -- so the code can be considered a sequence of 16-bit ints.
Each field denotes either a stack offset or number of items on the
stack (eg SLIDE), and index into the pointer table (eg PUSH_G), an
index into the literal table (eg PUSH_I/D/L), or a bytecode address in
this BCO.
\begin{code}
-- Top level assembler fn.
assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO
assembleBCO (ProtoBCO nm instrs origin)
= 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
mkLabelEnv env i_offset [] = 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 lab
= case lookupFM label_env lab of
Just bco_offset -> bco_offset
Nothing -> pprPanic "assembleBCO.findLabel" (int lab)
in
do -- pass 2: generate the instruction, ptr and nonptr bits
insns <- return emptySS :: IO (SizedSeq Word16)
lits <- return emptySS :: IO (SizedSeq Word)
ptrs <- return emptySS :: IO (SizedSeq Name)
itbls <- return emptySS :: IO (SizedSeq Name)
let init_asm_state = (insns,lits,ptrs,itbls)
(final_insns, final_lits, final_ptrs, final_itbls)
<- mkBits findLabel init_asm_state instrs
return (UnlinkedBCO nm final_insns final_lits final_ptrs final_itbls)
-- instrs nonptrs ptrs itbls
type AsmState = (SizedSeq Word16, SizedSeq Word, SizedSeq Name, SizedSeq Name)
data SizedSeq a = SizedSeq !Int [a]
emptySS = SizedSeq 0 []
addToSS (SizedSeq n r_xs) x = return (SizedSeq (n+1) (x:r_xs))
addListToSS (SizedSeq n r_xs) xs
= return (SizedSeq (n + length xs) (reverse xs ++ r_xs))
sizeSS (SizedSeq n r_xs) = n
listFromSS (SizedSeq n r_xs) = return (reverse r_xs)
-- This is where all the action is (pass 2 of the assembler)
mkBits :: (Int -> Int) -- label finder
-> AsmState
-> [BCInstr] -- instructions (in)
-> IO AsmState
mkBits findLabel st proto_insns
= foldM doInstr st proto_insns
where
doInstr :: AsmState -> BCInstr -> IO AsmState
doInstr st i
= case i of
ARGCHECK n -> instr2 st i_ARGCHECK n
PUSH_L o1 -> instr2 st i_PUSH_L o1
PUSH_LL o1 o2 -> instr3 st i_PUSH_LL o1 o2
PUSH_LLL o1 o2 o3 -> instr4 st i_PUSH_LLL o1 o2 o3
PUSH_G nm -> do (p, st2) <- ptr st nm
instr2 st2 i_PUSH_G p
PUSH_AS nm pk -> do (p, st2) <- ptr st nm
(np, st3) <- ctoi_itbl st2 pk
instr3 st3 i_PUSH_AS p np
PUSH_UBX lit nws -> do (np, st2) <- literal st lit
instr3 st2 i_PUSH_UBX np nws
PUSH_TAG tag -> instr2 st i_PUSH_TAG tag
SLIDE n by -> instr3 st i_SLIDE n by
ALLOC n -> instr2 st i_ALLOC n
MKAP off sz -> instr3 st i_MKAP off sz
UNPACK n -> instr2 st i_UNPACK n
UPK_TAG n m k -> instr4 st i_UPK_TAG n m k
PACK dcon sz -> do (itbl_no,st2) <- itbl st dcon
instr3 st2 i_PACK itbl_no sz
LABEL lab -> return st
TESTLT_I i l -> do (np, st2) <- int st i
instr3 st2 i_TESTLT_I np (findLabel l)
TESTEQ_I i l -> do (np, st2) <- int st i
instr3 st2 i_TESTEQ_I np (findLabel l)
TESTLT_F f l -> do (np, st2) <- float st f
instr3 st2 i_TESTLT_F np (findLabel l)
TESTEQ_F f l -> do (np, st2) <- float st f
instr3 st2 i_TESTEQ_F np (findLabel l)
TESTLT_D d l -> do (np, st2) <- double st d
instr3 st2 i_TESTLT_D np (findLabel l)
TESTEQ_D d l -> do (np, st2) <- double st d
instr3 st2 i_TESTEQ_D np (findLabel l)
TESTLT_P i l -> instr3 st i_TESTLT_P i (findLabel l)
TESTEQ_P i l -> instr3 st i_TESTEQ_P i (findLabel l)
CASEFAIL -> instr1 st i_CASEFAIL
ENTER -> instr1 st i_ENTER
RETURN rep -> do (itbl_no,st2) <- itoc_itbl st rep
instr2 st2 i_RETURN itbl_no
i2s :: Int -> Word16
i2s = fromIntegral
instr1 (st_i0,st_l0,st_p0,st_I0) i1
= do st_i1 <- addToSS st_i0 (i2s i1)
return (st_i1,st_l0,st_p0,st_I0)
instr2 (st_i0,st_l0,st_p0,st_I0) i1 i2
= do st_i1 <- addToSS st_i0 (i2s i1)
st_i2 <- addToSS st_i1 (i2s i2)
return (st_i2,st_l0,st_p0,st_I0)
instr3 (st_i0,st_l0,st_p0,st_I0) i1 i2 i3
= do st_i1 <- addToSS st_i0 (i2s i1)
st_i2 <- addToSS st_i1 (i2s i2)
st_i3 <- addToSS st_i2 (i2s i3)
return (st_i3,st_l0,st_p0,st_I0)
instr4 (st_i0,st_l0,st_p0,st_I0) i1 i2 i3 i4
= do st_i1 <- addToSS st_i0 (i2s i1)
st_i2 <- addToSS st_i1 (i2s i2)
st_i3 <- addToSS st_i2 (i2s i3)
st_i4 <- addToSS st_i3 (i2s i4)
return (st_i4,st_l0,st_p0,st_I0)
float (st_i0,st_l0,st_p0,st_I0) f
= do let ws = mkLitF f
st_l1 <- addListToSS st_l0 ws
return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
double (st_i0,st_l0,st_p0,st_I0) d
= do let ws = mkLitD d
st_l1 <- addListToSS st_l0 ws
return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
int (st_i0,st_l0,st_p0,st_I0) i
= do let ws = mkLitI i
st_l1 <- addListToSS st_l0 ws
return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
addr (st_i0,st_l0,st_p0,st_I0) a
= do let ws = mkLitA a
st_l1 <- addListToSS st_l0 ws
return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0))
ptr (st_i0,st_l0,st_p0,st_I0) p
= do st_p1 <- addToSS st_p0 p
return (sizeSS st_p0, (st_i0,st_l0,st_p1,st_I0))
itbl (st_i0,st_l0,st_p0,st_I0) dcon
= do st_I1 <- addToSS st_I0 (getName dcon)
return (sizeSS st_I0, (st_i0,st_l0,st_p0,st_I1))
literal st (MachInt j) = int st (fromIntegral j)
literal st (MachFloat r) = float st (fromRational r)
literal st (MachDouble r) = double st (fromRational r)
literal st (MachChar c) = int st c
ctoi_itbl st pk
= addr st ret_itbl_addr
where
ret_itbl_addr = case pk of
PtrRep -> stg_ctoi_ret_R1_info
IntRep -> stg_ctoi_ret_R1_info
CharRep -> stg_ctoi_ret_R1_info
FloatRep -> stg_ctoi_ret_F1_info
DoubleRep -> stg_ctoi_ret_D1_info
_ -> pprPanic "mkBits.ctoi_itbl" (ppr pk)
itoc_itbl st pk
= addr st ret_itbl_addr
where
ret_itbl_addr = case pk of
IntRep -> stg_gc_unbx_r1_info
FloatRep -> stg_gc_f1_info
DoubleRep -> stg_gc_d1_info
foreign label "stg_ctoi_ret_R1_info" stg_ctoi_ret_R1_info :: Addr
foreign label "stg_ctoi_ret_F1_info" stg_ctoi_ret_F1_info :: Addr
foreign label "stg_ctoi_ret_D1_info" stg_ctoi_ret_D1_info :: Addr
foreign label "stg_gc_unbx_r1_info" stg_gc_unbx_r1_info :: Addr
foreign label "stg_gc_f1_info" stg_gc_f1_info :: Addr