\section[ByteCodeGen]{Generate bytecode from Core}
\begin{code}
-module ByteCodeGen ( UnlinkedBCO, UnlinkedBCOExpr, ItblEnv, ClosureEnv, HValue,
- filterNameMap,
- byteCodeGen, coreExprToBCOs
+module ByteCodeGen ( UnlinkedBCO, UnlinkedBCOExpr,
+ byteCodeGen, coreExprToBCOs
) where
#include "HsVersions.h"
+import ByteCodeInstr ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO, bciStackUse )
+import ByteCodeFFI ( taggedSizeW, untaggedSizeW, mkMarshalCode, moan64 )
+import ByteCodeAsm ( CompiledByteCode(..), UnlinkedBCO, UnlinkedBCOExpr,
+ assembleBCO, assembleBCOs, iNTERP_STACK_CHECK_THRESH )
+import ByteCodeLink ( lookupStaticPtr )
+
import Outputable
-import Name ( Name, getName )
+import Name ( Name, getName, mkSystemName )
import Id ( Id, idType, isDataConId_maybe, isPrimOpId_maybe, isFCallId,
- idPrimRep, mkSysLocal, idName, isFCallId_maybe, isPrimOpId )
+ idPrimRep, mkLocalId, isFCallId_maybe, isPrimOpId )
import ForeignCall ( ForeignCall(..), CCallTarget(..), CCallSpec(..) )
import OrdList ( OrdList, consOL, snocOL, appOL, unitOL,
nilOL, toOL, concatOL, fromOL )
import FiniteMap ( FiniteMap, addListToFM, listToFM, elemFM,
addToFM, lookupFM, fmToList )
+import HscTypes ( ModGuts(..), ModGuts, typeEnvTyCons, typeEnvClasses )
+import CoreUtils ( exprType )
import CoreSyn
import PprCore ( pprCoreExpr )
import Literal ( Literal(..), literalPrimRep )
import PrimRep ( PrimRep(..) )
import PrimOp ( PrimOp(..) )
import CoreFVs ( freeVars )
-import Type ( typePrimRep, splitTyConApp_maybe, isTyVarTy )
+import Type ( typePrimRep, isUnLiftedType, splitTyConApp_maybe, isTyVarTy )
import DataCon ( dataConTag, fIRST_TAG, dataConTyCon,
dataConWrapId, isUnboxedTupleCon )
-import TyCon ( TyCon(..), tyConFamilySize, isDataTyCon, tyConDataCons,
+import TyCon ( tyConFamilySize, isDataTyCon, tyConDataCons,
isFunTyCon, isUnboxedTupleTyCon )
import Class ( Class, classTyCon )
import Type ( Type, repType, splitFunTys, dropForAlls )
import DataCon ( dataConRepArity )
import Var ( isTyVar )
import VarSet ( VarSet, varSetElems )
+import TysPrim ( foreignObjPrimTyCon,
+ arrayPrimTyCon, mutableArrayPrimTyCon,
+ byteArrayPrimTyCon, mutableByteArrayPrimTyCon
+ )
import PrimRep ( isFollowableRep )
import CmdLineOpts ( DynFlags, DynFlag(..) )
import ErrUtils ( showPass, dumpIfSet_dyn )
import Unique ( mkPseudoUnique3 )
-import FastString ( FastString(..) )
+import FastString ( FastString(..), unpackFS )
import Panic ( GhcException(..) )
import PprType ( pprType )
import SMRep ( arrWordsHdrSize, arrPtrsHdrSize )
import Constants ( wORD_SIZE )
-import ByteCodeInstr ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO, bciStackUse )
-import ByteCodeItbls ( ItblEnv, mkITbls )
-import ByteCodeLink ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO,
- ClosureEnv, HValue, filterNameMap, linkFail,
- iNTERP_STACK_CHECK_THRESH )
-import ByteCodeFFI ( taggedSizeW, untaggedSizeW, mkMarshalCode, moan64 )
-import Linker ( lookupSymbol )
import List ( intersperse, sortBy, zip4 )
-import Foreign ( Ptr(..), castPtr, mallocBytes, pokeByteOff, Word8 )
-import CTypes ( CInt )
-import Exception ( throwDyn )
+import Foreign ( Ptr, castPtr, mallocBytes, pokeByteOff, Word8 )
+import Foreign.C ( CInt )
+import Control.Exception ( throwDyn )
-import GlaExts ( Int(..), ByteArray# )
+import GHC.Exts ( Int(..), ByteArray# )
import Monad ( when )
import Maybe ( isJust )
\begin{code}
byteCodeGen :: DynFlags
- -> [CoreBind]
- -> [TyCon] -> [Class]
- -> IO ([UnlinkedBCO], ItblEnv)
-byteCodeGen dflags binds local_tycons local_classes
+ -> ModGuts
+ -> IO CompiledByteCode
+byteCodeGen dflags (ModGuts { mg_binds = binds, mg_types = type_env })
= do showPass dflags "ByteCodeGen"
- let tycs = local_tycons ++ map classTyCon local_classes
- itblenv <- mkITbls tycs
+ let local_tycons = typeEnvTyCons type_env
+ local_classes = typeEnvClasses type_env
+ tycs = local_tycons ++ map classTyCon local_classes
let flatBinds = concatMap getBind binds
getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)]
dumpIfSet_dyn dflags Opt_D_dump_BCOs
"Proto-bcos" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
- bcos <- mapM assembleBCO proto_bcos
-
- return (bcos, itblenv)
+ assembleBCOs proto_bcos tycs
-- Returns: (the root BCO for this expression,
-- create a totally bogus name for the top-level BCO; this
-- should be harmless, since it's never used for anything
- let invented_id = mkSysLocal FSLIT("Expr-Top-Level")
- (mkPseudoUnique3 0)
- (panic "invented_id's type")
- let invented_name = idName invented_id
-
- annexpr = freeVars expr
- fvs = filter (not.isTyVar) (varSetElems (fst annexpr))
+ let invented_name = mkSystemName (mkPseudoUnique3 0) FSLIT("ExprTopLevel")
+ invented_id = mkLocalId invented_name (panic "invented_id's type")
+ annexpr = freeVars expr
+ fvs = filter (not.isTyVar) (varSetElems (fst annexpr))
(BcM_State all_proto_bcos final_ctr mallocd, ())
<- runBc (BcM_State [] 0 [])
= schemeT d s p (fvs, AnnApp f a)
schemeE d s p e@(fvs, AnnVar v)
- | isFollowableRep v_rep
- = -- Ptr-ish thing; push it in the normal way
+ | not (isUnLiftedType v_type)
+ = -- Lifted-type thing; push it in the normal way
schemeT d s p (fvs, AnnVar v)
| otherwise
- = -- returning an unboxed value. Heave it on the stack, SLIDE, and RETURN.
+ = -- Returning an unlifted value.
+ -- Heave it on the stack, SLIDE, and RETURN.
pushAtom True d p (AnnVar v) `thenBc` \ (push, szw) ->
returnBc (push -- value onto stack
`appOL` mkSLIDE szw (d-s) -- clear to sequel
`snocOL` RETURN v_rep) -- go
where
- v_rep = typePrimRep (idType v)
+ v_type = idType v
+ v_rep = typePrimRep v_type
schemeE d s p (fvs, AnnLit literal)
= pushAtom True d p (AnnLit literal) `thenBc` \ (push, szw) ->
-{- Convert case .... of (# VoidRep'd-thing, a #) -> ...
- as
- case .... of a -> ...
- Use a as the name of the binder too.
-
- Also case .... of (# a #) -> ...
- to
- case .... of a -> ...
--}
schemeE d s p (fvs, AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)])
| isUnboxedTupleCon dc && VoidRep == typePrimRep (idType bind1)
+ -- Convert
+ -- case .... of x { (# VoidRep'd-thing, a #) -> ... }
+ -- to
+ -- case .... of a { DEFAULT -> ... }
+ -- becuse the return convention for both are identical.
+ --
+ -- Note that it does not matter losing the void-rep thing from the
+ -- envt (it won't be bound now) because we never look such things up.
+
= --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 bind2 [(DEFAULT, [], rhs)])
+ -- Note:
--)
schemeE d s p (fvs, AnnCase scrut bndr [(DataAlt dc, [bind1], rhs)])
| isUnboxedTupleCon dc
+ -- Similarly, convert
+ -- case .... of x { (# a #) -> ... }
+ -- to
+ -- case .... of a { DEFAULT -> ... }
= --trace "automagic mashing of case alts (# a #)" (
- schemeE d s p (fvs, AnnCase scrut bind1 [(DEFAULT, [bind1], rhs)])
+ schemeE d s p (fvs, AnnCase scrut bind1 [(DEFAULT, [], rhs)])
--)
schemeE d s p (fvs, AnnCase scrut bndr alts)
isAlgCase
| 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)
+ | otherwise
+ = WARN( scrut_primrep `elem` bad_reps,
+ text "Dire warning: strange rep in primitive case:" <+> ppr bndr )
+ -- We don't expect to see any of these
+ False
+ where
+ bad_reps = [CodePtrRep, DataPtrRep, RetRep, CostCentreRep]
-- given an alt, return a discr and code for it.
codeAlt alt@(discr, binds_f, rhs)
pargs d [] = returnBc []
pargs d ((_,a):az)
- = let rep_arg = atomRep a
- in case rep_arg of
+ = let arg_ty = repType (exprType (deAnnotate' a))
+
+ in case splitTyConApp_maybe arg_ty of
-- Don't push the FO; instead push the Addr# it
-- contains.
- ForeignObjRep
+ Just (t, _)
+ | t == foreignObjPrimTyCon
-> pushAtom False{-irrelevant-} d p a
`thenBc` \ (push_fo, _) ->
- let foro_szW = taggedSizeW ForeignObjRep
+ let foro_szW = taggedSizeW PtrRep
d_now = d + addr_tsizeW
code = push_fo `appOL` toOL [
UPK_TAG addr_usizeW 0 0,
in pargs d_now az `thenBc` \ rest ->
returnBc ((code, AddrRep) : rest)
- ArrayRep
+ | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
-> pargs (d + addr_tsizeW) az `thenBc` \ rest ->
parg_ArrayishRep arrPtrsHdrSize d p a
`thenBc` \ code ->
returnBc ((code,AddrRep):rest)
- ByteArrayRep
+ | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
-> pargs (d + addr_tsizeW) az `thenBc` \ rest ->
parg_ArrayishRep arrWordsHdrSize d p a
`thenBc` \ code ->
other
-> pushAtom True d p a `thenBc` \ (code_a, sz_a) ->
pargs (d+sz_a) az `thenBc` \ rest ->
- returnBc ((code_a, rep_arg) : rest)
+ returnBc ((code_a, atomRep a) : rest)
-- Do magic for Ptr/Byte arrays. Push a ptr to the array on
-- the stack but then advance it over the headers, so as to
DynamicTarget
-> returnBc (False, panic "ByteCodeGen.generateCCall(dyn)")
StaticTarget target
- -> let sym_to_find = _UNPK_ target in
- ioToBc (lookupSymbol sym_to_find) `thenBc` \res ->
- case res of
- Just aa -> returnBc (True, aa)
- Nothing -> ioToBc (linkFail "ByteCodeGen.generateCCall"
- sym_to_find)
+ -> ioToBc (lookupStaticPtr target) `thenBc` \res ->
+ returnBc (True, res)
CasmTarget _
-> pprPanic "ByteCodeGen.generateCCall: casm" (ppr ccall_spec)
in
atomRep (AnnLam x e) | isTyVar x = atomRep (snd e)
atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other)))
-
-- Compile code which expects an unboxed Int on the top of stack,
-- (call it i), and pushes the i'th closure in the supplied list
-- as a consequence.
pushStr s
= let getMallocvilleAddr
= case s of
- CharStr s i -> returnBc (Ptr s)
-
FastString _ l ba ->
-- sigh, a string in the heap is no good to us.
-- We need a static C pointer, since the type of