Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
GHC
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Locked Files
Issues
4,332
Issues
4,332
List
Boards
Labels
Service Desk
Milestones
Iterations
Merge Requests
370
Merge Requests
370
Requirements
Requirements
List
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Security & Compliance
Security & Compliance
Dependency List
License Compliance
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Code Review
Insights
Issue
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
81442869
Commit
81442869
authored
Dec 14, 2000
by
sewardj
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
[project @ 2000-12-14 12:52:40 by sewardj]
Clarify itbl and linking issues for bcos, and add flag -ddump-bcos.
parent
99d1ef14
Changes
4
Hide whitespace changes
Inline
Side-by-side
Showing
4 changed files
with
329 additions
and
63 deletions
+329
-63
ghc/compiler/ghci/ByteCodeGen.lhs
ghc/compiler/ghci/ByteCodeGen.lhs
+320
-58
ghc/compiler/main/CmdLineOpts.lhs
ghc/compiler/main/CmdLineOpts.lhs
+1
-0
ghc/compiler/main/DriverFlags.hs
ghc/compiler/main/DriverFlags.hs
+2
-1
ghc/compiler/main/HscMain.lhs
ghc/compiler/main/HscMain.lhs
+6
-4
No files found.
ghc/compiler/ghci/ByteCodeGen.lhs
View file @
81442869
...
...
@@ -14,46 +14,79 @@ import Id ( Id, idType, isDataConId_maybe )
import OrdList ( OrdList, consOL, snocOL, appOL, unitOL,
nilOL, toOL, concatOL, fromOL )
import FiniteMap ( FiniteMap, addListToFM, listToFM,
addToFM, lookupFM, fmToList, emptyFM )
addToFM, lookupFM, fmToList, emptyFM
, plusFM
)
import CoreSyn
import PprCore ( pprCoreExpr, pprCoreAlt )
import Literal ( Literal(..) )
import PrimRep ( PrimRep(..) )
import CoreFVs ( freeVars )
import Type ( typePrimRep )
import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon )
import TyCon ( tyConFamilySize )
import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
dataConRepArgTys )
import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
import Class ( Class, classTyCon )
import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem )
import Var ( isTyVar )
import VarSet ( VarSet, varSetElems )
import PrimRep ( getPrimRepSize, isFollowableRep )
import Constants ( wORD_SIZE )
import CmdLineOpts ( DynFlags, DynFlag(..) )
import ErrUtils ( showPass, dumpIfSet_dyn )
import UniqSet ( emptyUniqSet )
import ClosureInfo ( mkVirtHeapOffsets )
import List ( intersperse )
import Monad ( foldM )
import Foreign ( Addr, Word16, Word32 )
import ST ( runST )
--import MutableArray ( readWord32Array,
-- newFloatArray, writeFloatArray,
-- newDoubleArray, writeDoubleArray,
-- newIntArray, writeIntArray,
-- newAddrArray, writeAddrArray )
import MArray
import MArray ( MArray(..), IOArray, IOUArray, HasBounds(..),
castSTUArray, readWord32Array,
newFloatArray, writeFloatArray,
newDoubleArray, writeDoubleArray,
newIntArray, writeIntArray,
newAddrArray, writeAddrArray )
import Foreign ( Storable(..), Word8, Word16, Word32, Ptr,
malloc, castPtr, plusPtr )
import Addr ( Addr, addrToInt, nullAddr )
import Bits ( Bits(..), shiftR )
--import CTypes ( )
\end{code}
Entry point.
\begin{code}
byteCodeGen :: [CoreBind] -> [ProtoBCO Name]
byteCodeGen binds
= let flatBinds = concatMap getBind binds
getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)]
getBind (Rec binds) = [(bndr, freeVars rhs) | (bndr,rhs) <- binds]
final_state = runBc (BcM_State [] 0)
(mapBc schemeR flatBinds `thenBc_` returnBc ())
in
case final_state of
BcM_State bcos final_ctr -> bcos
-- visible from outside
byteCodeGen :: DynFlags
-> [CoreBind]
-> [TyCon] -> [Class]
-> IO ([UnlinkedBCO], ItblEnv)
byteCodeGen dflags binds local_tycons local_classes
= do showPass dflags "ByteCodeGen"
let tycs = local_tycons ++ map classTyCon local_classes
itblenv <- mkITbls tycs
let flatBinds = concatMap getBind binds
getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)]
getBind (Rec binds) = [(bndr, freeVars rhs) | (bndr,rhs) <- binds]
final_state = runBc (BcM_State [] 0)
(mapBc schemeR flatBinds `thenBc_` returnBc ())
(BcM_State proto_bcos final_ctr) = final_state
dumpIfSet_dyn dflags Opt_D_dump_BCOs
"Proto-bcos" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
bcos <- mapM assembleBCO proto_bcos
return (bcos, itblenv)
-- TEMPORARY !
data UnlinkedBCO
= UnlinkedBCO (IOUArray Int Word16) -- insns
(IOUArray Int Word32) -- literals
(IOArray Int Name) -- ptrs
(IOArray Int Name) -- itbl refs
-- needs a proper home
type ItblEnv = FiniteMap Name (Ptr StgInfoTable)
\end{code}
...
...
@@ -96,6 +129,8 @@ data BCInstr
-- 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
...
...
@@ -359,7 +394,8 @@ schemeT :: Bool -- do tagging?
-> Sequel -- Sequel depth
-> Int -- # arg words so far
-> BCEnv -- stack env
-> AnnExpr Id VarSet -> BCInstrList
-> AnnExpr Id VarSet
-> BCInstrList
schemeT enTag d s narg_words p (_, AnnApp f a)
= case snd a of
...
...
@@ -714,13 +750,9 @@ index into the literal table (eg PUSH_I/D/L), or a bytecode address in
this BCO.
\begin{code}
-- An (almost) assembled BCO.
data BCO a = BCO [Word16] -- instructions
[Word32] -- literal pool
[a] -- Names or HValues
-- Top level assembler fn.
assembleBCO :: ProtoBCO Name -> IO AsmState
assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO
assembleBCO (ProtoBCO nm instrs origin)
= let
-- pass 1: collect up the offsets of the local labels
...
...
@@ -738,22 +770,30 @@ assembleBCO (ProtoBCO nm instrs origin)
Nothing -> pprPanic "assembleBCO.findLabel" (int lab)
init_n_insns = 10
init_n_lits = 4
init_n_ptrs = 4
init_n_lits = 4
init_n_ptrs = 4
init_n_itbls = 4
in
do insns <- newXIOUArray init_n_insns :: IO (XIOUArray Word16)
lits <- newXIOUArray init_n_lits :: IO (XIOUArray Word32)
ptrs <- newXIOArray init_n_ptrs -- :: IO (XIOArray Name)
itbls <- newXIOArray init_n_itbls -- :: IO (XIOArray Name)
-- pass 2: generate the instruction, ptr and nonptr bits
let init_asm_state = (insns,lits,ptrs)
let init_asm_state = (insns,lits,ptrs
,itbls
)
final_asm_state <- mkBits findLabel init_asm_state instrs
return final_asm_state
-- unwrap the expandable arrays
let final_insns = stuffXIOU insns
final_nptrs = stuffXIOU lits
final_ptrs = stuffXIO ptrs
final_itbls = stuffXIO itbls
return (UnlinkedBCO final_insns final_nptrs final_ptrs final_itbls)
-- instrs nonptrs ptrs
type AsmState = (XIOUArray Word16, XIOUArray Word32, XIOArray Name)
-- instrs nonptrs ptrs itbls
type AsmState = (XIOUArray Word16, XIOUArray Word32, XIOArray Name, XIOArray Name)
-- This is where all the action is (pass 2 of the assembler)
...
...
@@ -785,8 +825,8 @@ mkBits findLabel st proto_insns
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 (
np
,st2) <- itbl st dcon
instr3 st2 i_PACK
np
sz
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)
...
...
@@ -811,59 +851,76 @@ mkBits findLabel st proto_insns
i2s :: Int -> Word16
i2s = fromIntegral
instr1 (st_i0,st_l0,st_p0) i1
instr1 (st_i0,st_l0,st_p0
,st_I0
) i1
= do st_i1 <- addToXIOUArray st_i0 (i2s i1)
return (st_i1,st_l0,st_p0)
return (st_i1,st_l0,st_p0
,st_I0
)
instr2 (st_i0,st_l0,st_p0) i1 i2
instr2 (st_i0,st_l0,st_p0
,st_I0
) i1 i2
= do st_i1 <- addToXIOUArray st_i0 (i2s i1)
st_i2 <- addToXIOUArray st_i1 (i2s i2)
return (st_i2,st_l0,st_p0)
return (st_i2,st_l0,st_p0
,st_I0
)
instr3 (st_i0,st_l0,st_p0) i1 i2 i3
instr3 (st_i0,st_l0,st_p0
,st_I0
) i1 i2 i3
= do st_i1 <- addToXIOUArray st_i0 (i2s i1)
st_i2 <- addToXIOUArray st_i1 (i2s i2)
st_i3 <- addToXIOUArray st_i2 (i2s i3)
return (st_i3,st_l0,st_p0)
return (st_i3,st_l0,st_p0
,st_I0
)
instr4 (st_i0,st_l0,st_p0) i1 i2 i3 i4
instr4 (st_i0,st_l0,st_p0
,st_I0
) i1 i2 i3 i4
= do st_i1 <- addToXIOUArray st_i0 (i2s i1)
st_i2 <- addToXIOUArray st_i1 (i2s i2)
st_i3 <- addToXIOUArray st_i2 (i2s i3)
st_i4 <- addToXIOUArray st_i3 (i2s i4)
return (st_i4,st_l0,st_p0)
return (st_i4,st_l0,st_p0
,st_I0
)
float (st_i0,st_l0,st_p0) f
float (st_i0,st_l0,st_p0
,st_I0
) f
= do let w32s = mkLitF f
st_l1 <- addListToXIOUArray st_l0 w32s
return (usedXIOU st_l0, (st_i0,st_l1,st_p0))
return (usedXIOU st_l0, (st_i0,st_l1,st_p0
,st_I0
))
double (st_i0,st_l0,st_p0) d
double (st_i0,st_l0,st_p0
,st_I0
) d
= do let w32s = mkLitD d
st_l1 <- addListToXIOUArray st_l0 w32s
return (usedXIOU st_l0, (st_i0,st_l1,st_p0))
return (usedXIOU st_l0, (st_i0,st_l1,st_p0
,st_I0
))
int (st_i0,st_l0,st_p0) i
int (st_i0,st_l0,st_p0
,st_I0
) i
= do let w32s = mkLitI i
st_l1 <- addListToXIOUArray st_l0 w32s
return (usedXIOU st_l0, (st_i0,st_l1,st_p0))
return (usedXIOU st_l0, (st_i0,st_l1,st_p0
,st_I0
))
addr (st_i0,st_l0,st_p0) a
addr (st_i0,st_l0,st_p0
,st_I0
) a
= do let w32s = mkLitA a
st_l1 <- addListToXIOUArray st_l0 w32s
return (usedXIOU st_l0, (st_i0,st_l1,st_p0))
return (usedXIOU st_l0, (st_i0,st_l1,st_p0
,st_I0
))
ptr (st_i0,st_l0,st_p0) p
ptr (st_i0,st_l0,st_p0
,st_I0
) p
= do st_p1 <- addToXIOArray st_p0 p
return (usedXIO st_p0, (st_i0,st_l0,st_p1))
return (usedXIO st_p0, (st_i0,st_l0,st_p1,st_I0))
itbl (st_i0,st_l0,st_p0,st_I0) dcon
= do st_I1 <- addToXIOArray st_I0 (getName dcon)
return (usedXIO 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)
ret_itbl st pk = panic "ret_itbl" -- return (65535, st)
itbl st dcon = panic "itbl" -- return (65536, st)
ret_itbl st pk
= addr st ret_itbl_addr
where
ret_itbl_addr
= case pk of
IntRep -> stg_ret_R1_info
FloatRep -> stg_ret_F1_info
DoubleRep -> stg_ret_D1_info
where -- TEMP HACK
stg_ret_R1_info = nullAddr
stg_ret_F1_info = nullAddr
stg_ret_D1_info = nullAddr
--foreign label "stg_ret_R1_info" stg_ret_R1_info :: Addr
--foreign label "stg_ret_F1_info" stg_ret_F1_info :: Addr
--foreign label "stg_ret_D1_info" stg_ret_D1_info :: Addr
-- The size in bytes of an instruction.
instrSizeB :: BCInstr -> Int
...
...
@@ -1027,6 +1084,211 @@ addToXIOArray (XIOArray n_arr arr) x
writeArray dst n nx
copy (n-1) src dst
\end{code}
%************************************************************************
%* *
\subsection{Manufacturing of info tables for DataCons}
%* *
%************************************************************************
\begin{code}
#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
-- | trace ("TYCON: " ++ showSDoc (ppr tc)) False
-- = error "?!?!"
| 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 mci_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
itbl = StgInfoTable {
ptrs = fromIntegral ptrs, nptrs = fromIntegral nptrs,
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)
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 = mci_constr1_entry
vecret_entry 1 = mci_constr2_entry
vecret_entry 2 = mci_constr3_entry
vecret_entry 3 = mci_constr4_entry
vecret_entry 4 = mci_constr5_entry
vecret_entry 5 = mci_constr6_entry
vecret_entry 6 = mci_constr7_entry
vecret_entry 7 = mci_constr8_entry
-- entry point for direct returns for created constr itbls
foreign label "stg_mci_constr_entry" mci_constr_entry :: Addr
-- and the 8 vectored ones
foreign label "stg_mci_constr1_entry" mci_constr1_entry :: Addr
foreign label "stg_mci_constr2_entry" mci_constr2_entry :: Addr
foreign label "stg_mci_constr3_entry" mci_constr3_entry :: Addr
foreign label "stg_mci_constr4_entry" mci_constr4_entry :: Addr
foreign label "stg_mci_constr5_entry" mci_constr5_entry :: Addr
foreign label "stg_mci_constr6_entry" mci_constr6_entry :: Addr
foreign label "stg_mci_constr7_entry" mci_constr7_entry :: Addr
foreign label "stg_mci_constr8_entry" mci_constr8_entry :: Addr
data Constructor = Constructor Int{-ptrs-} Int{-nptrs-}
-- 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}
%************************************************************************
%* *
\subsection{Connect to actual values for bytecode opcodes}
%* *
%************************************************************************
\begin{code}
#include "Bytecodes.h"
...
...
ghc/compiler/main/CmdLineOpts.lhs
View file @
81442869
...
...
@@ -244,6 +244,7 @@ data DynFlag
| Opt_D_dump_stix
| Opt_D_dump_simpl_stats
| Opt_D_dump_InterpSyn
| Opt_D_dump_BCOs
| Opt_D_source_stats
| Opt_D_verbose_core2core
| Opt_D_verbose_stg2stg
...
...
ghc/compiler/main/DriverFlags.hs
View file @
81442869
-----------------------------------------------------------------------------
-- $Id: DriverFlags.hs,v 1.3
4 2000/12/12 14:35:08 simonmar
Exp $
-- $Id: DriverFlags.hs,v 1.3
5 2000/12/14 12:52:40 sewardj
Exp $
--
-- Driver flags
--
...
...
@@ -404,6 +404,7 @@ dynamic_flags = [
,
(
"ddump-stix"
,
NoArg
(
setDynFlag
Opt_D_dump_stix
)
)
,
(
"ddump-simpl-stats"
,
NoArg
(
setDynFlag
Opt_D_dump_simpl_stats
)
)
,
(
"ddump-interpsyn"
,
NoArg
(
setDynFlag
Opt_D_dump_InterpSyn
)
)
,
(
"ddump-bcos"
,
NoArg
(
setDynFlag
Opt_D_dump_BCOs
)
)
,
(
"dsource-stats"
,
NoArg
(
setDynFlag
Opt_D_source_stats
)
)
,
(
"dverbose-core2core"
,
NoArg
(
setDynFlag
Opt_D_verbose_core2core
)
)
,
(
"dverbose-stg2stg"
,
NoArg
(
setDynFlag
Opt_D_verbose_stg2stg
)
)
...
...
ghc/compiler/main/HscMain.lhs
View file @
81442869
...
...
@@ -239,7 +239,7 @@ hscRecomp ghci_mode dflags location maybe_checked_iface hst hit pcs_ch
-- CONVERT TO STG
-------------------
; (stg_binds, cost_centre_info)
<- myCoreToStg dflags this_mod tidy_binds
<- myCoreToStg dflags this_mod tidy_binds
env_tc
-------------------
-- COMPLETE CODE GENERATION
...
...
@@ -365,15 +365,14 @@ restOfCodeGeneration dflags toInterp this_mod imported_module_names cost_centre_
(ppr nm)
myCoreToStg dflags this_mod tidy_binds
myCoreToStg dflags this_mod tidy_binds
env_tc
= do
() <- coreBindsSize tidy_binds `seq` return ()
-- TEMP: the above call zaps some space usage allocated by the
-- simplifier, which for reasons I don't understand, persists
-- thoroughout code generation
--let bcos = byteCodeGen tidy_binds
--putStrLn ("\n\n" ++ showSDocDebug (vcat (intersperse (char ' ') (map ppr bcos))))
let bcos = byteCodeGen dflags tidy_binds local_tycons local_classes
-- _scc_ "Core2Stg"
stg_binds <- coreToStg dflags this_mod tidy_binds
...
...
@@ -382,6 +381,9 @@ myCoreToStg dflags this_mod tidy_binds
(stg_binds2, cost_centre_info) <- stg2stg dflags this_mod stg_binds
return (stg_binds2, cost_centre_info)
where
local_tycons = typeEnvTyCons env_tc
local_classes = typeEnvClasses env_tc
\end{code}
...
...
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