[when compiling via ghc, import foreign functions in boxed form, add more primitives, make it choose the ghc representation of various primitives in a smarter way.
John Meacham <john@repetae.net>**20061206061333] hunk ./C/Arch.hs 2
-module C.Arch(determineArch) where
+module C.Arch(determineArch,primitiveInfo) where
hunk ./C/Arch.hs 24
+import qualified Data.Map as Map
+import System.IO.Unsafe
hunk ./C/Arch.hs 57
+primitiveInfo :: Monad m => ExtType -> m PrimType
+primitiveInfo et = Map.lookup et primMap
+
+
+
+primMap :: Map.Map ExtType PrimType
+primMap = Map.fromList [ (primTypeName a,a) | a <- as ] where
+    (_,_,as,_) = unsafePerformIO determineArch
+
hunk ./C/Arch.hs 88
-    print available_archs
-    print (fn,mp,opt)
+    return (backendGhc,fn,mp,opt)
hunk ./E/ToHs.hs 8
-import Text.PrettyPrint.HughesPJ
+import Text.PrettyPrint.HughesPJ(render,($$),nest,Doc())
hunk ./E/ToHs.hs 13
+import C.Arch
hunk ./E/ToHs.hs 16
+import Doc.DocLike
hunk ./E/ToHs.hs 40
-
hunk ./E/ToHs.hs 62
-showCType "wchar_t" = "Char#"
-showCType "HsChar" = "Char#"
-showCType "HsPtr" =  "Addr#"
-showCType "HsFunPtr" =  "Addr#"
-showCType _ =  "Int#"
+cTypeInfoT (ELit LitCons { litName = n }) | (RawType,t) <- fromName n = cTypeInfo t
+
+cTypeInfo "wchar_t" = ("Char#","C#","Char")
+cTypeInfo "HsChar" = ("Char#","C#","Char")
+cTypeInfo "HsPtr" =  ("Addr#","Ptr","Ptr ()")
+cTypeInfo "HsFunPtr" =  ("Addr#","Ptr","Ptr ()")
+cTypeInfo n = (if primTypeIsSigned pi then "Int#" else "Word#",v,i) where
+        (v,i) = if primTypeIsSigned pi then ('I':nn ++ "#","Int" ++ nn) else ('W':nn ++ "#","Word" ++ nn)
+        nn = show $ primTypeSizeOf pi * 8
+        Just pi = primitiveInfo n
+
+showCType n = fst3 $ cTypeInfo n
hunk ./E/ToHs.hs 85
+fst3 (x,_,_) = x
+
hunk ./E/ToHs.hs 91
-    f furc@Func { funcName = fn, funcIOLike = True, primArgTypes = as, primRetType = "void" } = ans where
-        ans = text $ "foreign import ccall unsafe \"" ++ fn ++ "\" " ++ cfuncname furc ++ " :: " ++ concatInter " -> " ("World__":map showCType as ++ ["World__"])
-    f furc@Func { funcName = fn, funcIOLike = False, primArgTypes = as, primRetType = rt } = ans where
-        ans = text $ "foreign import ccall unsafe \"" ++ fn ++ "\" " ++ cfuncname furc ++ " :: " ++ concatInter " -> " (map showCType (as ++ [rt]))
-    f furc@Func { funcName = fn, funcIOLike = True, primArgTypes = as, primRetType = rt } = ans where
-        ans = text $ "foreign import ccall unsafe \"" ++ fn ++ "\" " ++ cfuncname furc ++ " :: " ++ concatInter " -> " ("World__":(map showCType as ++ ["(# World__, " ++ showCType rt ++ " #)"]))
+    f furc@Func { funcName = fn, funcIOLike = True, primArgTypes = as, primRetType = "void" } = ans <$> ans' where
+        ans  = text $ "foreign import ccall unsafe \"" ++ fn ++ "\" " ++ '_':cfuncname furc ++ " :: " ++ concatInter " -> " (map (snd . snd) vals ++ ["IO ()"])
+        ans' = text $ cfuncname furc <+> "w" <+> unwords (fsts vals) <+> " = case _" ++ cfuncname furc <+> concatInter " " [ parens (c <+> a) | (a,(c,_)) <- vals ] <+> "of IO f -> case f w of (# w, _ #) -> w"
+        vals = [ ('a':show n,ioInfo a) | a <- as | n <- naturals ]
+    f furc@Func { funcName = fn, funcIOLike = True, primArgTypes = as, primRetType = rt' } = ans <$> ans' where
+        ans  = text $ "foreign import ccall unsafe \"" ++ fn ++ "\" " ++ '_':cfuncname furc ++ " :: " ++ concatInter " -> " (map (snd . snd) vals ++ ["IO " ++ rt])
+        ans' = text $ cfuncname furc <+> "w" <+> unwords (fsts vals) <+> " = case _" ++ cfuncname furc <+> concatInter " " [ parens (c <+> a) | (a,(c,_)) <- vals ] <+> "of IO f -> case f w of (# w, " ++ rc ++ " r #) -> (# w, r #)"
+        vals = [ ('a':show n,ioInfo a) | a <- as | n <- naturals ]
+        (rc,rt) = ioInfo rt'
+    f furc@Func { funcName = fn, funcIOLike = False, primArgTypes = as, primRetType = rt' } = ans <$> ans' where
+        ans  = text $ "foreign import ccall unsafe \"" ++ fn ++ "\" " ++ '_':cfuncname furc ++ " :: " ++ concatInter " -> " (map (snd . snd) vals ++ [rt])
+        ans' = text $ cfuncname furc <+> unwords (fsts vals) <+> " = case _" ++ cfuncname furc <+> concatInter " " [ parens (c <+> a) | (a,(c,_)) <- vals ] <+> "of " ++ rc ++ " r -> r"
+        vals = [ ('a':show n,ioInfo a) | a <- as | n <- naturals ]
+        (rc,rt) = ioInfo rt'
+--    f furc@Func { funcName = fn, funcIOLike = False, primArgTypes = as, primRetType = rt } = ans where
+--       ans = text $ "foreign import ccall unsafe \"" ++ fn ++ "\" " ++ cfuncname furc ++ " :: " ++ concatInter " -> " (map showCType (as ++ [rt]))
+--    f furc@Func { funcName = fn, funcIOLike = True, primArgTypes = as, primRetType = rt } = ans where
+--        ans = text $ "foreign import ccall unsafe \"" ++ fn ++ "\" " ++ cfuncname furc ++ " :: " ++ concatInter " -> " ("World__":(map showCType as ++ ["(# World__, " ++ showCType rt ++ " #)"]))
hunk ./E/ToHs.hs 110
+    ioInfo n = (x,y) where
+        (_,x,y) = cTypeInfo n
hunk ./E/ToHs.hs 175
-tshow x = text (show x)
-
hunk ./E/ToHs.hs 220
-transE (ELit (LitInt num t)) | t == tCharzh || t == rawType "wchar_t" = return $ text (show $ chr $ fromIntegral num) <> text "#"
-transE (ELit (LitInt num _)) | num < 0 = mparen $ return $ text (show num) <> text "#"
-transE (ELit (LitInt num _)) = return $ text (show num) <> text "#"
+transE (ELit (LitInt num t)) = case cTypeInfoT t of
+    ("Char#",_,_) -> return $ text (show $ chr $ fromIntegral num) <> text "#"
+    ("Int#",_,_)  | num < 0 -> mparen $ return $ text (show num) <> text "#"
+                  | otherwise -> return $ text (show num) <> text "#"
+    ("Addr#",_,_) | num == 0 -> return $ text "nullAddr#"
+    ("Word#",_,_) -> mparen $ text "int2Word# (" <> tshow num <> text "# )"
hunk ./E/ToHs.hs 310
-    ("Word#","Int#") -> return (text "addr2Int#" <+> x)
+    ("Word#","Int#") -> return (text "word2Int#" <+> x)
hunk ./E/ToHs.hs 312
+    ("Char#","Word#") -> return (text "char2Word__" <+> x)
+    ("Word#","Char#") -> return (text "word2Char__" <+> x)
+    xs -> fail $ "unknown coercion: " ++ show xs
hunk ./E/ToHs.hs 334
-cfuncname Func { funcName = fn, funcIOLike = iol, primArgTypes = as, primRetType = r  } =  ("func_" ++ (if iol then "io" else "pure") ++ "_" ++ fn ++ concatInter "_" (r:as))
+cfuncname Func { funcName = fn, funcIOLike = iol, primArgTypes = as, primRetType = r  } =  text $ ("func_" ++ (if iol then "io" else "pure") ++ "_" ++ fn ++ concatInter "_" (r:as))
hunk ./E/ToHs.hs 341
-    table = [ ("Int#",intTable)]
+    table = [ ("Int#",intTable),("Word#",wordTable)]
hunk ./E/ToHs.hs 349
+    wordTable = [
+        ("+","plusWord#"),
+        ("-","minusWord#"),
+        ("*","timesWord#"),
+        ("%","remWord#"),
+        ("/","quotWord#")
+        ]
hunk ./E/ToHs.hs 358
-    table = [ ("Int#",intTable), ("Char#",charTable)]
+    table = [ ("Int#",intTable), ("Char#",charTable), ("Addr#",addrTable),("Word#",wordTable)]
hunk ./E/ToHs.hs 373
+    addrTable = [
+        (">","gtAddr#"),
+        ("==","eqAddr#"),
+        ("<","ltAddr#"),
+        (">=","gteAddr#"),
+        ("<=","lteAddr#")
+        ]
+    wordTable = [
+        (">","gtWord#"),
+        ("==","eqWord#"),
+        ("<","ltWord#"),
+        (">=","gteWord#"),
+        ("<=","lteWord#")
+        ]
hunk ./E/ToHs.hs 392
-transAlt dobind b (Alt LitInt { litNumber = i } e) = do
+transAlt dobind b (Alt LitInt { litNumber = i, litType = tt } e) = do
+    let (t,_,_) = cTypeInfoT tt
hunk ./E/ToHs.hs 395
-    return ( (if dobind then b <> char '@' else empty) <> tshow i <> text "#" <+> text "->" <+> e)
+    if t == "Int#" then
+        return ( (if dobind then b <> char '@' else empty) <> tshow i <> text "#" <+> text "->" <+> e)
+     else do
+        let bvar = if dobind then b else text "_bvar"
+            Just eq = op2TableCmp ("==",t)
+        v <- transE (ELit (LitInt i tt))
+        return ( bvar <+> text "|" <+> text eq <+> bvar <+> v <+> text "->" <+> e)
hunk ./Main.hs 20
+import C.Arch
hunk ./Main.hs 520
+    (viaGhc,fn,_,_) <- determineArch
+    wdump FD.Progress $ putStrLn $ "Arch: " ++ fn
hunk ./Main.hs 524
-        targetIndex = if fopts FO.ViaGhc then 1 else 0
+        targetIndex = if viaGhc then 1 else 0
hunk ./Main.hs 610
-    when (fopts FO.ViaGhc) $ do
+    when viaGhc $ do
hunk ./data/HsFFI.h 6
-typedef uint32_t HsChar;
+typedef int32_t HsChar;
hunk ./data/ViaGhc.hs 4
+import GHC.Int
+import GHC.Word
hunk ./data/ViaGhc.hs 54
+word2Char__ x = chr# (word2Int# x)
+char2Word__ x = int2Word# (ord# x)
+