[clean up handling of Jhc.Options options
John Meacham <john@repetae.net>**20090306053012
 Ignore-this: ca971f7f12bcb66e3a15cb00cbdaa794
] hunk ./Cmm/OpEval.hs 15
+import qualified Data.Map as Map
hunk ./Cmm/OpEval.hs 80
-    f Eq  v1 v2 = return $ toBool (v1 == v2)
-    f NEq v1 v2 = return $ toBool (v1 /= v2)
hunk ./Cmm/OpEval.hs 93
-    f op v1 v2 | Just v <- lookup op ops = return $ toBool (v1 `v` v2) where
-        ops = [(Lt,(<)), (Gt,(>)), (Lte,(<=)), (Gte,(>=)),
-               (FLt,(<)), (FGt,(>)), (FLte,(<=)), (FGte,(>=))]
-    f op v1 v2 | Just v <- lookup op ops, v1 >= 0 && v2 >= 0 = return $ toBool (v1 `v` v2) where
-        ops = [(ULt,(<)), (UGt,(>)), (ULte,(<=)), (UGte,(>=))]
+    f op v1 v2 | Just v <- Map.lookup op ops = return $ toBool (v1 `v` v2) where
+        ops = Map.fromList [(Lt,(<)), (Gt,(>)), (Lte,(<=)), (Gte,(>=)),
+               (FLt,(<)), (FGt,(>)), (FLte,(<=)), (FGte,(>=)), (Eq,(==)),(NEq,(/=))]
+
+    f op v1 v2 | Just v <- Map.lookup op ops, v1 >= 0 && v2 >= 0 = return $ toBool (v1 `v` v2) where
+        ops = Map.fromList [(ULt,(<)), (UGt,(>)), (ULte,(<=)), (UGte,(>=))]
hunk ./E/PrimOpt.hs 29
-{-
+{-@Extensions
hunk ./E/PrimOpt.hs 31
-The primitive operators provided which may be imported into code are
+# Foreign Primitives
hunk ./E/PrimOpt.hs 33
-'seq' - evaluate first argument to WHNF, return second one
-plus/divide/minus  - perform operation on primitive type
-zero/one - the zero and one values for primitive types
-const.<foo> - evaluates to the C constant <foo>
-error.<err> - equivalent to 'error <err>'
-exitFailure__ - abort program immediately with no message
-increment/decrement - increment or decrement a primitive numeric type by 1
+In addition to foreign imports of external functions as described in the FFI
+spec. Jhc supports 'primitive' imports that let you communicate primitives directly
+to the compiler. In general, these should not be used other than in the implementation
+of the standard libraries. They generally do little error checking as it is assumed you
+know what you are doing if you use them. All haskell visible entities are
+introduced via foreign declarations in jhc.
+
+They all have the form
+
+    foreign import primitive "specification" haskell_name :: type
+
+where "specification" is one of the following
+
+seq
+: evaluate first argument to WHNF, then return the second argument
+
+zero,one
+: the values zero and one of any primitive type.
+
+const.C_CONSTANT
+: the text following const is directly inserted into the resulting C file
+
+peek.TYPE
+: the peek primitive for raw value TYPE
+
+poke.TYPE
+: the poke primitive for raw value TYPE
+
+sizeOf.TYPE, alignmentOf.TYPE, minBound.TYPE, maxBound.TYPE, umaxBound.TYPE
+: various properties of a given internal type.
+
+error.MESSAGE
+: results in an error with constant message MESSAGE.
+
+constPeekByte
+: peek of a constant value specialized to bytes, used internally by Jhc.String
+
+box
+: take an unboxed value and box it, the shape of the box is determined by the type at which this is imported
+
+unbox
+: take an boxed value and unbox it, the shape of the box is determined by the type at which this is imported
+
+increment, decrement
+: increment or decrement a numerical integral primitive value
+
+fincrement, fdecrement
+: increment or decrement a numerical floating point primitive value
+
+exitFailure__
+: abort the program immediately
+
+C-- Primitive
+: any C-- primitive may be imported in this manner.
hunk ./E/PrimOpt.hs 91
+
hunk ./E/PrimOpt.hs 100
+-- | this creates a string representing the type of primitive optimization was
+-- performed for bookkeeping purposes
+
hunk ./E/PrimOpt.hs 146
-{-
-
-primOpt' dataTable  (EPrim (APrim s _) xs t) | Just n <- primopt s xs t = do
-    mtick (toAtom $ "E.PrimOpt." ++ braces (pprint s) ++ cextra s xs )
-    primOpt' dataTable  n  where
-
-        -- constant operations
-        primopt (Operator "+" [ta,tb] tr) [(ELit (LitInt l1 t1)),(ELit (LitInt l2 t2))] rt  = return $ (ELit (LitInt (l1 + l2) rt))
-        primopt (Operator "-" [ta,tb] tr) [(ELit (LitInt l1 t1)),(ELit (LitInt l2 t2))] rt  = return $ (ELit (LitInt (l1 - l2) rt))
-        primopt (Operator "*" [ta,tb] tr) [(ELit (LitInt l1 t1)),(ELit (LitInt l2 t2))] rt  = return $ (ELit (LitInt (l1 * l2) rt))
-        primopt (Operator "==" [ta,tb] tr) [(ELit (LitInt l1 t1)),(ELit (LitInt l2 t2))] rt  = return $ if l1 == l2 then iTrue else iFalse
-        primopt (Operator ">=" [ta,tb] tr) [(ELit (LitInt l1 t1)),(ELit (LitInt l2 t2))] rt  = return $ if l1 >= l2 then iTrue else iFalse
-        primopt (Operator "<=" [ta,tb] tr) [(ELit (LitInt l1 t1)),(ELit (LitInt l2 t2))] rt  = return $ if l1 <= l2 then iTrue else iFalse
-        primopt (Operator ">" [ta,tb] tr) [(ELit (LitInt l1 t1)),(ELit (LitInt l2 t2))] rt  = return $ if l1 > l2 then iTrue else iFalse
-        primopt (Operator "<" [ta,tb] tr) [(ELit (LitInt l1 t1)),(ELit (LitInt l2 t2))] rt  = return $ if l1 < l2 then iTrue else iFalse
-        primopt (Operator "-" [ta] tr) [ELit (LitInt x t)] rt | ta == tr && rt == t = return $ ELit (LitInt (negate x) t)
-        -- compare of equals
-        primopt (Operator "==" [ta,tb] tr) [e1,e2] rt | e1 == e2  = return iTrue
-        primopt (Operator ">=" [ta,tb] tr) [e1,e2] rt | e1 == e2  = return iTrue
-        primopt (Operator "<=" [ta,tb] tr) [e1,e2] rt | e1 == e2  = return iTrue
-        primopt (Operator ">" [ta,tb] tr) [e1,e2] rt | e1 == e2  = return iFalse
-        primopt (Operator "<" [ta,tb] tr) [e1,e2] rt | e1 == e2  = return iFalse
-        -- x + 0 = x
-        primopt (Operator "+" [ta,tb] tr) [e1,(ELit (LitInt 0 t))] rt  = return $ e1
-        primopt (Operator "+" [ta,tb] tr) [(ELit (LitInt 0 t)),e1] rt  = return $ e1
-        -- x * 0 = 0
-        primopt (Operator "*" [ta,tb] tr) [_,(ELit (LitInt 0 t))] rt  = return $ (ELit (LitInt 0 t))
-        primopt (Operator "*" [ta,tb] tr) [(ELit (LitInt 0 t)),_] rt  = return $ (ELit (LitInt 0 t))
-        -- x * 1 = x
-        primopt (Operator "*" [ta,tb] tr) [e1,(ELit (LitInt 1 t))] rt  = return $ e1
-        primopt (Operator "*" [ta,tb] tr) [(ELit (LitInt 1 t)),e1] rt  = return $ e1
-        -- x / 1 = x
-        primopt (Operator "/" [ta,tb] tr) [e1,(ELit (LitInt 1 t))] rt  = return $ e1
-        -- x / x = 1  - check for 0 / 0
-        --primopt (Operator "/" [ta,tb] tr) [e1,e2] rt | e1 == e2  = return $ (ELit (LitInt 1 rt))
-        -- 0 / x = 0  - check for 0 / 0
-        --primopt (Operator "/" [ta,tb] tr) [(ELit (LitInt 0 t)),_] rt  = return $ (ELit (LitInt 0 t))
-        -- x - 0 = x
-        primopt (Operator "-" [ta,tb] tr) [e1,(ELit (LitInt 0 t))] rt  = return $ e1
-        -- 0 - x = -x
-        primopt (Operator "-" [ta,tb] tr) [(ELit (LitInt 0 t)),e1] rt  = return $ EPrim (APrim (Operator "-" [ta] tr) mempty) [e1] rt
-        -- x << 0 = x, x >> 0 = x
-        primopt (Operator "<<" [ta,tb] tr) [e1,(ELit (LitInt 0 t))] rt  = return $ e1
-        primopt (Operator ">>" [ta,tb] tr) [e1,(ELit (LitInt 0 t))] rt  = return $ e1
-        -- x % 1 = 0
-        primopt (Operator "%" [ta,tb] tr) [e1,(ELit (LitInt 1 t))] rt  = return $ (ELit (LitInt 0 rt))
-        -- x % x = 0 - check for 0 % 0
-        --primopt (Operator "%" [ta,tb] tr) [e1,e2] rt | e1 == e2  = return $ (ELit (LitInt 0 rt))
-        -- 0 % x = 0 - check for 0 % 0
-        --primopt (Operator "%" [ta,tb] tr) [(ELit (LitInt 0 t)),_] rt  = return $ (ELit (LitInt 0 t))
-        -- eq to case
-        primopt (Operator "==" [ta,tb] tr) [e,(ELit (LitInt x t))] rt | isIntegral t  = return $ eCase e [Alt (LitInt x t) iTrue ] iFalse
-        primopt (Operator "==" [ta,tb] tr) [(ELit (LitInt x t)),e] rt | isIntegral t = return $ eCase e [Alt (LitInt x t) iTrue ] iFalse
-        -- cast of constant
-        primopt (CCast _ _) [ELit (LitInt x _)] t = return $ ELit (LitInt x t)  -- TODO ensure constant fits
-        primopt _ _ _ = fail "No primitive optimization to apply"
-primOpt' _  x = return x
--}
-
+-- | this is called once after conversion to E on all primitives, it performs various
+-- one time only transformations.
hunk ./E/PrimOpt.hs 186
+    primopt "options_target" [] t     = return (ELit (LitInt 0 t))
+    primopt pn [] t | Just c <- getPrefix "options_" pn      = return (EPrim (APrim (CConst ("JHC_" ++ c) "int") mempty) [] t)
hunk ./Grin/FromE.hs 414
-        pconst s = Prim (APrim CConst { primConst = s, primRetType = "int" } mempty) [] [tIntzh]
+--        pconst s = Prim (APrim CConst { primConst = s, primRetType = "int" } mempty) [] [tEnumzh]
hunk ./Grin/FromE.hs 417
-        f "options_target" [_] = do return $ Return [toUnVal (0::Int)]
-        f "options_isWindows" [_] = do return $ pconst "JHC_isWindows"
-        f "options_isPosix" [_] = do return $ pconst "JHC_isPosix"
-        f "options_isBigEndian" [_] = do return $ pconst "JHC_isBigEndian"
+--        f "options_target" [] = do return $ Return [Lit 0 tEnumzh]
+--        f "options_isWindows" [] = do return $ pconst "JHC_isWindows"
+--        f "options_isPosix" [] = do return $ pconst "JHC_isPosix"
+--        f "options_isBigEndian" [] = do return $ pconst "JHC_isBigEndian"
hunk ./Main.hs 528
-    let theTarget = ELit litCons { litName = dc_Target, litArgs = [ELit (LitInt targetIndex tEnumzh)], litType = ELit litCons { litName = tc_Target, litArgs = [], litType = eStar } }
-        targetIndex = if viaGhc then 1 else 0
-    prog <- return $ runIdentity $ flip programMapDs prog $ \(t,e) -> return $ if tvrIdent t == toId v_target then (t { tvrInfo = setProperty prop_INLINE mempty },theTarget) else (t,e)
-
hunk ./data/names.txt 83
-target           Jhc.Options.target