Allow for stg registers to have pointer type in llvm BE.

Before all the stg registers were simply a bit type or
floating point type but now they can be declared to have
a pointer type to one of these. This will allow various
optimisations in the future in llvm since the type is
more accurate.

diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs
index 9afb76e..2227fb6 100644 (file)
--- a/compiler/llvmGen/Llvm/PpLlvm.hs
+++ b/compiler/llvmGen/Llvm/PpLlvm.hs
@@ -230,9 +230,12 @@ ppCmpOp op left right =
   let cmpOp
         | isInt (getVarType left) && isInt (getVarType right) = text "icmp"
         | isFloat (getVarType left) && isFloat (getVarType right) = text "fcmp"
+        | otherwise = text "icmp" -- Just continue as its much easier to debug
+        {-
         | otherwise = error ("can't compare different types, left = "
                 ++ (show $ getVarType left) ++ ", right = "
                 ++ (show $ getVarType right))
+        -}
   in cmpOp <+> texts op <+> texts (getVarType left)
         <+> (text $ getName left) <> comma <+> (text $ getName right)
 

diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index c945f97..41bc8ee 100644 (file)
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -26,6 +26,8 @@ import UniqSupply
 import Unique
 import Util
 
+import Control.Monad ( liftM )
+
 type LlvmStatements = OrdList LlvmStatement
 
 -- -----------------------------------------------------------------------------
@@ -61,7 +63,8 @@ basicBlocksCodeGen env ([]) (blocks, tops)
   = do let (blocks', allocs) = mapAndUnzip dominateAllocs blocks
        let allocs' = concat allocs
        let ((BasicBlock id fstmts):rblocks) = blocks'
-       let fblocks = (BasicBlock id (funPrologue ++ allocs' ++ fstmts)):rblocks
+       fplog <- funPrologue
+       let fblocks = (BasicBlock id (fplog ++  allocs' ++ fstmts)):rblocks
        return (env, fblocks, tops)
 
 basicBlocksCodeGen env (block:blocks) (lblocks', ltops')
@@ -432,16 +435,24 @@ genStore :: LlvmEnv -> CmmExpr -> CmmExpr -> UniqSM StmtData
 genStore env addr val = do
     (env1, vaddr, stmts1, top1) <- exprToVar env addr
     (env2, vval,  stmts2, top2) <- exprToVar env1 val
-    if getVarType vaddr == llvmWord
-        then do
+    case getVarType vaddr of
+        LMPointer _ -> do
+            let s1 = Store vval vaddr
+            return (env2, stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2)
+
+        i@(LMInt _) | i == llvmWord -> do
             let vty = pLift $ getVarType vval
             (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty
             let s2 = Store vval vptr
             return (env2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2,
                     top1 ++ top2)
 
-        else
-            panic $ "genStore: ptr not of word size! (" ++ show vaddr ++ ")"
+        other ->
+            pprPanic "genStore: ptr not right type!"
+                    (PprCmm.pprExpr addr <+> text (
+                        "Size of Ptr: " ++ show llvmPtrBits ++
+                        ", Size of var: " ++ show (llvmWidthInBits other) ++
+                        ", Var: " ++ show vaddr))
 
 
 -- | Unconditional branch
@@ -752,25 +763,23 @@ genMachOp _ _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!"
 genCmmLoad :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData
 genCmmLoad env e ty = do
     (env', iptr, stmts, tops) <- exprToVar env e
-    let ety = getVarType iptr
-    case (isInt ety) of
-         True | llvmPtrBits == llvmWidthInBits ety ->  do
+    case getVarType iptr of
+         LMPointer _ -> do
+                    (dvar, load) <- doExpr (cmmToLlvmType ty) $ Load iptr
+                    return (env', dvar, stmts `snocOL` load, tops)
+
+         i@(LMInt _) | i == llvmWord -> do
                     let pty = LMPointer $ cmmToLlvmType ty
                     (ptr, cast)  <- doExpr pty $ Cast LM_Inttoptr iptr pty
                     (dvar, load) <- doExpr (cmmToLlvmType ty) $ Load ptr
                     return (env', dvar, stmts `snocOL` cast `snocOL` load, tops)
 
-              | otherwise
-                -> pprPanic
-                        ("exprToVar: can't cast to pointer as int not of "
-                            ++ "pointer size!")
+         other -> pprPanic "exprToVar: CmmLoad expression is not right type!"
                         (PprCmm.pprExpr e <+> text (
                             "Size of Ptr: " ++ show llvmPtrBits ++
-                            ", Size of var: " ++ show (llvmWidthInBits ety) ++
+                            ", Size of var: " ++ show (llvmWidthInBits other) ++
                             ", Var: " ++ show iptr))
 
-         False -> panic "exprToVar: CmmLoad expression is not of type int!"
-
 
 -- | Handle CmmReg expression
 --
@@ -867,23 +876,35 @@ genLit _ CmmHighStackMark
 --
 
 -- | Function prologue. Load STG arguments into variables for function.
-funPrologue :: [LlvmStatement]
-funPrologue = concat $ map getReg activeStgRegs
+funPrologue :: UniqSM [LlvmStatement]
+funPrologue = liftM concat $ mapM getReg activeStgRegs
     where getReg rr =
             let reg = lmGlobalRegVar rr
                 arg = lmGlobalRegArg rr
                 alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1
-                store = Store arg reg
-            in [alloc, store]
+            in if (isPointer . getVarType) arg
+                  then do
+                      (v, c) <- doExpr llvmWord (Cast LM_Ptrtoint arg llvmWord)
+                      let store = Store v reg
+                      return [alloc, c, store]
+                  else do
+                      let store = Store arg reg
+                      return [alloc, store]
 
 
 -- | Function epilogue. Load STG variables to use as argument for call.
 funEpilogue :: UniqSM ([LlvmVar], LlvmStatements)
 funEpilogue = do
     let loadExpr r = do
-        (v,s) <- doExpr (pLower $ getVarType r) $ Load r
-        return (v, unitOL s)
-    loads <- mapM (loadExpr . lmGlobalRegVar) activeStgRegs
+        let reg = lmGlobalRegVar r
+        let arg = lmGlobalRegArg r
+        (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg
+        case (isPointer . getVarType) arg of
+             True  -> do
+                 (v2, s2) <- doExpr llvmWordPtr $ Cast LM_Inttoptr v llvmWordPtr
+                 return (v2, unitOL s `snocOL` s2)
+             False -> return (v, unitOL s)
+    loads <- mapM loadExpr activeStgRegs
     let (vars, stmts) = unzip loads
     return (vars, concatOL stmts)
 

diff --git a/compiler/llvmGen/LlvmCodeGen/Regs.hs b/compiler/llvmGen/LlvmCodeGen/Regs.hs
index b731a86..cc961cc 100644 (file)
--- a/compiler/llvmGen/LlvmCodeGen/Regs.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Regs.hs
@@ -1,5 +1,4 @@
--- ----------------------------------------------------------------------------
--- | Deal with Cmm registers
+-- ---------------------------------------------------------------------------- -- | Deal with Cmm registers
 --
 
 module LlvmCodeGen.Regs (
@@ -16,11 +15,15 @@ import FastString
 
 -- | Get the LlvmVar function variable storing the real register
 lmGlobalRegVar :: GlobalReg -> LlvmVar
-lmGlobalRegVar = lmGlobalReg "_Var"
+lmGlobalRegVar reg 
+  = let reg' = lmGlobalReg "_Var" reg
+    in if (isPointer . getVarType) reg'
+          then reg'
+          else pVarLift reg'
 
 -- | Get the LlvmVar function argument storing the real register
 lmGlobalRegArg :: GlobalReg -> LlvmVar
-lmGlobalRegArg = (pVarLower . lmGlobalReg "_Arg")
+lmGlobalRegArg = lmGlobalReg "_Arg"
 
 {- Need to make sure the names here can't conflict with the unique generated
    names. Uniques generated names containing only base62 chars. So using say
@@ -29,9 +32,9 @@ lmGlobalRegArg = (pVarLower . lmGlobalReg "_Arg")
 lmGlobalReg :: String -> GlobalReg -> LlvmVar
 lmGlobalReg suf reg
   = case reg of
-        BaseReg        -> wordGlobal $ "Base" ++ suf
-        Sp             -> wordGlobal $ "Sp" ++ suf
-        Hp             -> wordGlobal $ "Hp" ++ suf
+        BaseReg        -> ptrGlobal $ "Base" ++ suf
+        Sp             -> ptrGlobal $ "Sp" ++ suf
+        Hp             -> ptrGlobal $ "Hp" ++ suf
         VanillaReg 1 _ -> wordGlobal $ "R1" ++ suf
         VanillaReg 2 _ -> wordGlobal $ "R2" ++ suf
         VanillaReg 3 _ -> wordGlobal $ "R3" ++ suf
@@ -48,7 +51,8 @@ lmGlobalReg suf reg
         _other         -> panic $ "LlvmCodeGen.Reg: GlobalReg (" ++ (show reg)
                                 ++ ") not supported!"
     where
-        wordGlobal   name = LMNLocalVar (fsLit name) llvmWordPtr
-        floatGlobal  name = LMNLocalVar (fsLit name) $ pLift LMFloat
-        doubleGlobal name = LMNLocalVar (fsLit name) $ pLift LMDouble
+        wordGlobal   name = LMNLocalVar (fsLit name) llvmWord
+        ptrGlobal    name = LMNLocalVar (fsLit name) llvmWordPtr
+        floatGlobal  name = LMNLocalVar (fsLit name) LMFloat
+        doubleGlobal name = LMNLocalVar (fsLit name) LMDouble