[generate c-- primitives rather than C ones
John Meacham <john@repetae.net>**20070524052412] hunk ./C/Arch.hs 7
+    stringToOpTy,
hunk ./C/Arch.hs 86
-archInfo = ArchInfo { archPrimMap = primMap }
+archInfo = ArchInfo { archPrimMap = genericPrimMap }
hunk ./C/Arch.hs 92
+genericPrimMap :: Map.Map ExtType PrimType
+genericPrimMap = Map.fromList [ (primTypeName a,a) | a <- arch_generic ] where
+
+stringToOpTy = archOpTy genericArchInfo
+
hunk ./C/Arch.hs 105
-    f "float" = Op.TyBits  (Op.BitsExt "float") Op.HintFloat
-    f "double" = Op.TyBits (Op.BitsExt "double") Op.HintFloat
-    f "int" = Op.TyBits (Op.BitsExt "int") Op.HintSigned
-    f "unsigned int" = Op.TyBits (Op.BitsExt "unsigned int") Op.HintUnsigned
-    f "uintmax_t" = Op.TyBits (Op.BitsExt "uintmax_t") Op.HintUnsigned
-    f "intmax_t" = Op.TyBits (Op.BitsExt "intmax_t") Op.HintSigned
-    f "uintptr_t" = Op.TyBits Op.BitsPtr Op.HintUnsigned
-    f "intptr_t" = Op.TyBits Op.BitsPtr Op.HintSigned
-    f "HsPtr" = Op.TyBits Op.BitsPtr Op.HintUnsigned
-    f "HsFunPtr" = Op.TyBits Op.BitsPtr Op.HintUnsigned
+    f "float" = Op.TyBits  (Op.Bits 32) Op.HintFloat
+    f "double" = Op.TyBits (Op.Bits 64) Op.HintFloat
+    f "int" = Op.TyBits (Op.BitsArch Op.BitsInt) Op.HintSigned
+    f "unsigned int" = Op.TyBits (Op.BitsArch Op.BitsInt) Op.HintUnsigned
+
+    f "uintmax_t" = Op.TyBits (Op.BitsArch Op.BitsMax) Op.HintUnsigned
+    f "intmax_t" = Op.TyBits (Op.BitsArch Op.BitsMax)  Op.HintSigned
+    f "uintptr_t" = Op.TyBits (Op.BitsArch Op.BitsPtr) Op.HintUnsigned
+    f "intptr_t" = Op.TyBits (Op.BitsArch Op.BitsPtr) Op.HintSigned
+    f "HsPtr" = Op.TyBits (Op.BitsArch Op.BitsPtr) Op.HintUnsigned
+    f "HsFunPtr" = Op.TyBits (Op.BitsArch Op.BitsPtr) Op.HintUnsigned
hunk ./C/Op.hs 51
-    | Modu  -- ^ unsigned mod
+    | UMod  -- ^ unsigned mod
hunk ./C/Op.hs 93
-    deriving(Eq,Show,Ord)
+    deriving(Eq,Show,Ord,Read)
hunk ./C/Op.hs 101
+    | FNeg  -- ^ floating point negation
hunk ./C/Op.hs 114
-    deriving(Eq,Show,Ord)
+    deriving(Eq,Show,Ord,Read)
hunk ./C/Op.hs 135
-    deriving(Eq,Show,Ord)
+    | F2F
+    deriving(Eq,Show,Ord,Read)
hunk ./C/Op.hs 146
-    deriving(Eq,Show,Ord)
+    deriving(Eq,Show,Ord,Read)
hunk ./C/Op.hs 149
+data ArchBits = BitsInt | BitsMax | BitsPtr
+    deriving(Eq,Ord)
+    {-! derive: Binary !-}
hunk ./C/Op.hs 153
-data TyBits = Bits !Int | BitsPtr | BitsExt String
-    deriving(Eq,Show,Ord)
+data TyBits = Bits !Int | BitsArch !ArchBits |  BitsExt String
+    deriving(Eq,Ord)
hunk ./C/Op.hs 163
-    deriving(Eq,Show,Ord)
+    deriving(Eq,Ord)
hunk ./C/Op.hs 169
-    deriving(Eq,Show,Ord)
+    deriving(Eq,Ord)
hunk ./C/Op.hs 172
+instance Show TyHint where
+    showsPrec _ HintSigned = ('s':)
+    showsPrec _ HintUnsigned = ('u':)
+    showsPrec _ HintFloat = ('f':)
+    showsPrec _ HintCharacter = ('c':)
+    showsPrec _ HintNone = ('?':)
+
+instance Show Ty where
+    showsPrec _ TyBool = showString "bool"
+    showsPrec _ (TyBits b h) = shows h . showString "bits" . shows b
+
+instance Show TyBits where
+    showsPrec _ (Bits n) = shows n
+    showsPrec _ (BitsExt s) = showString "<" . showString s . showString ">"
+    showsPrec _ (BitsArch s) = showString "<" . shows s . showString ">"
+
+instance Show ArchBits where
+    show BitsInt = "int"
+    show BitsMax = "max"
+    show BitsPtr = "ptr"
+
+
+
hunk ./C/Op.hs 199
+    | ConvOp ConvOp v
hunk ./C/Op.hs 251
-binopInfix Modu = Just ("%",8)
+binopInfix UMod = Just ("%",8)
hunk ./C/Op.hs 281
-    isEagerSafe Modu = False
+    isEagerSafe UMod = False
hunk ./C/Prims.hs 142
-    pprint (APrim p _) = pprint p
+    pprintPrec n (APrim p _) = pprintPrec n p
hunk ./C/Prims.hs 155
+    pprint Op { primCOp = Op.BinOp bo ta tb, primRetTy = rt } | rt == ta && rt == tb = parens (pprint rt) <> tshow bo
+    pprint Op { primCOp = Op.UnOp bo ta, primRetTy = rt } | rt == ta = parens (pprint rt) <> tshow bo
hunk ./C/Prims.hs 158
-    pprint PrimDotNet { primDotNet = dn,  primDotNetName = n} = parens (text (unpackPS n))
+    pprint PrimDotNet { primDotNet = dn,  primDotNetName = nn} = parens (text (unpackPS nn))
hunk ./E/PrimOpt.hs 8
-import Control.Monad.Fix
+import Control.Monad.Fix()
hunk ./E/PrimOpt.hs 15
+import C.Arch
hunk ./E/PrimOpt.hs 24
-import Name.Names
-import Name.VConsts
hunk ./E/PrimOpt.hs 28
-import Util.HasSize
-import Util.NameMonad(genNames)
-import Util.SetLike
+import qualified C.Op as Op
hunk ./E/PrimOpt.hs 60
-    Just (cna,sta,ta) = lookupCType' dataTable te
+    Just (cna,sta,_ta) = lookupCType' dataTable te
hunk ./E/PrimOpt.hs 67
-vars :: [E] -> [TVr]
-vars ts = [ tVr n t | t <- ts | n <- [2,4 ..], n `notElem` fvs] where
-    fvs = freeVars ts
hunk ./E/PrimOpt.hs 141
+    primopt op [a,b] t | Just cop <- readM op = mdo
+        (pa,(ta,sta)) <- extractPrimitive dataTable a
+        (pb,(tb,stb)) <- extractPrimitive dataTable b
+        (bp,(tr,str)) <- boxPrimitive dataTable
+                (EPrim (APrim Op { primCOp = Op.BinOp cop (stringToOpTy ta) (stringToOpTy tb), primRetTy = (stringToOpTy tr) } mempty) [pa, pb] str) t
+        return bp
+    primopt op [a] t | Just cop <- readM op = mdo
+        (pa,(ta,sta)) <- extractPrimitive dataTable a
+        (bp,(tr,str)) <- boxPrimitive dataTable
+                (EPrim (APrim Op { primCOp = Op.UnOp cop (stringToOpTy ta), primRetTy = (stringToOpTy tr) } mempty) [pa] str) t
+        return bp
+    primopt op [a] t | Just cop <- readM op = mdo
+        (pa,(ta,sta)) <- extractPrimitive dataTable a
+        (bp,(tr,str)) <- boxPrimitive dataTable
+                (EPrim (APrim Op { primCOp = Op.ConvOp cop (stringToOpTy ta), primRetTy = (stringToOpTy tr) } mempty) [pa] str) t
+        return bp
hunk ./E/PrimOpt.hs 166
-        Just (cna,sta,ta) = lookupCType' dataTable t
+        Just (cna,_sta,_ta) = lookupCType' dataTable t
hunk ./E/PrimOpt.hs 175
-        let res = EPrim (APrim (Operator o [ta,ta] tr) mempty) [pa, ELit (LitInt 1 sta)] str
+        let res = EPrim (APrim (Op (Op.BinOp o (stringToOpTy ta) (stringToOpTy ta)) (stringToOpTy tr)) mempty) [pa, ELit (LitInt 1 sta)] str
hunk ./E/PrimOpt.hs 177
-        where unop = [("increment","+"),("decrement","-")]
+        where unop = [("increment",Op.Add),("decrement",Op.Sub)]
hunk ./Grin/FromE.hs 43
+import qualified C.Op as Op
hunk ./Grin/FromE.hs 129
+rawNameToTy :: Monad m => Name -> m Ty
+rawNameToTy n | RawType <- nameType n = return $ stringNameToTy (show n)
+              | otherwise = fail "rawNameToTy: not primitive type"
+
+stringNameToTy :: String -> Ty
+stringNameToTy n = TyPrim (archOpTy archInfo n)
+
hunk ./Grin/FromE.hs 139
-    toty (ELit LitCons { litName = n, litArgs = [], litType = ty }) |  ty == 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 (ELit LitCons { litName = n, litArgs = [], litType = ty }) |  ty == eHash, Just t <- rawNameToTy n = t
hunk ./Grin/FromE.hs 450
-            let p = prim { primType = (keepIts (map (Ty . toAtom) as),Ty (toAtom r)) }
+            let p = prim { primType = (keepIts (map stringNameToTy as),stringNameToTy r) }
hunk ./Grin/FromE.hs 454
-            let p = prim { primType = (keepIts (map (Ty . toAtom) as),Ty (toAtom r)) }
+            let p = prim { primType = (keepIts (map stringNameToTy as),stringNameToTy r) }
hunk ./Grin/FromE.hs 457
-            let p = prim { primType = ([Ty $ toAtom (show rt_HsPtr)],pt) }
-                pt = toType (Ty $ toAtom pt') ty
+            let p = prim { primType = ([stringNameToTy (show rt_HsPtr)],pt) }
+                pt = toType (stringNameToTy pt') ty
hunk ./Grin/FromE.hs 461
-            let p = prim { primType = ([Ty $ toAtom (show rt_HsPtr)],pt) }
+            let p = prim { primType = ([stringNameToTy (show rt_HsPtr)],pt) }
hunk ./Grin/FromE.hs 463
-                pt = Ty (toAtom pt')
+                pt = stringNameToTy pt'
hunk ./Grin/FromE.hs 466
-            let p = prim { primType = ([Ty $ toAtom (show rt_HsPtr),pt],tyUnit) }
+            let p = prim { primType = ([stringNameToTy (show rt_HsPtr),pt],tyUnit) }
hunk ./Grin/FromE.hs 468
-                pt = Ty (toAtom pt')
+                pt = stringNameToTy pt'
hunk ./Grin/FromE.hs 471
-            let ptypeto' = Ty $ toAtom to
-                ptypefrom' = Ty $ toAtom from
+            let ptypeto' = stringNameToTy to
+                ptypefrom' = stringNameToTy from
hunk ./Grin/FromE.hs 475
-        Operator n as r | Just _ <- fromRawType ty -> do
-            let p = prim { primType = ((map (Ty . toAtom) as),Ty (toAtom r)) }
+        Op (Op.BinOp _ a1 a2) rt -> do
+            let p = prim { primType = ([TyPrim a1,TyPrim a2],TyPrim rt) }
+            return $ Prim p (args xs)
+        Op (Op.UnOp _ a1) rt -> do
+            let p = prim { primType = ([TyPrim a1], TyPrim rt) }
+            return $ Prim p (args xs)
+        Op (Op.ConvOp _ a1) rt -> do
+            let p = prim { primType = ([TyPrim a1], TyPrim rt) }
hunk ./Grin/FromE.hs 484
+--        Operator n as r | Just _ <- fromRawType ty -> do
+--            let p = prim { primType = ((map (Ty . toAtom) as),Ty (toAtom r)) }
+--            return $ Prim p (args xs)
hunk ./data/PrimitiveOperators-in.hs 19
+import qualified C.Op as Op
hunk ./data/PrimitiveOperators-in.hs 47
-oper_aa op ct e = EPrim (APrim (Operator op [ct] ct) mempty) [e] (rawType ct)
-oper_aaB op ct a b = EPrim (APrim (Operator op [ct,ct] "int") mempty) [a,b] tBoolzh
-oper_aaa op ct a b = EPrim (APrim (Operator op [ct,ct] ct) mempty) [a,b] (rawType ct)
-oper_aIa op ct a b = EPrim (APrim (Operator op [ct,"int"] ct) mempty) [a,b] (rawType ct)
+binOp op ca cb cr = APrim (Op (Op.BinOp op ca cb) cr) mempty
+
+oper_aa op ct' e = EPrim (APrim (Op (Op.UnOp op ct) ct) mempty) [e] (rawType ct') where
+    ct = stringToOpTy ct'
+oper_aaB op ct' a b = EPrim (binOp op ct ct ot_int) [a,b] tBoolzh where
+    ct = stringToOpTy ct'
+oper_aaa op ct' a b = EPrim (binOp op ct ct ct) [a,b] (rawType ct') where
+    ct = stringToOpTy ct'
+oper_aIa op ct' a b = EPrim (binOp op ct ot_int ct) [a,b] (rawType ct') where    
+    ct = stringToOpTy ct'
hunk ./data/PrimitiveOperators-in.hs 60
+ot_int = stringToOpTy "int"
+
hunk ./data/PrimitiveOperators-in.hs 108
-build_abs ct cn v = unbox' v cn tvra (eCase (oper_aaB "<" ct (EVar tvra) zero)  [Alt lFalsezh (rebox $ EVar tvra), Alt lTruezh fs] Unknown) where
+build_abs ct cn v = unbox' v cn tvra (eCase (oper_aaB Op.Lt ct (EVar tvra) zero)  [Alt lFalsezh (rebox $ EVar tvra), Alt lTruezh fs] Unknown) where
hunk ./data/PrimitiveOperators-in.hs 114
-    fs = eStrictLet tvrb (oper_aa "-" ct (EVar tvra)) (rebox (EVar tvrb))
+    fs = eStrictLet tvrb (oper_aa Op.Neg ct (EVar tvra)) (rebox (EVar tvrb))
+    rebox x = ELit (litCons { litName = cn, litArgs = [x], litType = te })
+
+build_uabs ct cn v = v
+
+build_fabs ct cn v = unbox' v cn tvra (rebox (oper_aa Op.FAbs ct (EVar tvra))) where
+    te = getType v
+    tvra = tVr 2 st
+    st = rawType ct
hunk ./data/PrimitiveOperators-in.hs 125
-build_signum ct cn v = unbox' v cn tvra (eCase (EVar tvra) [Alt zero (rebox (ELit zero))] (eCase (oper_aaB "<" ct (EVar tvra) (ELit zero)) [Alt lFalsezh (rebox one),Alt lTruezh (rebox negativeOne)] Unknown)) where
+build_usignum ct cn v = unbox' v cn tvra (eCase (EVar tvra) [Alt zero (rebox (ELit zero))] (rebox (ELit one))) where
+    tvra = tVr 2 st
+    te = getType v
+    st = rawType ct
+    zero :: Lit a E
+    zero = LitInt 0 st
+    one = LitInt 1 st
+    rebox x = ELit (litCons { litName = cn, litArgs = [x], litType = te })
+
+build_signum ct cn v = unbox' v cn tvra (eCase (EVar tvra) [Alt zero (rebox (ELit zero))] (eCase (oper_aaB Op.Lt ct (EVar tvra) (ELit zero)) [Alt lFalsezh (rebox one),Alt lTruezh (rebox negativeOne)] Unknown)) where
hunk ./data/PrimitiveOperators-in.hs 145
+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 2 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 })
hunk ./utils/op_process.prl 4
+use warnings;
hunk ./utils/op_process.prl 15
+my %oper_map = (
+    "-" => "Sub",
+    "+" => "Add",
+    "*" => "Mul",
+    "u-" => "Sub",
+    "u+" => "Add",
+    "u*" => "Mul",
+    "f*" => "FMul",
+    "f-" => "FSub",
+    "f+" => "FAdd",
+    "==" => "Eq",
+    "!=" => "NEq",
+    ">" => "Gt",
+    ">=" => "Gte",
+    "<" => "Lt",
+    "<=" => "Lte",
+    "u==" => "Eq",
+    "u!=" => "NEq",
+    "u>" => "UGt",
+    "u>=" => "UGte",
+    "u<" => "ULt",
+    "u<=" => "ULte",
+
+    "&" => "And",
+    "|" => "Or",
+    "^" => "Xor",
+    "<<" => "Shl",
+    ">>" => "Shra",
+    "u>>" => "Shr",
+    "/" => "Div",
+    "%" => "Mod",
+    "u/" => "UDiv",
+    "u%" => "UMod",
+    "u&" => "And",
+    "u|" => "Or",
+    "u^" => "Xor",
+    "u<<" => "Shl",
+
+
+    "f==" => "FEq",
+    "f!=" => "FNEq",
+    "f>" => "FGt",
+    "f>=" => "FGte",
+    "f<" => "FLt",
+    "f<=" => "FLte",
+
+    "_-" => "Neg",
+    "_~" => "Com",
+    "u_-" => "Neg",
+    "u_~" => "Com",
+    "f_-" => "FNeg"
+
+    );
+
+sub vtype {
+    ($_) = @_ if @_;
+    return 'u' if /^uint/;
+    return '' if /^int/;
+    return 'f' if /^float/;
+    return 'f' if /^double/;
+    return 'u' if /unsigned/;
+    return 'u' if /HsChar/;
+    return 'u' if /HsPtr/;
+    return 'u' if /HsFunPtr/;
+    return '';
+
+}
+
hunk ./utils/op_process.prl 189
+    my $vtype = vtype $d->[1];
+    #print STDERR "$d->[1] - '$vtype'\n";
hunk ./utils/op_process.prl 226
-    #push @cmeth, "(toInstName \"Prelude.abs.$d->[0]\", ELam $tvar (buildAbs $tvar $t))" if $d->[2] =~ /int/ ;
-    push @cmeth, "($c_num, toInstName \"Jhc.Num.abs.$d->[0]\", ELam $tvar (build_abs \"$d->[1]\" $cncons (EVar $tvar)  ))" if $d->[2] =~ /int/ ;
-    #push @cmeth, "(toInstName \"Prelude.signum.$d->[0]\", ELam $tvar (buildSignum $tvar $t))" if $d->[2] =~ /int/ ;
-    push @cmeth, "($c_num, toInstName \"Jhc.Num.signum.$d->[0]\", ELam $tvar (build_signum \"$d->[1]\" $cncons (EVar $tvar) ))" if $d->[2] =~ /int/ ;
+    push @cmeth, "($c_num, toInstName \"Jhc.Num.abs.$d->[0]\", ELam $tvar (build_${vtype}abs \"$d->[1]\" $cncons (EVar $tvar)  ))" if $d->[2] !~ /char/ ;
+    push @cmeth, "($c_num, toInstName \"Jhc.Num.signum.$d->[0]\", ELam $tvar (build_${vtype}signum \"$d->[1]\" $cncons (EVar $tvar) ))" if $d->[2] !~ /char/ ;
hunk ./utils/op_process.prl 239
-        if ($c->[0] =~ /^a[aI][aIB]?$/) {
-        push @cmeth, "($nn,toInstName \"$x$c->[1].$d->[0]\", op_$c->[0]  \"$c->[3]\" \"$d->[1]\" $cncons $t)";
+        if ($c->[0] =~ /^a[aI][aIB]$/) {
+            push @cmeth, "($nn,toInstName \"$x$c->[1].$d->[0]\", op_$c->[0]  Op." . $oper_map{$vtype . $c->[3]} ." \"$d->[1]\" $cncons $t)";
+        } elsif ($c->[0] =~ /^a[aI]$/) {
+            push @cmeth, "($nn,toInstName \"$x$c->[1].$d->[0]\", op_$c->[0]  Op." . $oper_map{$vtype . "_" . $c->[3]} ." \"$d->[1]\" $cncons $t)";
hunk ./utils/op_process.prl 244
-        push @meth, "($nn,toInstName \"$x$c->[1].$d->[0]\", \"$c->[0]\", \"prim_op_$c->[0].$c->[3]\", \"$d->[0]\")";
-    }
+            push @meth, "($nn,toInstName \"$x$c->[1].$d->[0]\", \"$c->[0]\", \"prim_op_$c->[0].$c->[3]\", \"$d->[0]\")";
+        }
hunk ./utils/op_process.prl 251
-#print "{- This file is generated -}\n";
-#print "module PrimitiveOperators(primitiveInsts,constantMethods,theMethods,allCTypes) where\n\n";
-#print "import Representation\n";
-#print "import E.E\n";
-#print "import E.Values\n";
-#print "import C.Prims\n";
-#print "import VConsts\n";
-#print "import Name\n\n";
-#print "toHsName x = nameName \$ parseName TypeConstructor x\n\n";
-#print "toInstName x = toName Val (\"Instance@\",'i':x)\n\n";
-#print 'buildAbs v t = eIf (EPrim (primPrim "prim_op_aaB.<") [EVar v,(ELit (LitInt 0 t))] tBool) (EPrim (primPrim "prim_op_aa.-") [EVar v] t) (EVar v)'. "\n\n";
-#print 'buildSignum v t = eCase (EVar v) [Alt (LitInt 0 t) (ELit (LitInt 0 t))] (eIf (EPrim (primPrim "prim_op_aaB.<") [EVar v,(ELit (LitInt 0 t))] tBool) (ELit (LitInt (-1) t)) (ELit (LitInt 1  t)))' . "\n\n";
hunk ./utils/op_process.prl 270
-#    push @cmeth, "(toName Val (\"Instance@\",\"iForeign.Storable.sizeOf.$d->[0]\"), ELam (TVr 0 $t) \$ " . const("sizeof($d->[1])","tInt") . ")\n";
-#    push @cmeth, "(toName Val (\"Instance@\",\"iForeign.Storable.poke.$d->[0]\"), buildPoke $t \"$d->[1]\")\n";
-#    push @cmeth, "(toName Val (\"Instance@\",\"iForeign.Storable.peek.$d->[0]\"), buildPeek $t \"$d->[1]\")\n";
-#    push @cmeth, "(toName Val (\"Instance@\",\"iPrelude.maxBound.$d->[0]\"), " . const($d->[3],$t,"\"$d->[1]\"") . ")\n";
-#    push @cmeth, "(toName Val (\"Instance@\",\"iPrelude.minBound.$d->[0]\"), " . const($d->[4],$t,"\"$d->[1]\"") . ")\n";