projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
More on monad-comp; an intermediate state, so don't pull
[ghc-hetmet.git]
/
compiler
/
cmm
/
CmmCallConv.hs
diff --git
a/compiler/cmm/CmmCallConv.hs
b/compiler/cmm/CmmCallConv.hs
index
3fb347f
..
e7d0acc
100644
(file)
--- a/
compiler/cmm/CmmCallConv.hs
+++ b/
compiler/cmm/CmmCallConv.hs
@@
-8,9
+8,10
@@
module CmmCallConv (
#include "HsVersions.h"
#include "HsVersions.h"
-import Cmm
+import CmmExpr
import SMRep
import SMRep
-import ZipCfgCmmRep (Convention(..))
+import Cmm (Convention(..))
+import PprCmm ()
import Constants
import qualified Data.List as L
import Constants
import qualified Data.List as L
@@
-46,7
+47,8
@@
assignArgumentsPos conv arg_ty reps = assignments
(_, NativeDirectCall) -> getRegsWithoutNode
([_], NativeReturn) -> allRegs
(_, NativeReturn) -> getRegsWithNode
(_, NativeDirectCall) -> getRegsWithoutNode
([_], NativeReturn) -> allRegs
(_, NativeReturn) -> getRegsWithNode
- (_, GC) -> getRegsWithNode
+ -- GC calling convention *must* put values in registers
+ (_, GC) -> allRegs
(_, PrimOpCall) -> allRegs
([_], PrimOpReturn) -> allRegs
(_, PrimOpReturn) -> getRegsWithNode
(_, PrimOpCall) -> allRegs
([_], PrimOpReturn) -> allRegs
(_, PrimOpReturn) -> getRegsWithNode
@@
-60,6
+62,7
@@
assignArgumentsPos conv arg_ty reps = assignments
(reg_assts, stk_args) = assign_regs [] reps regs
stk_args' = case conv of NativeReturn -> part
PrimOpReturn -> part
(reg_assts, stk_args) = assign_regs [] reps regs
stk_args' = case conv of NativeReturn -> part
PrimOpReturn -> part
+ GC | length stk_args /= 0 -> panic "Failed to allocate registers for GC call"
_ -> stk_args
where part = uncurry (++)
(L.partition (not . isGcPtrType . arg_ty) stk_args)
_ -> stk_args
where part = uncurry (++)
(L.partition (not . isGcPtrType . arg_ty) stk_args)