[redo looking up foreign-able types and what they map to to be more general
John Meacham <john@repetae.net>**20090227075123
 Ignore-this: e7bf5a8333660b7994d4de4c714f0929
] hunk ./DataConstructors.hs 8
+    ExtTypeInfo(..),
+    extTypeInfoExtType,
hunk ./DataConstructors.hs 29
+    lookupExtTypeInfo,
hunk ./DataConstructors.hs 442
+data ExtTypeInfo
+    = ExtTypeVoid                  -- maps to 'void'
+    | ExtTypeRaw ExtType           -- value is an unboxed type suitable for passing with the argument calling convention
+    | ExtTypeBoxed Name E ExtType  -- boxed type, name is constructor of box, E is type of the slice, and ExtType is the calling convention to use
+
+extTypeInfoExtType (ExtTypeRaw et) = et
+extTypeInfoExtType (ExtTypeBoxed _ _ et) = et
+extTypeInfoExtType ExtTypeVoid = "void"
+
+lookupExtTypeInfo :: Monad m => DataTable -> E -> m ExtTypeInfo
+lookupExtTypeInfo dataTable oe = f oe where
+    -- handle the void context ones first
+    f e@(ELit LitCons { litName = c }) | c == tc_Unit || c == tc_World__ = return ExtTypeVoid
+    -- if the constructor is in the external type map, replace its external
+    -- type with the one in the map
+    f e@(ELit LitCons { litName = c }) | Just et <- Map.lookup c typeTable = do
+        res <- g e
+        return $ case res of
+            ExtTypeRaw _ -> ExtTypeRaw et
+            ExtTypeBoxed b t _ -> ExtTypeBoxed b t et
+            ExtTypeVoid -> ExtTypeVoid 
+    f e = g e
+    -- if we are a single constructor data type with a single foreignable unboxed
+    -- slot, we are foreiginable
+    g (ELit LitCons { litName = c }) 
+        | Just Constructor { conChildren = DataNormal [cn] }  <- getConstructor c dataTable,
+          Just Constructor { conOrigSlots = [SlotNormal st] } <- getConstructor cn dataTable,
+          Just (ExtTypeRaw et) <- lookupExtTypeInfo dataTable st = return $ ExtTypeBoxed cn st et
+    -- if we are a raw type, we can be foreigned
+    g (ELit LitCons { litName = c }) | Just et <- Map.lookup c rawExtTypeMap = return (ExtTypeRaw et)
+    g e | Just e' <- followAlias dataTable e = f e'
+        | otherwise = fail $ "lookupExtTypeInfo: " ++ show (oe,e)
+
+
hunk ./DataConstructors.hs 479
-lookupCType' dataTable e = case followAliases (mappend dataTablePrims dataTable) e of
+lookupCType' dataTable e = do
+    ExtTypeBoxed a b c <- lookupExtTypeInfo dataTable e 
+    return (a,b,c)
+{-
+    = g ecase followAliases (mappend dataTablePrims dataTable) e of
hunk ./DataConstructors.hs 490
+    -}
hunk ./DataConstructors.hs 903
+rawExtTypeMap = Map.fromList [
+    (rt_bool,  "bool"),
+    (rt_bits8,  "uint8_t"),
+    (rt_bits16, "uint16_t"),
+    (rt_bits32, "uint32_t"),
+    (rt_bits64, "uint64_t"),
+    (rt_bits128,"uint128_t"),
+    (rt_bits_ptr_, "uintptr_t" ),
+    (rt_bits_max_, "uintmax_t"),
+    (rt_bits_size_t_, "size_t" ),
+    (rt_bits_time_t_, "time_t" ),
+    (rt_bits_int_, "int" ),
+    (rt_bits_short_, "short" ),
+
+    (rt_float32, "float"),
+    (rt_float64, "double"),
+    (rt_float80, "long double"),
+    (rt_float128, "__float128")
+    ]
hunk ./E/FromHs.hs 250
-    Just (cna,sta,_ta) = lookupCType' dataTable te
+    Just (ExtTypeBoxed cna sta _) = lookupExtTypeInfo dataTable te
hunk ./E/FromHs.hs 252
-createFunc :: UniqueProducer m => DataTable -> [E] -> ([(TVr,String)] -> (E -> E,E)) -> m E
+createFunc :: UniqueProducer m => DataTable -> [E] -> ([TVr] -> (E -> E,E)) -> m E
hunk ./E/FromHs.hs 255
-        res@(_,sta,rt) <- lookupCType' dataTable te
-        [n,n'] <- newVars [te,sta]
-        return (n,(n',rt),res)
+        eti <- lookupExtTypeInfo dataTable te
+        [n] <- newVars [te]
+        case eti of
+            ExtTypeVoid -> fail "createFunc: attempt to pass a void argument"
+            ExtTypeBoxed cn sta _ -> do
+                [n'] <- newVars [sta]
+                return (n,n',Just cn)
+            ExtTypeRaw _ -> do
+                return (n,n,Nothing)
hunk ./E/FromHs.hs 268
-        esr (tvr,(tvr',_),(cn,_,_)) e = eCase (EVar tvr) [Alt (litCons { litName = cn, litArgs = [tvr'], litType = te }) e] Unknown  where
-            te = getType $ EVar tvr
+        esr (tvr,tvr',Just cn) e = eCase (EVar tvr) [Alt (litCons { litName = cn, litArgs = [tvr'], litType = tvrType tvr }) e] Unknown
+        esr (_,_,Nothing) e = e
hunk ./E/FromHs.hs 382
-    marshallToC dataTable e te | otherwise = do
-        (cna,sta,ta) <- lookupCType' dataTable te
-        [tvra] <- newVars [sta]
-        return $ eCase e
-                       [Alt (litCons { litName = cna, litArgs = [tvra], litType = te })
-                            (EVar tvra)]
-                       Unknown
+    marshallToC dataTable e te = do
+        eti <- lookupExtTypeInfo dataTable te
+        case eti of
+            ExtTypeBoxed cna sta _ -> do
+                [tvra] <- newVars [sta]
+                return $ eCase e
+                               [Alt (litCons { litName = cna, litArgs = [tvra], litType = te })
+                                    (EVar tvra)]
+                               Unknown
+            ExtTypeRaw _ -> return e
+            ExtTypeVoid -> fail "marshallToC: trying to marshall void"
hunk ./E/FromHs.hs 394
-    marshallFromC :: UniqueProducer m => DataTable -> E -> E -> m E
-    marshallFromC dataTable ce te | otherwise = do
-        (cna,sta,ta) <- lookupCType' dataTable te
-        return $ ELit (litCons { litName = cna, litArgs = [ce], litType = te })
+    marshallFromC :: Monad m => DataTable -> E -> E -> m E
+    marshallFromC dataTable ce te = do
+        eti <- lookupExtTypeInfo dataTable te
+        case eti of
+            ExtTypeBoxed cna _ _ -> return $ ELit (litCons { litName = cna, litArgs = [ce], litType = te })
+            ExtTypeRaw _ -> return ce
+            ExtTypeVoid -> fail "marshallFromC: trying to marshall void"
hunk ./E/FromHs.hs 414
-        pt <- lookupCType rt'
-        cts <- mapM lookupCType (filter (not . sortKindLike) ts)
+        pt <- lookupExtTypeInfo dataTable rt'
+        cts <- mapM (lookupExtTypeInfo dataTable) (filter (not . sortKindLike) ts)
hunk ./E/FromHs.hs 418
-            prim = myPrim cts pt
+            prim = myPrim (map extTypeInfoExtType cts) (extTypeInfoExtType pt)
hunk ./E/FromHs.hs 420
-            (True,"void") -> cFun $ \rs -> (,) (ELam tvrWorld) $
+            (True,ExtTypeVoid) -> cFun $ \rs -> (,) (ELam tvrWorld) $
hunk ./E/FromHs.hs 424
-                                          :[EVar t | (t,_) <- rs ])
+                                          :[EVar t | t <- rs ])
hunk ./E/FromHs.hs 427
-            (False,"void") -> fail "pure foreign function must return a valid value"
-            _ -> do
-                (cn,rtt',_) <- lookupCType' dataTable rt'
+            (False,ExtTypeVoid) -> fail "pure foreign function must return a valid value"
+            (_,ExtTypeBoxed cn rtt' _) -> do
hunk ./E/FromHs.hs 430
-                let _rttIO = ltTuple [tWorld__, rt']
-                    rttIO' = ltTuple' [tWorld__, rtt']
+                let rttIO' = ltTuple' [tWorld__, rtt']
hunk ./E/FromHs.hs 435
-                                                 [ EVar t | (t,_) <- rs ]
+                                                 [ EVar t | t <- rs ]
hunk ./E/FromHs.hs 440
-                                                (EVar tvrWorld:[EVar t | (t,_) <- rs ])
+                                                (EVar tvrWorld:[EVar t | t <- rs ])
hunk ./E/FromHs.hs 446
+            (_,ExtTypeRaw  _) -> do
+                [rtVar] <- newVars [rt']
+                let rttIO' = ltTuple' [tWorld__, rt']
+                case isIO of
+                    False -> cFun $ \rs -> (,) id $ (prim False [ EVar t | t <- rs ] rt') 
+                    True -> cFun $ \rs -> (,) (ELam tvrWorld) $
+                                eCaseTup' (prim True (EVar tvrWorld:[EVar t | t <- rs ]) rttIO')
+                                          [tvrWorld2,rtVar]
+                                          (eJustIO (EVar tvrWorld2) (EVar rtVar))
hunk ./E/FromHs.hs 469
-        (cn,st,_ct) <- lookupCType' dataTable rt
-        [uvar] <- newVars [st]
-        let expr x     = return [(name,setProperty prop_INLINE var,lamt x)]
+            expr x     = return [(name,setProperty prop_INLINE var,lamt x)]
hunk ./E/FromHs.hs 471
-        expr $ eStrictLet uvar (EPrim prim [] st) (ELit (litCons { litName = cn, litArgs = [EVar uvar], litType = rt }))
+        -- this needs to be a boxed value since we can't have top-level
+        -- unboxed values yet.
+        eti <- lookupExtTypeInfo dataTable rt
+        case eti of
+            ExtTypeBoxed cn st _ -> do
+                [uvar] <- newVars [st]
+                expr $ eStrictLet uvar (EPrim prim [] st) (ELit (litCons { litName = cn, litArgs = [EVar uvar], litType = rt }))
+            _ -> fail "foreign import of address must be of a boxed type"
hunk ./E/FromHs.hs 506
-        pt <- lookupCType rt'
+        pt <- lookupExtTypeInfo dataTable rt'
hunk ./E/FromHs.hs 512
-            (True,"void") -> cFun $ \rs -> (,) (ELam tvrWorld) $
-                        eStrictLet tvrWorld2 (prim rs "void" (EVar tvrWorld:[EVar t | (t,_) <- rs ]) tWorld__) (eJustIO (EVar tvrWorld2) vUnit)
-            (False,"void") -> fail "pure foreign function must return a valid value"
+            (True,ExtTypeVoid) -> cFun $ \rs -> (,) (ELam tvrWorld) $
+                        eStrictLet tvrWorld2 (prim rs "void" (EVar tvrWorld:[EVar t | t <- rs ]) tWorld__) (eJustIO (EVar tvrWorld2) vUnit)
+            (False,ExtTypeVoid) -> fail "pure foreign function must return a valid value"
hunk ./E/FromHs.hs 521
-                    False -> cFun $ \rs -> (,) id $ eStrictLet rtVar' (prim rs rtt [ EVar t | (t,_) <- rs ] rtt') (ELit $ litCons { litName = cn, litArgs = [EVar rtVar'], litType = rt' })
+                    False -> cFun $ \rs -> (,) id $ eStrictLet rtVar' (prim rs rtt [ EVar t | t <- rs ] rtt') (ELit $ litCons { litName = cn, litArgs = [EVar rtVar'], litType = rt' })
hunk ./E/FromHs.hs 523
-                                eCaseTup' (prim rs rtt (EVar tvrWorld:[EVar t | (t,_) <- rs ]) rttIO')  [tvrWorld2,rtVar'] (eLet rtVar (ELit $ litCons { litName = cn, litArgs = [EVar rtVar'], litType = rt' }) (eJustIO (EVar tvrWorld2) (EVar rtVar)))
+                                eCaseTup' (prim rs rtt (EVar tvrWorld:[EVar t | t <- rs ]) rttIO')  [tvrWorld2,rtVar'] (eLet rtVar (ELit $ litCons { litName = cn, litArgs = [EVar rtVar'], litType = rt' }) (eJustIO (EVar tvrWorld2) (EVar rtVar)))
hunk ./E/FromHs.hs 537
-        retCTy <- if retTy == tUnit
-                  then return unboxedTyUnit
-                  else liftM (\(_, _, x) -> rawType x) $ lookupCType' dataTable retTy
+        --retCTy <- if retTy == tUnit
+         --         then return unboxedTyUnit
+         --         else liftM (\(_, _, x) -> rawType x) $ lookupCType' dataTable retTy
hunk ./E/FromHs.hs 541
-        argCTys <- liftM (map rawType) (mapM (liftM (\(_,_,x) -> x) . lookupCType' dataTable) argTys)
+        argCTys <- mapM (liftM (\(_,st,_) -> st) . lookupCType' dataTable) argTys
hunk ./E/FromHs.hs 565
-        realRetCTy:realArgCTys <- mapM lookupCType (retTy:argTys)
+        realRetCTy:realArgCTys <- mapM (\x -> extTypeInfoExtType `liftM`  lookupExtTypeInfo dataTable x) (retTy:argTys)
hunk ./E/FromHs.hs 627
-    cExpr (HsLit (HsStringPrim s)) = return $ EPrim (APrim (PrimString (packString s)) mempty) [] (rawType "bits<ptr>")
+    cExpr (HsLit (HsStringPrim s)) = return $ EPrim (APrim (PrimString (packString s)) mempty) [] r_bits_ptr_
hunk ./E/FromHs.hs 635
-        ans = case lookupCType' dataTable ty of
-            Just (cn,st,_it) -> return $ ELit (litCons { litName = cn, litArgs = [ELit (LitInt (fromIntegral i) st)], litType = ty })
-            Nothing -> return $ intConvert' funcs ty i
+        -- XXX this can allow us to create integer literals out of things that
+        -- arn't in Num if we arn't careful
+        ans = case lookupExtTypeInfo dataTable ty of
+            Just (ExtTypeBoxed cn st _) -> return $ ELit (litCons { litName = cn, litArgs = [ELit (LitInt (fromIntegral i) st)], litType = ty })
+            _ -> return $ intConvert' funcs ty i
hunk ./E/FromHs.hs 769
-intConvert i | abs i > integer_cutoff  =  ELit (litCons { litName = dc_Integer, litArgs = [ELit $ LitInt (fromInteger i) (rawType "bits<max>")], litType = tInteger })
-intConvert i =  ELit (litCons { litName = dc_Int, litArgs = [ELit $ LitInt (fromInteger i) (rawType "bits32")], litType = tInt })
+intConvert i | abs i > integer_cutoff  =  ELit (litCons { litName = dc_Integer, litArgs = [ELit $ LitInt (fromInteger i) r_bits_max_], litType = tInteger })
+intConvert i =  ELit (litCons { litName = dc_Int, litArgs = [ELit $ LitInt (fromInteger i) r_bits32], litType = tInt })
hunk ./E/FromHs.hs 772
-intConvert' funcs typ i = EAp (EAp fun typ) (ELit (litCons { litName = con, litArgs = [ELit $ LitInt (fromInteger i) (rawType rawtyp)], litType = ltype }))  where
+intConvert' funcs typ i = EAp (EAp fun typ) (ELit (litCons { litName = con, litArgs = [ELit $ LitInt (fromInteger i) rawtyp], litType = ltype }))  where
hunk ./E/FromHs.hs 774
-        True -> (dc_Integer,tInteger,f_fromInteger,"bits<max>")
-        False -> (dc_Int,tInt,f_fromInt,"bits32")
+        True -> (dc_Integer,tInteger,f_fromInteger,r_bits_max_)
+        False -> (dc_Int,tInt,f_fromInt,r_bits32)
hunk ./E/FromHs.hs 973
-packupString s | all (\c -> c > '\NUL' && c <= '\xff') s = (EPrim (APrim (PrimString (packString s)) mempty) [] (rawType "bits<ptr>"),True)
+packupString s | all (\c -> c > '\NUL' && c <= '\xff') s = (EPrim (APrim (PrimString (packString s)) mempty) [] r_bits_ptr_,True)
hunk ./E/PrimOpt.hs 48
-    Just (cna,sta,_ta) = lookupCType' dataTable te
+    Just (ExtTypeBoxed cna sta _) = lookupExtTypeInfo dataTable te
hunk ./E/PrimOpt.hs 177
-        Just (cna,_sta,_ta) = lookupCType' dataTable t
+        Just (ExtTypeBoxed cna _ _) = lookupExtTypeInfo dataTable t
hunk ./E/Values.hs 172
-rawType s = ELit litCons { litName = toName RawType s, litType = eHash }
hunk ./data/PrimitiveOperators-in.hs 9
+    r_bits_ptr_,
+    r_bits_max_,
+    r_bits32,
hunk ./data/PrimitiveOperators-in.hs 30
+rawType s = ELit litCons { litName = toName RawType s, litType = eHash }
hunk ./data/PrimitiveOperators-in.hs 61
-create_fintegralCast_fromInt c2 t2 e t = create_integralCast Op.I2F dc_Int tIntzh c2 t2 e t
-create_fintegralCast_fromInteger c2 t2 e t = create_integralCast Op.I2F dc_Integer tIntegerzh c2 t2 e t
-
-
hunk ./data/PrimitiveOperators-in.hs 140
-build_fabs ct cn v = unbox' v cn tvra (rebox (oper_aa Op.FAbs ct (EVar tvra))) where
-    te = getType v
-    tvra = tVr va1 st
-    st = rawType ct
-    rebox x = ELit (litCons { litName = cn, litArgs = [x], litType = te })
hunk ./data/PrimitiveOperators-in.hs 160
-
-build_fsignum ct cn v = unbox' v cn tvra (eCase (EVar tvra) [Alt zero (rebox (ELit zero))] (eCase (oper_aaB Op.FLt ct (EVar tvra) (ELit zero)) [Alt lFalsezh (rebox one),Alt lTruezh (rebox negativeOne)] Unknown)) where
-    tvra = tVr va1 st
-    te = getType v
-    st = rawType ct
-    zero :: Lit a E
-    zero = LitInt 0 st
-    one = ELit $ LitInt 1 st
-    negativeOne = ELit $ LitInt (-1) st
-    rebox x = ELit (litCons { litName = cn, litArgs = [x], litType = te })
-
-