[completely redo IORef support, add support for both grin and ghc backends to use new support. allow C code generation to deal with pointers to pointers properly
John Meacham <john@repetae.net>**20061116040742] addfile ./regress/tests/1_io/basic/IORef.expected.stdout
addfile ./regress/tests/1_io/basic/IORef.hs
hunk ./C/FromGrin.hs 52
+ppnode_t = ptrType (ptrType node_t)
hunk ./C/FromGrin.hs 118
-convertExp (Fetch v) = do
+convertExp (Fetch v) | getType v == TyPtr TyNode = do
hunk ./C/FromGrin.hs 121
+convertExp (Fetch v) | getType v == TyPtr (TyPtr TyNode) = do
+    v <- convertVal v
+    return (mempty,dereference v)
hunk ./C/FromGrin.hs 128
-convertExp (Store n@Var {}) = do
+
+convertExp (Store n@Var {}) | getType n == TyNode = do
hunk ./C/FromGrin.hs 136
+convertExp (Store v) | TyPtr TyNode == getType v = do
+    v <- convertVal v
+    tmp <- newVar ppnode_t
+    return ((tmp `assign` jhc_malloc (sizeof pnode_t)) `mappend` (dereference tmp `assign` v),tmp)
hunk ./C/FromGrin.hs 147
-convertExp (Update v@Var {} (NodeC t as)) = do
+convertExp e@(Update v z) | getType v /= TyPtr (getType z) = do
+    return (err (show e),err "nothing")
+convertExp (Update v@Var {} (NodeC t as)) | getType v == TyPtr TyNode = do
hunk ./C/FromGrin.hs 157
-convertExp (Update v@Var {} (NodeV t [])) = do
+convertExp (Update v@Var {} (NodeV t [])) | getType v == TyPtr TyNode = do
hunk ./C/FromGrin.hs 162
-
-convertExp (Update v z) = do  -- TODO eliminate unknown updates
+convertExp (Update v z) | getType z == TyPtr TyNode = do
+    v' <- convertVal v
+    z' <- convertVal z
+    let tag = project' anyTag z'
+    return $ (dereference v' `assign` z',emptyExpression)
+convertExp (Update v z) | getType z == TyNode = do  -- TODO eliminate unknown updates
hunk ./C/FromGrin.hs 177
+convertType (TyPtr (TyPtr TyNode)) = return ppnode_t
hunk ./C/FromGrin.hs 282
+
hunk ./E/ToHs.hs 121
-    builtIns = [tc_Int,tc_Char,dc_Int,dc_Char,rt_int,rt_HsChar,tc_World__,tc_Array__,tc_MutArray__,rt_HsPtr]
+    builtIns = [tc_Int,tc_Char,dc_Int,dc_Char,rt_int,rt_HsChar,tc_World__,tc_Array__,tc_MutArray__,tc_Ref__,rt_HsPtr]
hunk ./E/ToHs.hs 160
+showCon c [a] | c == tc_Ref__ = parens $ text "Ref__" <+> a
hunk ./E/ToHs.hs 294
-    ("newRef__","newMVar#"),
+    ("newRef__","newMutVar#"),
hunk ./Grin/FromE.hs 72
+unboxedMap :: [(Name,Maybe Ty)]
+unboxedMap = [
+    (tc_World__,Nothing),
+    (tc_Ref__,Just $ TyPtr (TyPtr TyNode)),
+    (tc_Array__,Just $ TyPtr (TyPtr TyNode)),
+    (tc_MutArray__,Just $ TyPtr (TyPtr TyNode))
+    ]
+
hunk ./Grin/FromE.hs 99
-tagRef = toAtom "CData.IORef.Ref"
hunk ./Grin/FromE.hs 131
-    toty e | e == tWorld__ = TyTup []
+    --toty e | e == tWorld__ = TyTup []
hunk ./Grin/FromE.hs 133
-    toty (ELit LitCons { litName = n, litArgs = [], litType = es }) |  es == eHash, RawType <- nameType n = (Ty $ toAtom (show n))
+    toty (ELit LitCons { litName = n, litArgs = [], litType = ty }) |  ty == eHash, RawType <- nameType n = (Ty $ toAtom (show n))
+    toty e@(ELit LitCons { litName = n, litType = ty }) |  ty == eHash = case lookup n unboxedMap of
+        Just Nothing -> TyTup []
+        Just (Just x) -> x
+        Nothing -> error $ "Grin.FromE.toType: " ++ show e
hunk ./Grin/FromE.hs 244
-shouldKeep e | e == unboxedTyUnit = False
-shouldKeep e = e /= tWorld__
+shouldKeep e = tyUnit /= toType TyNode e
+--shouldKeep e | e == unboxedTyUnit = False
+--shouldKeep e = e /= tWorld__
hunk ./Grin/FromE.hs 311
-    toVal (TVr { tvrIdent = num, tvrType = w}) | w == tWorld__ = Tup []-- Var v0 tyUnit -- es == eHash, RawType <- nameType n  = Var (V num) (Ty $ toAtom (show n))
-    toVal (TVr { tvrIdent = num, tvrType = (ELit LitCons { litName = n, litArgs = [], litType = es })}) | es == eHash, RawType <- nameType n  = Var (V num) (Ty $ toAtom (show n))
-    toVal tvr = Var  (V (tvrIdent tvr)) (TyPtr TyNode) -- (toTy $ tvrType tvr)
+    toVal TVr { tvrType = ty, tvrIdent = num } = case toType (TyPtr TyNode) ty of
+        TyTup [] -> Tup []
+        ty -> Var (V num) ty
+--    toVal (TVr { tvrIdent = num, tvrType = w}) | w == tWorld__ = Tup []-- Var v0 tyUnit -- es == eHash, RawType <- nameType n  = Var (V num) (Ty $ toAtom (show n))
+--    toVal (TVr { tvrIdent = num, tvrType = (ELit LitCons { litName = n, litArgs = [], litType = es })}) | es == eHash, RawType <- nameType n  = Var (V num) (Ty $ toAtom (show n))
+--    toVal tvr = Var  (V (tvrIdent tvr)) (TyPtr TyNode) -- (toTy $ tvrType tvr)
hunk ./Grin/FromE.hs 402
+        --    var = Var v2 (TyPtr TyNode)
+        return $ Store v' -- (NodeC (convertName dc_Ref) [v']) :>>= var :-> Store (NodeC (convertName dc_IORef) [var])
+    ce (EPrim ap@(APrim (PrimPrim "readRef__") _) [r,_] _) = do
+        let [r'] = args [r]
+        return $ Fetch r' -- gEval r' :>>= NodeC (convertName dc_IORef) [var] :-> Fetch var :>>= NodeC (convertName dc_Ref) [var'] :-> Return var'
+    ce (EPrim ap@(APrim (PrimPrim "writeRef__") _) [r,v,_] _) = do
+        let [r',v'] = args [r,v]
+        return $ Update r' v' -- gEval r' :>>= NodeC (convertName dc_IORef) [var] :-> Update var (NodeC (convertName dc_Ref) [v'])
+    {-
+    ce (EPrim ap@(APrim (PrimPrim "newRef__") _) [v,_] _) = do
+        let [v'] = args [v]
hunk ./Grin/FromE.hs 425
+        -}
hunk ./Grin/FromE.hs 462
-    ce ECase { eCaseScrutinee = e, eCaseAlts = [], eCaseDefault = (Just r)} | getType e == tWorld__ = do
+    ce ECase { eCaseScrutinee = e, eCaseAlts = [], eCaseDefault = (Just r)} | not (shouldKeep (getType e)) = do
hunk ./Grin/Noodle.hs 99
-isMutableNodeTag t = t ==  convertName dc_Ref
+isMutableNodeTag _ = False
+--isMutableNodeTag t = t ==  convertName dc_Ref
hunk ./Grin/Noodle.hs 102
-valIsMutable (NodeC t _) = isMutableNodeTag t
-valIsMutable _ = False
+valIsMutable (NodeC t _) = isMutableNodeTag t || t == tagHole
+valIsMutable NodeC {} = False
+valIsMutable _ = True
hunk ./Grin/Noodle.hs 110
+isOmittable (Store x) | getType x /= TyNode = False
hunk ./Grin/Show.hs 114
+{-# NOINLINE prettyVal #-}
hunk ./Grin/Show.hs 124
-    | TyPtr _ <- t = char 'p' <> tshow i
+    | TyPtr t <- t = char 'p' <> prettyVal (Var (V i) t)
hunk ./Name/Names.hs 67
-dc_IORef = toName DataConstructor ("Data.IORef","IORef")
-dc_Ref = toName DataConstructor ("Data.IORef","Ref")
hunk ./Name/Names.hs 81
+tc_Ref__ = toName TypeConstructor ("Data.IORef","Ref__")
hunk ./data/ViaGhc.hs 12
+type Ref__ a = MutVar# RealWorld a
hunk ./lib/base/Data/IORef.hs 1
-{-# OPTIONS_JHC -N #-}
+{-# OPTIONS_JHC -N -funboxed-tuples #-}
hunk ./lib/base/Data/IORef.hs 14
+import Jhc.Int
hunk ./lib/base/Data/IORef.hs 16
-data IORef a = IORef (Ref a)
-data Ref a = Ref a
+data IORef a = IORef (Ref__ a)
+data Ref__ a :: #
hunk ./lib/base/Data/IORef.hs 20
-foreign import primitive newRef__   :: a -> World__ -> (# World__, IORef a #)
-foreign import primitive readRef__  :: IORef a -> World__ -> (# World__, a #)
-foreign import primitive writeRef__ :: IORef a -> a -> World__ -> World__
+foreign import primitive newRef__   :: a -> UIO (Ref__ a)
+foreign import primitive readRef__  :: Ref__ a -> UIO a
+foreign import primitive writeRef__ :: Ref__ a -> a -> UIO_
hunk ./lib/base/Data/IORef.hs 24
-{-# NOINLINE newIORef #-}
+-- {-# NOINLINE newIORef #-}
hunk ./lib/base/Data/IORef.hs 26
-newIORef v = IO $ \w -> newRef__ v w
+newIORef v = IO $ \w -> case newRef__ v w of (# w', r #) -> (# w', IORef r #)
hunk ./lib/base/Data/IORef.hs 29
-{-# NOINLINE readIORef #-}
+-- {-# NOINLINE readIORef #-}
hunk ./lib/base/Data/IORef.hs 31
-readIORef r = IO $ \w -> readRef__ r w
+readIORef (IORef r) = IO $ \w -> readRef__ r w
hunk ./lib/base/Data/IORef.hs 33
-{-# NOINLINE writeIORef #-}
+-- {-# NOINLINE writeIORef #-}
hunk ./lib/base/Data/IORef.hs 35
-writeIORef r v = IO $ \w -> case writeRef__ r v w of w' -> (# w', () #)
+writeIORef (IORef r) v = IO $ \w -> case writeRef__ r v w of w' -> (# w', () #)
hunk ./lib/base/Data/IORef.hs 37
-foreign import primitive eqRef__ :: IORef a -> IORef a -> Bool
+foreign import primitive eqRef__ :: Ref__ a -> Ref__ a -> Bool
hunk ./lib/base/Data/IORef.hs 40
-    x == y = eqRef__ x y
-    x /= y = not (eqRef__ x y)
+    (IORef x) == (IORef y) = eqRef__ x y
hunk ./lib/base/Data/IORef.hs 43
-{-# NOINLINE modifyIORef #-}
+--{-# NOINLINE modifyIORef #-}
hunk ./lib/base/Data/IORef.hs 45
-modifyIORef ref f = IO $ \w -> case readRef__ ref w of
+modifyIORef (IORef ref) f = IO $ \w -> case readRef__ ref w of
hunk ./lib/base/Data/IORef.hs 49
-{-# NOINLINE atomicModifyIORef #-}
+--{-# NOINLINE atomicModifyIORef #-}
hunk ./lib/base/Data/IORef.hs 51
-atomicModifyIORef r f = IO $ \w -> case readRef__ r w of
+atomicModifyIORef (IORef r) f = IO $ \w -> case readRef__ r w of
hunk ./regress/tests/1_io/basic/IORef.expected.stdout 1
+xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
hunk ./regress/tests/1_io/basic/IORef.hs 1
+
+
+
+import Data.IORef
+
+fact :: Int -> IO Int
+fact n = do
+    ref <- newIORef 1
+    let f 1 = return ()
+        f n = modifyIORef ref (n*) >> f (n - 1)
+    f n
+    readIORef ref
+
+
+main = do
+    r <- fact 5
+    putStrLn (replicate r 'x')
+