\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 )
+ 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,
+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, splitRepFunTys )
-import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem )
+import Type ( Type, repType, splitFunTys, dropForAlls )
+import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem,
+ isSingleton, lengthIs, notNull )
+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,
- iNTERP_STACK_CHECK_THRESH )
-import ByteCodeFFI ( taggedSizeW, untaggedSizeW, mkMarshalCode )
-import Linker ( lookupSymbol )
import List ( intersperse, sortBy, zip4 )
-import Foreign ( Ptr(..), mallocBytes )
-import Addr ( Addr(..), writeCharOffAddr )
-import CTypes ( CInt )
-import Exception ( throwDyn )
-
-import PrelBase ( Int(..) )
-import PrelGHC ( ByteArray# )
-import PrelIOBase ( IO(..) )
-import Monad ( when )
+import Foreign ( Ptr, castPtr, mallocBytes, pokeByteOff, Word8 )
+import Foreign.C ( CInt )
+import Control.Exception ( throwDyn )
+import GHC.Exts ( Int(..), ByteArray# )
+
+import Monad ( when )
+import Maybe ( isJust )
+import Char ( ord )
\end{code}
%************************************************************************
\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)]
(BcM_State proto_bcos final_ctr mallocd, ())
<- runBc (BcM_State [] 0 [])
- (mapBc (schemeR True) flatBinds `thenBc_` returnBc ())
+ (mapBc (schemeR True []) flatBinds `thenBc_` returnBc ())
+ -- ^^
+ -- better be no free vars in these top-level bindings
- when (not (null mallocd))
+ when (notNull mallocd)
(panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
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 SLIT("Expr-Top-Level") (mkPseudoUnique3 0)
- (panic "invented_id's type")
- let invented_name = idName invented_id
+ 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 [])
- (schemeR True (invented_id, freeVars expr))
+ (schemeR True fvs (invented_id, annexpr))
- when (not (null mallocd))
+ when (notNull mallocd)
(panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?")
dumpIfSet_dyn dflags Opt_D_dump_BCOs
-- variable to which this value was bound, so as to give the
-- resulting BCO a name. Bool indicates top-levelness.
-schemeR :: Bool -> (Id, AnnExpr Id VarSet) -> BcM ()
-schemeR is_top (nm, rhs)
+schemeR :: Bool -> [Id] -> (Id, AnnExpr Id VarSet) -> BcM ()
+schemeR is_top fvs (nm, rhs)
{-
| trace (showSDoc (
(char ' '
= undefined
-}
| otherwise
- = schemeR_wrk is_top rhs nm (collect [] rhs)
+ = schemeR_wrk is_top fvs rhs nm (collect [] rhs)
collect xs (_, AnnNote note e)
collect xs not_lambda
= (reverse xs, not_lambda)
-schemeR_wrk is_top original_body nm (args, body)
+schemeR_wrk is_top fvs original_body nm (args, body)
| Just dcon <- maybe_toplevel_null_con_rhs
= --trace ("nullary constructor! " ++ showSDocDebug (ppr nm)) (
emitBc (mkProtoBCO (getName nm) (toOL [PACK dcon 0, ENTER])
--)
| otherwise
- = let fvs = filter (not.isTyVar) (varSetElems (fst original_body))
- all_args = reverse args ++ fvs
+ = let all_args = reverse args ++ fvs
szsw_args = map taggedIdSizeW all_args
szw_args = sum szsw_args
p_init = listToFM (zip all_args (mkStackOffsets 0 szsw_args))
= 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) ->
`appOL` mkSLIDE szw (d-s) -- clear to sequel
`snocOL` RETURN l_rep) -- go
+
+{-
+ Deal specially with the cases
+ let x = fn atom1 .. atomn in B
+ and
+ let x = Con atom1 .. atomn in B
+ (Con must be saturated)
+
+ In these cases, generate code to allocate in-line.
+
+ This is optimisation of the general case for let, which follows
+ this one; this case can safely be omitted. The reduction in
+ interpreter execution time seems to be around 5% for some programs,
+ with a similar drop in allocations.
+
+ This optimisation should be done more cleanly. As-is, it is
+ inapplicable to RHSs in letrecs, and needlessly duplicates code in
+ schemeR and schemeT. Some refactoring of the machinery would cure
+ both ills.
+-}
+schemeE d s p ee@(fvs, AnnLet (AnnNonRec x rhs) b)
+ | ok_to_go
+ = let d_init = if is_con then d else d'
+ in
+ mkPushes d_init args_r_to_l_reordered `thenBc` \ (d_final, push_code) ->
+ schemeE d' s p' b `thenBc` \ body_code ->
+ let size = d_final - d_init
+ alloc = if is_con then nilOL else unitOL (ALLOC size)
+ pack = unitOL (if is_con then PACK the_dcon size else MKAP size size)
+ in
+ returnBc (alloc `appOL` push_code `appOL` pack
+ `appOL` body_code)
+ where
+ -- Decide whether we can do this or not
+ (ok_to_go, is_con, the_dcon, the_fn)
+ = case maybe_fn of
+ Nothing -> (False, bomb 1, bomb 2, bomb 3)
+ Just (Left fn) -> (True, False, bomb 5, fn)
+ Just (Right dcon)
+ | dataConRepArity dcon <= length args_r_to_l
+ -> (True, True, dcon, bomb 6)
+ | otherwise
+ -> (False, bomb 7, bomb 8, bomb 9)
+ bomb n = panic ("schemeE.is_con(hacky hack hack) " ++ show n)
+
+ -- Extract the args (R -> L) and fn
+ args_r_to_l_reordered
+ | not is_con
+ = args_r_to_l
+ | otherwise
+ = filter (not.isPtr.snd) args_r_to_l ++ filter (isPtr.snd) args_r_to_l
+ where isPtr = isFollowableRep . atomRep
+
+ args_r_to_l = filter (not.isTypeAtom.snd) args_r_to_l_raw
+ isTypeAtom (AnnType _) = True
+ isTypeAtom _ = False
+
+ (args_r_to_l_raw, maybe_fn) = chomp rhs
+ chomp expr
+ = case snd expr of
+ AnnVar v
+ | isFCallId v || isPrimOpId v
+ -> ([], Nothing)
+ | otherwise
+ -> case isDataConId_maybe v of
+ Just dcon -> ([], Just (Right dcon))
+ Nothing -> ([], Just (Left v))
+ AnnApp f a -> case chomp f of (az, f) -> (a:az, f)
+ AnnNote n e -> chomp e
+ other -> ([], Nothing)
+
+ -- This is the env in which to translate the body
+ p' = addToFM p x d
+ d' = d + 1
+
+ -- Shove the args on the stack, including the fn in the non-dcon case
+ tag_when_push = not is_con
+
+ mkPushes :: Int{-curr depth-} -> [AnnExpr Id VarSet]
+ -> BcM (Int{-final depth-}, BCInstrList)
+ mkPushes dd []
+ | is_con
+ = returnBc (dd, nilOL)
+ | otherwise
+ = pushAtom False dd p' (AnnVar the_fn) `thenBc` \ (fn_push_code, fn_szw) ->
+ returnBc (dd+fn_szw, fn_push_code)
+ mkPushes dd (atom:atoms)
+ = pushAtom tag_when_push dd p' (snd atom)
+ `thenBc` \ (push1_code, push1_szw) ->
+ mkPushes (dd+push1_szw) atoms `thenBc` \ (dd_final, push_rest) ->
+ returnBc (dd_final, push1_code `appOL` push_rest)
+
+
+-- General case for let. Generates correct, if inefficient, code in
+-- all situations.
schemeE d s p (fvs, AnnLet binds b)
= let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs])
AnnRec xs_n_rhss -> unzip xs_n_rhss
n = length xs
- fvss = map (filter (not.isTyVar).varSetElems.fst) rhss
+
+ is_local id = not (isTyVar id) && elemFM id p'
+ fvss = map (filter is_local . varSetElems . fst) rhss
-- Sizes of tagged free vars, + 1 for the fn
sizes = map (\rhs_fvs -> 1 + sum (map taggedIdSizeW rhs_fvs)) fvss
returnBc (concatOL tcodes)
allocCode = toOL (map ALLOC sizes)
+
+ schemeRs [] _ _ = returnBc ()
+ schemeRs (fvs:fvss) (x:xs) (rhs:rhss) =
+ schemeR False fvs (x,rhs) `thenBc_` schemeRs fvss xs rhss
in
schemeE d' s p' b `thenBc` \ bodyCode ->
- mapBc (schemeR False) (zip xs rhss) `thenBc_`
+ schemeRs fvss xs rhss `thenBc_`
genThunkCode `thenBc` \ thunkCode ->
returnBc (allocCode `appOL` thunkCode `appOL` bodyCode)
-{- 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)
-- and enter. Four cases:
--
-- 0. (Nasty hack).
--- An application "PrelGHC.tagToEnum# <type> unboxed-int".
+-- An application "GHC.Prim.tagToEnum# <type> unboxed-int".
-- The int will be on the stack. Generate a code sequence
-- to convert it to the relevant constructor, SLIDE and ENTER.
--
)
-- Case 2
- | let isVoidRepAtom (_, AnnVar v) = VoidRep == typePrimRep (idType v)
- isVoidRepAtom (_, AnnNote n e) = isVoidRepAtom e
- in is_con_call && isUnboxedTupleCon con
- && ( (length args_r_to_l == 2 && isVoidRepAtom (last (args_r_to_l)))
- || (length args_r_to_l == 1)
- )
- = --trace (if length args_r_to_l == 1
+ | is_con_call,
+ isUnboxedTupleCon con, -- (# ... #)
+ [(_,arg1),(_,arg2)] <- args_r_to_l, -- Exactly two args
+ let
+ isVoidRepAtom (AnnVar v) = typePrimRep (idType v) == VoidRep
+ isVoidRepAtom (AnnNote n (_,e)) = isVoidRepAtom e
+ isVoidRepAtom _ = False
+ in
+ isVoidRepAtom arg2 -- The first arg is void
+ = --trace (if isSingleton args_r_to_l
-- then "schemeT: unboxed singleton"
-- else "schemeT: unboxed pair with Void first component") (
- schemeT d s p (head args_r_to_l)
- --)
+ pushAtom True d p arg1 `thenBc` \ (push, szw) ->
+ returnBc (push -- value onto stack
+ `appOL` mkSLIDE szw (d-s) -- clear to sequel
+ `snocOL` RETURN (atomRep arg1)) -- go
+ -- We used to use "schemeT d s p arg1", but that is wrong.
+ -- We must use RETURN (because it's an unboxed tuple)
+ -- I think that this still does not work: SLPJ Oct 02
-- Case 3
| Just (CCall ccall_spec) <- isFCallId_maybe fn
other -> Nothing
-- Extract the args (R->L) and fn
- (args_r_to_l_raw, fn) = chomp app
+ (args_r_to_l, fn) = chomp app
chomp expr
= case snd expr of
AnnVar v -> ([], v)
- AnnApp f a -> case chomp f of (az, f) -> (a:az, f)
+ AnnApp f a
+ | isTypeAtom (snd a) -> chomp f
+ | otherwise -> case chomp f of (az, f) -> (a:az, f)
AnnNote n e -> chomp e
other -> pprPanic "schemeT"
- (ppr (deAnnotate (panic "schemeT.chomp", other)))
-
- args_r_to_l = filter (not.isTypeAtom.snd) args_r_to_l_raw
+ (ppr (deAnnotate (panic "schemeT.chomp", other)))
+
+ n_args = length args_r_to_l
+
isTypeAtom (AnnType _) = True
isTypeAtom _ = False
- -- decide if this is a constructor call, and rearrange
- -- args appropriately.
- maybe_dcon = isDataConId_maybe fn
- is_con_call = case maybe_dcon of Nothing -> False; Just _ -> True
+ -- decide if this is a constructor application, because we need
+ -- to rearrange the arguments on the stack if so. For building
+ -- a constructor, we put pointers before non-pointers and omit
+ -- the tags.
+ --
+ -- Also if the constructor is not saturated, we just arrange to
+ -- call the curried worker instead.
+
+ maybe_dcon = case isDataConId_maybe fn of
+ Just con | dataConRepArity con == n_args -> Just con
+ _ -> Nothing
+ is_con_call = isJust maybe_dcon
(Just con) = maybe_dcon
args_final_r_to_l
`snocOL` ENTER)
-
{- Deal with a CCall. Taggedly push the args onto the stack R->L,
deferencing ForeignObj#s and (ToDo: adjusting addrs to point to
payloads in Ptr/Byte arrays). Then, generate the marshalling
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
- -> ioToBc (lookupSymbol (_UNPK_ target)) `thenBc` \res ->
- case res of
- Just aa -> case aa of Ptr a# -> returnBc (True, A# a#)
- Nothing -> returnBc invalid
+ -> ioToBc (lookupStaticPtr target) `thenBc` \res ->
+ returnBc (True, res)
CasmTarget _
- -> returnBc invalid
- where
- invalid = pprPanic ("ByteCodeGen.generateCCall: unfindable "
- ++ "symbol or otherwise invalid target")
- (ppr ccall_spec)
+ -> pprPanic "ByteCodeGen.generateCCall: casm" (ppr ccall_spec)
in
get_target_info `thenBc` \ (is_static, static_target_addr) ->
let
recordMallocBc addr_of_marshaller `thenBc_`
let
-- do the call
- do_call = unitOL (CCALL addr_of_marshaller)
+ do_call = unitOL (CCALL (castPtr addr_of_marshaller))
-- slide and return
wrapup = mkSLIDE r_tsizeW (d_after_r - r_tsizeW - s)
`snocOL` RETURN r_rep
= case pr of
CharRep -> MachChar 0
IntRep -> MachInt 0
+ WordRep -> MachWord 0
DoubleRep -> MachDouble 0
FloatRep -> MachFloat 0
AddrRep | taggedSizeW AddrRep == taggedSizeW WordRep -> MachWord 0
- _ -> pprPanic "mkDummyLiteral" (ppr pr)
+ _ -> moan64 "mkDummyLiteral" (ppr pr)
-- Convert (eg)
--- PrelGHC.Char# -> PrelGHC.State# PrelGHC.RealWorld
--- -> (# PrelGHC.State# PrelGHC.RealWorld, PrelGHC.Int# #)
+-- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
+-- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)
--
-- to Just IntRep
-- and check that an unboxed pair is returned wherein the first arg is VoidRep'd.
--
-- Alternatively, for call-targets returning nothing, convert
--
--- PrelGHC.Char# -> PrelGHC.State# PrelGHC.RealWorld
--- -> (# PrelGHC.State# PrelGHC.RealWorld #)
+-- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
+-- -> (# GHC.Prim.State# GHC.Prim.RealWorld #)
--
-- to Nothing
maybe_getCCallReturnRep :: Type -> Maybe PrimRep
maybe_getCCallReturnRep fn_ty
- = let (a_tys, r_ty) = splitRepFunTys fn_ty
+ = let (a_tys, r_ty) = splitFunTys (dropForAlls fn_ty)
maybe_r_rep_to_go
- = if length r_reps == 1 then Nothing else Just (r_reps !! 1)
+ = if isSingleton r_reps then Nothing else Just (r_reps !! 1)
(r_tycon, r_reps)
= case splitTyConApp_maybe (repType r_ty) of
(Just (tyc, tys)) -> (tyc, map typePrimRep tys)
Nothing -> blargh
- ok = ( (length r_reps == 2 && VoidRep == head r_reps)
+ ok = ( ( r_reps `lengthIs` 2 && VoidRep == head r_reps)
|| r_reps == [VoidRep] )
&& isUnboxedTupleTyCon r_tycon
&& case maybe_r_rep_to_go of
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.
implement_tagToId :: [Name] -> BcM BCInstrList
implement_tagToId names
- = ASSERT(not (null names))
+ = ASSERT( notNull names )
getLabelsBc (length names) `thenBc` \ labels ->
getLabelBc `thenBc` \ label_fail ->
getLabelBc `thenBc` \ label_exit ->
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)
- | npr `elem` [IntRep, WordRep, FloatRep, DoubleRep, CharRep, AddrRep]
+ | npr `elem` [IntRep, WordRep, FloatRep, DoubleRep,
+ CharRep, AddrRep, StablePtrRep]
= approved
| otherwise
- = pprPanic "ByteCodeGen.mkUnpackCode" (ppr npr)
+ = moan64 "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
pushAtom False d p (AnnLit lit)
= case lit of
+ MachLabel fs -> code CodePtrRep
MachWord w -> code WordRep
MachInt i -> code IntRep
MachFloat r -> code FloatRep
pushStr s
= let getMallocvilleAddr
= case s of
- CharStr s i -> returnBc (A# 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
-- at the same time.
let n = I# l
-- CAREFUL! Chars are 32 bits in ghc 4.09+
- in ioToBc (mallocBytes (n+1)) `thenBc` \ (Ptr a#) ->
- recordMallocBc (A# a#) `thenBc_`
+ in ioToBc (mallocBytes (n+1)) `thenBc` \ ptr ->
+ recordMallocBc ptr `thenBc_`
ioToBc (
- do strncpy (Ptr a#) ba (fromIntegral n)
- writeCharOffAddr (A# a#) n '\0'
- return (A# a#)
+ do memcpy ptr ba (fromIntegral n)
+ pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8)
+ return ptr
)
other -> panic "ByteCodeGen.pushAtom.pushStr"
in
= pprPanic "ByteCodeGen.pushAtom"
(pprCoreExpr (deAnnotate (undefined, other)))
-foreign import "strncpy" strncpy :: Ptr a -> ByteArray# -> CInt -> IO ()
+foreign import "memcpy" memcpy :: Ptr a -> ByteArray# -> CInt -> IO ()
-- Given a bunch of alts code and their discrs, do the donkey work
data BcM_State
= BcM_State { bcos :: [ProtoBCO Name], -- accumulates completed BCOs
nextlabel :: Int, -- for generating local labels
- malloced :: [Addr] } -- ptrs malloced for current BCO
+ malloced :: [Ptr ()] } -- ptrs malloced for current BCO
-- Should be free()d when it is GCd
type BcM r = BcM_State -> IO (BcM_State, r)
mapBc f xs `thenBc` \ rs ->
returnBc (r:rs)
-emitBc :: ([Addr] -> ProtoBCO Name) -> BcM ()
+emitBc :: ([Ptr ()] -> ProtoBCO Name) -> BcM ()
emitBc bco st
= return (st{bcos = bco (malloced st) : bcos st, malloced=[]}, ())
newbcoBc :: BcM ()
newbcoBc st
- | not (null (malloced st))
+ | notNull (malloced st)
= panic "ByteCodeGen.newbcoBc: missed prior emitBc?"
| otherwise
= return (st, ())
-recordMallocBc :: Addr -> BcM ()
+recordMallocBc :: Ptr a -> BcM ()
recordMallocBc a st
- = return (st{malloced = a : malloced st}, ())
+ = return (st{malloced = castPtr a : malloced st}, ())
getLabelBc :: BcM Int
getLabelBc st
projects / ghc-hetmet.git / blobdiff