diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for language-bluespec + +## 0.1 -- 2024-02-08 + +* Initial version of `language-bluespec`. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2022, Ryan Scott + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ryan Scott nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,13 @@ +# `language-bluespec` + +This package contains an implementation of the +[Bluespec](http://wiki.bluespec.com/) AST. In particular, this implements the +Bluespec Haskell (BH) syntax, also known as Bluespec Classic. We may add +support for the Bluespec SystemVerilog (BSV) syntax at a later date. + +To our knowledge, there is no formal grammar that describes the syntax of BH or +BSV, so this package is based off of the code in the [Bluespec +compiler](https://github.com/B-Lang-org/bsc). Although the Bluespec compiler is +written in Haskell, it is not particularly simple to depend on the compiler as +a library, so this package exists to extract out the relevant compiler code +into a simple-to-use library. diff --git a/language-bluespec.cabal b/language-bluespec.cabal new file mode 100644 --- /dev/null +++ b/language-bluespec.cabal @@ -0,0 +1,77 @@ +cabal-version: 1.24 +name: language-bluespec +version: 0.1 +synopsis: An implementation of the Bluespec Haskell AST +description: This package contains an implementation of the + language's AST. In + particular, this implements the Bluespec Haskell (BH) + syntax, also known as Bluespec Classic. We may add support + for the Bluespec SystemVerilog (BSV) syntax at a later date. + + To our knowledge, there is no formal grammar that describes + the syntax of BH or BSV, so this package is based off of the + code in the . Although the Bluespec compiler is written in + Haskell, it is not particularly simple to depend on the + compiler as a library, so this package exists to extract out + the relevant compiler code into a simple-to-use library. +homepage: https://github.com/GaloisInc/language-bluespec +bug-reports: https://github.com/GaloisInc/language-bluespec/issues +license: BSD3 +license-file: LICENSE +author: Galois, Inc. +maintainer: Ryan Scott +stability: Experimental +copyright: (C) 2020-2022 Bluespec Inc., (C) 2022 Galois, Inc. +category: Language +build-type: Simple +extra-source-files: CHANGELOG.md, README.md +tested-with: GHC == 8.6.5 + , GHC == 8.8.4 + , GHC == 8.10.7 + , GHC == 9.0.2 + , GHC == 9.2.2 + , GHC == 9.4.8 + , GHC == 9.6.4 + , GHC == 9.8.1 + +source-repository head + type: git + location: https://github.com/GaloisInc/language-bluespec + +library + exposed-modules: Language.Bluespec.Classic.AST + Language.Bluespec.Classic.AST.FString + Language.Bluespec.Classic.AST.Id + Language.Bluespec.Classic.AST.IntLit + Language.Bluespec.Classic.AST.Literal + Language.Bluespec.Classic.AST.Position + Language.Bluespec.Classic.AST.Pragma + Language.Bluespec.Classic.AST.SchedInfo + Language.Bluespec.Classic.AST.SString + Language.Bluespec.Classic.AST.Syntax + Language.Bluespec.Classic.AST.Type + Language.Bluespec.Classic.AST.Undefined + Language.Bluespec.Classic.AST.VModInfo + + Language.Bluespec.Classic.AST.Builtin.FStrings + Language.Bluespec.Classic.AST.Builtin.Ids + Language.Bluespec.Classic.AST.Builtin.Types + + Language.Bluespec.Lex + Language.Bluespec.Pretty + other-modules: Language.Bluespec.IntegerUtil + Language.Bluespec.Log2 + Language.Bluespec.Prelude + Language.Bluespec.Util + default-extensions: NoImplicitPrelude + build-depends: base >= 4.12 && < 5 + , containers >= 0.1 && < 0.7 + , pretty >= 1.1.2 && < 1.2 + , text >= 0.1 && < 2.2 + + if !impl(ghc >= 9.0) + build-depends: integer-gmp + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall diff --git a/src/Language/Bluespec/Classic/AST.hs b/src/Language/Bluespec/Classic/AST.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bluespec/Classic/AST.hs @@ -0,0 +1,27 @@ +module Language.Bluespec.Classic.AST + ( module Language.Bluespec.Classic.AST.FString + , module Language.Bluespec.Classic.AST.Id + , module Language.Bluespec.Classic.AST.IntLit + , module Language.Bluespec.Classic.AST.Literal + , module Language.Bluespec.Classic.AST.Position + , module Language.Bluespec.Classic.AST.Pragma + , module Language.Bluespec.Classic.AST.SchedInfo + , module Language.Bluespec.Classic.AST.SString + , module Language.Bluespec.Classic.AST.Syntax + , module Language.Bluespec.Classic.AST.Type + , module Language.Bluespec.Classic.AST.Undefined + , module Language.Bluespec.Classic.AST.VModInfo + ) where + +import Language.Bluespec.Classic.AST.FString +import Language.Bluespec.Classic.AST.Id +import Language.Bluespec.Classic.AST.IntLit +import Language.Bluespec.Classic.AST.Literal +import Language.Bluespec.Classic.AST.Position +import Language.Bluespec.Classic.AST.Pragma +import Language.Bluespec.Classic.AST.SchedInfo +import Language.Bluespec.Classic.AST.SString +import Language.Bluespec.Classic.AST.Syntax +import Language.Bluespec.Classic.AST.Type +import Language.Bluespec.Classic.AST.Undefined +import Language.Bluespec.Classic.AST.VModInfo diff --git a/src/Language/Bluespec/Classic/AST/Builtin/FStrings.hs b/src/Language/Bluespec/Classic/AST/Builtin/FStrings.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bluespec/Classic/AST/Builtin/FStrings.hs @@ -0,0 +1,516 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +-- This corresponds to src/Comp/PreStrings.hs in bsc. +module Language.Bluespec.Classic.AST.Builtin.FStrings where + +import Language.Bluespec.Classic.AST.FString +import Language.Bluespec.Prelude +import Language.Bluespec.Util + +fsEmpty = mkFString "" +fsUnderscore = mkFString "_" +fsUnderUnder = mkFString "__" +fsDot = mkFString "." +fsRArrow = mkFString "->" +fsBar = mkFString "|" +fsStar = mkFString "*" +fsSlash = mkFString "/" +fsPercent = mkFString "%" +fsStarStar = mkFString "**" +fsHash = mkFString "#" +fsTilde = mkFString "~" +fsTyJoin = mkFString "_$" +fsAssign = mkFString ":=" +fsDollar = mkFString "$" +fsLT = mkFString "<" +fsGT = mkFString ">" +fsLTGT = mkFString "<>" +fsComma = mkFString "," +fsPlus = mkFString "+" +fsMinus = mkFString "-" +fsLsh = mkFString "<<" +fsRsh = mkFString ">>" +fsLtEq = mkFString "<=" +fsGtEq = mkFString ">=" +-- | Scheduling conflict operator for Classic +fsConfOp = mkFString "><" +fsPrelude = mkFString "Prelude" +fsPreludeBSV = mkFString "PreludeBSV" +fsPrimUnit = mkFString "PrimUnit" +fsBit = mkFString "Bit" +fsInt = mkFString "Int" +fsUInt = mkFString "UInt" +fsClock = mkFString "Clock" +fsClockOsc = mkFString "osc" +fsClockGate = mkFString "gate" +fsReset = mkFString "Reset" +fsInout = mkFString "Inout" +fsInout_ = mkFString "Inout_" +fsPrimInoutCast = mkFString "primInoutCast" +fsPrimInoutUncast = mkFString "primInoutUncast" +fsPrimInoutCast0 = mkFString "primInoutCast0" +fsPrimInoutUncast0 = mkFString "primInoutUncast0" +fsInteger = mkFString "Integer" +fsReal = mkFString "Real" +fsMonad = mkFString "Monad" +fsString = mkFString "String" +fsChar = mkFString "Char" +fsHandle = mkFString "Handle" +fsBufferMode = mkFString "BufferMode" +fsNoBuffering = mkFString "NoBuffering" +fsLineBuffering = mkFString "LineBuffering" +fsBlockBuffering = mkFString "BlockBuffering" +fsFmt = mkFString "Fmt" +fsPrimFmtConcat = mkFString "primFmtConcat" +fsPrimPriMux = mkFString "primPriMux" +fsFormat = mkFString "$format" +fsFShow = mkFString "FShow" +fsfshow = mkFString "fshow" +fsBool = mkFString "Bool" +fsPrimFst = mkFString "fst" +fsPrimSnd = mkFString "snd" +fsPrimPair = mkFString "PrimPair" +fsTrue = mkFString "True" +fsFalse = mkFString "False" +fsSizeOf = mkFString "SizeOf" +fsEq = mkFString "Eq" +fsBits = mkFString "Bits" +fsLiteral = mkFString "Literal" +fsRealLiteral = mkFString "RealLiteral" +fsSizedLiteral = mkFString "SizedLiteral" +fsStringLiteral = mkFString "StringLiteral" +fsPrimParam = mkFString "PrimParam" +fsPrimPort = mkFString "PrimPort" +fsPrimToParam = mkFString "primToParam" +fsPrimToPort = mkFString "primToPort" +fsPrimSeqCond = mkFString "primSeqCond" +fsPrimDeepSeqCond = mkFString "primDeepSeqCond" +fsClsDeepSeqCond = mkFString "PrimDeepSeqCond" +fsUndefined = mkFString "PrimMakeUndefined" +fsBuildUndef = mkFString "primBuildUndefined" +fsMakeUndef = mkFString "primMakeUndefined" +fsRawUndef = mkFString "primMakeRawUndefined" +fsEqual = mkFString "==" +fsNotEqual = mkFString "/=" +fsPrimOrd = mkFString "primOrd" +fsPrimChr = mkFString "primChr" +fsPack = mkFString "pack" +fsUnpack = mkFString "unpack" +fsVReg = mkFString "VReg" +fsReg = mkFString "Reg" +fsRWire = mkFString "RWire" +fsPulseWire = mkFString "PulseWire" +fsFIFO = mkFString "FIFO" +fsFIFOF = mkFString "FIFOF" +fsAction = mkFString "Action" +fsPrimAction = mkFString "PrimAction" +fsToPrimAction = mkFString "toPrimAction" +fsFromPrimAction = mkFString "fromPrimAction" +fsToActionValue_ = mkFString "toActionValue_" +fsFromActionValue_ = mkFString "fromActionValue_" +fsActionValue = mkFString "ActionValue" +fsAVValue = mkFString "avValue" +fsAVAction = mkFString "avAction" +fsActionValue_ = mkFString "ActionValue_" +fsAVValue_ = mkFString "avValue_" +fsAVAction_ = mkFString "avAction_" +fs__value = mkFString "__value" +fs__action = mkFString "__action" +fsMethodReturn = mkFString "method_return" +fsRules = mkFString "Rules" +fsSchedPragma = mkFString "SchedPragma" +fsModule = mkFString "Module" +fsId = mkFString "Id__" +fsPred = mkFString "Pred__" +fsIsModule = mkFString "IsModule" +fsPrimModule = mkFString "primModule" +fsName = mkFString "Name__" +fsGetModuleName = mkFString "primGetModuleName" +fsPosition = mkFString "Position__" +fsType = mkFString "Type" +fsTypeOf = mkFString "typeOf" +fsSavePortType = mkFString "primSavePortType" +fsPrintType = mkFString "printType" +fsNoPosition = mkFString "noPosition" +fsPrimGetEvalPosition = mkFString "primGetEvalPosition" +fsPrimGetName = mkFString "primGetName" +fsPrimGetParamName = mkFString "primGetParamName" +fsPrimJoinNames = mkFString "primJoinNames" +fsPrimExtNameIdx = mkFString "primExtendNameIndex" +fsSetStateName = mkFString "setStateName" +fsForceIsModule = mkFString "forceIsModule" +fsAttributes = mkFString "Attributes__" +fsSetStateAttrib = mkFString "setStateAttrib" +fsAdd = mkFString "Add" +fsMax = mkFString "Max" +fsMin = mkFString "Min" +fsLog = mkFString "Log" +fsMul = mkFString "Mul" +fsDiv = mkFString "Div" +fsNumEq = mkFString "NumEq" +fsAnd = mkFString "&&" +fsOr = mkFString "||" +fsBitAnd = mkFString "&" +fsBitOr = mkFString "|" +fsCaret = mkFString "^" +fsTildeCaret = mkFString "~^" +fsCaretTilde = mkFString "^~" +fsReduceAnd = mkFString "reduceAnd" +fsReduceOr = mkFString "reduceOr" +fsReduceXor = mkFString "reduceXor" +fsReduceNand = mkFString "reduceNand" +fsReduceNor = mkFString "reduceNor" +fsReduceXnor = mkFString "reduceXnor" +fsNot = mkFString "not" +fsPrimSplit = mkFString "primSplit" +fsPrimConcat = mkFString "primConcat" +fsPrimMul = mkFString "primMul" +fsPrimQuot = mkFString "primQuot" +fsPrimRem = mkFString "primRem" +fsPrimTrunc = mkFString "primTrunc" +fs_lam = mkFString "_lam" +fs_if = mkFString "_if" +fs_read = mkFString "_read" +fs_write = mkFString "_write" +fsAsIfc = mkFString "asIfc" +fsAsReg = mkFString "asReg" +fsRead = mkFString "read" +fsRegWrite = mkFString "write" +fsExtract = mkFString "primExtract" +fsFromInteger = mkFString "fromInteger" +fsFromReal = mkFString "fromReal" +fsFromSizedInteger = mkFString "fromSizedInteger" +fsFromString = mkFString "fromString" +fsPrimCharToString = mkFString "primCharToString" +fs_case = mkFString "_case" +fsPrimWhen = mkFString "_when" +fsBind = mkFString "bind" +fsBind_ = mkFString "bind_" +fsReturn = mkFString "return" +fs_x = mkFString "_x" +fs_y = mkFString "_y" +fs_fun = mkFString "_fun" +fs_forallb = mkFString "_forallb" +fsBounded = mkFString "Bounded" +fsMaxBound = mkFString "maxBound" +fsMinBound = mkFString "minBound" +fsDefaultValue = mkFString "DefaultValue" +fs_defaultValue = mkFString "defaultValue" +fsPrimSplitFst = mkFString "primSplitFst" +fsPrimSplitSnd = mkFString "primSplitSnd" +fsTo = mkFString "to" +fsFrom = mkFString "from" +fs_t = mkFString "_t" +fsMux = mkFString "MUX_" +fsMuxSel = mkFString "SEL" +fsMuxPreSel = mkFString "PSEL" +fsMuxVal = mkFString "VAL" +fsEnable = mkFString "EN_" +fs_rdy = mkFString "RDY_" +fs_rl = mkFString "RL_" +fs_unnamed = mkFString "unnamed" +s_unnamed = "unnamed" +fs_T = mkFString "_T" +fs_F = mkFString "_F" +fsCanFire = mkFString "CAN_FIRE_" +fsWillFire = mkFString "WILL_FIRE_" +fsCLK = mkFString "CLK" +fsCLK_GATE = mkFString "CLK_GATE" +-- fsRSTN = mkFString "RST" +fsDefaultClock = mkFString "default_clock" +fsDefaultReset = mkFString "default_reset" +fsPrimStringConcat = mkFString "primStringConcat" +fsNoinline = mkFString "noinline" +fsLiftM = mkFString "liftM" +fsLiftModule = mkFString "liftModule" +fsPrimBAnd = mkFString "primBAnd" +fsPrimBOr = mkFString "primBOr" +fsPrimBNot = mkFString "primBNot" +fsPrimIf = mkFString "primIf" +fsPrimCase = mkFString "primCase" +fsPrimArrayDynSelect = mkFString "primArrayDynSelect" +fsPrimBuildArray = mkFString "primBuildArray" +fsPrimSelect = mkFString "primSelect" +fsPrimSelectable = mkFString "PrimSelectable" +fsPrimUpdateable = mkFString "PrimUpdateable" +fsPrimWriteable = mkFString "PrimWriteable" +fsPrimSelectFn = mkFString "primSelectFn" +fsPrimUpdateFn = mkFString "primUpdateFn" +fsPrimWriteFn = mkFString "primWriteFn" +fsPrimIndex = mkFString "PrimIndex" +fsPrimUpdateRangeFn = mkFString "primUpdateRangeFn" +fsPrimZeroExt = mkFString "primZeroExt" +fsPrimSignExt = mkFString "primSignExt" +fsPrimValueOf = mkFString "primValueOf" +fsPrimStringOf = mkFString "primStringOf" +fsStringProxy = mkFString "StringProxy" +fsPrimJoinRules = mkFString "primJoinRules" +fsPrimNoRules = mkFString "primNoRules" +fsPrimRule = mkFString "primRule" +fsPrimAddSchedPragmas = mkFString "primAddSchedPragmas" +fsPrimJoinActions = mkFString "primJoinActions" +fsPrimNoActions = mkFString "primNoActions" +fsPrimNoExpIf = mkFString "primNoExpIf" +fsPrimExpIf = mkFString "primExpIf" +fsPrimNosplitDeep = mkFString "primNosplitDeep" +fsPrimSplitDeep = mkFString "primSplitDeep" +fsSplitDeepAV = mkFString "splitDeepAV" +fsNosplitDeepAV = mkFString "nosplitDeepAV" +fsPrimInv = mkFString "primInv" +fsPrimEQ = mkFString "primEQ" +fsPrimULE = mkFString "primULE" +fsPrimULT = mkFString "primULT" +fsPrimSLE = mkFString "primSLE" +fsPrimSLT = mkFString "primSLT" +fsPrimSL = mkFString "primSL" +fsPrimSRL = mkFString "primSRL" +fsPrimAdd = mkFString "primAdd" +fsPrimSub = mkFString "primSub" +fsClsUninitialized = mkFString "PrimMakeUninitialized" +fsPrimUninitialized = mkFString "primUninitialized" +fsPrimMakeUninitialized = mkFString "primMakeUninitialized" +fsPrimRawUninitialized= mkFString "primMakeRawUninitialized" +fsPrimPoisonedDef = mkFString "primPoisonedDef" +fsChangeSpecialWires = mkFString "changeSpecialWires" +fsPrimSetSelPosition = mkFString "primSetSelPosition" +fsTAdd = mkFString "TAdd" +fsTSub = mkFString "TSub" +fsTMul = mkFString "TMul" +fsTDiv = mkFString "TDiv" +fsTLog = mkFString "TLog" +fsTExp = mkFString "TExp" +fsTMax = mkFString "TMax" +fsTMin = mkFString "TMin" +fsStaticAssert = mkFString "staticAssert" +fsDynamicAssert = mkFString "dynamicAssert" +fsContinuousAssert = mkFString "continuousAssert" +fs_staticAssert = mkFString "_staticAssert" +fs_dynamicAssert = mkFString "_dynamicAssert" +fs_continuousAssert= mkFString "_continuousAssert" +fsAddRules = mkFString "addRules" +fsASSERT = mkFString "ASSERT" +fsFire = mkFString "fire" +fsEnabled = mkFString "enabled" +fsNo = mkFString "no" +fsImplicit = mkFString "implicit" +fsConditions = mkFString "conditions" +fsCan = mkFString "can" +fsSchedule = mkFString "schedule" +fsFirst = mkFString "first" +fsClockCrossing = mkFString "clock-crossing" +fsAggressiveImplicitConditions = mkFString "aggressive_implicit_conditions" +fsConservativeImplicitConditions = mkFString "conservative_implicit_conditions" +fsNoWarn = mkFString "no_warn" +fsWarnAllConflicts = mkFString "warn_all_conflicts" +fsRule = mkFString "rule" +fsMkRegU = mkFString "mkRegU" +fsPrimFix = mkFString "primFix" +fsMfix = mkFString "mfix" +fsFmap = mkFString "fmap" +fsNegate = mkFString "negate" +fsIdentity = mkFString "id" +fsInvert = mkFString "invert" +fsEmptyIfc = mkFString "Empty" +fs1 = mkFString "1" +fsB = mkFString "B" +fsR = mkFString "R" +fsExposeCurrentClock = mkFString "exposeCurrentClock" +fsExposeCurrentReset = mkFString "exposeCurrentReset" +fsNoClock = mkFString "noClock" +fsNoReset = mkFString "noReset" +fsPrimReplaceClockGate = mkFString "primReplaceClockGate" +fsVRWireN = mkFString "VRWireN" +fsVmkRWire1 = mkFString "vMkRWire1" +fsWGet = mkFString "wget" +fsWSet = mkFString "wset" +fsWHas = mkFString "whas" +fsSend = mkFString "send" +fsFIFO_notFull = mkFString "i_notFull" +fsFIFO_notEmpty = mkFString "i_notEmpty" +fsFIFOEnq = mkFString "enq" +fsFIFODeq = mkFString "deq" +fsFIFOFirst = mkFString "first" +fsGeneric = mkFString "Generic" +fsConc = mkFString "Conc" +fsConcPrim = mkFString "ConcPrim" +fsConcPoly = mkFString "ConcPoly" +fsMeta = mkFString "Meta" +fsMetaData = mkFString "MetaData" +fsStarArg = mkFString "StarArg" +fsNumArg = mkFString "NumArg" +fsStrArg = mkFString "StrArg" +fsConArg = mkFString "ConArg" +fsMetaConsNamed = mkFString "MetaConsNamed" +fsMetaConsAnon = mkFString "MetaConsAnon" +fsMetaField = mkFString "MetaField" +fsPolyWrapField = mkFString "val" + +-- XXX low ASCII only, please... +sAcute = "__" +fsAcute = mkFString sAcute +fsTheResult = mkFString "_theResult__" +fsF = mkFString "_f__" +fsM = mkFString "_m__" +fsC = mkFString "_c__" +fsClk = mkFString "_clk__" +fsRst = mkFString "_rst__" +fsList = mkFString "List" +fsPrimArray = mkFString "Array" +fsPrimArrayNew = mkFString "primArrayNew" +fsPrimArrayNewU = mkFString "primArrayNewU" +fsPrimArrayLength = mkFString "primArrayLength" +fsPrimArrayInitialize = mkFString "primArrayInitialize" +fsPrimArrayCheck = mkFString "primArrayCheck" +fsListN = mkFString "ListN" +fsVector = mkFString "Vector" +fsToVector = mkFString "toVector" +fsToListN = mkFString "toListN" +fsSAction = mkFString "SAction" +fsSActionValue = mkFString "SActionValue" +fsStmtify = mkFString "stmtify" +fsCallServer = mkFString "callServer" +fsSIf1 = mkFString "SIf1" +fsSIf2 = mkFString "SIf2" +fsSAbtIf1 = mkFString "SAbtIf1" +fsSAbtIf2 = mkFString "SAbtIf2" +fsSRepeat = mkFString "SRepeat" +fsSWhile = mkFString "SWhile" +fsSFor = mkFString "SFor" +fsSSeq = mkFString "SSeq" +fsSPar = mkFString "SPar" +fsSLabel = mkFString "SLabel" +fsSJump = mkFString "SJump" +fsSNamed = mkFString "SNamed" +fsS = mkFString "S" +fsStmt = mkFString "stmt" +fsSBreak = mkFString "SBreak" +fsSContinue = mkFString "SContinue" +fsSReturn = mkFString "SReturn" +fsCons = mkFString "Cons" +fsConcat = mkFString "concat" +fsNil = mkFString "Nil" +fsNothing = mkFString "Nothing" +fsSprime = mkFString "_s__" +fsMaybe = mkFString "Maybe" +fsInvalid = mkFString "Invalid" +fsValid = mkFString "Valid" +fsEither = mkFString "Either" +fsLeft = mkFString "Left" +fsRight = mkFString "Right" +-- | Names used for tuple fields internally? +fsTuples = map mkFString ["_"++ itos i | i <- [1..25::Int]] +-- | Names exposed to the BSV user +fsTuple2 = mkFString "Tuple2" +fsTuple3 = mkFString "Tuple3" +fsTuple4 = mkFString "Tuple4" +fsTuple5 = mkFString "Tuple5" +fsTuple6 = mkFString "Tuple6" +fsTuple7 = mkFString "Tuple7" +fsTuple8 = mkFString "Tuple8" +fsConstAllBitsSet = mkFString "constantWithAllBitsSet" +fsConstAllBitsUnset= mkFString "constantWithAllBitsUnset" +fs_the_ = mkFString "the_" +s__fire = "_fire" +fs__fire = mkFString s__fire + + +fsPrimError = mkFString "primError" + +-- XXX should be a system task? +fsError = mkFString "error" + +-- system task strings +fsFinish = mkFString "$finish" +fsStop = mkFString "$stop" +fsDisplay = mkFString "$display" +fsDisplayh = mkFString "$displayh" +fsDisplayb = mkFString "$displayb" +fsDisplayo = mkFString "$displayo" +fsWrite = mkFString "$write" +fsWriteh = mkFString "$writeh" +fsWriteb = mkFString "$writeb" +fsWriteo = mkFString "$writeo" + +fsFDisplay = mkFString "$fdisplay" +fsFDisplayh = mkFString "$fdisplayh" +fsFDisplayb = mkFString "$fdisplayb" +fsFDisplayo = mkFString "$fdisplayo" +fsFWrite = mkFString "$fwrite" +fsFWriteh = mkFString "$fwriteh" +fsFWriteb = mkFString "$fwriteb" +fsFWriteo = mkFString "$fwriteo" +fsSWriteAV = mkFString "$swriteAV" +fsSWrite = mkFString "$swrite" +fsSWritehAV = mkFString "$swritehAV" +fsSWriteh = mkFString "$swriteh" +fsSWritebAV = mkFString "$swritebAV" +fsSWriteb = mkFString "$swriteb" +fsSWriteoAV = mkFString "$swriteoAV" +fsSWriteo = mkFString "$swriteo" +fsSFormatAV = mkFString "$sformatAV" +fsSFormat = mkFString "$sformat" + +fsErrorTask = mkFString "$error" +fsWarnTask = mkFString "$warning" +fsInfoTask = mkFString "$info" +fsFatalTask = mkFString "$fatal" + +fsSVA = mkFString "$SVA" +fsSvaParam = mkFString "SvaParam" +fsSvaBool = mkFString "SvaBool" +fsSvaNumber = mkFString "SvaNumber" + +fsSVAsampled = mkFString "$sampled" +fsSVArose = mkFString "$rose" +fsSVAfell = mkFString "$fell" +fsSVAstable = mkFString "$stable" +fsSVApast = mkFString "$past" +fsSVAonehot = mkFString "$onehot" +fsSVAonehot0 = mkFString "$onehot0" +fsSVAisunknown = mkFString "$isunknown" +fsSVAcountones = mkFString "$countones" + +fsRandom = mkFString "$random" + +fsDumpon = mkFString "$dumpon" +fsDumpoff = mkFString "$dumpoff" +fsDumpvars = mkFString "$dumpvars" +fsDumpall = mkFString "$dumpall" +fsDumplimit = mkFString "$dumplimit" +fsDumpflush = mkFString "$dumpflush" +fsDumpfile = mkFString "$dumpfile" +fsSigned = mkFString "$signed" +sSigned = "$signed" +fsUnsigned = mkFString "$unsigned" +sUnsigned = "$unsigned" +fsTime = mkFString "$time" +fsSTime = mkFString "$stime" +fsFOpen = mkFString "$fopen" +fsFGetc = mkFString "$fgetc" +fsUngetc = mkFString "$ungetc" +fsFClose = mkFString "$fclose" +fsFFlush = mkFString "$fflush" +fsTestPlusargs = mkFString "$test$plusargs" +fsRealToBits = mkFString "$realtobits" +fsBitsToReal = mkFString "$bitstoreal" + +fsFile = mkFString "File" + + +-- | Classes hardcoded in the Prelude which were added for ContextErrors +fsBitwise, fsBitReduce, fsBitExtend, fsArith, fsOrd :: FString +fsBitwise = mkFString "Bitwise" +fsBitReduce = mkFString "BitReduction" +fsBitExtend = mkFString "BitExtend" +fsArith = mkFString "Arith" +fsOrd = mkFString "Ord" + +-- | Nice display names for instance hierarchy +fsLoop, fsBody :: FString +fsLoop = mkFString "Loop" +fsBody = mkFString "Body" + +fsHide, fsHideAll, fsElements, fsvElements :: FString +fsHide = mkFString "hide" +fsHideAll = mkFString "hide_all" +fsElements = mkFString "_elements" +fsvElements = mkFString "_velements" diff --git a/src/Language/Bluespec/Classic/AST/Builtin/Ids.hs b/src/Language/Bluespec/Classic/AST/Builtin/Ids.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bluespec/Classic/AST/Builtin/Ids.hs @@ -0,0 +1,735 @@ +-- This corresponds to src/Comp/PreIds.hs in bsc. +module Language.Bluespec.Classic.AST.Builtin.Ids where + +import Language.Bluespec.Classic.AST.Builtin.FStrings +import Language.Bluespec.Classic.AST.FString +import Language.Bluespec.Classic.AST.Id +import Language.Bluespec.Classic.AST.Position +import Language.Bluespec.Prelude + +-- | Identifier without a position +mk_no :: FString -> Id +mk_no fs = mkId noPosition fs + +-- | Identifier in the Standard Prelude, with a position +prelude_id :: Position -> FString -> Id +prelude_id p fs = mkQId p fsPrelude fs + +-- | Identifier in the Standard Prelude, with no position +prelude_id_no :: FString -> Id +prelude_id_no fs = prelude_id noPosition fs + +-- | Identifier in the Standard Prelude, with a position +prelude_bsv_id :: Position -> FString -> Id +prelude_bsv_id p fs = mkQId p fsPreludeBSV fs + +-- | Identifier in the Standard Prelude, with no position +prelude_bsv_id_no :: FString -> Id +prelude_bsv_id_no fs = prelude_bsv_id noPosition fs + +-- | Add id properties to an already existing identifier +prop_prelude_id_no :: FString -> [IdProp] -> Id +prop_prelude_id_no fs props = + addIdProps (prelude_id (updatePosStdlib noPosition True) fs) props + +idB, idR :: Id +idB = prelude_id_no fsB +idR = prelude_id_no fsR +idArrow :: Position -> Id +idArrow p = prelude_id p fsRArrow +idPrimUnit, idBit, idInt, idUInt, idVReg, idReg, idRWire, idPulseWire :: Id +idPrimUnit = prelude_id_no fsPrimUnit +idBit = prelude_id_no fsBit +idInt = prelude_id_no fsInt +idUInt = prelude_id_no fsUInt +idVReg = prelude_id_no fsVReg +idReg = prelude_id_no fsReg +idRWire = prelude_bsv_id_no fsRWire +idPulseWire = prelude_bsv_id_no fsPulseWire +idFIFO, idFIFOF, idSend, id_notFull, id_notEmpty, idEnq, idDeq, idFirst :: Id +idFIFO = mkQId noPosition fsFIFO fsFIFO +idFIFOF = mkQId noPosition fsFIFOF fsFIFOF +idSend = prelude_bsv_id_no fsSend +id_notFull = mk_no fsFIFO_notFull +id_notEmpty = mk_no fsFIFO_notEmpty +idEnq = mk_no fsFIFOEnq +idDeq = mk_no fsFIFODeq +idFirst = mk_no fsFIFOFirst +idInteger, idReal :: Id +idInteger = prelude_id_no fsInteger +idReal = prelude_id_no fsReal +idRealAt :: Position -> Id +idRealAt pos = prelude_id pos fsReal +idString, idChar, idHandle, idBufferMode, idNoBuffering, idLineBuffering :: Id +idString = prelude_id_no fsString +idChar = prelude_id_no fsChar +idHandle = prelude_id_no fsHandle +idBufferMode = prelude_id_no fsBufferMode +idNoBuffering = prelude_id_no fsNoBuffering +idLineBuffering = prelude_id_no fsLineBuffering +idBlockBuffering, idFmt, idPrimFmtConcat, idPrimPriMux, idFormat, idFShow :: Id +idBlockBuffering = prelude_id_no fsBlockBuffering +idFmt = prelude_id_no fsFmt +idPrimFmtConcat = prelude_id_no fsPrimFmtConcat +idPrimPriMux = prelude_id_no fsPrimPriMux +idFormat = prelude_id_no fsFormat +idFShow = prelude_id_no fsFShow +idfshow, idBool, idPrimFst, idPrimSnd, idPrimPair, idFalse, idTrue :: Id +idfshow = prelude_id_no fsfshow +idBool = prelude_id_no fsBool +idPrimFst = prelude_id_no fsPrimFst +idPrimSnd = prelude_id_no fsPrimSnd +idPrimPair = prelude_id_no fsPrimPair +idFalse = prelude_id_no fsFalse +idTrue = prelude_id_no fsTrue +idSizeOf, idTAdd, idTSub, idTMul, idTDiv, idTLog, idTExp, idTMax, idTMin :: Id +idSizeOf = prelude_id_no fsSizeOf +idTAdd = prelude_id_no fsTAdd +idTSub = prelude_id_no fsTSub +idTMul = prelude_id_no fsTMul +idTDiv = prelude_id_no fsTDiv +idTLog = prelude_id_no fsTLog +idTExp = prelude_id_no fsTExp +idTMax = prelude_id_no fsTMax +idTMin = prelude_id_no fsTMin +idAction, idPrimAction, idToPrimAction, idFromPrimAction :: Id +idAction = prelude_id_no fsAction +idPrimAction = prelude_id_no fsPrimAction +idToPrimAction = prelude_id_no fsToPrimAction +idFromPrimAction = prelude_id_no fsFromPrimAction +idFromActionValue_, idToActionValue_, idRules, idSchedPragma, idValueOf, idStringOf, idStringProxy :: Id +idFromActionValue_ = prelude_id_no fsFromActionValue_ +idToActionValue_ = prelude_id_no fsToActionValue_ +idRules = prelude_id_no fsRules +idSchedPragma = prelude_id_no fsSchedPragma +idValueOf = prelude_id_no fsPrimValueOf +idStringOf = prelude_id_no fsPrimStringOf +idStringProxy = prelude_id_no fsStringProxy +idPrimIndex, idPrimSelectable, idPrimUpdateable, idPrimWriteable :: Id +idPrimIndex = prelude_id_no fsPrimIndex +idPrimSelectable = prelude_id_no fsPrimSelectable +idPrimUpdateable = prelude_id_no fsPrimUpdateable +idPrimWriteable = prelude_id_no fsPrimWriteable +idChangeSpecialWires :: Position -> Id +idChangeSpecialWires pos = prelude_id pos fsChangeSpecialWires +idPrimSetSelPosition, idMaybe, idInvalid, idValid, idEmpty, idFile :: Id +idPrimSetSelPosition = prelude_id_no fsPrimSetSelPosition +idMaybe = prelude_id_no fsMaybe +idInvalid = prelude_id_no fsInvalid +idValid = prelude_id_no fsValid +idEmpty = prelude_id_no fsEmptyIfc +idFile = prelude_id_no fsFile +idEither, idLeft, idRight :: Id +idEither = prelude_id_no fsEither +idLeft = prelude_id_no fsLeft +idRight = prelude_id_no fsRight + +idActionValue :: Id +idActionValue = prelude_id_no fsActionValue +-- field names for the ActionValue interface +idAVValue, idAVAction :: Id +idAVValue = prelude_id_no fsAVValue +idAVAction = prelude_id_no fsAVAction + +idActionValue_ :: Id +idActionValue_ = prelude_id_no fsActionValue_ +-- field names for the ActionValue_ interface +idAVValue_, idAVAction_ :: Id +idAVValue_ = prelude_id_no fsAVValue_ +idAVAction_ = prelude_id_no fsAVAction_ + +-- names of the special selector functions in the Prelude +id__value, id__action :: Id +id__value = prelude_id_no fs__value +id__action = prelude_id_no fs__action +id__value_at, id__action_at :: Position -> Id +id__value_at pos = prelude_id pos fs__value +id__action_at pos = prelude_id pos fs__action + +idComma, idPlus, idMinus, idPrelude, idPreludeBSV :: Id +idComma = mk_no fsComma +idPlus = mk_no fsPlus +idMinus = mk_no fsMinus +idPrelude = mk_no fsPrelude +idPreludeBSV = mk_no fsPreludeBSV + +idPreludePlus :: Id +idPreludePlus = prelude_id_no fsPlus + +-- Used by deriving +idEq, idBits, idLiteral, idRealLiteral, idSizedLiteral, idStringLiteral :: Id +idEq = prelude_id_no fsEq +idBits = prelude_id_no fsBits +idLiteral = prelude_id_no fsLiteral +idRealLiteral = prelude_id_no fsRealLiteral +idSizedLiteral = prelude_id_no fsSizedLiteral +idStringLiteral = prelude_id_no fsStringLiteral +idPrimParam, idPrimPort, idBounded, idDefaultValue, id_defaultValue, idClsDeepSeqCond, idPrimDeepSeqCond :: Id +idPrimParam = prelude_id_no fsPrimParam +idPrimPort = prelude_id_no fsPrimPort +idBounded = prelude_id_no fsBounded +idDefaultValue = prelude_id_no fsDefaultValue +id_defaultValue = prelude_id_no fs_defaultValue +idClsDeepSeqCond = prelude_id_no fsClsDeepSeqCond +idPrimDeepSeqCond = prelude_id_no fsPrimDeepSeqCond +idPrimSeqCond, idUndefined, idEqual, idNotEqual, idPack, idUnpack, idFmap :: Id +idPrimSeqCond = prelude_id_no fsPrimSeqCond +idUndefined = prelude_id_no fsUndefined +idEqual = prelude_id_no fsEqual +idNotEqual = prelude_id_no fsNotEqual +idPack = prelude_id_no fsPack +idUnpack = prelude_id_no fsUnpack +idFmap = prelude_id_no fsFmap +idMaxBound, idMinBound, idBuildUndef, idMakeUndef, idRawUndef, idAdd :: Id +idMaxBound = prelude_id_no fsMaxBound +idMinBound = prelude_id_no fsMinBound +idBuildUndef = prelude_id_no fsBuildUndef +idMakeUndef = prelude_id_no fsMakeUndef +idRawUndef = prelude_id_no fsRawUndef +idAdd = prop_prelude_id_no fsAdd [IdPCommutativeTCon] +idMax, idMin, idLog, idMul, idDiv, idNumEq, idAnd, idNot, idPrimSplit :: Id +idMax = prop_prelude_id_no fsMax [IdPCommutativeTCon] +idMin = prop_prelude_id_no fsMin [IdPCommutativeTCon] +idLog = prelude_id_no fsLog +idMul = prop_prelude_id_no fsMul [IdPCommutativeTCon] +idDiv = prelude_id_no fsDiv +idNumEq = prop_prelude_id_no fsNumEq [IdPCommutativeTCon] +idAnd = prelude_id_no fsAnd +idNot = prelude_id_no fsNot +idPrimSplit = prelude_id_no fsPrimSplit +idPrimConcat, idPrimMul, idPrimQuot, idPrimRem, idPrimTrunc, idPrimOrd :: Id +idPrimConcat = prelude_id_no fsPrimConcat +idPrimMul = prelude_id_no fsPrimMul +idPrimQuot = prelude_id_no fsPrimQuot +idPrimRem = prelude_id_no fsPrimRem +idPrimTrunc = prelude_id_no fsPrimTrunc +idPrimOrd = prelude_id_no fsPrimOrd +idPrimChr, idLiftM, idPrimError :: Id +idPrimChr = prelude_id_no fsPrimChr +idLiftM = prelude_id_no fsLiftM +idPrimError = prelude_id_no fsPrimError +idGeneric, idFrom, idTo, idConc, idConcPrim, idConcPoly, idMeta :: Id +idGeneric = prelude_id_no fsGeneric +idFrom = prelude_id_no fsFrom +idTo = prelude_id_no fsTo +idConc = prelude_id_no fsConc +idConcPrim = prelude_id_no fsConcPrim +idConcPoly = prelude_id_no fsConcPoly +idMeta = prelude_id_no fsMeta +idMetaData, idStarArg, idNumArg, idStrArg, idConArg, idMetaConsNamed, idMetaConsAnon, idMetaField :: Id +idMetaData = prelude_id_no fsMetaData +idStarArg = prelude_id_no fsStarArg +idNumArg = prelude_id_no fsNumArg +idStrArg = prelude_id_no fsStrArg +idConArg = prelude_id_no fsConArg +idMetaConsNamed = prelude_id_no fsMetaConsNamed +idMetaConsAnon = prelude_id_no fsMetaConsAnon +idMetaField = prelude_id_no fsMetaField +idPolyWrapField :: Id +idPolyWrapField = mk_no fsPolyWrapField + +-- | Used by GenWrap for "polymorphic" modules +idLiftModule :: Id +idLiftModule = prelude_id_no fsLiftModule + +-- Used by desugaring +id_lam, id_if, id_read, id_write :: Position -> Id +id_lam pos = mkId pos fs_lam +id_if pos = mkId pos fs_if +id_read pos = mkId pos fs_read +id_write pos = mkId pos fs_write +idPreludeRead, idPreludeWrite, idAssign :: Id +idPreludeRead = prelude_id_no fsRead +idPreludeWrite = prelude_id_no fsRegWrite +idAssign = mkId noPosition fsAssign +idExtract, idFromInteger, idFromReal, idFromSizedInteger :: Position -> Id +idExtract pos = prelude_id pos fsExtract +idFromInteger pos = prelude_id pos fsFromInteger +idFromReal pos = prelude_id pos fsFromReal +idFromSizedInteger pos = prelude_id pos fsFromSizedInteger +idFromString, idPrimCharToString, idPrimToParam, idPrimToPort :: Position -> Id +idFromString pos = prelude_id pos fsFromString +idPrimCharToString pos = prelude_id pos fsPrimCharToString +idPrimToParam pos = prelude_id pos fsPrimToParam +idPrimToPort pos = prelude_id pos fsPrimToPort +id_case, idBind, idBind_, idReturn, idMonad :: Position -> Id +id_case pos = mkId pos fs_case +idBind pos = prelude_id pos fsBind +idBind_ pos = prelude_id pos fsBind_ +idReturn pos = prelude_id pos fsReturn +idMonad pos = prelude_id pos fsMonad +idIsModule, idModule, idId :: Id +idIsModule = prelude_id_no fsIsModule +idModule = prelude_id_no fsModule +idId = prelude_id_no fsId +idPrimModule :: Position -> Id +idPrimModule pos = prelude_id pos fsPrimModule +idPrimStringConcat :: Id +idPrimStringConcat = prelude_id_no fsPrimStringConcat +idAddRules, idMkRegU, idTheResult, idF, idM, idC :: Position -> Id +idAddRules pos = prelude_id pos fsAddRules +idMkRegU pos = prelude_id pos fsMkRegU +idTheResult pos = addIdProp (mkId pos fsTheResult) IdPRenaming +idF pos = mkId pos fsF +idM pos = mkId pos fsM +idC pos = mkId pos fsC +idPrimSelectFn, idPrimUpdateFn, idPrimWriteFn, idPrimUpdateRangeFn :: Position -> Id +idPrimSelectFn pos = mkId pos fsPrimSelectFn +idPrimUpdateFn pos = mkId pos fsPrimUpdateFn +idPrimWriteFn pos = mkId pos fsPrimWriteFn +idPrimUpdateRangeFn pos = prelude_id pos fsPrimUpdateRangeFn +idSAction, idSActionValue, idStmtify, idCallServer :: Position -> Id +idSAction pos = mkId pos fsSAction +idSActionValue pos = mkId pos fsSActionValue +idStmtify pos = mkId pos fsStmtify +idCallServer pos = mkId pos fsCallServer +idSIf1, idSIf2, idSAbtIf1, idSAbtIf2, idSRepeat, idSWhile, idSFor :: Position -> Id +idSIf1 pos = mkId pos fsSIf1 +idSIf2 pos = mkId pos fsSIf2 +idSAbtIf1 pos = mkId pos fsSAbtIf1 +idSAbtIf2 pos = mkId pos fsSAbtIf2 +idSRepeat pos = mkId pos fsSRepeat +idSWhile pos = mkId pos fsSWhile +idSFor pos = mkId pos fsSFor +idSSeq, idSPar, idSLabel, idSJump, idSNamed, idS, idStmt :: Position -> Id +idSSeq pos = mkId pos fsSSeq +idSPar pos = mkId pos fsSPar +idSLabel pos = mkId pos fsSLabel +idSJump pos = mkId pos fsSJump +idSNamed pos = mkId pos fsSNamed +idS pos = mkId pos fsS +idStmt pos = mkId pos fsStmt +idSBreak, idSContinue, idSReturn, idCons, idConcat :: Position -> Id +idSBreak pos = mkId pos fsSBreak +idSContinue pos = mkId pos fsSContinue +idSReturn pos = mkId pos fsSReturn +idCons pos = mkId pos fsCons +idConcat pos = mkId pos fsConcat +idNil, idNothing, idSprime :: Position -> Id +idNil pos = mkId pos fsNil +idNothing pos = mkId pos fsNothing +idSprime pos = mkId pos fsSprime + +-- | Used to prevent implicit read etc. +idAsIfc, idAsReg :: Id +idAsIfc = prelude_id_no fsAsIfc +idAsReg = prelude_id_no fsAsReg + +-- used to inject state names +idName, idPrimGetName :: Id +idName = prelude_id_no fsName +idPrimGetName = prelude_id_no fsPrimGetName +idPrimGetNameAt :: Position -> Id +idPrimGetNameAt pos = prelude_id pos fsPrimGetName +idPrimGetParamName :: Id +idPrimGetParamName = prelude_id_no fsPrimGetParamName +idPrimGetParamNameAt, idPrimJoinNamesAt, idPrimExtNameIdxAt, idSetStateNameAt :: Position -> Id +idPrimGetParamNameAt pos = prelude_id pos fsPrimGetParamName +idPrimJoinNamesAt pos = prelude_id pos fsPrimJoinNames +idPrimExtNameIdxAt pos = prelude_id pos fsPrimExtNameIdx +idSetStateNameAt pos = prelude_id pos fsSetStateName +idGetModuleName :: Id +idGetModuleName = prelude_id_no fsGetModuleName + +-- | Used to force the monad in a "module" expression to be a module, +-- so that we fail fast for good error positions +idForceIsModuleAt :: Position -> Id +idForceIsModuleAt pos = prelude_id pos fsForceIsModule + +-- | Use for communicating positions for errors, warnings and messages +idPosition, idNoPosition, idPrimGetEvalPosition :: Id +idPosition = prelude_id_no fsPosition +idNoPosition = prelude_id_no fsNoPosition +idPrimGetEvalPosition = prelude_id_no fsPrimGetEvalPosition + +-- | Used to carry attributes +idAttributes :: Id +idAttributes = prelude_id_no fsAttributes +idSetStateAttribAt :: Position -> Id +idSetStateAttribAt pos = prelude_id pos fsSetStateAttrib + +idType, idTypeOf, idSavePortType, idPrintType :: Id +idType = prelude_id_no fsType +idTypeOf = prelude_id_no fsTypeOf +idSavePortType = prelude_id_no fsSavePortType +idPrintType = prelude_id_no fsPrintType + +-- | Abstract type for implicit conditions +idPred :: Id +idPred = prelude_id_no fsPred + +-- Used by iConv +idPrimBAnd, idPrimBOr, idPrimBNot, idPrimSL, idPrimSRL :: Id +idPrimBAnd = prelude_id_no fsPrimBAnd +idPrimBOr = prelude_id_no fsPrimBOr +idPrimBNot = prelude_id_no fsPrimBNot +idPrimSL = prelude_id_no fsPrimSL +idPrimSRL = prelude_id_no fsPrimSRL +idPrimInv, idPrimIf, idPrimCase, idPrimArrayDynSelect, idPrimBuildArray :: Id +idPrimInv = prelude_id_no fsPrimInv +idPrimIf = prelude_id_no fsPrimIf +idPrimCase = prelude_id_no fsPrimCase +idPrimArrayDynSelect = prelude_id_no fsPrimArrayDynSelect +idPrimBuildArray = prelude_id_no fsPrimBuildArray +idPrimWhen, idPrimSelect :: Id +idPrimWhen = prelude_id_no fsPrimWhen +idPrimSelect = prelude_id_no fsPrimSelect +idPrimSelectAt :: Position -> Id +idPrimSelectAt pos = prelude_id pos fsPrimSelect +idPrimZeroExt, idPrimSignExt, idPrimJoinRules, idPrimNoRules, idPrimRule :: Id +idPrimZeroExt = prelude_id_no fsPrimZeroExt +idPrimSignExt = prelude_id_no fsPrimSignExt +idPrimJoinRules = prelude_id_no fsPrimJoinRules +idPrimNoRules = prelude_id_no fsPrimNoRules +idPrimRule = prelude_id_no fsPrimRule +idPrimJoinActions, idPrimAddSchedPragmas, idPrimNoActions, idPrimNoExpIf :: Id +idPrimJoinActions = prelude_id_no fsPrimJoinActions +idPrimAddSchedPragmas = prelude_id_no fsPrimAddSchedPragmas +idPrimNoActions = prelude_id_no fsPrimNoActions +idPrimNoExpIf = prelude_id_no fsPrimNoExpIf +idPrimExpIf, idPrimNosplitDeep, idPrimSplitDeep, idSplitDeepAV :: Id +idPrimExpIf = prelude_id_no fsPrimExpIf +idPrimNosplitDeep = prelude_id_no fsPrimNosplitDeep +idPrimSplitDeep = prelude_id_no fsPrimSplitDeep +idSplitDeepAV = prelude_id_no fsSplitDeepAV +idNosplitDeepAV, idMfix, idStaticAssert, idDynamicAssert :: Id +idNosplitDeepAV = prelude_id_no fsNosplitDeepAV +idPrimFix :: Position -> Id +idPrimFix pos = prelude_id pos fsPrimFix +idMfix = prelude_id_no fsMfix +idStaticAssert = mk_no fsStaticAssert +idDynamicAssert = mk_no fsDynamicAssert +idContinuousAssert, id_staticAssert, id_dynamicAssert, id_continuousAssert :: Id +idContinuousAssert = mk_no fsContinuousAssert +id_staticAssert = mk_no fs_staticAssert +id_dynamicAssert = mk_no fs_dynamicAssert +id_continuousAssert = mk_no fs_continuousAssert +idClsUninitialized, idPrimUninitialized :: Id +idClsUninitialized = prelude_id_no fsClsUninitialized +idPrimUninitialized = prelude_id_no fsPrimUninitialized +idPrimUninitializedAt :: Position -> Id +idPrimUninitializedAt pos = prelude_id pos fsPrimUninitialized +idPrimMakeUninitialized, idPrimRawUninitialized, idPrimPoisonedDef :: Id +idPrimMakeUninitialized = prelude_id_no fsPrimMakeUninitialized +idPrimRawUninitialized = prelude_id_no fsPrimRawUninitialized +idPrimPoisonedDef = prelude_id_no fsPrimPoisonedDef +idStringAt, idFmtAt, idPrimStringConcatAt :: Position -> Id +idStringAt pos = prelude_id pos fsString +idFmtAt pos = prelude_id pos fsFmt +idPrimStringConcatAt pos = prelude_id pos fsPrimStringConcat + +-- | Clock and reset identifiers +idClock, idClockOsc, idClockGate, idReset, idInout, idInout_ :: Id +idClock = prelude_id_no fsClock +idClockOsc = prelude_id_no fsClockOsc +idClockGate = prelude_id_no fsClockGate +idReset = prelude_id_no fsReset +idInout = prelude_id_no fsInout +idInout_ = prelude_id_no fsInout_ +idPrimInoutCast, idPrimInoutUncast, idPrimInoutCast0, idPrimInoutUncast0 :: Id +idPrimInoutCast = prelude_id_no fsPrimInoutCast +idPrimInoutUncast = prelude_id_no fsPrimInoutUncast +idPrimInoutCast0 = prelude_id_no fsPrimInoutCast0 +idPrimInoutUncast0 = prelude_id_no fsPrimInoutUncast0 + +idExposeCurrentClock, idExposeCurrentReset :: Id +idExposeCurrentClock = prelude_id_no fsExposeCurrentClock +idExposeCurrentReset = prelude_id_no fsExposeCurrentReset + +idNoClock, idNoReset, idPrimReplaceClockGate :: Id +-- needed for noClock constant in ISyntax +idNoClock = prelude_id_no fsNoClock +-- needed for noReset constant in ISyntax +idNoReset = prelude_id_no fsNoReset +-- needed for GenWrap +idPrimReplaceClockGate = prelude_id_no fsPrimReplaceClockGate + +idClk, idRst :: Id +idClk = mk_no fsClk -- position? +idRst = mk_no fsRst -- position? + +idCLK, idCLK_GATE :: Id +idCLK = mk_no fsCLK +idCLK_GATE = mk_no fsCLK_GATE +-- idRSTN = mk_no fsRSTN + +idDefaultClock, idDefaultReset :: Id +idDefaultClock = mk_no fsDefaultClock +idDefaultReset = mk_no fsDefaultReset + +-- iConv junk +idPrimSplitFst, idPrimSplitSnd :: Id +idPrimSplitFst = prelude_id_no fsPrimSplitFst +idPrimSplitSnd = prelude_id_no fsPrimSplitSnd + +id_x, id_y, id_fun, id_forallb :: Id +id_x = setBadId $ mk_no fs_x +id_y = setBadId $ mk_no fs_y +id_fun = setBadId $ mk_no fs_fun +id_forallb = setBadId $ mk_no fs_forallb + +tmpVarIds, tmpVarXIds, tmpVarYIds, tmpVarSIds :: [Id] +tmpVarIds = map (enumId "a" noPosition) [1000..] +tmpVarXIds = map (enumId "x" noPosition) [1000000..] +tmpVarYIds = map (enumId "y" noPosition) [2000000..] +tmpVarSIds = map (enumId "s" noPosition) [3000000..] +tmpTyNumIds, tmpTyVarIds :: [Id] +tmpTyNumIds = map (enumId "tnum" noPosition) [4000000..] +tmpTyVarIds = map (enumId "v" noPosition) [100..] + +-- | Used by iExpand +idPrimEQ, idPrimULE, idPrimULT, idPrimSLE, idPrimSLT :: Id +idPrimEQ = prelude_id_no fsPrimEQ +idPrimULE = prelude_id_no fsPrimULE +idPrimULT = prelude_id_no fsPrimULT +idPrimSLE = prelude_id_no fsPrimSLE +idPrimSLT = prelude_id_no fsPrimSLT + +-- | Used by iTransform +idPrimAdd, idPrimSub :: Id +idPrimAdd = prelude_id_no fsPrimAdd +idPrimSub = prelude_id_no fsPrimSub + +-- | Used by AddCFWire +idVRWireN, idVmkRWire1, idWGet, idWSet, idWHas :: Id +idVRWireN = prelude_bsv_id_no fsVRWireN +idVmkRWire1 = prelude_bsv_id_no fsVmkRWire1 +idWGet = prelude_bsv_id_no fsWGet +idWSet = prelude_bsv_id_no fsWSet +idWHas = prelude_bsv_id_no fsWHas + +-- versions parametrized on position +idPrimConcatAt, idTrueAt, idAddRulesAt, idOrAt, idEqualAt :: Position -> Id +idPrimConcatAt pos = prelude_id pos fsPrimConcat +idTrueAt pos = prelude_id pos fsTrue +idAddRulesAt pos = prelude_id pos fsAddRules +idOrAt pos = prelude_id pos fsOr +idEqualAt pos = prelude_id pos fsEqual +idNotEqualAt, idPrimUnitAt, idErrorAt, idNegateAt, idIdentityAt :: Position -> Id +idNotEqualAt pos = prelude_id pos fsNotEqual +idPrimUnitAt pos = prelude_id pos fsPrimUnit +idErrorAt pos = prelude_id pos fsError +idNegateAt pos = prelude_id pos fsNegate +idIdentityAt pos = prelude_id pos fsIdentity +idNotAt, idInvertAt, idPercentAt, idModuleAt, idIsModuleAt :: Position -> Id +idNotAt pos = prelude_id pos fsNot +idInvertAt pos = prelude_id pos fsInvert +idPercentAt pos = prelude_id pos fsPercent +idModuleAt pos = prelude_id pos fsModule +idIsModuleAt pos = prelude_id pos fsIsModule +idActionAt, idActionValueAt, idActionValue_At, idIntAt :: Position -> Id +idActionAt pos = prelude_id pos fsAction +idActionValueAt pos = prelude_id pos fsActionValue +idActionValue_At pos = prelude_id pos fsActionValue_ +idIntAt pos = prelude_id pos fsInt +idUnpackAt, idStarAt, idSlashAt, idStarStarAt, idPlusAt :: Position -> Id +idUnpackAt pos = prelude_id pos fsUnpack +idStarAt pos = prelude_id pos fsStar +idSlashAt pos = prelude_id pos fsSlash +idStarStarAt pos = prelude_id pos fsStarStar +idPlusAt pos = prelude_id pos fsPlus +idMinusAt, idLshAt, idRshAt, idLtAt, idGtAt, idLtEqAt :: Position -> Id +idMinusAt pos = prelude_id pos fsMinus +idLshAt pos = prelude_id pos fsLsh +idRshAt pos = prelude_id pos fsRsh +idLtAt pos = prelude_id pos fsLT +idGtAt pos = prelude_id pos fsGT +idLtEqAt pos = prelude_id pos fsLtEq +idGtEqAt, idAndAt, idBitAndAt, idBitOrAt, idCaretAt :: Position -> Id +idGtEqAt pos = prelude_id pos fsGtEq +idAndAt pos = prelude_id pos fsAnd +idBitAndAt pos = prelude_id pos fsBitAnd +idBitOrAt pos = prelude_id pos fsBitOr +idCaretAt pos = prelude_id pos fsCaret +idTildeCaretAt, idCaretTildeAt, idReduceAndAt, idReduceOrAt :: Position -> Id +idTildeCaretAt pos = prelude_id pos fsTildeCaret +idCaretTildeAt pos = prelude_id pos fsCaretTilde +idReduceAndAt pos = prelude_id pos fsReduceAnd +idReduceOrAt pos = prelude_id pos fsReduceOr +idReduceXorAt, idReduceNandAt, idReduceNorAt, idReduceXnorAt :: Position -> Id +idReduceXorAt pos = prelude_id pos fsReduceXor +idReduceNandAt pos = prelude_id pos fsReduceNand +idReduceNorAt pos = prelude_id pos fsReduceNor +idReduceXnorAt pos = prelude_id pos fsReduceXnor +idRulesAt, idConstAllBitsSetAt, idConstAllBitsUnsetAt :: Position -> Id +idRulesAt pos = prelude_id pos fsRules +idConstAllBitsSetAt pos = prelude_id pos fsConstAllBitsSet +idConstAllBitsUnsetAt pos = prelude_id pos fsConstAllBitsUnset + +-- | List declaration desugaring +idListAt :: Position -> Id +idListAt pos = prelude_id pos fsList + +-- array declaration desugaring +idPrimArrayAt, idPrimArrayNewAt, idPrimArrayNewUAt :: Position -> Id +idPrimArrayAt pos = prelude_id pos fsPrimArray +idPrimArrayNewAt pos = prelude_id pos fsPrimArrayNew +idPrimArrayNewUAt pos = prelude_id pos fsPrimArrayNewU +idPrimArrayLengthAt, idPrimArrayInitializeAt, idPrimArrayCheckAt :: Position -> Id +idPrimArrayLengthAt pos = prelude_id pos fsPrimArrayLength +idPrimArrayInitializeAt pos = prelude_id pos fsPrimArrayInitialize +idPrimArrayCheckAt pos = prelude_id pos fsPrimArrayCheck + +-- | List identifiers for catching type errors on lists +idList, idListN, idVector, idToVector, idToListN, idPrimArray :: Id +idList = prelude_id_no fsList -- there is no List::List +idListN = mkQId noPosition fsListN fsListN -- not yet moved to Prelude +idVector = mkQId noPosition fsVector fsVector -- but renamed to Vector +idToVector = mkQId noPosition fsVector fsToVector +idToListN = mkQId noPosition fsListN fsToListN +idPrimArray = prelude_id_no fsPrimArray + +-- system task ids +idFinish, idStop :: Id +idFinish = prelude_id_no fsFinish +idStop = prelude_id_no fsStop + +idDisplay, idDisplayh, idDisplayb, idDisplayo :: Id +idDisplay = prelude_id_no fsDisplay +idDisplayh = prelude_id_no fsDisplayh +idDisplayb = prelude_id_no fsDisplayb +idDisplayo = prelude_id_no fsDisplayo + +idWrite, idWriteh, idWriteb, idWriteo :: Id +idWrite = prelude_id_no fsWrite +idWriteh = prelude_id_no fsWriteh +idWriteb = prelude_id_no fsWriteb +idWriteo = prelude_id_no fsWriteo + +idFDisplay, idFDisplayh, idFDisplayb, idFDisplayo :: Id +idFDisplay = prelude_id_no fsFDisplay +idFDisplayh = prelude_id_no fsFDisplayh +idFDisplayb = prelude_id_no fsFDisplayb +idFDisplayo = prelude_id_no fsFDisplayo + +idFWrite, idFWriteh, idFWriteb, idFWriteo :: Id +idFWrite = prelude_id_no fsFWrite +idFWriteh = prelude_id_no fsFWriteh +idFWriteb = prelude_id_no fsFWriteb +idFWriteo = prelude_id_no fsFWriteo + +idSWriteAV, idSWrite, idSWritehAV, idSWriteh, idSWritebAV :: Id +idSWriteAV = prelude_id_no fsSWriteAV +idSWrite = prelude_id_no fsSWrite +idSWritehAV = prelude_id_no fsSWritehAV +idSWriteh = prelude_id_no fsSWriteh +idSWritebAV = prelude_id_no fsSWritebAV +idSWriteb, idSWriteoAV, idSWriteo, idSFormatAV, idSFormat :: Id +idSWriteb = prelude_id_no fsSWriteb +idSWriteoAV = prelude_id_no fsSWriteoAV +idSWriteo = prelude_id_no fsSWriteo +idSFormatAV = prelude_id_no fsSFormatAV +idSFormat = prelude_id_no fsSFormat + +idErrorTask, idWarnTask, idInfoTask, idFatalTask :: Id +idErrorTask = prelude_id_no fsErrorTask +idWarnTask = prelude_id_no fsWarnTask +idInfoTask = prelude_id_no fsInfoTask +idFatalTask = prelude_id_no fsFatalTask + +idSVA, idSvaParam, idSvaBool, idSvaNumber :: Id +idSVA = prelude_id_no fsSVA +idSvaParam = prelude_id_no fsSvaParam +idSvaBool = prelude_id_no fsSvaBool +idSvaNumber = prelude_id_no fsSvaNumber + +idSVAsampled, idSVArose, idSVAfell, idSVAstable, idSVApast :: Id +idSVAsampled = prelude_id_no fsSVAsampled +idSVArose = prelude_id_no fsSVArose +idSVAfell = prelude_id_no fsSVAfell +idSVAstable = prelude_id_no fsSVAstable +idSVApast = prelude_id_no fsSVApast +idSVAonehot, idSVAonehot0, idSVAisunknown, idSVAcountones :: Id +idSVAonehot = prelude_id_no fsSVAonehot +idSVAonehot0 = prelude_id_no fsSVAonehot0 +idSVAisunknown = prelude_id_no fsSVAisunknown +idSVAcountones = prelude_id_no fsSVAcountones + +idRandom :: Id +idRandom = prelude_id_no fsRandom + +idDumpon, idDumpoff, idDumpvars, idDumpall, idDumplimit, idDumpflush :: Id +idDumpon = prelude_id_no fsDumpon +idDumpoff = prelude_id_no fsDumpoff +idDumpvars = prelude_id_no fsDumpvars +idDumpall = prelude_id_no fsDumpall +idDumplimit = prelude_id_no fsDumplimit +idDumpflush = prelude_id_no fsDumpflush + +idDumpfile, idTime, idSTime, idFOpen, idFGetc, idUngetc, idFClose :: Id +idDumpfile = prelude_id_no fsDumpfile +idTime = prelude_id_no fsTime +idSTime = prelude_id_no fsSTime +idFOpen = prelude_id_no fsFOpen +idFGetc = prelude_id_no fsFGetc +idUngetc = prelude_id_no fsUngetc +idFClose = prelude_id_no fsFClose + +idFFlush, idTestPlusargs, idRealToBits, idBitsToReal :: Id +idFFlush = prelude_id_no fsFFlush +idTestPlusargs = prelude_id_no fsTestPlusargs +idRealToBits = prelude_id_no fsRealToBits +idBitsToReal = prelude_id_no fsBitsToReal + +taskIds :: [Id] +taskIds = [ idFinish, idStop, + -- + idDisplay, idDisplayh, idDisplayb, idDisplayo, + idWrite, idWriteb, idWriteh, idWriteo, + -- + idErrorTask, idWarnTask, idInfoTask, idFatalTask, + -- + idRandom, + -- + idFDisplay, idFDisplayh, idFDisplayb, idFDisplayo, + idFWrite, idFWriteb, idFWriteh, idFWriteo, + -- + idSFormatAV, idSFormat, + idSWriteAV, idSWrite, idSWritehAV, idSWriteh, + idSWritebAV, idSWriteb, idSWriteoAV, idSWriteo, + idFormat, + -- + idSVA, + -- + idDumpon, idDumpoff, idDumpvars, idDumpflush, idDumpfile, + idDumpall, idDumplimit, + -- + idTime, idSTime, + -- + idFOpen, idFGetc, idUngetc, idFClose, idFFlush, + -- + idTestPlusargs + ] + +-- these are explicitly NOT supported in user code +-- they are for internal use only (so not part of the taskids list) +idSigned, idUnsigned :: Position -> Id +idSigned pos = prelude_id pos fsSigned +idUnsigned pos = prelude_id pos fsUnsigned + +-- | Classes hardcoded in the Prelude which were added for ContextErrors +idBitwise, idBitReduce, idBitExtend, idArith, idOrd :: Id +idBitwise = prelude_id_no fsBitwise +idBitReduce = prelude_id_no fsBitReduce +idBitExtend = prelude_id_no fsBitExtend +idArith = prelude_id_no fsArith +idOrd = prelude_id_no fsOrd + +-- | Names used for tuple fields internally? +tupleIds :: [Id] +tupleIds = map (\fs -> mkId noPosition fs) fsTuples +-- | Names exposed to the BSV user +idTuple2, idTuple3, idTuple4, idTuple5, idTuple6, idTuple7, idTuple8 :: Id +idTuple2 = prelude_id_no fsTuple2 +idTuple3 = prelude_id_no fsTuple3 +idTuple4 = prelude_id_no fsTuple4 +idTuple5 = prelude_id_no fsTuple5 +idTuple6 = prelude_id_no fsTuple6 +idTuple7 = prelude_id_no fsTuple7 +idTuple8 = prelude_id_no fsTuple8 + +-- Classes that we always derive implicitly. +-- Note that these are assumed to have a single parameter, or if multiple, +-- the first is the one for which the instance is defined. +autoderivedClasses :: [Id] +autoderivedClasses = [idGeneric] diff --git a/src/Language/Bluespec/Classic/AST/Builtin/Types.hs b/src/Language/Bluespec/Classic/AST/Builtin/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bluespec/Classic/AST/Builtin/Types.hs @@ -0,0 +1,204 @@ +-- This corresponds to src/Comp/Type.hs in bsc. +module Language.Bluespec.Classic.AST.Builtin.Types where + +import Language.Bluespec.Classic.AST.Builtin.Ids +import Language.Bluespec.Classic.AST.Id +import Language.Bluespec.Classic.AST.Position +import Language.Bluespec.Classic.AST.Type +import Language.Bluespec.Prelude +import Language.Bluespec.Pretty + +infixr 4 `fn` + +-- XXX these definitions should be synced with StdPrel.hs where applicable + +tArrow, tBit, tInt :: Type +tArrow = TCon (TyCon (idArrow noPosition) (Just (Kfun KStar (Kfun KStar KStar))) TIabstract) +tBit = TCon (TyCon idBit (Just (Kfun KNum KStar)) TIabstract) +tInt = TCon (TyCon idInt (Just (Kfun KNum KStar)) TIabstract) + +tIntAt :: Position -> Type +tIntAt pos = TCon (TyCon (idIntAt pos) (Just (Kfun KNum KStar)) TIabstract) + +tiData, tiEnum :: [Id] -> TISort +tiEnum cons = TIdata { tidata_cons = cons, tidata_enum = True } +tiData cons = TIdata { tidata_cons = cons, tidata_enum = False } + +tUInt, tBool, tPrimUnit :: Type +tUInt = TCon (TyCon idUInt (Just (Kfun KNum KStar)) TIabstract) +tBool = TCon (TyCon idBool (Just KStar) (tiEnum [idFalse, idTrue])) +--tArray = TCon (TyCon idArray (Just (Kfun KNum (Kfun KNum KStar))) (TIstruct SInterface [id_sub, id_upd])) +tPrimUnit = TCon (TyCon idPrimUnit (Just KStar) (TIstruct SStruct [])) + +tPrimUnitAt :: Position -> Type +tPrimUnitAt pos = TCon (TyCon (idPrimUnitAt pos) (Just KStar) (TIstruct SStruct [])) + +tInteger, tReal :: Type +tInteger = TCon (TyCon idInteger (Just KStar) TIabstract) +tReal = TCon (TyCon idReal (Just KStar) TIabstract) + +tRealAt :: Position -> Type +tRealAt pos = TCon (TyCon (idRealAt pos) (Just KStar) TIabstract) + +tClock, tReset, tInout, tInout_, tChar, tString :: Type +tClock = TCon (TyCon idClock (Just KStar) TIabstract) +tReset = TCon (TyCon idReset (Just KStar) TIabstract) +tInout = TCon (TyCon idInout (Just (Kfun KStar KStar)) TIabstract) +tInout_ = TCon (TyCon idInout_ (Just (Kfun KNum KStar)) TIabstract) +tString = TCon (TyCon idString (Just KStar) TIabstract) +tChar = TCon (TyCon idChar (Just KStar) TIabstract) + +tFmt, tName, tPosition, tType :: Type +tFmt = TCon (TyCon idFmt (Just KStar) TIabstract) +tName = TCon (TyCon idName (Just KStar) TIabstract) +tPosition = TCon (TyCon idPosition (Just KStar) TIabstract) +tType = TCon (TyCon idType (Just KStar) TIabstract) + +tPred, tAttributes, tPrimPair, tSizeOf :: Type +tPred = TCon (TyCon idPred (Just KStar) TIabstract) +tAttributes = TCon (TyCon idAttributes (Just KStar) TIabstract) +tPrimPair = TCon (TyCon idPrimPair (Just (Kfun KStar (Kfun KStar KStar))) (TIstruct SStruct [idPrimFst, idPrimSnd])) +tSizeOf = TCon (TyCon idSizeOf (Just (Kfun KStar KNum)) TIabstract) + +tAction, tActionValue, tActionValue_, tAction_:: Type +tAction = TCon (TyCon idAction (Just KStar) (TItype 0 (TAp tActionValue tPrimUnit))) +tActionValue = TCon (TyCon idActionValue (Just (Kfun KStar KStar)) (TIstruct SStruct [id__value, id__action])) +tActionValue_ = TCon (TyCon idActionValue_ (Just (Kfun KNum KStar)) (TIstruct SStruct [id__value, id__action])) +tAction_ = TAp tActionValue_ (tOfSize 0 noPosition) + +tActionAt, tActionValueAt, tActionValue_At :: Position -> Type +tActionAt pos = TCon (TyCon (idActionAt pos) (Just KStar) (TItype 0 (TAp (tActionValueAt pos) (tPrimUnitAt pos)))) +tActionValueAt pos = TCon (TyCon (idActionValueAt pos) (Just (Kfun KStar KStar)) (TIstruct SStruct [id__value_at pos, id__action_at pos])) +tActionValue_At pos = TCon (TyCon (idActionValue_At pos) (Just (Kfun KNum KStar)) (TIstruct SStruct [id__value_at pos, id__action_at pos])) + +tPrimAction, tRules :: Type +tPrimAction = TCon (TyCon idPrimAction (Just KStar) TIabstract) +tRules = TCon (TyCon idRules (Just KStar) TIabstract) + +tRulesAt :: Position -> Type +tRulesAt pos = TCon (TyCon (idRulesAt pos) (Just KStar) TIabstract) + +tSchedPragma, tModule, tVRWireN, tId, t32 :: Type +tSchedPragma = TCon (TyCon idSchedPragma (Just KStar) TIabstract) +tModule = TCon (TyCon idModule (Just (Kfun KStar KStar)) TIabstract) +tVRWireN = TCon (TyCon idVRWireN (Just (Kfun KNum KStar)) (TIstruct SStruct [idWSet, idWGet, idWHas])) +tId = TCon (TyCon idId (Just (Kfun KStar KStar)) TIabstract) +t32 = tOfSize 32 noPosition + +t32At :: Position -> Type +t32At pos = tOfSize 32 pos + +tOfSize :: Integer -> Position -> Type +tOfSize n pos = cTNum n pos + +tInt32At :: Position -> Type +tInt32At pos = TAp (tIntAt pos) (t32At pos) + +tBitN :: Integer -> Position -> Type +tBitN n pos = TAp tBit (tOfSize n pos) + +tNat :: Position -> Type +tNat pos = tBitN 32 pos + +tFile, tSvaParam :: Type +tFile = TCon (TyCon idFile (Just KStar) TIabstract) +tSvaParam = TCon (TyCon idSvaParam (Just KStar) (tiData [idSvaBool, idSvaNumber])) + +fn :: Type -> Type -> Type +a `fn` b = TAp (TAp tArrow a) b + +-- numeric kinds and type constructors +kNNN, kNN, kNNS, kNS :: Kind +kNNN = Kfun KNum kNN +kNN = Kfun KNum KNum + +kNNS = Kfun KNum kNS +kNS = Kfun KNum KStar + +tAdd, tSub, tMul, tDiv, tLog, tExp, tMax, tMin :: Type +tAdd = TCon (TyCon idTAdd (Just kNNN) TIabstract) +tSub = TCon (TyCon idTSub (Just kNNN) TIabstract) +tMul = TCon (TyCon idTMul (Just kNNN) TIabstract) +tDiv = TCon (TyCon idTDiv (Just kNNN) TIabstract) +tLog = TCon (TyCon idTLog (Just kNN) TIabstract) +tExp = TCon (TyCon idTExp (Just kNN) TIabstract) +tMax = TCon (TyCon idTMax (Just kNNN) TIabstract) +tMin = TCon (TyCon idTMin (Just kNNN) TIabstract) + +class HasKind t where + kind :: t -> Kind + +instance HasKind TyVar where + kind (TyVar _v _ k) = k + +instance HasKind TyCon where + kind (TyCon _v (Just k) _) = k + kind (TyNum _ _) = KNum + kind (TyStr _ _) = KStr + kind (TyCon _v Nothing _) = error "HasKind(TyCon).kind: TyCon without kind" + +instance HasKind Type where + kind (TCon tc) = kind tc + kind (TVar u) = kind u + kind tt@(TAp t _) = case kind t of + Kfun _ k -> k + k -> + error ("kind: " ++ ppReadable k ++ (show tt) ++ "\n") + kind (TGen _ _) = error "HasKind(Type).kind: TGen" + kind (TDefMonad _) = error "HasKind(Type).kind: TDefMonad" + +arrow :: Type -> Type -> Type +arrow a r = TAp (TAp tArrow a) r + + +-- ------------------------- + +-- XXX kill this +isPrimAction :: Type -> Bool +isPrimAction t = t == tPrimAction + +isActionValue :: Type -> Bool +isActionValue (TAp av _) = av == tActionValue +isActionValue _ = False + +getAVType :: Type -> Type +getAVType (TAp av t) | av == tActionValue = t +getAVType t = error("getAVType not ActionValue: " ++ ppReadable t) + +isActionWithoutValue :: Type -> Bool +isActionWithoutValue (TAp av (TCon (TyNum 0 _))) = av == tActionValue_ +isActionWithoutValue _ = False + +isActionWithValue :: Type -> Bool +isActionWithValue (TAp av (TCon (TyNum n _))) = (av == tActionValue_) && (n > 0) +isActionWithValue (TAp av (TVar _)) = av == tActionValue_ +isActionWithValue _ = False + +isClock, isReset, isInout, isInout_ :: Type -> Bool +isClock t = t == tClock +isReset t = t == tReset + +isInout (TAp i _) = i == tInout +isInout _ = False + +isInout_ (TAp i _) = i == tInout_ +isInout_ _ = False + +isBit, isInt, isUInt, isBool, isInteger, isString, isChar, isReal, isFmt :: Type -> Bool +isBit (TAp b _) = b == tBit +isBit _ = False + +isInt (TAp i _) = i == tInt +isInt _ = False + +isUInt (TAp u _) = u == tUInt +isUInt _ = False + +isBool t = t == tBool +isInteger t = t == tInteger +isString t = t == tString +isChar t = t == tChar +isReal t = t == tReal +isFmt t = t == tFmt + +-- ------------------------- diff --git a/src/Language/Bluespec/Classic/AST/FString.hs b/src/Language/Bluespec/Classic/AST/FString.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bluespec/Classic/AST/FString.hs @@ -0,0 +1,40 @@ +-- This corresponds to src/comp/FStringCompat.hs in bsc. +module Language.Bluespec.Classic.AST.FString + ( FString + , getFString + , mkFString + , tmpFString + ) where + +import Data.String (IsString(..)) +import qualified Data.Text as T +import Text.PrettyPrint.HughesPJClass + +import Language.Bluespec.Classic.AST.SString +import Language.Bluespec.Prelude + +-- wrapper to make SStrings look like FStrings + +newtype FString = FString SString + deriving (Eq, Ord) + +instance IsString FString where + fromString = FString . T.pack + +instance Show FString where + show (FString s) = show s + +instance Pretty FString where + pPrintPrec _ _ x = text (show x) + +getFString :: FString -> String +getFString = toString + +mkFString :: String -> FString +mkFString s = fromString s + +tmpFString :: Int -> String -> FString +tmpFString _ = fromString + +toString :: FString -> String +toString (FString s) = T.unpack s diff --git a/src/Language/Bluespec/Classic/AST/Id.hs b/src/Language/Bluespec/Classic/AST/Id.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bluespec/Classic/AST/Id.hs @@ -0,0 +1,270 @@ +-- This corresponds to src/comp/Id.hs and src/comp/IdPrint.hs in bsc. +module Language.Bluespec.Classic.AST.Id + ( Id + , addIdProp + , addIdProps + , createPositionString + , enumId + , getIdBase + , getIdBaseString + , getIdPosition + , getIdProps + , getIdQual + , getIdQualString + , getIdString + , mkId + , mkQId + , ppConId + , ppId + , ppVarId + , qualEq + , setBadId + , setIdProps + + , IdProp(..) + + , Longname + ) where + +import Data.Char (isDigit) +import qualified Data.List as L +import Text.PrettyPrint.HughesPJClass + +import Language.Bluespec.Classic.AST.Builtin.FStrings +import Language.Bluespec.Classic.AST.FString +import Language.Bluespec.Classic.AST.Position +import Language.Bluespec.Lex +import Language.Bluespec.Prelude +import Language.Bluespec.Pretty +import Language.Bluespec.Util + +data Id = Id { id_pos :: !Position, + id_mfs :: !FString, + id_fs :: !FString, + id_props :: [IdProp] {- , id_stab :: Int -} + } + +idEq :: Id -> Id -> Bool +idEq a b = (id_fs a == id_fs b) && (id_mfs a == id_mfs b) + +idCompare :: Id -> Id -> Ordering +idCompare a b = case (compare (id_fs a) (id_fs b)) of + EQ -> compare (id_mfs a) (id_mfs b) + LT -> LT + GT -> GT + +instance Eq Id where + a == b = idEq a b + +instance Ord Id where + compare = idCompare + +instance Show Id where + show = show_brief + +instance Pretty Id where + pPrintPrec d _p i + | d == pdDebug + = text (local_show i) + | otherwise + = if (dbgLevel >= 1) + then text ((getIdString i) ++ + "_" ++ + (createPositionString (getIdPosition i))) + else text (getIdString i) + +instance HasPosition Id where + getPosition i = getIdPosition i + +local_show :: Id -> String +local_show id' = + let + pos = getIdPosition id' + mfs = getIdQualString id' + fs = getIdBaseString id' + str = show pos ++ " " ++ + show mfs ++ " " ++ + show fs + in str + +show_brief :: Id -> String +show_brief i = + case (getFString (id_mfs i), getFString (id_fs i)) of + ("", str) -> add_props str + (pkg, str) -> add_props (pkg ++ "::" ++ str) + where add_props str | null (id_props i) = str + | otherwise = str ++ show (id_props i) + +createPositionString :: Position -> String +createPositionString _ = "" + +-- Create an id of the form "_". +-- This is used to ENUMerate a list of Ids with the same name, +-- but with uniquifying numbers. +-- +-- Note: The Ids created with this are marked as "bad". If these Ids +-- need to be created from a user-given name, consider creating a new +-- interface for this which takes Id and not String, and derives its +-- properties from that Id. +enumId :: String -> Position -> Int -> Id +enumId str pos index = + let id_str = tmpFString index ("_" ++ str ++ itos index) + in setBadId + (Id pos fsEmpty id_str []) + +getIdBase :: Id -> FString +getIdBase a = id_fs a + +getIdBaseString :: Id -> String +getIdBaseString a = getFString $ getIdBase a + +getIdPosition :: Id -> Position +getIdPosition a = id_pos a + +getIdProps :: Id -> [IdProp] +getIdProps a = id_props a + +getIdQual :: Id -> FString +getIdQual a = id_mfs a + +getIdQualString :: Id -> String +getIdQualString a = getFString $ getIdQual a + +getIdString :: Id -> String +getIdString a | mfs == fsEmpty = getFString fs + | otherwise = getFString mfs ++ "." ++ getFString fs + where mfs = getIdQual a + fs = getIdBase a + +mkId :: Position -> FString -> Id +mkId pos fs = + let value = Id pos fsEmpty fs [] + in -- trace("ID: " ++ (ppReadable value)) $ + value + +-- Qualified with a path. +mkQId :: Position -> FString -> FString -> Id +mkQId pos mfs fs + | fs == fsEmpty = Id pos fsEmpty fsEmpty [] + | fHead:_ <- getFString fs + , isDigit fHead = Id pos fsEmpty fs [] -- XXX + | otherwise = Id pos mfs fs [] + +ppConId :: PDetail -> Id -> Doc +ppConId d i + | d == pdDebug + = pPrintPrec pdDebug 0 i + | otherwise + = -- text ( "props:" ++ show (getIdProps i)) <> + case (getIdBaseString i) of + "->" -> text "(->)" -- arrow + s@(_:_) | all isDigit s -> text s -- numbers + _ -> text (getIdStringCon i) -- constructor-identifiers + +ppId :: PDetail -> Id -> Doc +ppId d i + | d == pdDebug + = pPrintPrec pdDebug 0 i + | otherwise + = if (dbgLevel >= 1) + then case (getIdBaseString i) of + "->" -> text "(->)" -- arrow + s@(c:_) | isDigit c -> text( s ++ "_" ++ (createPositionString (getIdPosition i))) + c:_ | isIdChar c -> text ((getIdString i) ++ "_" ++ (createPositionString (getIdPosition i))) + '$':c:_ | isIdChar c -> text (getIdString i) -- task names + _ -> text ("(" ++ (getIdString i) ++ "_" ++ (createPositionString (getIdPosition i))) + else case (getIdBaseString i) of + "->" -> text "(->)" -- arrow + s@(c:_) | isDigit c -> text s -- numbers + c:_ | isIdChar c -> text (getIdString i) -- identifiers + '$':c:_ | isIdChar c -> text (getIdString i) -- task names + _ -> text ("("++getIdString i++")") -- infix operators + +ppVarId :: PDetail -> Id -> Doc +ppVarId d i + | d == pdDebug + = pPrintPrec pdDebug 0 i + | otherwise + = if (dbgLevel >= 1) + then case (getIdBaseString i) of + s | all isSym s -> text ("("++ (getIdStringOp i) ++ (createPositionString (getIdPosition i)) ++ + ")") -- infix operators + '$':c:_ | isIdChar c -> text ((getIdStringVar i) ++ (createPositionString (getIdPosition i))) + _ -> text ((getIdStringVar i) ++ (createPositionString (getIdPosition i))) + else case (getIdBaseString i) of + s | all isSym s -> text ("("++getIdStringOp i ++ ")") -- infix operators + '$':c:_ | isIdChar c -> text (getIdStringVar i) -- task names + _ -> text (getIdStringVar i) + +qualEq :: Id -> Id -> Bool +qualEq a b | getIdQual a == fsEmpty || getIdQual b == fsEmpty = getIdBase a == getIdBase b +qualEq a b = a == b + +setBadId :: Id -> Id +setBadId idx = addIdProp idx IdP_bad_name + +setIdProps :: Id -> [IdProp] -> Id +setIdProps a l = a { id_props = l } + +-- These used to encode properties in .bi files +getIdStringCon :: Id -> String +getIdStringCon = getIdString +getIdStringVar :: Id -> String +getIdStringVar = getIdString +getIdStringOp :: Id -> String +getIdStringOp = getIdString + +data IdProp = IdPCanFire + | IdPWillFire + | IdPProbe + | IdPInternal + | IdPReady -- interface ready signal + | IdPGeneratedIfc -- generated interface name + | IdPMeth + | IdPCommutativeTCon -- commutative type constructor + | IdP_enable + | IdP_keep + | IdP_keepEvenUnused + | IdPRule + | IdPSplitRule + | IdPDict -- is a dictionary + | IdPRenaming -- id for temporary renaming + | IdP_suffixed -- a _nn suffix has been added + | IdP_SuffixCount Integer -- the number of suffixes added ... not to be used with IdP_suffixed + | IdP_bad_name -- a name generated without good information (e.g., __d5) + | IdP_from_rhs -- a name generated from the right-hand-side of an assignment (e.g., x_PLUS_5__d32) + | IdP_signed -- in C backend, an id created from $signed() + | IdP_NakedInst -- id associated with a "naked" instantiation (i.e. without a bind) + | IdPDisplayName FString -- provide an alternate display string + | IdP_hide + | IdP_hide_all + | IdP_TypeJoin Id Id -- Internally generated type name (anonymous structs) + -- Arguments are the original type and constructor name + | IdPMethodPredicate -- is a predicate of a method call in a rule + -- the Id of meth calls on imported/synthesized modules + -- can be tagged with the position of inlined method calls + -- that it was contained in (the top methods are last) + | IdPInlinedPositions [Position] + -- used by the BSV parser to keep track of which array types + -- were introduced from bracket syntax + | IdPParserGenerated + deriving (Eq, Ord, Show) + +instance Pretty IdProp where + pPrintPrec d _ (IdPInlinedPositions poss) = + pparen True (text "IdPInlinedPositions" <+> pPrintPrec d 0 poss) + pPrintPrec _ _ prop = text (show prop) + +-- ############################################################################# +-- # Methods for adding properties to Id's, checking for them etc. +-- ############################################################################# + +addIdProp :: Id -> IdProp -> Id +addIdProp a prop = setIdProps a (L.union (getIdProps a) [prop]) + +addIdProps :: Id -> [IdProp] -> Id +addIdProps a propl = setIdProps a (L.union (getIdProps a) propl) + +-- Long names + +type Longname = [Id] diff --git a/src/Language/Bluespec/Classic/AST/IntLit.hs b/src/Language/Bluespec/Classic/AST/IntLit.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bluespec/Classic/AST/IntLit.hs @@ -0,0 +1,56 @@ +-- This corresponds to src/comp/IntLit.hs in bsc. +module Language.Bluespec.Classic.AST.IntLit + ( IntLit(..) + , ilDec + , ilSizedDec + , ilHex + , ilSizedHex + , ilBin + , ilSizedBin + ) where + +import Text.PrettyPrint.HughesPJClass + +import Language.Bluespec.IntegerUtil +import Language.Bluespec.Prelude + +data IntLit = IntLit { ilWidth :: Maybe Integer, + ilBase :: Integer, + ilValue :: Integer } + +instance Eq IntLit where + IntLit { ilValue = i1 } == IntLit { ilValue = i2 } = i1 == i2 + IntLit { ilValue = i1 } /= IntLit { ilValue = i2 } = i1 /= i2 + +instance Ord IntLit where + IntLit { ilValue = i1 } <= IntLit { ilValue = i2 } = i1 <= i2 + IntLit { ilValue = i1 } < IntLit { ilValue = i2 } = i1 < i2 + IntLit { ilValue = i1 } >= IntLit { ilValue = i2 } = i1 >= i2 + IntLit { ilValue = i1 } > IntLit { ilValue = i2 } = i1 > i2 + IntLit { ilValue = i1 } `compare` IntLit { ilValue = i2 } = i1 `compare` i2 + +instance Show IntLit where + showsPrec _ (IntLit { ilValue = i, ilWidth = _mw, ilBase = b }) s = + -- width of 0 means don't pad with leading zeros + integerFormatPref 0 b i ++ s + +instance Pretty IntLit where + pPrintPrec _d _p i = text (show i) + +ilDec :: Integer -> IntLit +ilDec i = IntLit { ilWidth = Nothing, ilBase = 10, ilValue = i } + +ilSizedDec :: Integer -> Integer -> IntLit +ilSizedDec w i = IntLit { ilWidth = Just w, ilBase = 10, ilValue = i } + +ilHex :: Integer -> IntLit +ilHex i = IntLit { ilWidth = Nothing, ilBase = 16, ilValue = i } + +ilSizedHex :: Integer -> Integer -> IntLit +ilSizedHex w i = IntLit { ilWidth = Just w, ilBase = 16, ilValue = i } + +ilBin :: Integer -> IntLit +ilBin i = IntLit { ilWidth = Nothing, ilBase = 2, ilValue = i } + +ilSizedBin :: Integer -> Integer -> IntLit +ilSizedBin w i = IntLit { ilWidth = Just w, ilBase = 2, ilValue = i } diff --git a/src/Language/Bluespec/Classic/AST/Literal.hs b/src/Language/Bluespec/Classic/AST/Literal.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bluespec/Classic/AST/Literal.hs @@ -0,0 +1,24 @@ +-- This corresponds to src/comp/Literal.hs in bsc. +module Language.Bluespec.Classic.AST.Literal + ( Literal(..) + ) where + +import Text.PrettyPrint.HughesPJClass + +import Language.Bluespec.Classic.AST.IntLit +import Language.Bluespec.Prelude + +data Literal + = LString String + | LChar Char + | LInt IntLit + | LReal Double + | LPosition -- a position literal is a placeholder for the position in CLiteral + deriving (Eq, Ord, Show) + +instance Pretty Literal where + pPrintPrec _ _ (LString s) = text (show s) + pPrintPrec _ _ (LChar c) = text (show c) + pPrintPrec d p (LInt i) = pPrintPrec d p i + pPrintPrec d p (LReal r) = pPrintPrec d p r + pPrintPrec _ _ LPosition = text ("") diff --git a/src/Language/Bluespec/Classic/AST/Position.hs b/src/Language/Bluespec/Classic/AST/Position.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bluespec/Classic/AST/Position.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE FlexibleInstances #-} +-- This corresponds to src/comp/Position.hs in bsc. +module Language.Bluespec.Classic.AST.Position + ( Position(..) + , bestPosition + , noPosition + , updatePosStdlib + , HasPosition(..) + ) where + +import Text.PrettyPrint.HughesPJClass + +import Language.Bluespec.Prelude + +-- For now, we don't track positions, although we may do so in the future. +data Position = NoPos + deriving (Eq, Ord, Show) + +instance Pretty Position where + pPrintPrec _ _ NoPos = text "" + +bestPosition :: Position -> Position -> Position +bestPosition p1 p2 = if p1 == noPosition then p2 else p1 + +noPosition :: Position +noPosition = NoPos + +updatePosStdlib :: Position -> Bool -> Position +updatePosStdlib pos _is_stdlib = pos + +class HasPosition a where + getPosition :: a -> Position + +instance HasPosition Position where + getPosition p = p + +instance (HasPosition a) => HasPosition (Maybe a) where + getPosition (Just x) = getPosition x + getPosition Nothing = noPosition + +instance (HasPosition a, HasPosition b) => HasPosition (Either a b) where + getPosition (Right x) = getPosition x + getPosition (Left x) = getPosition x + +instance (HasPosition a) => HasPosition [a] where + getPosition [] = noPosition + getPosition (x:xs) = getPosition x `bestPosition` getPosition xs + +instance (HasPosition a, HasPosition b) => HasPosition (a, b) where + getPosition (x, y) = getPosition x `bestPosition` getPosition y + +instance (HasPosition a, HasPosition b, HasPosition c) => HasPosition (a, b, c) where + getPosition (x, y, z) = getPosition x `bestPosition` getPosition y `bestPosition` getPosition z + +instance (HasPosition a, HasPosition b, HasPosition c, HasPosition d) => HasPosition (a, b, c, d) where + getPosition (x, y, z, w) = getPosition x `bestPosition` getPosition y `bestPosition` getPosition z `bestPosition` getPosition w + +instance HasPosition String where + getPosition _x = noPosition diff --git a/src/Language/Bluespec/Classic/AST/Pragma.hs b/src/Language/Bluespec/Classic/AST/Pragma.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bluespec/Classic/AST/Pragma.hs @@ -0,0 +1,230 @@ +-- This corresponds to src/comp/Pragma.hs in bsc. +module Language.Bluespec.Classic.AST.Pragma + ( Pragma(..) + , PProp(..) + , RulePragma(..) + , SchedulePragma(..) + , CSchedulePragma + , IfcPragma(..) + + , ppPProp + ) where + +import Text.PrettyPrint.HughesPJClass + +import Language.Bluespec.Classic.AST.Id +import Language.Bluespec.Classic.AST.Position +import Language.Bluespec.Classic.AST.SchedInfo +import Language.Bluespec.Prelude +import Language.Bluespec.Pretty +import Language.Bluespec.Util + +data Pragma + = Pproperties Id [PProp]-- module Id and properties associate with + | Pnoinline [Id] -- [Id] is a list of functions which should not be inlined + deriving (Eq, Ord, Show) + +instance Pretty Pragma where + pPrintPrec d _p (Pproperties i pps) = + (text "{-# properties" <+> ppId d i <+> text "= { ") <> + sepList (map (pPrintPrec d 0) pps) (text ",") <> text " } #-}" + pPrintPrec d _p (Pnoinline is) = + text "{-# noinline" <+> sep (map (ppId d) is) <+> text " #-}" + +instance HasPosition Pragma where + getPosition (Pproperties i _) = getPosition i + getPosition (Pnoinline (i:_)) = getPosition i + getPosition (Pnoinline []) = error "HasPosition(Pragma).getPosition: Pnoinline []" + +-- Module definition properties: +data PProp + = PPverilog -- generate verilog + | PPforeignImport Id -- wrapper for a foreign import + -- (Id is link name, needed for dependency check, if we're + -- generating the .ba file for the link name, not the src name) + | PPalwaysReady [Longname] -- no ready signals for these methods ([] means all) + | PPalwaysEnabled [Longname] -- execute on every cycle + | PPenabledWhenReady [Longname] -- enable is equivalent to ready + | PPscanInsert Integer -- insert scan chain ports + | PPbitBlast -- do "bit blasting", + -- e.g., split multibit ports + | PPCLK String -- clock port prefix + | PPGATE String -- gate port prefix + | PPRSTN String -- reset port prefix + | PPclock_osc [(Id,String)] -- port name for clock + | PPclock_gate [(Id,String)] -- port name for gate + | PPgate_inhigh [Id] -- clock args with inhigh gates + | PPgate_unused [Id] -- clock args with unused gates + | PPreset_port [(Id,String)] -- port name for reset + | PParg_param [(Id,String)] -- name for parameter argument + | PParg_port [(Id,String)] -- port name for other arguments + | PParg_clocked_by [(Id,String)] -- clocks of module arguments + | PParg_reset_by [(Id,String)] -- resets of module arguments + | PPoptions [String] -- compiler options + | PPgate_input_clocks [Id] -- list of clock args with gates + | PPmethod_scheduling (MethodConflictInfo Longname) + -- scheduling constraints for interface arg methods + | PPdoc String -- comment to carry through to Verilog + | PPperf_spec [[Id]] -- method composition order for performance specs + | PPclock_family [Id] -- ids of input clocks in the same family + | PPclock_ancestors [[Id]] -- input clock ancestry sequences + -- module arguments which should generate to params instead of ports + | PPparam [Id] + | PPinst_name Id + | PPinst_hide + | PPinst_hide_all + | PPdeprecate String + deriving (Eq, Ord, Show) + +instance Pretty PProp where + pPrintPrec d _ (PPscanInsert i) = text "scanInsert = " <+> pPrintPrec d 0 i + pPrintPrec _d _ (PPCLK s) = text ("clock_prefix = " ++ s) + pPrintPrec _d _ (PPGATE s) = text ("gate_prefix = " ++ s) + pPrintPrec _d _ (PPRSTN s) = text ("reset_prefix = " ++ s) + pPrintPrec d _ (PPclock_osc xs) = + text "clock_osc = {" + <> sepList [ text "(" <> ppId d i <> text "," <> (text s) <> text ")" + | (i,s) <- xs ] + (text ",") + <> text "}" + pPrintPrec d _ (PPclock_gate xs) = + text "clock_gate = {" + <> sepList [ text "(" <> ppId d i <> text "," <> (text s) <> text ")" + | (i,s) <- xs ] + (text ",") + <> text "}" + pPrintPrec d _ (PPgate_inhigh is) = + text "gate_inhigh = {" <> sepList (map (ppId d) is) (text ",") <> text "}" + pPrintPrec d _ (PPgate_unused is) = + text "gate_unused = {" <> sepList (map (ppId d) is) (text ",") <> text "}" + pPrintPrec d _ (PPreset_port xs) = + text "reset_port = {" + <> sepList [ text "(" <> ppId d i <> text "," <> (text s) <> text ")" + | (i,s) <- xs ] + (text ",") + <> text "}" + pPrintPrec d _ (PParg_param xs) = + text "arg_param = {" + <> sepList [ text "(" <> ppId d i <> text "," <> (text s) <> text ")" + | (i,s) <- xs ] + (text ",") + <> text "}" + pPrintPrec d _ (PParg_port xs) = + text "arg_port = {" + <> sepList [ text "(" <> ppId d i <> text "," <> (text s) <> text ")" + | (i,s) <- xs ] + (text ",") + <> text "}" + pPrintPrec d _ (PParg_clocked_by xs) = + text "clocked_by = {" + <> sepList [ text "(" <> ppId d i <> text "," <> (text s) <> text ")" + | (i,s) <- xs ] + (text ",") + <> text "}" + pPrintPrec d _ (PParg_reset_by xs) = + text "reset_by = {" + <> sepList [ text "(" <> ppId d i <> text "," <> (text s) <> text ")" + | (i,s) <- xs ] + (text ",") + <> text "}" + pPrintPrec _d _ (PPoptions os) = + text "options = {" + <> sepList (map (text . show) os) (text ",") + <> text "}" + pPrintPrec _d _ (PPdoc comment) = text ("doc = " ++ doubleQuote comment) + pPrintPrec _d _ (PPdeprecate comment) = text ("deprecate = " ++ doubleQuote comment) + pPrintPrec _d _ (PPinst_hide) = text "hide" + pPrintPrec _d _p v = text (drop 2 (show v)) + +ppPProp :: PDetail -> PProp -> Doc +ppPProp d pprop = text "{-#" <+> pPrintPrec d 0 pprop <+> text "#-};" + +data RulePragma + = RPfireWhenEnabled + | RPnoImplicitConditions + | RPaggressiveImplicitConditions + | RPconservativeImplicitConditions + | RPnoWarn -- suppress (on a per-rule basis) warnings G0023, G0036, and G0117 + | RPwarnAllConflicts + | RPcanScheduleFirst + | RPclockCrossingRule + | RPdoc String -- comment to carry through to Verilog + | RPhide + deriving (Eq, Ord, Show) + +-- used for classic printing of CSyntax +-- and by various internal dumps of ISyntax/ASyntax +instance Pretty RulePragma where + pPrintPrec _d _p RPfireWhenEnabled = text "{-# ASSERT fire when enabled #-}" + pPrintPrec _d _p RPnoImplicitConditions = + text "{-# ASSERT no implicit conditions #-}" + pPrintPrec _d _p RPcanScheduleFirst = + text "{-# ASSERT can schedule first #-}" + pPrintPrec _d _p RPaggressiveImplicitConditions = + text "{-# aggressive_implicit_conditions #-}" + pPrintPrec _d _p RPconservativeImplicitConditions = + text "{-# conservative_implicit_conditions #-}" + pPrintPrec _d _p RPnoWarn = + text "{-# no_warn #-}" + pPrintPrec _d _p RPwarnAllConflicts = + text "{-# warn_all_conflicts #-}" + pPrintPrec _d _p RPclockCrossingRule = + text "{-# clock-crossing rule #-}" + pPrintPrec _d _p (RPdoc comment) = + text ("{-# doc = " ++ doubleQuote comment ++ " #-}") + pPrintPrec _d _p RPhide = + text ("{-# hide #-}") + +data SchedulePragma id_t + = SPUrgency [id_t] + | SPExecutionOrder [id_t] + | SPMutuallyExclusive [[id_t]] + | SPConflictFree [[id_t]] + | SPPreempt [id_t] [id_t] + | SPSchedule (MethodConflictInfo id_t) + deriving (Eq, Ord, Show) + +instance (Pretty t, Ord t) => Pretty (SchedulePragma t) where + pPrintPrec d p (SPUrgency ids) = + text "{-# ASSERT descending urgency: " <+> + pPrintPrec d p ids <+> text "#-}" + pPrintPrec d p (SPExecutionOrder ids) = + text "{-# ASSERT execution order: " <+> + pPrintPrec d p ids <+> text "#-}" + pPrintPrec d p (SPMutuallyExclusive idss) = + text "{-# ASSERT mutually exclusive: " <+> + pPrintPrec d p idss <+> text "#-}" + pPrintPrec d p (SPConflictFree idss) = + text "{-# ASSERT conflict-free: " <+> + pPrintPrec d p idss <+> text "#-}" + pPrintPrec d p (SPPreempt ids1 ids2) = + text "{-# ASSERT preempt: " <+> + pPrintPrec d p ids1 <+> pPrintPrec d p ids2 <+> text "#-}" + pPrintPrec d p (SPSchedule s) = + text "{-# ASSERT schedule: " <+> + pPrintPrec d p s <+> text "#-}" + +type CSchedulePragma = SchedulePragma Longname + +-- Interface definition pragmas +-- These pragma are associated with interfaces and/or the fields within the interface +-- The first arg is the field name which the attribute is associated with +data IfcPragma + = PIArgNames [Id] -- arg names used as dummy names (XX this can be removed?) + | PIPrefixStr String -- Method or interface + | PIResultName String -- name for the result of the method AV or value methods + | PIRdySignalName String -- name for the ready signal on this method + | PIEnSignalName String -- name for the enable signal + | PIAlwaysRdy -- ifc or methods tagged as always ready + | PIAlwaysEnabled -- ifc or methods tagged as always enabled + deriving (Eq, Ord, Show) + +instance Pretty IfcPragma where + pPrintPrec d _ (PIArgNames ids) = text "arg_names =" <+> + brackets ( (sepList (map (ppVarId d) ids) comma) ) + pPrintPrec _d _ (PIPrefixStr flds) = text "prefixs =" <+> doubleQuotes (text flds) + pPrintPrec _d _ (PIRdySignalName flds) = text "ready =" <+> doubleQuotes (text flds) + pPrintPrec _d _ (PIEnSignalName flds) = text "enable =" <+> doubleQuotes (text flds) + pPrintPrec _d _ (PIResultName flds) = text "result =" <+> doubleQuotes (text flds) + pPrintPrec _d _ (PIAlwaysRdy ) = text "always_ready " + pPrintPrec _d _ (PIAlwaysEnabled ) = text "always_enabled " diff --git a/src/Language/Bluespec/Classic/AST/SString.hs b/src/Language/Bluespec/Classic/AST/SString.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bluespec/Classic/AST/SString.hs @@ -0,0 +1,10 @@ +-- This corresponds to src/comp/SpeedyString.hs in bsc. +module Language.Bluespec.Classic.AST.SString + ( SString + ) where + +import Data.Text (Text) + +-- bsc represents SStrings as interned strings, but we simplify things as bit +-- and represent them as Text. +type SString = Text diff --git a/src/Language/Bluespec/Classic/AST/SchedInfo.hs b/src/Language/Bluespec/Classic/AST/SchedInfo.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bluespec/Classic/AST/SchedInfo.hs @@ -0,0 +1,120 @@ +-- This corresponds to src/comp/SchedInfo.hs in bsc. +module Language.Bluespec.Classic.AST.SchedInfo + ( SchedInfo(..) + , MethodConflictInfo(..) + , makeMethodConflictDocs + ) where + +import qualified Data.List as L +import qualified Data.Map as M +import qualified Data.Set as S +import Text.PrettyPrint.HughesPJClass + +import Language.Bluespec.Prelude +import Language.Bluespec.Pretty + +data SchedInfo idtype = SchedInfo { + methodConflictInfo :: MethodConflictInfo idtype, + -- methods which have a rule that must execute between them + -- (in the given order) and the list of rules + -- XXX should we include the rule names? they don't exist + -- XXX on the boundary, but could be useful for debugging + rulesBetweenMethods :: [((idtype, idtype), [idtype])], + -- methods which have a rule that must execute before it + -- along with the list of rules involved. + -- Left = rule directly before this method + -- Right = method called by this method which requires a rule before it + rulesBeforeMethods :: [(idtype,[Either idtype idtype])], + -- methods which allow an unsynchronized clock domain crossing + clockCrossingMethods :: [idtype] + } + deriving (Eq, Ord, Show) + +instance (Pretty idtype, Ord idtype) => Pretty (SchedInfo idtype) where + pPrintPrec d _p si = + sep [text "SchedInfo", + pPrintPrec d 0 (methodConflictInfo si), + pPrintPrec d 0 (rulesBetweenMethods si), + pPrintPrec d 0 (rulesBeforeMethods si), + pPrintPrec d 0 (clockCrossingMethods si)] + +{- a CF b => a & b have the same effect when executed in parallel + in the same rule, or when executed in either order + in different rules in the same cycle. + a SB b => a & b have the same effect when executed in parallel + in the same rule, or when a is executed before b in + different rules in the same cycle. Executing b before + a within one cycle is illegal. + ME [a,b,c] => only one of a,b or c can execute in any cycle. + a P b => a & b may be executed in parallel within a single + rule. It is illegal to execute a & b in the same + cycle in two different rules, in any order. + a SBR b => a may be executed before b in different rules in + the same cycle. It is illegal to execute a & b in + parallel in a single rule, or to execute b before a + in two different rules in the same cycle. + a C b => a & b may not execute in the same cycle, whether in + one rule or two, in any order. + EXT a => two executions of a cannot occur in one rule. + a & b can execute in two different rules in the same + cycle but the effect will be different. The + difference must be resolved external to the module. +-} +data MethodConflictInfo idtype = + MethodConflictInfo { + sCF :: [(idtype, idtype)], + sSB :: [(idtype, idtype)], + sME :: [[idtype]], + sP :: [(idtype, idtype)], + sSBR :: [(idtype, idtype)], + sC :: [(idtype, idtype)], + sEXT :: [idtype] + } + deriving (Eq, Ord, Show) + +instance (Pretty idtype, Ord idtype) => Pretty (MethodConflictInfo idtype) where + pPrintPrec d p mci = + let ds = makeMethodConflictDocs (pPrintPrec d p) ppReadable "[" "]" mci + in text "[" <> sepList ds (text ",") <> text "]" + +-- Given: +-- * a printing function for ids (pPrint or pvPrint) +-- * a function for turning the ids into strings for sorting order +-- * start and stop enclosure for a list (we assume comma-separated) +-- * a MethodConflictInfo structure +-- Produce: +-- a list of Doc for the MethodConflictInfo info +-- (un-factored from pairs to groups) +-- +makeMethodConflictDocs :: (Ord idtype) => + (idtype -> Doc) -> + (idtype -> String) -> + String -> String -> + MethodConflictInfo idtype -> [Doc] +makeMethodConflictDocs pId sId listStart listEnd + (MethodConflictInfo { sCF=sCF0, sSB=sSB0, sME=sME0, sP=sP0, + sSBR=sSBR0, sC=sC0, sEXT=sEXT0 }) = + [pp m <+> text "CF" <+> pp m' | (m,m') <- toPairsOfLists sCF0 ] ++ + [pp m <+> text "SB" <+> pp m' | (m,m') <- toPairsOfLists sSB0 ] ++ + [ text "ME" <+> pp m | m <- sME_ordered ] ++ + [pp m <+> text "P" <+> pp m' | (m,m') <- toPairsOfLists sP0 ] ++ + [pp m <+> text "SBR" <+> pp m' | (m,m') <- toPairsOfLists sSBR0 ] ++ + [pp m <+> text "C" <+> pp m' | (m,m') <- toPairsOfLists sC0 ] ++ + (if null sEXT0 then [] else [text "EXT" <+> pp sEXT_ordered]) + where + pp [m] = pId m + pp ms = + text listStart <> (sepList (map pId ms) (text ",")) <> text listEnd + + collect ps = M.fromListWith (S.union) [(a,S.singleton b) | (a,b) <- ps] + toPairsOfLists ps = let m1 = collect ps + m2 = collect [(s,a) | (a,s) <- M.toList m1] + in sortLP [ (sortI (S.toList s2), sortI (S.toList s1)) + | (s1,s2) <- M.toList m2 + ] + + sortI = L.sortBy (\ i1 i2 -> (sId i1) `compare` (sId i2)) + sortL = L.sortBy (\ is1 is2 -> (map sId is1) `compare` (map sId is2)) + sortLP = L.sortBy (\(is1,_) (is2,_) -> (map sId is1) `compare` (map sId is2)) + sME_ordered = sortL (map sortI sME0) + sEXT_ordered = sortI sEXT0 diff --git a/src/Language/Bluespec/Classic/AST/Syntax.hs b/src/Language/Bluespec/Classic/AST/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bluespec/Classic/AST/Syntax.hs @@ -0,0 +1,987 @@ +module Language.Bluespec.Classic.AST.Syntax + ( CPackage(..) + , CExport(..) + , CImport(..) + , CSignature(..) + , CFixity(..) + , CDefn(..) + , IdK(..) + , CFunDeps + , CExpr(..) + , CLiteral(..) + , COp(..) + , CSummands + , CInternalSummand(..) + , COSummands + , COriginalSummand(..) + , CField(..) + , CFields + , CCaseArm(..) + , CCaseArms + , CStmt(..) + , CStmts + , CMStmt(..) + , CRule(..) + , CDefl(..) + , CDef(..) + , CClause(..) + , CQual(..) + , CPat(..) + , CPOp(..) + , CInclude(..) + + , cApply + , cVApply + , getName + , iKName + ) where + +import Data.Char (isAlpha) +import qualified Data.List as L +import Text.PrettyPrint.HughesPJClass + +import Language.Bluespec.Classic.AST.Builtin.Ids +import Language.Bluespec.Classic.AST.Builtin.FStrings +import Language.Bluespec.Classic.AST.FString +import Language.Bluespec.Classic.AST.Id +import Language.Bluespec.Classic.AST.Literal +import Language.Bluespec.Classic.AST.Position +import Language.Bluespec.Classic.AST.Pragma +import Language.Bluespec.Classic.AST.Type +import Language.Bluespec.Classic.AST.Undefined +import Language.Bluespec.Classic.AST.VModInfo +import Language.Bluespec.IntegerUtil +import Language.Bluespec.Lex +import Language.Bluespec.Log2 +import Language.Bluespec.Prelude +import Language.Bluespec.Pretty +import Language.Bluespec.Util + +-- Complete package +data CPackage = CPackage + Id -- package name + (Either [CExport] + [CExport]) -- export identifiers + -- Left exps = export only exps + -- Right exps = export everything but exps + [CImport] -- imported identifiers + [CFixity] -- fixity declarations for infix operators + [CDefn] -- top level definitions + [CInclude] -- any `include files + deriving (Eq, Ord, Show) + +instance Pretty CPackage where + pPrintPrec d _ (CPackage i exps imps fixs def includes) = + (t"package" <+> ppConId d i <> ppExports d exps <+> t "where {") $+$ + pBlock d 0 True (map (pp d) imps ++ map (pp d) fixs ++ map (pp d) def ++ map (pp d) includes) + +data CExport + = CExpVar Id -- export a variable identifier + | CExpCon Id -- export a constructor + | CExpConAll Id -- export an identifier and constructors + -- (datatypes, interfaces, etc.) + | CExpPkg Id -- export an entire package + deriving (Eq, Ord, Show) + +instance Pretty CExport where + pPrintPrec d _p (CExpVar i) = ppVarId d i + pPrintPrec d _p (CExpCon i) = ppConId d i + pPrintPrec d _p (CExpConAll i) = ppConId d i <> t"(..)" + pPrintPrec d _p (CExpPkg i) = t"package" <+> ppId d i + +ppExports :: PDetail -> Either [CExport] [CExport] -> Doc +ppExports _d (Right []) = empty +ppExports d (Right noexps) = t " hiding (" <> sepList (map (pp d) noexps) (t",") <> t")" +ppExports d (Left exports) = t "(" <> sepList (map (pp d) exports) (t",") <> t")" + +data CImport + = CImpId Bool Id -- Bool indicates qualified + | CImpSign String Bool CSignature + deriving (Eq, Ord, Show) + +instance Pretty CImport where + pPrintPrec d _p (CImpId q i) = t"import" <+> ppQualified q <+> ppConId d i + pPrintPrec d _p (CImpSign _ q (CSignature i _ _ _)) = t"import" <+> ppQualified q <+> ppConId d i <+> t "..." + +ppQualified :: Bool -> Doc +ppQualified True = text "qualified" +ppQualified False = empty + +-- Package signature from import +data CSignature + = CSignature Id [Id] [CFixity] [CDefn] -- package name, imported packages, definitions + deriving (Eq, Ord, Show) + +instance Pretty CSignature where + pPrintPrec d _ (CSignature i imps fixs def) = + (t"signature" <+> ppConId d i <+> t "where" <+> t "{") $+$ + pBlock d 0 True (map pi' imps ++ map (pp d) fixs ++ map (pp d) def) + where pi' i' = t"import" <+> ppConId d i' + +data CFixity + = CInfix Integer Id + | CInfixl Integer Id + | CInfixr Integer Id + deriving (Eq, Ord, Show) + +instance Pretty CFixity where + pPrintPrec d _ (CInfix p i) = text "infix" <+> text (show p) <+> ppInfix d i + pPrintPrec d _ (CInfixl p i) = text "infixl" <+> text (show p) <+> ppInfix d i + pPrintPrec d _ (CInfixr p i) = text "infixr" <+> text (show p) <+> ppInfix d i + +-- Top level definition +data CDefn + = Ctype IdK [Id] CType + | Cdata { cd_visible :: Bool, + cd_name :: IdK, + cd_type_vars :: [Id], + cd_original_summands :: COSummands, + cd_internal_summands :: CSummands, + cd_derivings :: [CTypeclass] } + | Cstruct Bool StructSubType IdK [Id] CFields + [CTypeclass] + -- Bool indicates the constrs are visible + -- first [Id] are the names of this definition's argument type variables + -- last [CTypeclass] are derived classes + -- incoherent_matches superclasses name_with_kind variables fundeps default_methods + | Cclass (Maybe Bool) [CPred] IdK [Id] CFunDeps CFields + | Cinstance CQType [CDefl] + | CValue Id [CClause] + | CValueSign CDef + | Cforeign { cforg_name :: Id, + cforg_type :: CQType, + cforg_foreign_name :: Maybe String, + cforg_ports :: Maybe ([String], [String]) } + | Cprimitive Id CQType + | CprimType IdK + | CPragma Pragma + -- only in package signatures + | CIinstance Id CQType + -- CItype is imported abstractly + | CItype IdK [Id] [Position] -- positions of use that caused export + | CIclass (Maybe Bool) [CPred] IdK [Id] CFunDeps [Position] -- positions of use that caused export + | CIValueSign Id CQType + deriving (Eq, Ord, Show) + +instance Pretty CDefn where + pPrintPrec d _p (Ctype i as ty) = + sep [sep ((t"type" <+> ppConIdK d i) : map (nest 2 . ppVarId d) as) <+> t "=", + nest 2 (pp d ty)] + pPrintPrec d _p (Cdata { cd_visible = vis, + cd_name = i, + cd_type_vars = as, + cd_original_summands = cs@(_:_), + cd_internal_summands = [], + cd_derivings = _ds }) = -- a hack to print original constructors + sep [sep ((t"data" <+> ppConIdK d i) : map (nest 2 . ppVarId d) as) <> t(if vis then " =" else " =="), + nest 2 (ppOSummands d cs)] + pPrintPrec d _p (Cdata { cd_visible = vis, + cd_name = i, + cd_type_vars = as, + cd_internal_summands = cs, + cd_derivings = ds }) = + sep [sep ((t"data" <+> ppConIdK d i) : map (nest 2 . ppVarId d) as) <> t(if vis then " =" else " =="), + nest 2 (ppSummands d cs)] + <> ppDer d ds + pPrintPrec d _p (Cstruct vis (SInterface prags) i as fs ds) = + (t("interface ") <> sep (ppConIdK d i : map (nest 2 . ppVarId d) as) <+> ppIfcPragma d prags <+> t(if vis then "= {" else "== {")) $+$ + pBlock d 4 False (map (ppField d) fs) <> ppDer d ds + pPrintPrec d _p (Cstruct vis _ss i as fs ds) = + (t("struct ") <> sep (ppConIdK d i : map (nest 2 . ppVarId d) as) <+> t(if vis then "= {" else "== {")) $+$ + pBlock d 4 False (map (ppField d) fs) <> ppDer d ds + pPrintPrec d _p (Cclass incoh ps ik is fd ss) = + (t_cls <+> ppPreds d ps (sep (ppConIdK d ik : map (ppVarId d) is)) <> ppFDs d fd <+> t "where {") $+$ + pBlock d 4 False (map (ppField d) ss) + where t_cls = case incoh of + Just False -> t"class coherent" + Just True -> t"class incoherent" + Nothing -> t"class" + pPrintPrec d _p (Cinstance qt ds) = + (t"instance" <+> pPrintPrec d 0 qt <+> t "where {") $+$ + pBlock d 4 False (map (pPrintPrec d 0) ds) + pPrintPrec d p (CValueSign def) = pPrintPrec d p def + pPrintPrec d p (CValue i cs) = + vcat (map (\ cl -> ppClause d p [ppVarId d i] cl <> t";") cs) + pPrintPrec d _p (Cprimitive i ty) = + text "primitive" <+> ppVarId d i <+> t "::" <+> pp d ty + pPrintPrec d p (CPragma pr) = pPrintPrec d p pr + pPrintPrec d _p (CprimType ik) = + t"primitive type" <+> + -- don't use ppConIdK because this syntax has no parentheses + case (ik) of + (IdK i) -> ppConId d i + (IdKind i k) -> ppConId d i <+> t "::" <+> pp d k + (IdPKind i pk) -> ppConId d i <+> t "::" <+> pp d pk + pPrintPrec d _p (Cforeign i ty oname opnames) = + text "foreign" <+> ppVarId d i <+> t "::" <+> pp d ty <> (case oname of Nothing -> text ""; Just s -> text (" = " ++ show s)) <> (case opnames of Nothing -> text ""; Just (is, os) -> t"," <> pparen True (sep (map (text . show) is ++ po os))) + where po [o] = [text ",", text (show o)] + po os = [t"(" <> sepList (map (text . show) os) (t",") <> t ")"] + pPrintPrec d _p (CIinstance i qt) = + t"instance" <+> ppConId d i <+> pPrintPrec d 0 qt + pPrintPrec d _p (CItype i as _positions) = + sep (t"type" <+> ppConIdK d i : map (nest 2 . ppVarId d) as) + pPrintPrec d _p (CIclass incoh ps ik is fd _positions) = + t_cls <+> ppPreds d ps (sep (ppConIdK d ik : map (nest 2 . ppVarId d) is)) <> ppFDs d fd + where t_cls = case incoh of + Just False -> t"class coherent" + Just True -> t"class incoherent" + Nothing -> t"class" + pPrintPrec d _p (CIValueSign i ty) = ppVarId d i <+> t "::" <+> pp d ty + +instance HasPosition CDefn where + getPosition d = getPosition (getName d) + +-- Since IdPKind is only expected in some disjuncts of CDefn, we could +-- create a separate IdPK for those cases, but that seems like overkill. +-- IdPKind in other locations will just be treated like IdK (no kind info). +data IdK + = IdK Id + | IdKind Id Kind + -- this should not exist after typecheck + | IdPKind Id PartialKind + deriving (Eq, Ord, Show) + +instance Pretty IdK where + pPrintPrec d p (IdK i) = pPrintPrec d p i + pPrintPrec d _p (IdKind i k) = pparen True $ pp d i <+> t "::" <+> pp d k + pPrintPrec d _p (IdPKind i pk) = pparen True $ pp d i <+> t "::" <+> pp d pk + +instance HasPosition IdK where + getPosition (IdK i) = getPosition i + getPosition (IdKind i _) = getPosition i + getPosition (IdPKind i _) = getPosition i + +pBlock :: PDetail -> Int -> Bool -> [Doc] -> Doc +pBlock _ _n _ [] = t"}" +pBlock _ n nl xs = + (t (replicate n ' ') <> + foldr1 ($+$) (map (\ x -> x <> if nl then t";" $+$ t"" else t";") (init xs) ++ [last xs])) $+$ + t"}" + +ppDer :: PDetail -> [CTypeclass] -> Doc +ppDer _d [] = text "" +ppDer d is = text " deriving (" <> sepList (map (pPrintPrec d 0) is) (text ",") <> text ")" + +type CFunDeps = [([Id],[Id])] + +-- Expressions +data CExpr + = CLam (Either Position Id) CExpr + | CLamT (Either Position Id) CQType CExpr + | Cletseq [CDefl] CExpr -- rhs of "let x = x" refers to previous def + -- before current let or in earlier arm + | Cletrec [CDefl] CExpr -- rhs of "let x = x" refers to self + | CSelect CExpr Id -- expr, field id + | CCon Id [CExpr] -- constructor id, arguments + | Ccase Position CExpr CCaseArms + -- Either a struct type or a constructor with named fields. + -- The 'Maybe Bool' argument can indicate if it is specifically + -- one or the other (True for struct), otherwise the typechecker + -- will attempt to determine which is intended. + | CStruct (Maybe Bool) Id [(Id, CExpr)] + | CStructUpd CExpr [(Id, CExpr)] + + -- for hardware writes + -- lhs <= rhs + | Cwrite Position CExpr CExpr + + | CAny Position UndefKind + | CVar Id + | CApply CExpr [CExpr] + | CTaskApply CExpr [CExpr] -- system task calls + | CTaskApplyT CExpr CType [CExpr] -- type-checked $task (only $display) calls (the type is the inferred function type for the varargs task) + | CLit CLiteral + | CBinOp CExpr Id CExpr + | CHasType CExpr CQType + | Cif Position CExpr CExpr CExpr + -- x[a] + | CSub Position CExpr CExpr + -- x[a:b] + | CSub2 CExpr CExpr CExpr + -- x[a:b] = y + | CSubUpdate Position CExpr (CExpr, CExpr) CExpr + | Cmodule Position [CMStmt] + | Cinterface Position (Maybe Id) [CDefl] + | CmoduleVerilog + CExpr -- expr for the module name (type String) + Bool -- whether it is a user-imported module + VClockInfo -- clocks + VResetInfo -- resets + [(VArgInfo,CExpr)] -- input arguments + [VFieldInfo] -- output interface fields + VSchedInfo -- scheduling annotations + VPathInfo -- path annotations + | CForeignFuncC Id CQType -- link name, wrapped type + | Cdo Bool CStmts -- Bool indicates recursive binding + | Caction Position CStmts + | Crules [CSchedulePragma] [CRule] + -- used before operator parsing + | COper [COp] + -- from deriving + | CCon1 Id Id CExpr -- type id, con id, expr + | CSelectTT Id CExpr Id -- type id, expr, field id + -- INTERNAL in type checker + | CCon0 (Maybe Id) Id -- type id, constructor id + -- Not part of the surface syntax, used after type checking + | CConT Id Id [CExpr] -- type id, constructor id, arguments + | CStructT CType [(Id, CExpr)] + | CSelectT Id Id -- type id, field id + | CLitT CType CLiteral + | CAnyT Position UndefKind CType + | CmoduleVerilogT CType + CExpr -- expr for the module name (type String) + Bool -- whether it is a user-imported module + VClockInfo -- clocks + VResetInfo -- resets + [(VArgInfo,CExpr)] -- input arguments + [VFieldInfo] -- output interface fields + VSchedInfo -- scheduling annotations + VPathInfo -- path annotations + | CForeignFuncCT Id CType -- link name, primitive type + | CTApply CExpr [CType] + -- for passing pprops as values + | Cattributes [(Position,PProp)] + deriving (Eq, Ord, Show) + +instance Pretty CExpr where + pPrintPrec d p (CLam ei e) = ppQuant "\\ " d p ei e + pPrintPrec d p (CLamT ei _ty e) = ppQuant "\\ " d p ei e + pPrintPrec d p (Cletseq [] e) = pparen (p > 0) $ + (t"letseq in" <+> pp d e) + pPrintPrec d p (Cletseq ds e) = pparen (p > 0) $ + (t"letseq" <+> text "{" <+> foldr1 ($+$) (map (pp d) ds)) <+> text "}" $+$ + (t"in " <> pp d e) + pPrintPrec d p (Cletrec [] e) = pparen (p > 0) $ + (t"let in" <+> pp d e) + pPrintPrec d p (Cletrec ds e) = pparen (p > 0) $ + (t"let" <+> t "{" <+> foldr1 ($+$) (map (pp d) ds)) <+> t "}" $+$ + (t"in " <> pp d e) + pPrintPrec d p (CSelect e i) = pparen (p > (fromIntegral maxPrec+2)) $ pPrintPrec d (fromIntegral maxPrec+2) e <> t"." <> ppVarId d i + pPrintPrec d _p (CCon i []) = ppConId d i + pPrintPrec d p (CCon i es) = pPrintPrec d p (CApply (CCon i []) es) + pPrintPrec d p (Ccase _pos e arms) = pparen (p > 0) $ ppCase d e arms + pPrintPrec _d _p (CAny {}) = text "_" + pPrintPrec d _p (CVar i) = ppVarId d i + pPrintPrec _d _p (CStruct _ tyc []) | tyc == idPrimUnit = text "()" + pPrintPrec d p (CStruct _ tyc ies) = pparen (p > 0) $ pPrintPrec d (fromIntegral maxPrec+1) tyc <+> t "{" <+> sepList (map f ies ++ [t"}"]) (t";") + where f (i, e) = ppVarId d i <+> t "=" <+> pp d e + pPrintPrec d p (CStructUpd e ies) = pparen (p > 0) $ pPrintPrec d (fromIntegral maxPrec+1) e <+> t "{" <+> sepList (map f ies ++ [t"}"]) (t";") + where f (i, e') = ppVarId d i <+> t "=" <+> pp d e' + pPrintPrec d p (Cwrite _ e v) = pparen (p > 0) $ pPrintPrec d (fromIntegral maxPrec+1) e <+> t ":=" <+> pPrintPrec d p v + pPrintPrec d p (CApply e []) + | d == pdReadable + = pPrintPrec pdReadable p e + pPrintPrec d p (CApply e es) = pparen (p>(fromIntegral maxPrec-1)) $ + sep (pPrintPrec d (fromIntegral maxPrec-1) e : map (nest 2 . ppApArg) es) + where ppApArg e' = pPrintPrec d (fromIntegral maxPrec) e' + pPrintPrec d p (CTaskApply e es) = pparen (p>(fromIntegral maxPrec-1)) $ + sep (pPrintPrec d (fromIntegral maxPrec-1) e : map (nest 2 . ppApArg) es) + where ppApArg e' = pPrintPrec d (fromIntegral maxPrec) e' + -- XXX: should include t? + pPrintPrec d p (CTaskApplyT e _t es) = pparen (p>(fromIntegral maxPrec-1)) $ + sep (pPrintPrec d (fromIntegral maxPrec-1) e : map (nest 2 . ppApArg) es) + where ppApArg e' = pPrintPrec d (fromIntegral maxPrec) e' + pPrintPrec d p (CLit l) = pPrintPrec d p l + pPrintPrec d p (CBinOp e1 i e2) = ppOp d p i e1 e2 + pPrintPrec d p (CHasType e t') = pparen (p>0) $ pPrintPrec d (fromIntegral maxPrec) e <> text "::" <> pPrintPrec d (fromIntegral maxPrec) t' + pPrintPrec d p (Cif _pos c tr e) = pparen (p>0) (sep [t"if" <+> pp d c <+> t "then", nest 4 (pp d tr), t"else", nest 4 (pp d e)]) + pPrintPrec d _p (CSub _pos e s) = pPrintPrec d (fromIntegral maxPrec) e <> t"[" <> pp d s <> t"]" + pPrintPrec d _p (CSub2 e h l) = pPrintPrec d (fromIntegral maxPrec) e <> t"[" <> pp d h <> t":" <> pp d l <> t"]" + pPrintPrec d p (CSubUpdate _pos e (h, l) rhs) = pPrintPrec d p (CSub2 e h l) <> t"=" <> pPrintPrec d (fromIntegral maxPrec) rhs + pPrintPrec d _p (Cmodule _ is) = t"module {" $+$ pBlock d 2 False (map (pp d) is) + pPrintPrec d p (Cinterface _pos Nothing ds) = + pparen (p>0) (t"interface {" $+$ pBlock d 2 False (map (pp d) ds)) + pPrintPrec d p (Cinterface _pos (Just i) ds) = + pparen (p>0) (t"interface" <+> pp d i <+> t "{" $+$ pBlock d 2 False (map (pp d) ds)) + pPrintPrec d _p (CmoduleVerilog m _ui c r ses fs sch _ps) = + sep [ + t"module verilog" <+> pp d m <+> + pp d c <> t"" <+> pp d r <+> t"", + nest 4 (if null ses then t"" else pparen True (sepList (map ppA ses) (t","))), + nest 4 (t"{" $+$ pBlock d 2 False (map f fs)), + nest 4 (pp d sch) ] + where mfi _s Nothing = empty + mfi s (Just i) = t s <+> ppVarId d i + mfp _s Nothing = empty + mfp s (Just (VName s', _)) = t s <+> t s' + f (Clock i) = t "clock_field " <> ppVarId d i + f (Reset i) = t "reset_field " <> ppVarId d i + f (Inout i (VName p') mc mr) = + t "inout_field " <> ppVarId d i <+> t p' <+> + mfi "clocked_by" mc <+> mfi "reset_by" mr + f (Method i mc mr n ps mo me) = + ppVarId d i <> g n <+> t "=" <+> t (unwords (map h ps)) <+> + mfi "clocked_by" mc <+> mfi "reset_by" mr <+> mfp "output" mo <+> mfp "enable" me + g 1 = t"" + g n = t("[" ++ itos n ++ "]") + h (s,[]) = show s + h (s,ps) = show s ++ "{" ++ L.intercalate "," (map (drop 2 . show) ps) ++ "}" + ppA (ai, e) = text "(" <> text (ppReadable ai) <> text "," <+> pp d e <> text ")" + pPrintPrec d _p (CForeignFuncC i _wrap_ty) = + -- There's no real Classic syntax for this: + t"ForeignFuncC" <+> pp d i + pPrintPrec d p (Cdo _ ss) = pparen (p>0) $ t "do" <+> t "{" <+> sepList (map (pPrintPrec d 0) ss ++ [t"}"]) (t";") + pPrintPrec d p (Caction _ ss) = pparen (p>0) $ t "action" <+> t "{" <+> sepList (map (pPrintPrec d 0) ss ++ [t"}"]) (t";") + pPrintPrec d p (Crules [] rs) = pparen (p>0) $ t"rules {" $+$ pBlock d 2 False (map (pp d) rs) + pPrintPrec d p (Crules ps rs) = pPrintPrec d p ps $+$ + (pparen (p>0) $ t"rules {" $+$ pBlock d 2 False (map (pp d) rs)) + pPrintPrec d p (COper ops) = pparen (p > fromIntegral maxPrec-1) (sep (map (pPrintPrec d (fromIntegral maxPrec-1)) ops)) + ---- + pPrintPrec d p (CCon1 _ i e) = pPrintPrec d p (CCon i [e]) + pPrintPrec d p (CSelectTT _ e i) = pparen (p > (fromIntegral maxPrec+2)) $ pPrintPrec d (fromIntegral maxPrec+2) e <> t"." <> ppVarId d i + ---- + pPrintPrec d _p (CCon0 _ i) = ppConId d i + ---- + pPrintPrec d p (CConT _ i es) = pPrintPrec d p (CCon i es) + pPrintPrec d p (CStructT ty ies) = pPrintPrec d p (CStruct (Just True) tyc ies) + -- where (Just tyc) = leftCon ty + where tyc = case leftCon ty of + Just tyc' -> tyc' + Nothing -> error "Syntax.Pretty(CExpr): CStructT (leftCon ty failed)" + pPrintPrec d _p (CSelectT _ i) = text "." <> ppVarId d i + pPrintPrec d p (CLitT _ l) = pPrintPrec d p l + pPrintPrec _d _p (CAnyT _pos _uk _t) = text "_" + pPrintPrec d p (CmoduleVerilogT _ m ui c mr ses fs sch ps) = pPrintPrec d p (CmoduleVerilog m ui c mr ses fs sch ps) + pPrintPrec d _p (CForeignFuncCT i _prim_ty) = t"ForeignFuncC" <+> pp d i + pPrintPrec d p (CTApply e ts) = pparen (p>(fromIntegral maxPrec-1)) $ + sep (pPrintPrec d (fromIntegral maxPrec-1) e : map (nest 2 . ppApArg) ts) + where ppApArg ty = t"\183" <> pPrintPrec d (fromIntegral maxPrec) ty + pPrintPrec d _p (Cattributes pps) = pparen True $ text "Attributes" <+> pPrintPrec d 0 (map snd pps) + +instance HasPosition CExpr where + getPosition (CLam ei _) = getPosition ei + getPosition (CLamT ei _ _) = getPosition ei + getPosition (Cletseq ds e) = getPosition (ds, e) + getPosition (Cletrec ds e) = getPosition (ds, e) + getPosition (CSelect e _) = getPosition e + getPosition (CSelectTT _ e _) = getPosition e + getPosition (CCon c _) = getPosition c + getPosition (Ccase pos _ _) = pos + getPosition (CStruct _ i _) = getPosition i + getPosition (CStructUpd e _) = getPosition e + getPosition (Cwrite pos _ _) = pos + getPosition (CAny pos _) = pos + getPosition (CVar i) = getPosition i + getPosition (CApply e _) = getPosition e + getPosition (CTaskApply e _) = getPosition e + getPosition (CTaskApplyT e _ _) = getPosition e + getPosition (CLit l) = getPosition l + getPosition (CBinOp e _ _) = getPosition e + getPosition (CHasType e _) = getPosition e + getPosition (Cif pos _ _ _) = pos + getPosition (CSub pos _ _) = pos + getPosition (CSub2 e _ _) = getPosition e + getPosition (CSubUpdate pos _ _ _) = pos + getPosition (CCon1 _ c _) = getPosition c + getPosition (Cmodule pos _) = pos + getPosition (Cinterface pos _i _ds) = pos + getPosition (CmoduleVerilog e _ _ _ ses fs _ _) = + getPosition (e, map snd ses, fs) + getPosition (CmoduleVerilogT _ e _ _ _ ses fs _ _) = + getPosition (e, map snd ses, fs) + getPosition (CForeignFuncC i _) = getPosition i + getPosition (CForeignFuncCT i _) = getPosition i + getPosition (Cdo _ ss) = getPosition ss + getPosition (Caction pos _ss) = pos + getPosition (Crules _ rs) = getPosition rs + getPosition (COper es) = getPosition es + getPosition (Cattributes pps) = + -- take the position of the first pprop with a good position + getPosition (map fst pps) + -- + getPosition (CTApply e ts) = getPosition (e, ts) + getPosition (CConT _ c _) = getPosition c + getPosition (CCon0 _ c) = getPosition c + getPosition (CSelectT _ i) = getPosition i + getPosition (CLitT _ l) = getPosition l + getPosition (CAnyT pos _ _) = pos + getPosition e = error ("no match in getPosition: " ++ ppReadable e) + +data CLiteral = CLiteral Position Literal deriving (Show) + +instance Eq CLiteral where + CLiteral _ l == CLiteral _ l' = l == l' + +instance Ord CLiteral where + CLiteral _ l `compare` CLiteral _ l' = l `compare` l' + +instance Pretty CLiteral where + pPrintPrec d p (CLiteral _ l) = pPrintPrec d p l + +instance HasPosition CLiteral where + getPosition (CLiteral p _) = p + +ppQuant :: String -> PDetail -> Rational -> Either Position Id -> CExpr -> Doc +ppQuant s d p ei e = + let ppI (Left _) = text "_" + ppI (Right i) = pPrintPrec d 0 i + in pparen (p>0) (sep [t s <> ppI ei <+> t "->", pp d e]) + +data COp + = CRand CExpr -- operand + | CRator Int Id -- infix operator Id, Int is the number of arguments? + deriving (Eq, Ord, Show) + +instance Pretty COp where + pPrintPrec d _ (CRand p) = pp d p + pPrintPrec d _ (CRator _ i) = ppInfix d i + +instance HasPosition COp where + getPosition (CRand e) = getPosition e + getPosition (CRator _ i) = getPosition i + +ppCase :: PDetail -> CExpr -> [CCaseArm] -> Doc +ppCase detail scrutinee arms = + (t"case" <+> pp detail scrutinee <+> t "of {") $+$ + pBlock detail 0 False (map ppArm arms) + where ppArm arm = + sep [pPrintPrec detail 0 (cca_pattern arm) <> + ppQuals detail (cca_filters arm) <+> t "-> ", + nest 2 (pp detail (cca_consequent arm))] + +ppOp :: PDetail -> Rational -> Id -> CExpr -> CExpr -> Doc +ppOp d pd i p1 p2 = + pparen (pd > 0) (sep [pPrintPrec d 1 p1 <> t"" <+> ppInfix d i, pPrintPrec d 1 p2]) +{- + let (p, lp, rp) = + case getFixity i of + FInfixl p -> (p, p, p+1) + FInfixr p -> (p, p+1, p) + FInfix p -> (p, p+1, p+1) + in pparen (d > PDReadable || pd>p) + (sep [pPrint d lp p1 <> t"" <+> ppInfix d i, pPrint d rp p2]) +-} + +type CSummands = [CInternalSummand] + +-- summand in internal form (each summand only takes a single argument +-- whose type is CType) +-- Data constructors can have multiple names for a constructor (for backwards +-- compatibility with old names), but the first name is the primary name +-- (used in compiler output etc). +data CInternalSummand = + CInternalSummand { cis_names :: [Id], + cis_arg_type :: CType, + cis_tag_encoding :: Integer } + deriving (Eq, Ord, Show) + +instance HasPosition CInternalSummand where + getPosition summand = getPosition (cis_names summand) + +-- original summands (taking a list of arguments, each of whose types +-- is given by CQType); the Int is a hack to support Enums with +-- noncontiguous Bits encodings +-- Data constructors can have multiple names for a constructor (for backwards +-- compatibility with old names), but the first name is the primary name +-- (used in compiler output etc). +type COSummands = [COriginalSummand] + +data COriginalSummand = + COriginalSummand { cos_names :: [Id], + cos_arg_types :: [CQType], + cos_field_names :: Maybe [Id], + cos_tag_encoding :: Maybe Integer } + deriving (Eq, Ord, Show) + +-- if CQType is a function, [IfcPragmas] (if present) lists argument names +-- (used by the backend to generate pretty names for module ports) +data CField = CField { cf_name :: Id, + cf_pragmas :: Maybe [IfcPragma], + cf_type :: CQType, + cf_default :: [CClause], + cf_orig_type :: Maybe CType + } + deriving (Eq, Ord, Show) + +instance Pretty CField where + pPrintPrec d _p f = ppField d f + +ppField :: PDetail -> CField -> Doc +ppField detail field = + let fid = cf_name field + dfl = cf_default field + in + (ppVarId detail fid <+> t "::" <+> pp detail (cf_type field) + <+> maybe empty (ppIfcPragma detail) (cf_pragmas field) <> + if (null dfl) then empty else text ";") $$ + -- display the default, if it exists + if (null dfl) + then empty + else let ppC cl = ppClause detail 0 [ppVarId detail fid] cl + in foldr1 (\ x y -> x <> text ";" $$ y) (map ppC dfl) + -- XXX not including orig_type + +ppIfcPragma :: PDetail -> [IfcPragma] -> Doc +ppIfcPragma _detail [] = empty +ppIfcPragma detail ps = + text "{-#" <+> + sep (punctuate comma (map (pPrintPrec detail 0) ps ) ) + <+> text "#-}" + +ppFDs :: PDetail -> CFunDeps -> Doc +ppFDs _d [] = empty +ppFDs d fd = text " |" <+> sepList (map (ppFD d) fd) (t",") + +ppFD :: PDetail -> ([Id], [Id]) -> Doc +ppFD d (as,rs) = sep (ppVarId d <$> as) <+> t "->" <+> sep (ppVarId d <$> rs) + +ppPreds :: PDetail -> [CPred] -> Doc -> Doc +ppPreds _d [] x = x +ppPreds d preds x = t "(" <> sepList (map (pPrintPrec d 0) preds) (t ",") <> t ") =>" <+> x + +ppConIdK :: PDetail -> IdK -> Doc +ppConIdK d (IdK i) = ppConId d i +ppConIdK d (IdKind i k) = pparen True $ ppConId d i <+> t "::" <+> pp d k +ppConIdK d (IdPKind i pk) = pparen True $ ppConId d i <+> t "::" <+> pp d pk + +type CFields = [CField] -- just a list of CField + +-- redundant +--type Ids = [Id] +data CCaseArm = CCaseArm { cca_pattern :: CPat, + cca_filters :: [CQual], + cca_consequent :: CExpr } + deriving (Eq, Ord, Show) + +instance HasPosition CCaseArm where + getPosition arm = + getPosition (cca_pattern arm) `bestPosition` + getPosition (cca_filters arm) `bestPosition` + getPosition (cca_consequent arm) + +type CCaseArms = [CCaseArm] -- [(CPat, [CQual], CExpr)] + +data CStmt + -- bind cexpr of type cqtype to cpat; id, if present, is instance name + = CSBindT CPat (Maybe CExpr) [(Position,PProp)] CQType CExpr + -- bind cexpr to cpat; id, if present, is instance name + | CSBind CPat (Maybe CExpr) [(Position,PProp)] CExpr + | CSletseq [CDefl] -- rhs of "let x = x" refers to previous def + -- before current let or in earlier arm + | CSletrec [CDefl] -- rhs of "let x = x" refers to self + | CSExpr (Maybe CExpr) CExpr + deriving (Eq, Ord, Show) + +instance Pretty CStmt where + pPrintPrec d _p (CSBindT pat _inst pprops ty e) = + foldr ($+$) empty $ + (map (ppPProp d . snd) pprops) ++ + [pp d pat <+> t "::" <+> pp d ty <+> t "<-" <+> pp d e] + pPrintPrec d _p (CSBind pat _inst pprops e) = + foldr ($+$) empty $ + (map (ppPProp d . snd) pprops) ++ + [pp d pat <+> t "<-" <+> pp d e] + pPrintPrec _d _p (CSletseq []) = error "Syntax.Pretty(CStmt): CSletseq []" + pPrintPrec d _p (CSletseq ds) = text "letseq" <+> text "{" <+> foldr1 ($+$) (map (pp d) ds) <+> text "}" + pPrintPrec _d _p (CSletrec []) = error "Syntax.Pretty(CStmt): CSletrec []" + pPrintPrec d _p (CSletrec ds) = text "let" <+> text "{" <+> foldr1 ($+$) (map (pp d) ds) <+> text "}" + pPrintPrec d p (CSExpr _ e) = pPrintPrec d p e + +instance HasPosition CStmt where + getPosition (CSBindT p _i _pps _t _e) = getPosition p + getPosition (CSBind p _i _pps _e) = getPosition p + getPosition (CSletseq ds) = getPosition ds + getPosition (CSletrec ds) = getPosition ds + getPosition (CSExpr _ e) = getPosition e + +type CStmts = [CStmt] + +data CMStmt + = CMStmt CStmt + | CMrules CExpr + | CMinterface CExpr + | CMTupleInterface Position [CExpr] + deriving (Eq, Ord, Show) + +instance Pretty CMStmt where + pPrintPrec d p (CMStmt s) = pPrintPrec d p s + pPrintPrec d p (CMrules e) = pPrintPrec d p e + pPrintPrec d p (CMinterface e) = pPrintPrec d p (cVApply (idReturn (getPosition e)) [e]) + pPrintPrec d p (CMTupleInterface _ es) = text"(" <> sepList (map (pPrintPrec d p) es) (text ",") <> text ")" + +instance HasPosition CMStmt where + getPosition (CMStmt s) = getPosition s + getPosition (CMrules e) = getPosition e + getPosition (CMinterface e) = getPosition e + getPosition (CMTupleInterface pos _e) = pos + +data CRule + = CRule [RulePragma] (Maybe CExpr) [CQual] CExpr + | CRuleNest [RulePragma] (Maybe CExpr) [CQual] [CRule] + deriving (Eq, Ord, Show) + +instance HasPosition CRule where + getPosition (CRule _ i qs e) = getPosition (i, qs, e) + getPosition (CRuleNest _ i qs rs) = getPosition (i, qs, rs) + +instance Pretty CRule where + pPrintPrec d _p (CRule rps mlbl mqs e) = + ppRPS d rps $+$ + (case mlbl of Nothing -> t""; Just i -> pp d i <> t": ") <> sep [ppQuals d mqs, t " ==>", + nest 4 (pp d e)] + pPrintPrec d _p (CRuleNest rps mlbl mqs rs) = + ppRPS d rps $+$ + (case mlbl of Nothing -> t""; Just i -> pp d i <> t": ") <> + (ppQuals d mqs $+$ pBlock d 2 False (map (pp d) rs)) + +ppRPS :: PDetail -> [RulePragma] -> Doc +ppRPS _d [] = text "" +ppRPS d rps = vcat (map (pPrintPrec d 0) rps) + +-- | A definition with a binding. Can occur as a let expression, let statement +-- in a do block, a typeclass instance defn, or bindings in an interface. +data CDefl -- [CQual] part is the when clause used in an interface + -- binding, ie the explicit condition attached to each method + = CLValueSign CDef [CQual] -- let x :: T = e2 -- explicit type sig + | CLValue Id [CClause] [CQual] -- let y = e2 -- no explicit type sig + | CLMatch CPat CExpr -- let [z] = e3 + deriving (Eq, Ord, Show) + +instance Pretty CDefl where + pPrintPrec d p (CLValueSign def me) = optWhen d me $ pPrintPrec d p def + pPrintPrec d p (CLValue i cs me) = optWhen d me $ + foldr1 ($+$) (map (\ cl -> ppClause d p [ppVarId d i] cl <> t";") cs) + pPrintPrec d p (CLMatch pat e) = ppClause d p [] (CClause [pat] [] e) + +instance HasPosition CDefl where + getPosition (CLValueSign d _) = getPosition d + getPosition (CLValue i _ _) = getPosition i + getPosition (CLMatch p e) = getPosition (p, e) + +optWhen :: PDetail -> [CQual] -> Doc -> Doc +optWhen _d [] s = s +optWhen d qs s = s $+$ (t" " <> ppQuals d qs) + +ppValueSign :: PDetail -> Id -> [TyVar] -> CQType -> [CClause] -> Doc +ppValueSign d i [] ty cs = + (ppVarId d i <+> t "::" <+> pp d ty <> t";") $+$ + foldr1 ($+$) (map (\ cl -> ppClause d 0 [ppVarId d i] cl <> t";") cs) +ppValueSign d i vs ty cs = + (ppVarId d i <+> t ":: /\\" <> sep (map (pPrintPrec d (fromIntegral maxPrec)) vs) <> t"." <> pp d ty <> t";") $+$ + foldr1 ($+$) (map (\ cl -> ppClause d 0 [ppVarId d i] cl <> t";") cs) + +ppClause :: PDetail -> Rational -> [Doc] -> CClause -> Doc +ppClause d _p xs (CClause ps mqs e) = + sep [sep (xs ++ map (pPrintPrec d (fromIntegral maxPrec)) ps) <> ppQuals d mqs <+> t "= ", + nest 4 (pp d e)] + +-- Definition, local or global +data CDef + = CDef Id CQType [CClause] -- before type checking + | CDefT Id [TyVar] CQType [CClause] -- after type checking, with type variables from the CQType + deriving (Eq, Ord, Show) + +instance Pretty CDef where + pPrintPrec d _p (CDef i ty cs) = ppValueSign d i [] ty cs + pPrintPrec d _p (CDefT i vs ty cs) = ppValueSign d i vs ty cs + +instance HasPosition CDef where + getPosition (CDef i _ _) = getPosition i + getPosition (CDefT i _ _ _) = getPosition i + +-- Definition clause +-- each interface's definitions (within the module) correspond to one of these +data CClause + = CClause [CPat] -- arguments (including patterns) + [CQual] -- qualifier on the args + CExpr -- the body + deriving (Eq, Ord, Show) + +instance Pretty CClause where + pPrintPrec d p cl = ppClause d p [] cl + +instance HasPosition CClause where + getPosition (CClause ps qs e) = getPosition (ps, qs, e) + +-- Pattern matching +data CQual + = CQGen CType CPat CExpr + | CQFilter CExpr + deriving (Eq, Ord, Show) + +instance Pretty CQual where + pPrintPrec d _p (CQGen _ pa e) = pp d pa <+> t "<-" <+> pp d e + pPrintPrec d _p (CQFilter e) = pp d e + +instance HasPosition CQual where + getPosition (CQGen _ p _) = getPosition p + getPosition (CQFilter e) = getPosition e + +ppQuals :: PDetail -> [CQual] -> Doc +ppQuals _d [] = t"" +ppQuals d qs = t" when" <+> sepList (map (pp d) qs) (t",") + +ppOSummands :: PDetail -> [COriginalSummand] -> Doc +ppOSummands d cs = sepList (map (nest 2 . ppOCon) cs) (t" |") + where ppOCon summand = + let pp_name = case (cos_names summand) of + [cn] -> ppConId d cn + cns -> text "(" <> + sepList (map (ppConId d) cns) (text ",") <> + text ")" + pp_args = map (pPrintPrec d (fromIntegral maxPrec)) (cos_arg_types summand) + pp_encoding = + case cos_tag_encoding summand of + Nothing -> empty + Just num -> + text "{-# tag " <+> pPrintPrec d 0 num <+> text "#-}" + in sep (pp_name : pp_encoding : pp_args) + +ppSummands :: PDetail -> [CInternalSummand] -> Doc +ppSummands d cs = sepList (map (nest 2 . ppCon) cs) (t" |") + where ppCon summand = + let pp_name = case (cis_names summand) of + [cn] -> ppConId d cn + cns -> text "(" <> + sepList (map (ppConId d) cns) (text ",") <> + text ")" + pp_arg = pPrintPrec d (fromIntegral maxPrec) (cis_arg_type summand) + in sep [pp_name, pp_arg] + +data CPat + = CPCon Id [CPat] + -- Either a struct type or a constructor with named fields. + -- The 'Maybe Bool' argument can indicate if it is specifically + -- one or the other (True for struct), otherwise the typechecker + -- will attempt to determine which is intended. + | CPstruct (Maybe Bool) Id [(Id, CPat)] + | CPVar Id + | CPAs Id CPat + | CPAny Position + | CPLit CLiteral + -- position, base, [(length, value or don't-care)] starting from MSB + -- note that length is length in digits, not bits! + | CPMixedLit Position Integer [(Integer, Maybe Integer)] + -- used before operator parsing + | CPOper [CPOp] + -- generated by deriving code + | CPCon1 Id Id CPat -- first Id is type of constructor + -- After type checking + | CPConTs Id Id [CType] [CPat] + deriving (Eq, Ord, Show) + +instance Pretty CPat where + pPrintPrec d p (CPVar a) = pPrintPrec d p a + pPrintPrec d p (CPCon i as) = pparen (p>(fromIntegral maxPrec-1)) $ sep (ppConId d i : map (pPrintPrec d (fromIntegral maxPrec)) as) + pPrintPrec _d _p (CPstruct _ tyc []) | tyc == idPrimUnit = text "()" + pPrintPrec d _p (CPstruct _ tyc [(_, fst'), (_, snd')]) | tyc == idPrimPair = + pparen True (pPrintPrec d 0 fst' <> t"," <+> pPrintPrec d 0 snd') + pPrintPrec d p (CPstruct _ i fs) = pparen (p>(fromIntegral maxPrec-1)) $ ppConId d i <+> t "{" <+> sep (map ppField' fs ++ [t"}"]) + where ppField' (i', CPVar i'') | i' == i'' = ppVarId d i' <> t";" + ppField' (i', p') = ppVarId d i' <+> t "=" <+> pp d p' <> t";" + pPrintPrec d _p (CPAs a pp') = pPrintPrec d (fromIntegral maxPrec) a <> t"@" <> pPrintPrec d (fromIntegral maxPrec) pp' + pPrintPrec _d _p (CPAny _) = text "_" + pPrintPrec d p (CPLit l) = pPrintPrec d p l + pPrintPrec _d _p (CPMixedLit _ base ps) = + let digitBits = log2 base + f (len, Just val) = integerFormat (len `div` digitBits) base val + f (len, Nothing) = L.genericReplicate (len `div` digitBits) '?' + pref 2 = "0b" + pref 8 = "0o" + pref 10 = "" + pref 16 = "0x" + pref x = error ("bad radix to CPMixedLit: " ++ show x) + in text (pref base ++ concatMap f ps) + pPrintPrec d p (CPOper ops) = pparen (p > fromIntegral maxPrec-1) (sep (map (pPrintPrec d (fromIntegral maxPrec-1)) ops)) + pPrintPrec d p (CPCon1 _ i a) = pPrintPrec d p (CPCon i [a]) + ---- + pPrintPrec d p (CPConTs _ i ts as) = pparen (p>(fromIntegral maxPrec-1)) $ sep (ppConId d i : map ppApArg ts ++ map (pPrintPrec d (fromIntegral maxPrec)) as) + where ppApArg ty = t"\183" <> pPrintPrec d (fromIntegral maxPrec) ty + +instance HasPosition CPat where + getPosition (CPCon c _) = getPosition c + getPosition (CPstruct _ c _) = getPosition c + getPosition (CPVar i) = getPosition i + getPosition (CPAs i _) = getPosition i + getPosition (CPAny p) = p + getPosition (CPLit l) = getPosition l + getPosition (CPMixedLit p _ _) = p + getPosition (CPOper ps) = getPosition ps + getPosition (CPCon1 _ c _) = getPosition c + getPosition (CPConTs _ c _ _) = getPosition c + +data CPOp + = CPRand CPat + | CPRator Int Id + deriving (Eq, Ord, Show) + +instance Pretty CPOp where + pPrintPrec d _ (CPRand p) = pp d p + pPrintPrec d _ (CPRator _ i) = ppInfix d i + +instance HasPosition CPOp where + getPosition (CPRand p) = getPosition p + getPosition (CPRator _ i) = getPosition i + +ppInfix :: PDetail -> Id -> Doc +ppInfix _d i = + --case getIdString i of + --s@(c:_) | isIdChar c -> t"`" <> t s <> t"`" + --s -> t s + let p = getIdQual i + b = getIdBase i + in if (p==fsEmpty) then + (case getFString b of + s@(c:_) | isIdChar c -> t"`" <> t s <> t"`" + s -> t s) + else (t"`" <> t (getFString p) <> t "." <> + (case getFString b of + s@(c:_) | isIdChar c -> t s + s -> t "(" <> t s <> t")") <> t"`") + +pp :: (Pretty a) => PDetail -> a -> Doc +pp d x = pPrintPrec d 0 x + +t :: String -> Doc +t s = text s + +newtype CInclude + = CInclude String + deriving (Eq, Ord, Show) + +instance Pretty CInclude where + pPrintPrec d p (CInclude s) = pPrintPrec d p s + +-------- +-- Utilities + +cApply :: Int -> CExpr -> [CExpr] -> CExpr +cApply _n e [] = e +cApply _n (CCon i es) es' = CCon i (es ++ es') +cApply _n (CConT t' i es) es' = CConT t' i (es ++ es') +cApply _n (CApply e es) es' = CApply e (es ++ es') +cApply _n (CTaskApply e es) es' = CTaskApply e (es ++ es') +cApply _n e as = CApply e as + +cVApply :: Id -> [CExpr] -> CExpr +cVApply i _es | isTaskName (getIdBaseString i) = + error $ "cVApply to " ++ (show i) ++ "\n" +cVApply i es = cApply 2 (CVar i) es + +-- tasks start with $ followed by a letter +isTaskName :: String -> Bool +isTaskName ('$':c:_) = isAlpha c +isTaskName _ = False + +getName :: CDefn -> Either Position Id +getName (CValue i _) = Right i +getName (CValueSign (CDef i _ _)) = Right i +getName (CValueSign (CDefT i _ _ _)) = Right i +getName (Cprimitive i _) = Right i +getName (CprimType i) = Right $ iKName i +getName (CPragma pr) = Left $ getPosition pr +getName (Cforeign { cforg_name = i }) = Right i +getName (Ctype i _ _) = Right $ iKName i +getName (Cdata { cd_name = name }) = Right $ iKName name +getName (Cstruct _ _ i _ _ _) = Right $ iKName i +getName (Cclass _ _ i _ _ _) = Right $ iKName i +getName (Cinstance qt _) = Left $ getPosition qt +getName (CItype i _ _) = Right $ iKName i +getName (CIclass _ _ i _ _ _) = Right $ iKName i +getName (CIinstance _ qt) = Left $ getPosition qt +getName (CIValueSign i _) = Right i + +iKName :: IdK -> Id +iKName (IdK i) = i +iKName (IdKind i _) = i +iKName (IdPKind i _) = i diff --git a/src/Language/Bluespec/Classic/AST/Type.hs b/src/Language/Bluespec/Classic/AST/Type.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bluespec/Classic/AST/Type.hs @@ -0,0 +1,283 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- This corresponds to src/comp/CType.hs in bsc. +module Language.Bluespec.Classic.AST.Type + ( Type(..) + , TyVar(..) + , TyCon(..) + , TISort(..) + , StructSubType(..) + , CType + , Kind(..) + , PartialKind(..) + , CTypeclass(..) + , CPred(..) + , CQType(..) + + , baseKVar + , cTNum + , isTConArrow + , isTConPair + , leftCon + ) where + +import Data.Char (chr) +import Text.PrettyPrint.HughesPJClass + +import Language.Bluespec.Classic.AST.Builtin.Ids +import Language.Bluespec.Classic.AST.FString +import Language.Bluespec.Classic.AST.Id +import Language.Bluespec.Classic.AST.Position +import Language.Bluespec.Classic.AST.Pragma +import Language.Bluespec.Prelude +import Language.Bluespec.Pretty +import Language.Bluespec.Util + +-- | Representation of types +data Type = TVar TyVar -- ^ type variable + | TCon TyCon -- ^ type constructor + | TAp Type Type -- ^ type-level application + | TGen Position Int -- ^ quantified type variable used in type schemes + | TDefMonad Position -- ^ not used after CVParserImperative + deriving Show + +instance Eq Type where + x == y = cmp x y == EQ + +instance Ord Type where + compare x y = cmp x y + +instance Pretty Type where + pPrintPrec _d _p (TCon (TyCon unit _ _)) | unit == idPrimUnit = text "()" + pPrintPrec d _p (TCon c) = pPrintPrec d 0 c + pPrintPrec d _p (TVar i) = pPrintPrec d 0 i + pPrintPrec d p (TAp (TAp (TCon pair) a) b) | isTConPair pair = + pparen (p >= 0) (sep [pPrintPrec d 0 a <> text ",", pPrintPrec d (-1) b]) + pPrintPrec d p (TAp (TAp (TCon arr) a) r) | isTConArrow arr = + pparen (p > 8) (sep [pPrintPrec d 9 a <+> text "->", pPrintPrec d 8 r]) + pPrintPrec d p (TAp e e') = pparen (p>9) $ + sep [pPrintPrec d 9 e, pPrintPrec d 10 e'] + pPrintPrec _d _p (TDefMonad _) = text ("TDefMonad") + pPrintPrec d p (TGen _ n) = pparen True (text "TGen" <+> pPrintPrec d p n) + +instance HasPosition Type where + getPosition (TVar var) = getPosition var + getPosition (TCon con) = getPosition con + getPosition (TAp f a) = getPosition f `bestPosition` getPosition a + getPosition (TGen pos _) = pos + getPosition (TDefMonad pos) = pos + +cTNum :: Integer -> Position -> CType +cTNum n pos = TCon (TyNum n pos) + +isTConArrow :: TyCon -> Bool +isTConArrow (TyCon i _ _) = i == idArrow noPosition +isTConArrow t = error("isTConArrow: not TCon " ++ show t) + +isTConPair :: TyCon -> Bool +isTConPair (TyCon i _ _) = i == idPrimPair +isTConPair t = error("isTConPair: not TCon " ++ show t) + +-- | used to do the sorting of instances +-- so that overlapping matches go to the most specific +-- TAp first because it brings forward instances with larger structure +-- see the Has_tpl_n instances in the Prelude +cmp :: Type -> Type -> Ordering +cmp (TAp f1 a1) (TAp f2 a2) = compare (f1, a1) (f2, a2) +cmp (TAp _ _) _ = LT +cmp (TCon c1) (TCon c2) = compare c1 c2 +cmp (TCon _) (TAp _ _) = GT +cmp (TCon _) _ = LT +cmp (TVar _) (TCon _) = GT +cmp (TVar _) (TAp _ _) = GT +cmp (TVar v1) (TVar v2) = compare v1 v2 +cmp (TVar _) _ = LT +cmp (TGen _ i1) (TGen _ i2) = compare i1 i2 +cmp (TGen _ _) (TDefMonad _) = LT +cmp (TGen _ _) _ = GT +cmp (TDefMonad _) (TDefMonad _) = EQ +cmp (TDefMonad _) _ = GT + +-- | Representation of a type variable +data TyVar = TyVar { tv_name :: Id -- ^ name of the type variable + , tv_num :: Int -- ^ number for a generated type variable + , tv_kind :: Kind -- ^ kind of the type variable + } + deriving Show + +instance Eq TyVar where + TyVar i n _ == TyVar i' n' _ = (n, i) == (n', i') + +instance Ord TyVar where + TyVar i n _ <= TyVar i' n' _ = (n, i) <= (n', i') + TyVar i n _ < TyVar i' n' _ = (n, i) < (n', i') + TyVar i n _ >= TyVar i' n' _ = (n, i) >= (n', i') + TyVar i n _ > TyVar i' n' _ = (n, i) > (n', i') + TyVar i n _ `compare` TyVar i' n' _ = (n, i) `compare` (n', i') + +instance Pretty TyVar where + pPrintPrec d _ (TyVar i _ _) = ppVarId d i + +instance HasPosition TyVar where + getPosition (TyVar name _ _) = getPosition name + +-- | Representation of a type constructor +data TyCon = -- | A constructor for a type of value kind + TyCon { tcon_name :: Id -- ^ name of the type constructor + , tcon_kind :: (Maybe Kind) -- ^ kind of the type constructor + , tcon_sort :: TISort -- ^ purpose of the type constructor + } + -- | A constructor for a type of numeric kind + | TyNum { tynum_value :: Integer -- ^ type-level numeric value + , tynum_pos :: Position -- ^ position of introduction + } + -- | A constructor for a type of string kind + | TyStr { tystr_value :: FString -- ^ type-level string value + , tystr_pos :: Position -- ^ position of introduction + } + deriving Show + +instance Eq TyCon where + TyCon i k _ == TyCon i' k' _ = qualEq i i' && k == k' + TyNum i _ == TyNum i' _ = i == i' + TyStr s _ == TyStr s' _ = s == s' + _ == _ = False + +instance Ord TyCon where + TyCon i k _ `compare` TyCon i' k' _ = (getIdBase i, getIdQual i, k) `compare` (getIdBase i', getIdQual i', k') + TyCon _ _ _ `compare` TyNum _ _ = LT + TyCon _ _ _ `compare` TyStr _ _ = LT + TyNum _ _ `compare` TyCon _ _ _ = GT + TyNum i _ `compare` TyNum i' _ = i `compare` i' + TyNum _ _ `compare` TyStr _ _ = LT + TyStr _ _ `compare` TyCon _ _ _ = GT + TyStr _ _ `compare` TyNum _ _ = GT + TyStr s _ `compare` TyStr s' _ = s `compare` s' + +instance Pretty TyCon where + pPrintPrec d _ (TyCon i _ _) = ppConId d i + pPrintPrec _d _ (TyNum i _) = text (itos i) + pPrintPrec _d _ (TyStr s _) = text (show s) + +instance HasPosition TyCon where + getPosition (TyCon name _k _) = getPosition name + getPosition (TyNum _ pos) = pos + getPosition (TyStr _ pos) = pos + +data TISort + = -- type synonym + TItype Integer Type + | TIdata { tidata_cons :: [Id] + , tidata_enum :: Bool + } + | TIstruct StructSubType [Id] + -- primitive abstract type + -- e.g. Integer, Bit, Module, etc. + | TIabstract + deriving (Eq, Ord, Show) + +instance Pretty TISort where + pPrintPrec d p (TItype n t) = pparen (p>0) $ text "TItype" <+> pPrintPrec d 0 n <+> pPrintPrec d 1 t + pPrintPrec d p (TIdata is enum) = pparen (p>0) $ text (if enum then "TIdata (enum)" else "TIdata") <+> pPrintPrec d 1 is + pPrintPrec d p (TIstruct ss is) = pparen (p>0) $ text "TIstruct" <+> pPrintPrec d 1 ss <+> pPrintPrec d 1 is + pPrintPrec _d _p (TIabstract) = text "TIabstract" + +data StructSubType + = SStruct + | SClass + | SDataCon { sdatacon_id :: Id + , sdatacon_named_fields :: Bool + } + | SInterface [IfcPragma] + | SPolyWrap { spolywrap_id :: Id -- ^ name of the type with the wrapped field + , spolywrap_ctor :: Maybe Id -- ^ name of the data constructor + , spolywrap_field :: Id -- ^ name of the wrapped field + } + deriving (Eq, Ord, Show) + +instance Pretty StructSubType where + pPrintPrec _ _ ss = text (show ss) + +type CType = Type + +leftCon :: CType -> Maybe Id +leftCon (TAp f _) = leftCon f +leftCon (TCon (TyCon i _ _)) = Just i +leftCon _ = Nothing + +-- | Representation of kinds +data Kind = KStar -- ^ kind of a simple value type + | KNum -- ^ kind of a simple numeric type + | KStr -- ^ kind of a simple string type + | Kfun Kind Kind -- ^ kind of type constructors (type-level function) + | KVar Int -- ^ generated kind variable (used only during kind inference) + deriving (Eq, Ord, Show) + +instance Pretty Kind where + pPrintPrec _ _ KStar = text "*" + pPrintPrec _ _ KNum = text "#" + pPrintPrec _ _ KStr = text "$" + pPrintPrec d p (Kfun l r) = pparen (p>9) $ pPrintPrec d 10 l <+> text "->" <+> pPrintPrec d 9 r + pPrintPrec _ _ (KVar i) = text (showKVar i) + +-- KIMisc.newKVar starts at this number +baseKVar :: Int +baseKVar = 1000 + +-- Display the kind variable with letters +showKVar :: Int -> String +showKVar v = + let + makeDigit x = chr (x + 97) -- 97 = ASCII a + + showDigits :: Int -> String + showDigits x | (x < 26) = [makeDigit x] + showDigits x = (showDigits (x `div` 26)) ++ [makeDigit (x `mod` 26)] + in + if (v < baseKVar) + then (itos v) + else (showDigits (v - baseKVar)) + +-- Used for providing partial Kind information +data PartialKind + = PKNoInfo -- this is what makes it partial + | PKStar + | PKNum + | PKStr + | PKfun PartialKind PartialKind + deriving (Eq, Ord, Show) + +instance Pretty PartialKind where + pPrintPrec _ _ PKNoInfo = text "?" + pPrintPrec _ _ PKStar = text "*" + pPrintPrec _ _ PKNum = text "#" + pPrintPrec _ _ PKStr = text "$" + pPrintPrec d p (PKfun l r) = + pparen (p>9) $ pPrintPrec d 10 l <+> text "->" <+> pPrintPrec d 9 r + +-- | A named typeclass +newtype CTypeclass = CTypeclass Id + deriving (Eq, Ord, Show, Pretty, HasPosition) + +-- | Representation of the provisos and other class constraints +data CPred = CPred { cpred_tc :: CTypeclass -- ^ constraint class, e.g., "Eq" + , cpred_args :: [CType] -- ^ argument types + } + deriving (Eq, Ord, Show) + +instance Pretty CPred where + pPrintPrec d _p (CPred (CTypeclass c) []) = ppConId d c + pPrintPrec d _p (CPred (CTypeclass c) ts) = ppConId d c <+> sep (map (pPrintPrec d (fromIntegral (maxPrec+1))) ts) + +instance HasPosition CPred where + getPosition (CPred c ts) = getPosition (c, ts) + +data CQType = CQType [CPred] CType + deriving (Eq, Ord, Show) + +instance Pretty CQType where + pPrintPrec d p (CQType [] ct) = pPrintPrec d p ct + pPrintPrec d _p (CQType preds ct) = sep [text "(" <> sepList (map (pPrintPrec d 0) preds) (text ",") <> text ")" <+> text "=>", pPrintPrec d 0 ct] + +instance HasPosition CQType where + -- prefer t to ps, since that is a better position for BSV + getPosition (CQType ps t) = getPosition t `bestPosition` getPosition ps diff --git a/src/Language/Bluespec/Classic/AST/Undefined.hs b/src/Language/Bluespec/Classic/AST/Undefined.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bluespec/Classic/AST/Undefined.hs @@ -0,0 +1,22 @@ +-- This corresponds to src/comp/Undefined.hs in bsc. +module Language.Bluespec.Classic.AST.Undefined + ( UndefKind(..) + ) where + +import Language.Bluespec.Prelude + +-- Undefined values in BSC carry information about their origin. +-- (The evaluator uses this for choosing error messages and optimizations.) + +-- * UNotUsed is for values that we expect will never be used, such as +-- in unreachable code or the return value for an expression whose value +-- is unused. + +-- * UNoMatch is the value returned from a case expression when no arm +-- matches but some value still needs to be returned. + +-- * UDontCare is an explicit dont-care value written by the user, or +-- any other dont-care value that doesn't fit the above kinds. + +data UndefKind = UNotUsed | UDontCare | UNoMatch + deriving (Eq, Ord, Show) diff --git a/src/Language/Bluespec/Classic/AST/VModInfo.hs b/src/Language/Bluespec/Classic/AST/VModInfo.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bluespec/Classic/AST/VModInfo.hs @@ -0,0 +1,259 @@ +-- This corresponds to src/comp/VModInfo.hs in bsc. +module Language.Bluespec.Classic.AST.VModInfo + ( VName(..) + , VPathInfo(..) + , VeriPortProp(..) + , VArgInfo(..) + , VPort + , VSchedInfo + , VFieldInfo(..) + , InputClockInf + , OutputClockInf + , VOscPort + , VInputGatePort + , VOutputGatePort + , VClockInfo(..) + , ResetInf + , VResetInfo(..) + ) where + +import qualified Data.List as L +import Text.PrettyPrint.HughesPJClass + +import Language.Bluespec.Classic.AST.Id +import Language.Bluespec.Classic.AST.Position +import Language.Bluespec.Classic.AST.SchedInfo +import Language.Bluespec.Prelude +import Language.Bluespec.Pretty + +newtype VName = VName String + deriving (Eq, Ord, Show) + +instance Pretty VName where + pPrintPrec _ _ (VName s) = text s + +newtype VPathInfo = VPathInfo [(VName, VName)] + deriving (Eq, Ord, Show) + +instance Pretty VPathInfo where + pPrintPrec _d _p (VPathInfo []) = + s2par "No combinational paths from inputs to outputs" + pPrintPrec d p (VPathInfo nns) = + let + -- function to join paths going to the same output + joinPaths [] = [] + joinPaths zs@((_,o):_) = + case (L.partition ((== o) . snd) zs) of + (xs, ys) -> (map fst xs, o) : joinPaths ys + + -- function to display one pair + ppOne ([i],out) = pPrintPrec d p i <+> text "->" <+> pPrintPrec d p out + ppOne (ins,out) = text "(" <> + sepList (map (pPrintPrec d p) ins) (text ",") <> + text ")" <+> text "->" <+> pPrintPrec d p out + in + s2par "Combinational paths from inputs to outputs:" $+$ + nest 2 (vcat (map ppOne (joinPaths nns))) + +instance HasPosition VFieldInfo where + getPosition (Method { vf_name = n }) = getPosition n + getPosition (Clock i) = getPosition i -- or noPosition? + getPosition (Reset i) = getPosition i -- or noPosition? + getPosition (Inout { vf_name = n }) = getPosition n + +-- the order is important for VIOProps ("unused" should come last) +data VeriPortProp = VPreg + | VPconst + | VPinhigh + | VPouthigh + | VPclock + | VPclockgate + | VPreset + | VPinout + | VPunused + deriving (Eq, Ord, Show) + +instance Pretty VeriPortProp where + pPrintPrec _ _ VPreg = text "reg" + pPrintPrec _ _ VPclock = text "clock" + pPrintPrec _ _ VPconst = text "const" + pPrintPrec _ _ VPinhigh = text "inhigh" + pPrintPrec _ _ VPouthigh = text "outhigh" + pPrintPrec _ _ VPunused = text "unused" + pPrintPrec _ _ VPreset = text "reset" + pPrintPrec _ _ VPinout = text "inout" + pPrintPrec _ _ VPclockgate = text "clock gate" + +data VArgInfo = Param VName -- named module parameter + -- named module port, with associated clock and reset + | Port VPort (Maybe Id) (Maybe Id) + | ClockArg Id -- named clock + | ResetArg Id -- named reset + -- named module inout, with associated clock and reset + | InoutArg VName (Maybe Id) (Maybe Id) + deriving (Eq, Ord, Show) + +instance Pretty VArgInfo where + pPrintPrec d _p (Param x) = text "param " <> pPrintPrec d 0 x <> text ";" + pPrintPrec d _p (Port x mclk mrst) = + text "port " <> pPrintPrec d 0 x <+> + ppMClk d mclk <+> ppMRst d mrst <> + text ";" + pPrintPrec d p (ClockArg x) = text "clockarg " <> pPrintPrec d p x <> text ";" + pPrintPrec d p (ResetArg x) = text "resetarg " <> pPrintPrec d p x <> text ";" + pPrintPrec d _p (InoutArg x mclk mrst) = + text "inoutarg " <> pPrintPrec d 0 x <+> + ppMClk d mclk <+> ppMRst d mrst <> + text ";" + +ppMClk :: PDetail -> Maybe Id -> Doc +ppMClk d mclk = + let clk = case mclk of + Nothing -> text "no_clock" + Just c -> pPrintPrec d 0 c + in text "clocked_by (" <> clk <> text ")" + +ppMRst :: PDetail -> Maybe Id -> Doc +ppMRst d mrst = + let rst = case mrst of + Nothing -> text "no_reset" + Just r -> pPrintPrec d 0 r + in text "reset_by (" <> rst <> text ")" + +type VPort = (VName, [VeriPortProp]) + +type VSchedInfo = SchedInfo Id + +-- XXX why does the VFieldInfo not contain a ready signal? +data VFieldInfo = Method { vf_name :: Id, -- method name + vf_clock :: (Maybe Id), -- optional clock + -- optional because the method may be combinational + vf_reset :: (Maybe Id), -- optional reset + -- optional because the method may be independent of a reset signal + vf_mult :: Integer, -- multiplicity + vf_inputs :: [VPort], + vf_output :: Maybe VPort, + vf_enable :: Maybe VPort } + | Clock { vf_name :: Id } -- output clock name + -- connection information is in the ClockInfo + | Reset { vf_name :: Id } -- output reset name + -- connection information is in the ResetInfo + | Inout { vf_name :: Id, -- output inout name + vf_inout :: VName, + vf_clock :: (Maybe Id), -- optional clock + vf_reset :: (Maybe Id) } -- optional reset + deriving (Eq, Ord, Show) + +instance Pretty VFieldInfo where + pPrintPrec d p (Method n c r m i o e) = + text "method " <> pout o <> pPrintPrec d p n <> pmult m <> + pins i <> pena e <+> ppMClk d c <+> ppMRst d r <> + text ";" + where pout Nothing = empty + pout (Just po) = pPrintPrec d p po + pmult 1 = empty + pmult n' = text "[" <> pPrintPrec d p n' <> text "]" + pins [] = empty + pins i' = text "(" <> sepList (map (pPrintPrec d p) i') (text ",") <> text ")" + pena Nothing = empty + pena (Just en) = text " enable (" <> pPrintPrec d p en <> text ")" + pPrintPrec d p (Clock i) = text "clock " <> pPrintPrec d p i <> text ";" + pPrintPrec d p (Reset i) = text "reset " <> pPrintPrec d p i <> text ";" + pPrintPrec d p (Inout n port c r) = + text "inout " <> pPrintPrec d p n <+> + text "(" <> pPrintPrec d p port <> text ")" <+> + ppMClk d c <+> ppMRst d r <> text ";" + +-- describes the clocks imported by a module +type InputClockInf = (Id, Maybe (VOscPort, VInputGatePort)) + +-- describes the clocks exported by a module +type OutputClockInf = (Id, Maybe (VOscPort, VOutputGatePort)) + +-- no VeriPortProp needed, so we use VName and not VPort +type VOscPort = VName + +-- gate port for input clocks +-- Either there is no port, in which case the boolean indicates +-- whether the gate is assumed True or is unneeded, or there is gate port. +type VInputGatePort = Either Bool VName + +-- gate port for output clocks +-- Either there is no port, in which case users should assume a value True, +-- or there is a port, and we annotate whether it is "outhigh" with a +-- port property (VPouthigh) +type VOutputGatePort = Maybe VPort + +data VClockInfo = ClockInfo { + -- named list of input clocks + input_clocks :: [InputClockInf], + -- named list of output clocks + output_clocks :: [OutputClockInf], + -- edges in the ancestor relationships (transitive) + -- first clock is parent, second is child + ancestorClocks :: [(Id, Id)], + -- other sibling relationships + -- transitive (but often trumped by ancestry) + -- method calls are permitted across sibling relationships + -- but *both* gate conditions must be enforced + siblingClocks :: [(Id, Id)] } + deriving (Eq, Ord, Show) + +instance Pretty VClockInfo where + pPrintPrec d _p (ClockInfo in_cs out_cs as ss) = + vcat (map pOutCInf out_cs ++ + map pInCInf in_cs ++ + map pAnc as ++ + map pSib ss) + where + pOutCInf (i,mc) = text "clock " <> pPrintPrec d 0 i <> + text "(" <> pOutMClk mc <> text ");" + pOutMClk Nothing = empty + pOutMClk (Just (vn, mg)) = pPrintPrec d 0 vn <> pOutMGate mg + pOutMGate Nothing = empty + pOutMGate (Just (vn, vpps)) = + text ", " <> pPortProps vpps <> pPrintPrec d 0 vn + pPortProps [] = empty + pPortProps (vp:vpps) = + text "{-" <> pPrintPrec d 0 vp <> text "-} " <> pPortProps vpps + + pInCInf (i,mc) = text "clock " <> pPrintPrec d 0 i <> + text "(" <> pInMClk mc <> text ");" + pInMClk Nothing = empty + pInMClk (Just (vn, mg)) = pPrintPrec d 0 vn <> pInMGate mg + pInMGate (Left True) = text ", {-inhigh-}" + pInMGate (Left False) = text ", {-unused-}" + pInMGate (Right vn) = text ", " <> pPrintPrec d 0 vn + + pAnc (i,j) = text "ancestor (" <> pPrintPrec d 0 i <> text ", " <> + pPrintPrec d 0 j <> text ");" + pSib (i,j) = text "sibling (" <> pPrintPrec d 0 i <> text ", " <> + pPrintPrec d 0 j <> text ");" + +instance HasPosition VClockInfo where + getPosition (ClockInfo { output_clocks = ((id',_):_)}) = getPosition id' + getPosition (ClockInfo { input_clocks = ((id',_):_)}) = getPosition id' + getPosition _ = noPosition + +-- reset name, Verilog port (optional), clock (optional) +type ResetInf = (Id, (Maybe VName, Maybe Id)) + +-- basic information on reset signals +-- more information to be added (sync/async, clock relationships, etc.) +data VResetInfo = ResetInfo { + input_resets :: [ResetInf], + output_resets :: [ResetInf] + } + deriving (Eq, Ord, Show) + +instance Pretty VResetInfo where + pPrintPrec d p (ResetInfo in_rs out_rs) = vcat (map pRInf (out_rs ++ in_rs)) + where t = text + pRInf (i,(mn,mc)) = + t"reset " <> pPrintPrec d p i <> + t"(" <> pMRst mn <> t")" <+> + t"clocked_by(" <> pMClk mc <> t");" + pMRst Nothing = empty + pMRst (Just n) = pPrintPrec d p n + pMClk Nothing = t"no_clock" + pMClk (Just c) = pPrintPrec d p c diff --git a/src/Language/Bluespec/IntegerUtil.hs b/src/Language/Bluespec/IntegerUtil.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bluespec/IntegerUtil.hs @@ -0,0 +1,42 @@ +-- This corresponds to src/comp/IntegerUtil.hs in bsc. +module Language.Bluespec.IntegerUtil + ( integerFormat + , integerFormatPref + , integerToString + ) where + +import Language.Bluespec.Prelude + +integerFormat :: Integer -> Integer -> Integer -> String +integerFormat width base value = + if value < 0 then + '-' : integerFormat width base (-value) + else + let s = integerToString (fromInteger base) value + l = length s + w = fromInteger width + pad = if l < w then replicate (w-l) '0' else "" + in pad ++ s + +integerFormatPref :: Integer -> Integer -> Integer -> String +integerFormatPref width 2 value = "0b" ++ integerFormat width 2 value +integerFormatPref width 8 value = "0o" ++ integerFormat width 8 value +integerFormatPref width 10 value = integerFormat width 10 value +integerFormatPref width 16 value = "0x" ++ integerFormat width 16 value +-- otherwise, use decimal +integerFormatPref width _ value = integerFormatPref width 10 value + +integerToString :: Int -> Integer -> String +integerToString b i | b < 2 = error "integerToString: base must be >= 2" + | i < 0 = '-' : showIntBase (toInteger b) (negate i) "" + | otherwise = showIntBase (toInteger b) i "" + +-- mostly duplicates the function in the Prelude from the Haskell 98 Report +showIntBase :: Integer -> Integer -> String -> String +showIntBase b n r | n < 0 = error "Numeric.showInt: can't show negative numbers" + | otherwise = + let (n',d) = quotRem n b + r' = digit d : r + digit d' | d' < 10 = toEnum (fromEnum '0' + fromIntegral d') + | otherwise = toEnum (fromEnum 'A' + fromIntegral d' - 10) + in if n' == 0 then r' else showIntBase b n' r' diff --git a/src/Language/Bluespec/Lex.hs b/src/Language/Bluespec/Lex.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bluespec/Lex.hs @@ -0,0 +1,37 @@ +-- This corresponds to src/comp/Lex.hs in bsc. +module Language.Bluespec.Lex + ( isIdChar + , isSym + ) where + +import Data.Char (isAlphaNum) + +import Language.Bluespec.Prelude + +isSym :: Char -> Bool +isSym '!' = True; isSym '@' = True; isSym '#' = True; isSym '$' = True +isSym '%' = True; isSym '&' = True; isSym '*' = True; isSym '+' = True +isSym '.' = True; isSym '/' = True; isSym '<' = True; isSym '=' = True +isSym '>' = True; isSym '?' = True; isSym '\\' = True; isSym '^' = True +isSym '|' = True; isSym ':' = True; isSym '-' = True; isSym '~' = True +isSym ',' = True +isSym c | c >= '\x80' = c `elem` ['\162', '\163', '\164', '\165', '\166', + '\167', '\168', '\169', '\170', '\171', + '\172', '\173', '\174', '\175', '\176', + '\177', '\178', '\179', '\180', '\181', + '\183', '\184', '\185', '\186', '\187', + '\188', '\189', '\190', '\191', '\215', + '\247' ] + +--isSym c | c >= '\x80' = isSymbol c +isSym _ = False + +isIdChar :: Char -> Bool +isIdChar '\'' = True +isIdChar '_' = True + +-- \176 (hexB0) (octal 0260) is the degree symbol +isIdChar '\176' = True +-- \180 (hexB4) (octal 0264) is the prime (acute accent) symbol +isIdChar '\180' = True +isIdChar c = isAlphaNum c diff --git a/src/Language/Bluespec/Log2.hs b/src/Language/Bluespec/Log2.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bluespec/Log2.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +-- This corresponds to src/comp/Log2.hs in bsc. +module Language.Bluespec.Log2 + ( log2 + ) where + +import Data.Bits +import GHC.Exts + +-- GHC 9.0 has an entirely new ghc-bignum package. +-- See https://iohk.io/en/blog/posts/2020/07/28/improving-haskells-big-numbers-support/ +#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 900) +import GHC.Num.Integer (Integer(IS, IP, IN)) +import GHC.Num.BigNat +#else +import GHC.Integer.GMP.Internals +#endif + +import Language.Bluespec.Prelude + +-- In GHC 7.8, internal primops return Int# instead of Bool +eqInt, neqInt :: Int# -> Int# -> Bool +{-# INLINE eqInt #-} +{-# INLINE neqInt #-} +eqInt a b = isTrue# (a ==# b) +neqInt a b = isTrue# (a /=# b) + +-- |Number of bits in an Int (or Int#) on this machine +wordSize :: Int +wordSize = finiteBitSize (0 :: Int) + +-- |Compute the logarithm base 2, rounded up, for Integral types. +-- One interpretation of this log2 function is that it tells you +-- the minimum number of bits required to represent a given number +-- of distinct values. +log2 :: (Integral a, Integral b) => a -> b +log2 0 = 0 +log2 x = case (toInteger x) of + -- for values which fit in a single word, we + -- find the index of the most significant non-zero + -- bit. if all other bits are zero, then this is + -- the value of the base 2 log, otherwise we must + -- add one to the value to get the base 2 log. + -- 'small' integer that fits in a single word +#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 900) + IS n -> let !(top_one,any_other_ones) = analyze (I# n) + in toEnum (top_one + (if any_other_ones then 1 else 0)) +#else + S# n -> let !(top_one,any_other_ones) = analyze (I# n) + in toEnum (top_one + (if any_other_ones then 1 else 0)) +#endif + -- for values which exceed the word size, we use the + -- log2large function to examine the values in the array. + -- positive and negative multiword integers respectively +#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 900) + IP bn -> let sz = bigNatSize# bn + in log2large (sz -# 1#) bn + IN bn -> let sz = bigNatSize# bn + in log2large (sz -# 1#) bn +#else + Jp# bn@(BN# arr) -> let sz = sizeofBigNat# bn + in log2large (sz -# 1#) arr + Jn# bn@(BN# arr) -> let sz = sizeofBigNat# bn + in log2large (sz -# 1#) arr +#endif + +-- |Utility function to find the index of the most significant +-- non-zero bit in a single-word Int and also report if any +-- other bits are non-zero. Note: this assumes n /= 0. +analyze :: Int -> (Int,Bool) +analyze n = helper n (wordSize - 1) + where helper v idx = if (testBit v idx) + then (idx, (clearBit v idx) /= 0) + else helper n (idx - 1) + +-- |Utility function to determine if any words in a ByteArray# +-- up to a given index are non-zero. +anyNonZero :: ByteArray# -> Int# -> Bool +anyNonZero arr idx = if (indexIntArray# arr idx) `neqInt` 0# + then True + else (idx `neqInt` 0#) && (anyNonZero arr (idx -# 1#)) + +-- |Compute the log2 for Integers which span multiple words. This +-- first scans the memory for the most significant word that is not 0. +-- Then it analyzes that word to determine, along with the word's +-- index, the provisional logarithm value, If that word had any +-- additional non-zero bits, or if any other words in the ByteArray# +-- are non-zero, then the actual logarithm will be one more than the +-- provisional value. +log2large :: (Integral b) => Int# -> ByteArray# -> b +log2large i arr = + let !w = indexIntArray# arr i + in if w `eqInt` 0# + then if i `eqInt` 0# then 0 else log2large (i -# 1#) arr + else let !(top_one,any_other_ones) = analyze (I# w) + base = (wordSize * (I# i) + top_one) + in if any_other_ones || ((i `neqInt` 0#) && (anyNonZero arr (i -# 1#))) + then toEnum (base + 1) + else toEnum base diff --git a/src/Language/Bluespec/Prelude.hs b/src/Language/Bluespec/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bluespec/Prelude.hs @@ -0,0 +1,8 @@ +-- Unfortunately, the (<>) function from the Prelude has a different fixity than +-- the (<>) function from the pretty library, so we avoid re-exporting (<>) from +-- the Prelude to avoid fixity clashes. +module Language.Bluespec.Prelude + ( module Prelude + ) where + +import Prelude hiding ((<>)) diff --git a/src/Language/Bluespec/Pretty.hs b/src/Language/Bluespec/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bluespec/Pretty.hs @@ -0,0 +1,98 @@ +-- This adapts definitions found in src/comp/PPrint.hs and src/comp/Pretty.hs +-- in bsc. +module Language.Bluespec.Pretty + ( PDetail + , pdReadable + , pdAll + , pdDebug + , pdMark + , pdInfo + , pdNoqual + + , ppReadable + , ppReadableIndent + , ppAll + , ppDebug + + , pparen + , sepList + , ppr + , maxPrec + + , s2par + ) where + +import Text.PrettyPrint.HughesPJClass + +import Language.Bluespec.Prelude + +type PDetail = PrettyLevel + +pdReadable :: PDetail +pdReadable = PrettyLevel 1 + +pdAll :: PDetail +pdAll = PrettyLevel 2 + +pdDebug :: PDetail +pdDebug = PrettyLevel 3 + +pdMark :: PDetail +pdMark = PrettyLevel 4 + +pdInfo :: PDetail +pdInfo = PrettyLevel 5 + +pdNoqual :: PDetail +pdNoqual = PrettyLevel 6 + +ppReadable :: Pretty a => a -> String +ppReadable = ppr pdReadable + +ppReadableIndent :: Pretty a => Int -> a -> String +ppReadableIndent i = pprIndent i pdReadable + +ppAll :: Pretty a => a -> String +ppAll = ppr pdAll + +ppDebug :: Pretty a => a -> String +ppDebug = ppr pdDebug + +pparen :: Bool -> Doc -> Doc +pparen False x = x +pparen True x = text"(" <> x <> text")" + +sepList :: [Doc] -> Doc -> Doc +sepList [] _ = empty +sepList xs s = sep (map (\x->x <> s) (init xs) ++ [last xs]) + +maxPrec :: Int +maxPrec = 20 + +ppr :: Pretty a => PDetail -> a -> String +ppr d = pretty lineWidth linePref . pPrintPrec d 0 + +pprIndent :: Pretty a => Int -> PDetail -> a -> String +pprIndent i d = pretty lineWidth linePref . nest i . pPrintPrec d 0 + +lineWidth, linePref :: Int +lineWidth = 120 +linePref = 100 + +-- Produces a string from a text "x" in Normal mode with "w" line +-- length, "w/m" ribbons per line. +pretty :: Int -> Int -> Doc -> String +pretty w m x = fullRender PageMode w (toEnum w / toEnum m) string_txt "\n" x + +-- The function which tells fullRender how to compose Doc elements +-- into a String. +string_txt :: TextDetails -> String -> String +string_txt (Chr c) s = c:s +string_txt (Str s1) s2 = s1 ++ s2 +string_txt (PStr s1) s2 = s1 ++ s2 + +-- Pretty printing utilities + +-- Creates a paragraph +s2par :: String -> Doc +s2par str = fsep $ map text (words str) diff --git a/src/Language/Bluespec/Util.hs b/src/Language/Bluespec/Util.hs new file mode 100644 --- /dev/null +++ b/src/Language/Bluespec/Util.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE FlexibleInstances #-} +-- This corresponds to src/comp/Util.hs in bsc. +module Language.Bluespec.Util + ( dbgLevel + , doubleQuote + , ToString(..) + ) where + +import Data.Char (intToDigit) + +import Language.Bluespec.Prelude + +-- ===== +-- Configurable traces +-- (currently only used in Id and XRef) + +dbgLevel :: Int +dbgLevel = -1 + +-- ===== +-- String utilities + +doubleQuote :: String -> String +doubleQuote s = "\"" ++ s ++ "\"" + +-- ===== +-- ToString class + +class ToString a where + to_string :: a -> String + itos :: a -> String + +instance ToString Int where + itos a = show a + to_string a = error ("to_string applied to nonsymbol (Int) " + ++ show a) + +instance ToString Integer where + itos a = show a + to_string a = error ("to_string applied to nonsymbol (Integer) " + ++ show a) + +instance ToString Char where + itos a = show a + to_string a = case a of + '\n' -> "\\n" + '\r' -> "\\r" + '\t' -> "\\t" + '\a' -> "\\a" + '\\' -> "\\\\" + '"' -> "\\\"" -- backslash double-quote + _ | n < 0 || + n > 0x100 -> error $ "quoting a character value " ++ show n + _ | n < 0x20 || n >= 0x7F -> + [ '\\', intToDigit highest, intToDigit middle, intToDigit lowest ] + _ -> [a] + where + n = fromEnum a + (top2, lowest) = quotRem n 8 + (highest, middle) = quotRem top2 8 + +instance ToString String where + itos a = error $ "itos applied to string " ++ show a + to_string a = concatMap to_string a