[make foreign imports work with unboxed IO types, improve primitive operators.
John Meacham <john@repetae.net>**20120207105510
 Ignore-this: b43075dce20079f7892e7f0f0c0abb66
] hunk ./lib/base/Foreign/StablePtr.hs 1
-{-# OPTIONS_JHC -fno-prelude -fffi #-}
+{-# OPTIONS_JHC -fno-prelude -fffi -funboxed-tuples #-}
hunk ./lib/base/Foreign/StablePtr.hs 11
-import Jhc.Addr
+import Jhc.Prim.Rts
+import Jhc.IO
+import Jhc.Type.Ptr
hunk ./lib/base/Foreign/StablePtr.hs 15
-import Jhc.Monad
hunk ./lib/base/Foreign/StablePtr.hs 16
-newtype StablePtr a = StablePtr (Ptr ())
-data PlaceHolder
+data StablePtr a
hunk ./lib/base/Foreign/StablePtr.hs 19
-castPtrToStablePtr p = StablePtr p
+castPtrToStablePtr (Ptr (Addr_ p)) = fromBang_ (bangFromRaw p)
hunk ./lib/base/Foreign/StablePtr.hs 22
-castStablePtrToPtr (StablePtr p) = p
-
+castStablePtrToPtr p = Ptr (Addr_ (bangToRaw (toBang_ p)))
hunk ./lib/base/Foreign/StablePtr.hs 25
-freeStablePtr _ = return ()
+freeStablePtr p = c_freeStablePtr (toBang_ p)
hunk ./lib/base/Foreign/StablePtr.hs 27
+-- | newStablePtr will seq its argument to get rid of nasty GC issues and be
+-- compatible with FFI calling conventions, if this is an issue, you can put an
+-- extra box around it.
hunk ./lib/base/Foreign/StablePtr.hs 32
-    ptr <- ref_ptr (unsafeCoerce x)
-    return (StablePtr ptr)
+    fromUIO $ \w -> case c_newStablePtr (toBang_ x) w of
+        (# w', s #) -> (# w', fromBang_ s #)
hunk ./lib/base/Foreign/StablePtr.hs 36
-deRefStablePtr (StablePtr x) = do
-    v <- deref_ptr x
-    return (unsafeCoerce v)
-
-deref_ptr = undefined
-ref_ptr = undefined
-unsafeCoerce = undefined
-
-{-
-
-foreign import primitive deref_ptr :: Ptr () -> IO PlaceHolder
-foreign import primitive ref_ptr   :: PlaceHolder -> IO (Ptr ())
+deRefStablePtr x = do
+    fromUIO $ \w -> case c_derefStablePtr (toBang_ x) w of
+        (# w', s #) -> (# w', fromBang_ s #)
hunk ./lib/base/Foreign/StablePtr.hs 40
-foreign import primitive unsafeCoerce :: a -> b
--}
+foreign import ccall unsafe "rts/stableptr.c c_freeStablePtr"  c_freeStablePtr   :: Bang_ (StablePtr a) -> IO ()
+foreign import ccall unsafe "rts/stableptr.c c_newStablePtr"   c_newStablePtr    :: Bang_ a -> UIO (Bang_ (StablePtr a))
+foreign import ccall unsafe "rts/stableptr.c c_derefStablePtr" c_derefStablePtr :: Bang_ (StablePtr a) -> UIO (Bang_ a)
hunk ./lib/jhc-prim/Jhc/Prim/Rts.hs 6
---data Void
-
hunk ./lib/jhc-prim/Jhc/Prim/Rts.hs 7
--- toBang_ will seq the object if needed.
-data Bang_ a :: #  -- TODO(jwm): should be '!'
-
-foreign import primitive toBang_ :: a -> Bang_ a
-foreign import primitive fromBang_ :: Bang_ a -> a
-foreign import primitive isWHNF :: a -> Bool_
-foreign import primitive isInHeap :: Bang_ a -> Bool_
-foreign import primitive bangBits :: Bang_ a -> BitsPtr_
-foreign import primitive bangPtr  :: Bang_ a -> Addr_
+-- Bang_ is also an FFI-able type that turns into a raw haskell object pointer.
+data Bang_ a :: #
hunk ./lib/jhc-prim/Jhc/Prim/Rts.hs 10
---isWHNF   :: a -> Bool_
---isInHeap :: Bang_ a -> Bool_
---bangBits :: Bang_ a -> BitsPtr_
+-- safe
+foreign import primitive toBang_     :: a -> Bang_ a
+foreign import primitive fromBang_   :: Bang_ a -> a
+-- unwise
+foreign import primitive isWHNF      :: a -> Bool_
+foreign import primitive isInHeap    :: Bang_ a -> Bool_
+foreign import primitive bangPtr     :: Bang_ a -> Addr_
+foreign import primitive bangToRaw   :: Bang_ a -> BitsPtr_
+-- unsafe
+foreign import primitive bangFromRaw :: BitsPtr_ -> Bang_ a
hunk ./rts/slub.c 279
-        sc->pi.flags = FLAG_NONE;
+        sc->pi.flags = 0;
hunk ./src/DataConstructors.hs 380
-extractIO' :: E -> (Bool,E)
-extractIO' e = case extractIO e of
-    Just x -> (True,x)
-    Nothing -> (False,e)
+-- extract IO or an unboxed version of it, (ST, World -> (# Wold, a #))
+extractIO' :: E -> ([E],Bool,E)
+extractIO' e = f e [] where
+    f (ELit LitCons { litName = c, litArgs = [x] }) rs | c == tc_IO  = (reverse rs, True,x)
+    f (ELit LitCons { litName = c, litArgs = [_,x] }) rs | c == tc_ST  = (reverse rs, True,x)
+    f (expandAlias -> Just t) rs = f t rs
+    f (fromPi -> (fromUnboxedTuple -> Just [s',x],[getType -> s''])) rs
+        | isState_ s' && isState_ s'' = (reverse rs, True,x)
+    f (EPi v e) rs = f e (getType v:rs)
+    f e rs = (reverse rs, False,e)
+--    f (fromPi -> (getType -> s',[getType -> s''])) | isState_ s' && isState_ s'' = (True,tUnit)
hunk ./src/DataConstructors.hs 426
+expandAlias :: Monad m => E -> m E
+expandAlias (ELit LitCons { litAliasFor = Just af, litArgs = as }) = return (foldl eAp af as)
+expandAlias  _ = fail "expandAlias: not alias"
+
hunk ./src/DataConstructors.hs 888
-    (rt_float128,  "__float128")
+    (rt_float128,  "__float128"),
+    (tc_Bang_,     "wptr_t")
hunk ./src/DataConstructors.hs 938
-
hunk ./src/DataConstructors.hs 944
-    (tc_State_,   "void")
+    (tc_State_,   "void"),
+    (tc_Bang_,    "wptr_t")  -- internal rts type
hunk ./src/E/FromHs.hs 241
-createFunc :: UniqueProducer m => DataTable -> [E] -> ([TVr] -> (E -> E,E)) -> m E
+createFunc :: Monad t =>  DataTable -> [E] -> ([TVr] -> (E -> E,E)) -> Ce t E
hunk ./src/E/FromHs.hs 366
-        nds <- mapM cDecl hsDecls
+        nds <- mapM cDecl' hsDecls
hunk ./src/E/FromHs.hs 403
-        let (ts,rt) = argTypes' ty
-            (isIO,rt') =  extractIO' rt
+        let --(ts,rt) = argTypes' ty
+          --  (isIO,rt') =  extractIO' rt
+            (ts,isIO,rt') = extractIO' ty
hunk ./src/E/FromHs.hs 444
-                    True -> cFun $ \rs -> (,) (ELam tvrWorld) $
-                                eCaseTup' (prim True (EVar tvrWorld:[EVar t | t <- rs ]) rttIO')
-                                          [tvrWorld2,rtVar]
-                                          (eJustIO (EVar tvrWorld2) (EVar rtVar))
+                    True -> cFun $ \rs -> (,) (ELam tvrWorld) $ (prim True (EVar tvrWorld:[EVar t | t <- rs ]) rttIO')
+                                --eCaseTup' (prim True (EVar tvrWorld:[EVar t | t <- rs ]) rttIO')
+                                --          [tvrWorld2,rtVar]
+                                --          (eJustIO (EVar tvrWorld2) (EVar rtVar))
hunk ./src/E/FromHs.hs 449
-    cDecl :: Monad m => HsDecl -> Ce m [(Name,TVr,E)]
+    cDecl,cDecl' :: Monad m => HsDecl -> Ce m [(Name,TVr,E)]
+    cDecl' d = withSrcLoc (srcLoc d) $ cDecl d
hunk ./src/E/FromHs.hs 498
-        let (ts,rt) = argTypes' ty
-            (isIO,rt') = extractIO' rt
+        let --(ts,rt) = argTypes' ty
+            --(isIO,rt') = extractIO' rt
+            (ts,isIO,rt') = extractIO' ty
hunk ./src/E/FromHs.hs 530
-        let (argTys,retTy') = argTypes' ty
-            (isIO,retTy) = extractIO' retTy'
+        let --(argTys,retTy') = argTypes' ty
+            --(isIO,retTy) = extractIO' retTy'
+            (argTys,isIO,retTy) = extractIO' ty
hunk ./src/E/Show.hs 159
-      tc_Char_,    dc_Boolzh,  dc_Char,    dc_Int,     dc_Integer, dc_Word ]
+      tc_Char_,    dc_Boolzh,  dc_Char,    dc_Int,     dc_Integer, dc_Word,
+      tc_ST,       tc_Bang_]
hunk ./src/Grin/FromE.hs 429
-            return $ gEval x
+            return $ if getType x == tyDNode then Return [x] else gEval x
hunk ./src/Grin/FromE.hs 431
-            return (BaseOp Demote $ args [x])
+            return $ Return (args [x]) -- (BaseOp Demote $ args [x])
hunk ./src/Grin/FromE.hs 571
+    cc (EPrim (APrim (PrimPrim "fromBang_") _) (args -> [e]) _) = return $ if getType e == tyDNode then demote e else Return [e] -- $ demote e
+--        e <- ce e
+--        return $ e :>>= [v] :-> demote v
hunk ./src/Grin/Main.hs 94
-    let extraCFiles = ["-I" ++ tdir ++ "/cbits" ] ++ [ tdir FP.</> "cbits" FP.</> fn | fn@(reverse -> 'c':'.':_) <- ds ] 
+    let extraCFiles = ["-I" ++ tdir ++ "/cbits" ] ++ [ tdir FP.</> "cbits" FP.</> fn | fn@(reverse -> 'c':'.':_) <- ds ]
hunk ./src/data/names.txt 12
+ST         Jhc.Prim.IO.ST